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