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