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