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