1*> \brief \b SCHKTP 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8* Definition: 9* =========== 10* 11* SUBROUTINE SCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 12* NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, 13* IWORK, NOUT ) 14* 15* .. Scalar Arguments .. 16* LOGICAL TSTERR 17* INTEGER NMAX, NN, NNS, NOUT 18* REAL THRESH 19* .. 20* .. Array Arguments .. 21* LOGICAL DOTYPE( * ) 22* INTEGER IWORK( * ), NSVAL( * ), NVAL( * ) 23* REAL AINVP( * ), AP( * ), B( * ), RWORK( * ), 24* $ WORK( * ), X( * ), XACT( * ) 25* .. 26* 27* 28*> \par Purpose: 29* ============= 30*> 31*> \verbatim 32*> 33*> SCHKTP tests STPTRI, -TRS, -RFS, and -CON, and SLATPS 34*> \endverbatim 35* 36* Arguments: 37* ========== 38* 39*> \param[in] DOTYPE 40*> \verbatim 41*> DOTYPE is LOGICAL array, dimension (NTYPES) 42*> The matrix types to be used for testing. Matrices of type j 43*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 44*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 45*> \endverbatim 46*> 47*> \param[in] NN 48*> \verbatim 49*> NN is INTEGER 50*> The number of values of N contained in the vector NVAL. 51*> \endverbatim 52*> 53*> \param[in] NVAL 54*> \verbatim 55*> NVAL is INTEGER array, dimension (NN) 56*> The values of the matrix column dimension N. 57*> \endverbatim 58*> 59*> \param[in] NNS 60*> \verbatim 61*> NNS is INTEGER 62*> The number of values of NRHS contained in the vector NSVAL. 63*> \endverbatim 64*> 65*> \param[in] NSVAL 66*> \verbatim 67*> NSVAL is INTEGER array, dimension (NNS) 68*> The values of the number of right hand sides NRHS. 69*> \endverbatim 70*> 71*> \param[in] THRESH 72*> \verbatim 73*> THRESH is REAL 74*> The threshold value for the test ratios. A result is 75*> included in the output file if RESULT >= THRESH. To have 76*> every test ratio printed, use THRESH = 0. 77*> \endverbatim 78*> 79*> \param[in] TSTERR 80*> \verbatim 81*> TSTERR is LOGICAL 82*> Flag that indicates whether error exits are to be tested. 83*> \endverbatim 84*> 85*> \param[in] NMAX 86*> \verbatim 87*> NMAX is INTEGER 88*> The leading dimension of the work arrays. NMAX >= the 89*> maximumm value of N in NVAL. 90*> \endverbatim 91*> 92*> \param[out] AP 93*> \verbatim 94*> AP is REAL array, dimension 95*> (NMAX*(NMAX+1)/2) 96*> \endverbatim 97*> 98*> \param[out] AINVP 99*> \verbatim 100*> AINVP is REAL array, dimension 101*> (NMAX*(NMAX+1)/2) 102*> \endverbatim 103*> 104*> \param[out] B 105*> \verbatim 106*> B is REAL array, dimension (NMAX*NSMAX) 107*> where NSMAX is the largest entry in NSVAL. 108*> \endverbatim 109*> 110*> \param[out] X 111*> \verbatim 112*> X is REAL array, dimension (NMAX*NSMAX) 113*> \endverbatim 114*> 115*> \param[out] XACT 116*> \verbatim 117*> XACT is REAL array, dimension (NMAX*NSMAX) 118*> \endverbatim 119*> 120*> \param[out] WORK 121*> \verbatim 122*> WORK is REAL array, dimension 123*> (NMAX*max(3,NSMAX)) 124*> \endverbatim 125*> 126*> \param[out] IWORK 127*> \verbatim 128*> IWORK is INTEGER array, dimension (NMAX) 129*> \endverbatim 130*> 131*> \param[out] RWORK 132*> \verbatim 133*> RWORK is REAL array, dimension 134*> (max(NMAX,2*NSMAX)) 135*> \endverbatim 136*> 137*> \param[in] NOUT 138*> \verbatim 139*> NOUT is INTEGER 140*> The unit number for output. 141*> \endverbatim 142* 143* Authors: 144* ======== 145* 146*> \author Univ. of Tennessee 147*> \author Univ. of California Berkeley 148*> \author Univ. of Colorado Denver 149*> \author NAG Ltd. 150* 151*> \date November 2011 152* 153*> \ingroup single_lin 154* 155* ===================================================================== 156 SUBROUTINE SCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 157 $ NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, 158 $ IWORK, NOUT ) 159* 160* -- LAPACK test routine (version 3.4.0) -- 161* -- LAPACK is a software package provided by Univ. of Tennessee, -- 162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 163* November 2011 164* 165* .. Scalar Arguments .. 166 LOGICAL TSTERR 167 INTEGER NMAX, NN, NNS, NOUT 168 REAL THRESH 169* .. 170* .. Array Arguments .. 171 LOGICAL DOTYPE( * ) 172 INTEGER IWORK( * ), NSVAL( * ), NVAL( * ) 173 REAL AINVP( * ), AP( * ), B( * ), RWORK( * ), 174 $ WORK( * ), X( * ), XACT( * ) 175* .. 176* 177* ===================================================================== 178* 179* .. Parameters .. 180 INTEGER NTYPE1, NTYPES 181 PARAMETER ( NTYPE1 = 10, NTYPES = 18 ) 182 INTEGER NTESTS 183 PARAMETER ( NTESTS = 9 ) 184 INTEGER NTRAN 185 PARAMETER ( NTRAN = 3 ) 186 REAL ONE, ZERO 187 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 188* .. 189* .. Local Scalars .. 190 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE 191 CHARACTER*3 PATH 192 INTEGER I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO, 193 $ K, LAP, LDA, N, NERRS, NFAIL, NRHS, NRUN 194 REAL AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO, 195 $ SCALE 196* .. 197* .. Local Arrays .. 198 CHARACTER TRANSS( NTRAN ), UPLOS( 2 ) 199 INTEGER ISEED( 4 ), ISEEDY( 4 ) 200 REAL RESULT( NTESTS ) 201* .. 202* .. External Functions .. 203 LOGICAL LSAME 204 REAL SLANTP 205 EXTERNAL LSAME, SLANTP 206* .. 207* .. External Subroutines .. 208 EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRTR, SGET04, 209 $ SLACPY, SLARHS, SLATPS, SLATTP, STPCON, STPRFS, 210 $ STPT01, STPT02, STPT03, STPT05, STPT06, STPTRI, 211 $ STPTRS 212* .. 213* .. Scalars in Common .. 214 LOGICAL LERR, OK 215 CHARACTER*32 SRNAMT 216 INTEGER INFOT, IOUNIT 217* .. 218* .. Common blocks .. 219 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 220 COMMON / SRNAMC / SRNAMT 221* .. 222* .. Intrinsic Functions .. 223 INTRINSIC MAX 224* .. 225* .. Data statements .. 226 DATA ISEEDY / 1988, 1989, 1990, 1991 / 227 DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' / 228* .. 229* .. Executable Statements .. 230* 231* Initialize constants and the random number seed. 232* 233 PATH( 1: 1 ) = 'Single precision' 234 PATH( 2: 3 ) = 'TP' 235 NRUN = 0 236 NFAIL = 0 237 NERRS = 0 238 DO 10 I = 1, 4 239 ISEED( I ) = ISEEDY( I ) 240 10 CONTINUE 241* 242* Test the error exits 243* 244 IF( TSTERR ) 245 $ CALL SERRTR( PATH, NOUT ) 246 INFOT = 0 247* 248 DO 110 IN = 1, NN 249* 250* Do for each value of N in NVAL 251* 252 N = NVAL( IN ) 253 LDA = MAX( 1, N ) 254 LAP = LDA*( LDA+1 ) / 2 255 XTYPE = 'N' 256* 257 DO 70 IMAT = 1, NTYPE1 258* 259* Do the tests only if DOTYPE( IMAT ) is true. 260* 261 IF( .NOT.DOTYPE( IMAT ) ) 262 $ GO TO 70 263* 264 DO 60 IUPLO = 1, 2 265* 266* Do first for UPLO = 'U', then for UPLO = 'L' 267* 268 UPLO = UPLOS( IUPLO ) 269* 270* Call SLATTP to generate a triangular test matrix. 271* 272 SRNAMT = 'SLATTP' 273 CALL SLATTP( IMAT, UPLO, 'No transpose', DIAG, ISEED, N, 274 $ AP, X, WORK, INFO ) 275* 276* Set IDIAG = 1 for non-unit matrices, 2 for unit. 277* 278 IF( LSAME( DIAG, 'N' ) ) THEN 279 IDIAG = 1 280 ELSE 281 IDIAG = 2 282 END IF 283* 284*+ TEST 1 285* Form the inverse of A. 286* 287 IF( N.GT.0 ) 288 $ CALL SCOPY( LAP, AP, 1, AINVP, 1 ) 289 SRNAMT = 'STPTRI' 290 CALL STPTRI( UPLO, DIAG, N, AINVP, INFO ) 291* 292* Check error code from STPTRI. 293* 294 IF( INFO.NE.0 ) 295 $ CALL ALAERH( PATH, 'STPTRI', INFO, 0, UPLO // DIAG, N, 296 $ N, -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 297* 298* Compute the infinity-norm condition number of A. 299* 300 ANORM = SLANTP( 'I', UPLO, DIAG, N, AP, RWORK ) 301 AINVNM = SLANTP( 'I', UPLO, DIAG, N, AINVP, RWORK ) 302 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 303 RCONDI = ONE 304 ELSE 305 RCONDI = ( ONE / ANORM ) / AINVNM 306 END IF 307* 308* Compute the residual for the triangular matrix times its 309* inverse. Also compute the 1-norm condition number of A. 310* 311 CALL STPT01( UPLO, DIAG, N, AP, AINVP, RCONDO, RWORK, 312 $ RESULT( 1 ) ) 313* 314* Print the test ratio if it is .GE. THRESH. 315* 316 IF( RESULT( 1 ).GE.THRESH ) THEN 317 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 318 $ CALL ALAHD( NOUT, PATH ) 319 WRITE( NOUT, FMT = 9999 )UPLO, DIAG, N, IMAT, 1, 320 $ RESULT( 1 ) 321 NFAIL = NFAIL + 1 322 END IF 323 NRUN = NRUN + 1 324* 325 DO 40 IRHS = 1, NNS 326 NRHS = NSVAL( IRHS ) 327 XTYPE = 'N' 328* 329 DO 30 ITRAN = 1, NTRAN 330* 331* Do for op(A) = A, A**T, or A**H. 332* 333 TRANS = TRANSS( ITRAN ) 334 IF( ITRAN.EQ.1 ) THEN 335 NORM = 'O' 336 RCONDC = RCONDO 337 ELSE 338 NORM = 'I' 339 RCONDC = RCONDI 340 END IF 341* 342*+ TEST 2 343* Solve and compute residual for op(A)*x = b. 344* 345 SRNAMT = 'SLARHS' 346 CALL SLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0, 347 $ IDIAG, NRHS, AP, LAP, XACT, LDA, B, 348 $ LDA, ISEED, INFO ) 349 XTYPE = 'C' 350 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 351* 352 SRNAMT = 'STPTRS' 353 CALL STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, X, 354 $ LDA, INFO ) 355* 356* Check error code from STPTRS. 357* 358 IF( INFO.NE.0 ) 359 $ CALL ALAERH( PATH, 'STPTRS', INFO, 0, 360 $ UPLO // TRANS // DIAG, N, N, -1, 361 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 362* 363 CALL STPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, 364 $ LDA, B, LDA, WORK, RESULT( 2 ) ) 365* 366*+ TEST 3 367* Check solution from generated exact solution. 368* 369 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 370 $ RESULT( 3 ) ) 371* 372*+ TESTS 4, 5, and 6 373* Use iterative refinement to improve the solution and 374* compute error bounds. 375* 376 SRNAMT = 'STPRFS' 377 CALL STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, 378 $ LDA, X, LDA, RWORK, RWORK( NRHS+1 ), 379 $ WORK, IWORK, INFO ) 380* 381* Check error code from STPRFS. 382* 383 IF( INFO.NE.0 ) 384 $ CALL ALAERH( PATH, 'STPRFS', INFO, 0, 385 $ UPLO // TRANS // DIAG, N, N, -1, 386 $ -1, NRHS, IMAT, NFAIL, NERRS, 387 $ NOUT ) 388* 389 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 390 $ RESULT( 4 ) ) 391 CALL STPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, 392 $ LDA, X, LDA, XACT, LDA, RWORK, 393 $ RWORK( NRHS+1 ), RESULT( 5 ) ) 394* 395* Print information about the tests that did not pass 396* the threshold. 397* 398 DO 20 K = 2, 6 399 IF( RESULT( K ).GE.THRESH ) THEN 400 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 401 $ CALL ALAHD( NOUT, PATH ) 402 WRITE( NOUT, FMT = 9998 )UPLO, TRANS, DIAG, 403 $ N, NRHS, IMAT, K, RESULT( K ) 404 NFAIL = NFAIL + 1 405 END IF 406 20 CONTINUE 407 NRUN = NRUN + 5 408 30 CONTINUE 409 40 CONTINUE 410* 411*+ TEST 7 412* Get an estimate of RCOND = 1/CNDNUM. 413* 414 DO 50 ITRAN = 1, 2 415 IF( ITRAN.EQ.1 ) THEN 416 NORM = 'O' 417 RCONDC = RCONDO 418 ELSE 419 NORM = 'I' 420 RCONDC = RCONDI 421 END IF 422* 423 SRNAMT = 'STPCON' 424 CALL STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, 425 $ IWORK, INFO ) 426* 427* Check error code from STPCON. 428* 429 IF( INFO.NE.0 ) 430 $ CALL ALAERH( PATH, 'STPCON', INFO, 0, 431 $ NORM // UPLO // DIAG, N, N, -1, -1, 432 $ -1, IMAT, NFAIL, NERRS, NOUT ) 433* 434 CALL STPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK, 435 $ RESULT( 7 ) ) 436* 437* Print the test ratio if it is .GE. THRESH. 438* 439 IF( RESULT( 7 ).GE.THRESH ) THEN 440 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 441 $ CALL ALAHD( NOUT, PATH ) 442 WRITE( NOUT, FMT = 9997 ) 'STPCON', NORM, UPLO, 443 $ DIAG, N, IMAT, 7, RESULT( 7 ) 444 NFAIL = NFAIL + 1 445 END IF 446 NRUN = NRUN + 1 447 50 CONTINUE 448 60 CONTINUE 449 70 CONTINUE 450* 451* Use pathological test matrices to test SLATPS. 452* 453 DO 100 IMAT = NTYPE1 + 1, NTYPES 454* 455* Do the tests only if DOTYPE( IMAT ) is true. 456* 457 IF( .NOT.DOTYPE( IMAT ) ) 458 $ GO TO 100 459* 460 DO 90 IUPLO = 1, 2 461* 462* Do first for UPLO = 'U', then for UPLO = 'L' 463* 464 UPLO = UPLOS( IUPLO ) 465 DO 80 ITRAN = 1, NTRAN 466* 467* Do for op(A) = A, A**T, or A**H. 468* 469 TRANS = TRANSS( ITRAN ) 470* 471* Call SLATTP to generate a triangular test matrix. 472* 473 SRNAMT = 'SLATTP' 474 CALL SLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, X, 475 $ WORK, INFO ) 476* 477*+ TEST 8 478* Solve the system op(A)*x = b. 479* 480 SRNAMT = 'SLATPS' 481 CALL SCOPY( N, X, 1, B, 1 ) 482 CALL SLATPS( UPLO, TRANS, DIAG, 'N', N, AP, B, SCALE, 483 $ RWORK, INFO ) 484* 485* Check error code from SLATPS. 486* 487 IF( INFO.NE.0 ) 488 $ CALL ALAERH( PATH, 'SLATPS', INFO, 0, 489 $ UPLO // TRANS // DIAG // 'N', N, N, 490 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 491* 492 CALL STPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE, 493 $ RWORK, ONE, B, LDA, X, LDA, WORK, 494 $ RESULT( 8 ) ) 495* 496*+ TEST 9 497* Solve op(A)*x = b again with NORMIN = 'Y'. 498* 499 CALL SCOPY( N, X, 1, B( N+1 ), 1 ) 500 CALL SLATPS( UPLO, TRANS, DIAG, 'Y', N, AP, B( N+1 ), 501 $ SCALE, RWORK, INFO ) 502* 503* Check error code from SLATPS. 504* 505 IF( INFO.NE.0 ) 506 $ CALL ALAERH( PATH, 'SLATPS', INFO, 0, 507 $ UPLO // TRANS // DIAG // 'Y', N, N, 508 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 509* 510 CALL STPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE, 511 $ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK, 512 $ RESULT( 9 ) ) 513* 514* Print information about the tests that did not pass 515* the threshold. 516* 517 IF( RESULT( 8 ).GE.THRESH ) THEN 518 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 519 $ CALL ALAHD( NOUT, PATH ) 520 WRITE( NOUT, FMT = 9996 )'SLATPS', UPLO, TRANS, 521 $ DIAG, 'N', N, IMAT, 8, RESULT( 8 ) 522 NFAIL = NFAIL + 1 523 END IF 524 IF( RESULT( 9 ).GE.THRESH ) THEN 525 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 526 $ CALL ALAHD( NOUT, PATH ) 527 WRITE( NOUT, FMT = 9996 )'SLATPS', UPLO, TRANS, 528 $ DIAG, 'Y', N, IMAT, 9, RESULT( 9 ) 529 NFAIL = NFAIL + 1 530 END IF 531 NRUN = NRUN + 2 532 80 CONTINUE 533 90 CONTINUE 534 100 CONTINUE 535 110 CONTINUE 536* 537* Print a summary of the results. 538* 539 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 540* 541 9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, 542 $ ', type ', I2, ', test(', I2, ')= ', G12.5 ) 543 9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1, 544 $ ''', N=', I5, ''', NRHS=', I5, ', type ', I2, ', test(', 545 $ I2, ')= ', G12.5 ) 546 9997 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',', 547 $ I5, ', ... ), type ', I2, ', test(', I2, ')=', G12.5 ) 548 9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''', 549 $ A1, ''',', I5, ', ... ), type ', I2, ', test(', I2, ')=', 550 $ G12.5 ) 551 RETURN 552* 553* End of SCHKTP 554* 555 END 556