1*> \brief \b SCHKTB 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 SCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 12* NMAX, AB, AINV, B, X, XACT, WORK, RWORK, IWORK, 13* 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 AB( * ), AINV( * ), B( * ), RWORK( * ), 24* $ WORK( * ), X( * ), XACT( * ) 25* .. 26* 27* 28*> \par Purpose: 29* ============= 30*> 31*> \verbatim 32*> 33*> SCHKTB tests STBTRS, -RFS, and -CON, and SLATBS. 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. 89*> NMAX >= the maximum value of N in NVAL. 90*> \endverbatim 91*> 92*> \param[out] AB 93*> \verbatim 94*> AB is REAL array, dimension (NMAX*NMAX) 95*> \endverbatim 96*> 97*> \param[out] AINV 98*> \verbatim 99*> AINV is REAL array, dimension (NMAX*NMAX) 100*> \endverbatim 101*> 102*> \param[out] B 103*> \verbatim 104*> B is REAL array, dimension (NMAX*NSMAX) 105*> where NSMAX is the largest entry in NSVAL. 106*> \endverbatim 107*> 108*> \param[out] X 109*> \verbatim 110*> X is REAL array, dimension (NMAX*NSMAX) 111*> \endverbatim 112*> 113*> \param[out] XACT 114*> \verbatim 115*> XACT is REAL array, dimension (NMAX*NSMAX) 116*> \endverbatim 117*> 118*> \param[out] WORK 119*> \verbatim 120*> WORK is REAL array, dimension 121*> (NMAX*max(3,NSMAX)) 122*> \endverbatim 123*> 124*> \param[out] RWORK 125*> \verbatim 126*> RWORK is REAL array, dimension 127*> (max(NMAX,2*NSMAX)) 128*> \endverbatim 129*> 130*> \param[out] IWORK 131*> \verbatim 132*> IWORK is INTEGER array, dimension (NMAX) 133*> \endverbatim 134*> 135*> \param[in] NOUT 136*> \verbatim 137*> NOUT is INTEGER 138*> The unit number for output. 139*> \endverbatim 140* 141* Authors: 142* ======== 143* 144*> \author Univ. of Tennessee 145*> \author Univ. of California Berkeley 146*> \author Univ. of Colorado Denver 147*> \author NAG Ltd. 148* 149*> \date November 2011 150* 151*> \ingroup single_lin 152* 153* ===================================================================== 154 SUBROUTINE SCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 155 $ NMAX, AB, AINV, B, X, XACT, WORK, RWORK, IWORK, 156 $ NOUT ) 157* 158* -- LAPACK test routine (version 3.4.0) -- 159* -- LAPACK is a software package provided by Univ. of Tennessee, -- 160* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 161* November 2011 162* 163* .. Scalar Arguments .. 164 LOGICAL TSTERR 165 INTEGER NMAX, NN, NNS, NOUT 166 REAL THRESH 167* .. 168* .. Array Arguments .. 169 LOGICAL DOTYPE( * ) 170 INTEGER IWORK( * ), NSVAL( * ), NVAL( * ) 171 REAL AB( * ), AINV( * ), B( * ), RWORK( * ), 172 $ WORK( * ), X( * ), XACT( * ) 173* .. 174* 175* ===================================================================== 176* 177* .. Parameters .. 178 INTEGER NTYPE1, NTYPES 179 PARAMETER ( NTYPE1 = 9, NTYPES = 17 ) 180 INTEGER NTESTS 181 PARAMETER ( NTESTS = 8 ) 182 INTEGER NTRAN 183 PARAMETER ( NTRAN = 3 ) 184 REAL ONE, ZERO 185 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 186* .. 187* .. Local Scalars .. 188 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE 189 CHARACTER*3 PATH 190 INTEGER I, IDIAG, IK, IMAT, IN, INFO, IRHS, ITRAN, 191 $ IUPLO, J, K, KD, LDA, LDAB, N, NERRS, NFAIL, 192 $ NIMAT, NIMAT2, NK, NRHS, NRUN 193 REAL AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO, 194 $ SCALE 195* .. 196* .. Local Arrays .. 197 CHARACTER TRANSS( NTRAN ), UPLOS( 2 ) 198 INTEGER ISEED( 4 ), ISEEDY( 4 ) 199 REAL RESULT( NTESTS ) 200* .. 201* .. External Functions .. 202 LOGICAL LSAME 203 REAL SLANTB, SLANTR 204 EXTERNAL LSAME, SLANTB, SLANTR 205* .. 206* .. External Subroutines .. 207 EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRTR, SGET04, 208 $ SLACPY, SLARHS, SLASET, SLATBS, SLATTB, STBCON, 209 $ STBRFS, STBSV, STBT02, STBT03, STBT05, STBT06, 210 $ STBTRS 211* .. 212* .. Scalars in Common .. 213 LOGICAL LERR, OK 214 CHARACTER*32 SRNAMT 215 INTEGER INFOT, IOUNIT 216* .. 217* .. Common blocks .. 218 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 219 COMMON / SRNAMC / SRNAMT 220* .. 221* .. Intrinsic Functions .. 222 INTRINSIC MAX, MIN 223* .. 224* .. Data statements .. 225 DATA ISEEDY / 1988, 1989, 1990, 1991 / 226 DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' / 227* .. 228* .. Executable Statements .. 229* 230* Initialize constants and the random number seed. 231* 232 PATH( 1: 1 ) = 'Single precision' 233 PATH( 2: 3 ) = 'TB' 234 NRUN = 0 235 NFAIL = 0 236 NERRS = 0 237 DO 10 I = 1, 4 238 ISEED( I ) = ISEEDY( I ) 239 10 CONTINUE 240* 241* Test the error exits 242* 243 IF( TSTERR ) 244 $ CALL SERRTR( PATH, NOUT ) 245 INFOT = 0 246* 247 DO 140 IN = 1, NN 248* 249* Do for each value of N in NVAL 250* 251 N = NVAL( IN ) 252 LDA = MAX( 1, N ) 253 XTYPE = 'N' 254 NIMAT = NTYPE1 255 NIMAT2 = NTYPES 256 IF( N.LE.0 ) THEN 257 NIMAT = 1 258 NIMAT2 = NTYPE1 + 1 259 END IF 260* 261 NK = MIN( N+1, 4 ) 262 DO 130 IK = 1, NK 263* 264* Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes 265* it easier to skip redundant values for small values of N. 266* 267 IF( IK.EQ.1 ) THEN 268 KD = 0 269 ELSE IF( IK.EQ.2 ) THEN 270 KD = MAX( N, 0 ) 271 ELSE IF( IK.EQ.3 ) THEN 272 KD = ( 3*N-1 ) / 4 273 ELSE IF( IK.EQ.4 ) THEN 274 KD = ( N+1 ) / 4 275 END IF 276 LDAB = KD + 1 277* 278 DO 90 IMAT = 1, NIMAT 279* 280* Do the tests only if DOTYPE( IMAT ) is true. 281* 282 IF( .NOT.DOTYPE( IMAT ) ) 283 $ GO TO 90 284* 285 DO 80 IUPLO = 1, 2 286* 287* Do first for UPLO = 'U', then for UPLO = 'L' 288* 289 UPLO = UPLOS( IUPLO ) 290* 291* Call SLATTB to generate a triangular test matrix. 292* 293 SRNAMT = 'SLATTB' 294 CALL SLATTB( IMAT, UPLO, 'No transpose', DIAG, ISEED, 295 $ N, KD, AB, LDAB, X, WORK, INFO ) 296* 297* Set IDIAG = 1 for non-unit matrices, 2 for unit. 298* 299 IF( LSAME( DIAG, 'N' ) ) THEN 300 IDIAG = 1 301 ELSE 302 IDIAG = 2 303 END IF 304* 305* Form the inverse of A so we can get a good estimate 306* of RCONDC = 1/(norm(A) * norm(inv(A))). 307* 308 CALL SLASET( 'Full', N, N, ZERO, ONE, AINV, LDA ) 309 IF( LSAME( UPLO, 'U' ) ) THEN 310 DO 20 J = 1, N 311 CALL STBSV( UPLO, 'No transpose', DIAG, J, KD, 312 $ AB, LDAB, AINV( ( J-1 )*LDA+1 ), 1 ) 313 20 CONTINUE 314 ELSE 315 DO 30 J = 1, N 316 CALL STBSV( UPLO, 'No transpose', DIAG, N-J+1, 317 $ KD, AB( ( J-1 )*LDAB+1 ), LDAB, 318 $ AINV( ( J-1 )*LDA+J ), 1 ) 319 30 CONTINUE 320 END IF 321* 322* Compute the 1-norm condition number of A. 323* 324 ANORM = SLANTB( '1', UPLO, DIAG, N, KD, AB, LDAB, 325 $ RWORK ) 326 AINVNM = SLANTR( '1', UPLO, DIAG, N, N, AINV, LDA, 327 $ RWORK ) 328 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 329 RCONDO = ONE 330 ELSE 331 RCONDO = ( ONE / ANORM ) / AINVNM 332 END IF 333* 334* Compute the infinity-norm condition number of A. 335* 336 ANORM = SLANTB( 'I', UPLO, DIAG, N, KD, AB, LDAB, 337 $ RWORK ) 338 AINVNM = SLANTR( 'I', UPLO, DIAG, N, N, AINV, LDA, 339 $ RWORK ) 340 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 341 RCONDI = ONE 342 ELSE 343 RCONDI = ( ONE / ANORM ) / AINVNM 344 END IF 345* 346 DO 60 IRHS = 1, NNS 347 NRHS = NSVAL( IRHS ) 348 XTYPE = 'N' 349* 350 DO 50 ITRAN = 1, NTRAN 351* 352* Do for op(A) = A, A**T, or A**H. 353* 354 TRANS = TRANSS( ITRAN ) 355 IF( ITRAN.EQ.1 ) THEN 356 NORM = 'O' 357 RCONDC = RCONDO 358 ELSE 359 NORM = 'I' 360 RCONDC = RCONDI 361 END IF 362* 363*+ TEST 1 364* Solve and compute residual for op(A)*x = b. 365* 366 SRNAMT = 'SLARHS' 367 CALL SLARHS( PATH, XTYPE, UPLO, TRANS, N, N, KD, 368 $ IDIAG, NRHS, AB, LDAB, XACT, LDA, 369 $ B, LDA, ISEED, INFO ) 370 XTYPE = 'C' 371 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 372* 373 SRNAMT = 'STBTRS' 374 CALL STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, 375 $ LDAB, X, LDA, INFO ) 376* 377* Check error code from STBTRS. 378* 379 IF( INFO.NE.0 ) 380 $ CALL ALAERH( PATH, 'STBTRS', INFO, 0, 381 $ UPLO // TRANS // DIAG, N, N, KD, 382 $ KD, NRHS, IMAT, NFAIL, NERRS, 383 $ NOUT ) 384* 385 CALL STBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, 386 $ LDAB, X, LDA, B, LDA, WORK, 387 $ RESULT( 1 ) ) 388* 389*+ TEST 2 390* Check solution from generated exact solution. 391* 392 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 393 $ RESULT( 2 ) ) 394* 395*+ TESTS 3, 4, and 5 396* Use iterative refinement to improve the solution 397* and compute error bounds. 398* 399 SRNAMT = 'STBRFS' 400 CALL STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, 401 $ LDAB, B, LDA, X, LDA, RWORK, 402 $ RWORK( NRHS+1 ), WORK, IWORK, 403 $ INFO ) 404* 405* Check error code from STBRFS. 406* 407 IF( INFO.NE.0 ) 408 $ CALL ALAERH( PATH, 'STBRFS', INFO, 0, 409 $ UPLO // TRANS // DIAG, N, N, KD, 410 $ KD, NRHS, IMAT, NFAIL, NERRS, 411 $ NOUT ) 412* 413 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 414 $ RESULT( 3 ) ) 415 CALL STBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, 416 $ LDAB, B, LDA, X, LDA, XACT, LDA, 417 $ RWORK, RWORK( NRHS+1 ), 418 $ RESULT( 4 ) ) 419* 420* Print information about the tests that did not 421* pass the threshold. 422* 423 DO 40 K = 1, 5 424 IF( RESULT( K ).GE.THRESH ) THEN 425 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 426 $ CALL ALAHD( NOUT, PATH ) 427 WRITE( NOUT, FMT = 9999 )UPLO, TRANS, 428 $ DIAG, N, KD, NRHS, IMAT, K, RESULT( K ) 429 NFAIL = NFAIL + 1 430 END IF 431 40 CONTINUE 432 NRUN = NRUN + 5 433 50 CONTINUE 434 60 CONTINUE 435* 436*+ TEST 6 437* Get an estimate of RCOND = 1/CNDNUM. 438* 439 DO 70 ITRAN = 1, 2 440 IF( ITRAN.EQ.1 ) THEN 441 NORM = 'O' 442 RCONDC = RCONDO 443 ELSE 444 NORM = 'I' 445 RCONDC = RCONDI 446 END IF 447 SRNAMT = 'STBCON' 448 CALL STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, 449 $ RCOND, WORK, IWORK, INFO ) 450* 451* Check error code from STBCON. 452* 453 IF( INFO.NE.0 ) 454 $ CALL ALAERH( PATH, 'STBCON', INFO, 0, 455 $ NORM // UPLO // DIAG, N, N, KD, KD, 456 $ -1, IMAT, NFAIL, NERRS, NOUT ) 457* 458 CALL STBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, 459 $ LDAB, RWORK, RESULT( 6 ) ) 460* 461* Print information about the tests that did not pass 462* the threshold. 463* 464 IF( RESULT( 6 ).GE.THRESH ) THEN 465 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 466 $ CALL ALAHD( NOUT, PATH ) 467 WRITE( NOUT, FMT = 9998 ) 'STBCON', NORM, UPLO, 468 $ DIAG, N, KD, IMAT, 6, RESULT( 6 ) 469 NFAIL = NFAIL + 1 470 END IF 471 NRUN = NRUN + 1 472 70 CONTINUE 473 80 CONTINUE 474 90 CONTINUE 475* 476* Use pathological test matrices to test SLATBS. 477* 478 DO 120 IMAT = NTYPE1 + 1, NIMAT2 479* 480* Do the tests only if DOTYPE( IMAT ) is true. 481* 482 IF( .NOT.DOTYPE( IMAT ) ) 483 $ GO TO 120 484* 485 DO 110 IUPLO = 1, 2 486* 487* Do first for UPLO = 'U', then for UPLO = 'L' 488* 489 UPLO = UPLOS( IUPLO ) 490 DO 100 ITRAN = 1, NTRAN 491* 492* Do for op(A) = A, A**T, and A**H. 493* 494 TRANS = TRANSS( ITRAN ) 495* 496* Call SLATTB to generate a triangular test matrix. 497* 498 SRNAMT = 'SLATTB' 499 CALL SLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, 500 $ AB, LDAB, X, WORK, INFO ) 501* 502*+ TEST 7 503* Solve the system op(A)*x = b 504* 505 SRNAMT = 'SLATBS' 506 CALL SCOPY( N, X, 1, B, 1 ) 507 CALL SLATBS( UPLO, TRANS, DIAG, 'N', N, KD, AB, 508 $ LDAB, B, SCALE, RWORK, INFO ) 509* 510* Check error code from SLATBS. 511* 512 IF( INFO.NE.0 ) 513 $ CALL ALAERH( PATH, 'SLATBS', INFO, 0, 514 $ UPLO // TRANS // DIAG // 'N', N, N, 515 $ KD, KD, -1, IMAT, NFAIL, NERRS, 516 $ NOUT ) 517* 518 CALL STBT03( UPLO, TRANS, DIAG, N, KD, 1, AB, LDAB, 519 $ SCALE, RWORK, ONE, B, LDA, X, LDA, 520 $ WORK, RESULT( 7 ) ) 521* 522*+ TEST 8 523* Solve op(A)*x = b again with NORMIN = 'Y'. 524* 525 CALL SCOPY( N, X, 1, B, 1 ) 526 CALL SLATBS( UPLO, TRANS, DIAG, 'Y', N, KD, AB, 527 $ LDAB, B, SCALE, RWORK, INFO ) 528* 529* Check error code from SLATBS. 530* 531 IF( INFO.NE.0 ) 532 $ CALL ALAERH( PATH, 'SLATBS', INFO, 0, 533 $ UPLO // TRANS // DIAG // 'Y', N, N, 534 $ KD, KD, -1, IMAT, NFAIL, NERRS, 535 $ NOUT ) 536* 537 CALL STBT03( UPLO, TRANS, DIAG, N, KD, 1, AB, LDAB, 538 $ SCALE, RWORK, ONE, B, LDA, X, LDA, 539 $ WORK, RESULT( 8 ) ) 540* 541* Print information about the tests that did not pass 542* the threshold. 543* 544 IF( RESULT( 7 ).GE.THRESH ) THEN 545 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 546 $ CALL ALAHD( NOUT, PATH ) 547 WRITE( NOUT, FMT = 9997 )'SLATBS', UPLO, TRANS, 548 $ DIAG, 'N', N, KD, IMAT, 7, RESULT( 7 ) 549 NFAIL = NFAIL + 1 550 END IF 551 IF( RESULT( 8 ).GE.THRESH ) THEN 552 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 553 $ CALL ALAHD( NOUT, PATH ) 554 WRITE( NOUT, FMT = 9997 )'SLATBS', UPLO, TRANS, 555 $ DIAG, 'Y', N, KD, IMAT, 8, RESULT( 8 ) 556 NFAIL = NFAIL + 1 557 END IF 558 NRUN = NRUN + 2 559 100 CONTINUE 560 110 CONTINUE 561 120 CONTINUE 562 130 CONTINUE 563 140 CONTINUE 564* 565* Print a summary of the results. 566* 567 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 568* 569 9999 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', 570 $ DIAG=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=', I5, 571 $ ', type ', I2, ', test(', I2, ')=', G12.5 ) 572 9998 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',', 573 $ I5, ',', I5, ', ... ), type ', I2, ', test(', I2, ')=', 574 $ G12.5 ) 575 9997 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''', 576 $ A1, ''',', I5, ',', I5, ', ... ), type ', I2, ', test(', 577 $ I1, ')=', G12.5 ) 578 RETURN 579* 580* End of SCHKTB 581* 582 END 583