1*> \brief \b ZCHKSY_ROOK 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 ZCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 12* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, 13* XACT, WORK, RWORK, IWORK, 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 IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) 23* DOUBLE PRECISION RWORK( * ) 24* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), 25* $ WORK( * ), X( * ), XACT( * ) 26* .. 27* 28* 29*> \par Purpose: 30* ============= 31*> 32*> \verbatim 33*> 34*> ZCHKSY_ROOK tests ZSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK, 35*> and -CON_ROOK. 36*> \endverbatim 37* 38* Arguments: 39* ========== 40* 41*> \param[in] DOTYPE 42*> \verbatim 43*> DOTYPE is LOGICAL array, dimension (NTYPES) 44*> The matrix types to be used for testing. Matrices of type j 45*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 46*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 47*> \endverbatim 48*> 49*> \param[in] NN 50*> \verbatim 51*> NN is INTEGER 52*> The number of values of N contained in the vector NVAL. 53*> \endverbatim 54*> 55*> \param[in] NVAL 56*> \verbatim 57*> NVAL is INTEGER array, dimension (NN) 58*> The values of the matrix dimension N. 59*> \endverbatim 60*> 61*> \param[in] NNB 62*> \verbatim 63*> NNB is INTEGER 64*> The number of values of NB contained in the vector NBVAL. 65*> \endverbatim 66*> 67*> \param[in] NBVAL 68*> \verbatim 69*> NBVAL is INTEGER array, dimension (NNB) 70*> The values of the blocksize NB. 71*> \endverbatim 72*> 73*> \param[in] NNS 74*> \verbatim 75*> NNS is INTEGER 76*> The number of values of NRHS contained in the vector NSVAL. 77*> \endverbatim 78*> 79*> \param[in] NSVAL 80*> \verbatim 81*> NSVAL is INTEGER array, dimension (NNS) 82*> The values of the number of right hand sides NRHS. 83*> \endverbatim 84*> 85*> \param[in] THRESH 86*> \verbatim 87*> THRESH is DOUBLE PRECISION 88*> The threshold value for the test ratios. A result is 89*> included in the output file if RESULT >= THRESH. To have 90*> every test ratio printed, use THRESH = 0. 91*> \endverbatim 92*> 93*> \param[in] TSTERR 94*> \verbatim 95*> TSTERR is LOGICAL 96*> Flag that indicates whether error exits are to be tested. 97*> \endverbatim 98*> 99*> \param[in] NMAX 100*> \verbatim 101*> NMAX is INTEGER 102*> The maximum value permitted for N, used in dimensioning the 103*> work arrays. 104*> \endverbatim 105*> 106*> \param[out] A 107*> \verbatim 108*> A is COMPLEX*16 array, dimension (NMAX*NMAX) 109*> \endverbatim 110*> 111*> \param[out] AFAC 112*> \verbatim 113*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) 114*> \endverbatim 115*> 116*> \param[out] AINV 117*> \verbatim 118*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) 119*> \endverbatim 120*> 121*> \param[out] B 122*> \verbatim 123*> B is COMPLEX*16 array, dimension (NMAX*NSMAX) 124*> where NSMAX is the largest entry in NSVAL. 125*> \endverbatim 126*> 127*> \param[out] X 128*> \verbatim 129*> X is COMPLEX*16 array, dimension (NMAX*NSMAX) 130*> \endverbatim 131*> 132*> \param[out] XACT 133*> \verbatim 134*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX) 135*> \endverbatim 136*> 137*> \param[out] WORK 138*> \verbatim 139*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX)) 140*> \endverbatim 141*> 142*> \param[out] RWORK 143*> \verbatim 144*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) 145*> \endverbatim 146*> 147*> \param[out] IWORK 148*> \verbatim 149*> IWORK is INTEGER array, dimension (2*NMAX) 150*> \endverbatim 151*> 152*> \param[in] NOUT 153*> \verbatim 154*> NOUT is INTEGER 155*> The unit number for output. 156*> \endverbatim 157* 158* Authors: 159* ======== 160* 161*> \author Univ. of Tennessee 162*> \author Univ. of California Berkeley 163*> \author Univ. of Colorado Denver 164*> \author NAG Ltd. 165* 166*> \ingroup complex16_lin 167* 168* ===================================================================== 169 SUBROUTINE ZCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 170 $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, 171 $ XACT, WORK, RWORK, IWORK, NOUT ) 172* 173* -- LAPACK test routine -- 174* -- LAPACK is a software package provided by Univ. of Tennessee, -- 175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 176* 177* .. Scalar Arguments .. 178 LOGICAL TSTERR 179 INTEGER NMAX, NN, NNB, NNS, NOUT 180 DOUBLE PRECISION THRESH 181* .. 182* .. Array Arguments .. 183 LOGICAL DOTYPE( * ) 184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) 185 DOUBLE PRECISION RWORK( * ) 186 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), 187 $ WORK( * ), X( * ), XACT( * ) 188* .. 189* 190* ===================================================================== 191* 192* .. Parameters .. 193 DOUBLE PRECISION ZERO, ONE 194 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) 195 DOUBLE PRECISION ONEHALF 196 PARAMETER ( ONEHALF = 0.5D+0 ) 197 DOUBLE PRECISION EIGHT, SEVTEN 198 PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) 199 COMPLEX*16 CZERO 200 PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) 201 INTEGER NTYPES 202 PARAMETER ( NTYPES = 11 ) 203 INTEGER NTESTS 204 PARAMETER ( NTESTS = 7 ) 205* .. 206* .. Local Scalars .. 207 LOGICAL TRFCON, ZEROT 208 CHARACTER DIST, TYPE, UPLO, XTYPE 209 CHARACTER*3 PATH, MATPATH 210 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, 211 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE, 212 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT 213 DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX, 214 $ SING_MIN, RCOND, RCONDC 215* .. 216* .. Local Arrays .. 217 CHARACTER UPLOS( 2 ) 218 INTEGER ISEED( 4 ), ISEEDY( 4 ) 219 DOUBLE PRECISION RESULT( NTESTS ) 220 COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 ) 221* .. 222* .. External Functions .. 223 DOUBLE PRECISION DGET06, ZLANGE, ZLANSY 224 EXTERNAL DGET06, ZLANGE, ZLANSY 225* .. 226* .. External Subroutines .. 227 EXTERNAL ALAERH, ALAHD, ALASUM, ZERRSY, ZGESVD, ZGET04, 228 $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY,ZSYT02, 229 $ ZSYT03, ZSYCON_ROOK, ZSYT01_ROOK, ZSYTRF_ROOK, 230 $ ZSYTRI_ROOK, ZSYTRS_ROOK, XLAENV 231* .. 232* .. Intrinsic Functions .. 233 INTRINSIC MAX, MIN, SQRT 234* .. 235* .. Scalars in Common .. 236 LOGICAL LERR, OK 237 CHARACTER*32 SRNAMT 238 INTEGER INFOT, NUNIT 239* .. 240* .. Common blocks .. 241 COMMON / INFOC / INFOT, NUNIT, OK, LERR 242 COMMON / SRNAMC / SRNAMT 243* .. 244* .. Data statements .. 245 DATA ISEEDY / 1988, 1989, 1990, 1991 / 246 DATA UPLOS / 'U', 'L' / 247* .. 248* .. Executable Statements .. 249* 250* Initialize constants and the random number seed. 251* 252 ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT 253* 254* Test path 255* 256 PATH( 1: 1 ) = 'Zomplex precision' 257 PATH( 2: 3 ) = 'SR' 258* 259* Path to generate matrices 260* 261 MATPATH( 1: 1 ) = 'Zomplex precision' 262 MATPATH( 2: 3 ) = 'SY' 263* 264 NRUN = 0 265 NFAIL = 0 266 NERRS = 0 267 DO 10 I = 1, 4 268 ISEED( I ) = ISEEDY( I ) 269 10 CONTINUE 270* 271* Test the error exits 272* 273 IF( TSTERR ) 274 $ CALL ZERRSY( PATH, NOUT ) 275 INFOT = 0 276* 277* Set the minimum block size for which the block routine should 278* be used, which will be later returned by ILAENV 279* 280 CALL XLAENV( 2, 2 ) 281* 282* Do for each value of N in NVAL 283* 284 DO 270 IN = 1, NN 285 N = NVAL( IN ) 286 LDA = MAX( N, 1 ) 287 XTYPE = 'N' 288 NIMAT = NTYPES 289 IF( N.LE.0 ) 290 $ NIMAT = 1 291* 292 IZERO = 0 293* 294* Do for each value of matrix type IMAT 295* 296 DO 260 IMAT = 1, NIMAT 297* 298* Do the tests only if DOTYPE( IMAT ) is true. 299* 300 IF( .NOT.DOTYPE( IMAT ) ) 301 $ GO TO 260 302* 303* Skip types 3, 4, 5, or 6 if the matrix size is too small. 304* 305 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 306 IF( ZEROT .AND. N.LT.IMAT-2 ) 307 $ GO TO 260 308* 309* Do first for UPLO = 'U', then for UPLO = 'L' 310* 311 DO 250 IUPLO = 1, 2 312 UPLO = UPLOS( IUPLO ) 313* 314* Begin generate test matrix A. 315* 316 IF( IMAT.NE.NTYPES ) THEN 317* 318* Set up parameters with ZLATB4 for the matrix generator 319* based on the type of matrix to be generated. 320* 321 CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, 322 $ MODE, CNDNUM, DIST ) 323* 324* Generate a matrix with ZLATMS. 325* 326 SRNAMT = 'ZLATMS' 327 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 328 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, 329 $ WORK, INFO ) 330* 331* Check error code from ZLATMS and handle error. 332* 333 IF( INFO.NE.0 ) THEN 334 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, 335 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 336* 337* Skip all tests for this generated matrix 338* 339 GO TO 250 340 END IF 341* 342* For matrix types 3-6, zero one or more rows and 343* columns of the matrix to test that INFO is returned 344* correctly. 345* 346 IF( ZEROT ) THEN 347 IF( IMAT.EQ.3 ) THEN 348 IZERO = 1 349 ELSE IF( IMAT.EQ.4 ) THEN 350 IZERO = N 351 ELSE 352 IZERO = N / 2 + 1 353 END IF 354* 355 IF( IMAT.LT.6 ) THEN 356* 357* Set row and column IZERO to zero. 358* 359 IF( IUPLO.EQ.1 ) THEN 360 IOFF = ( IZERO-1 )*LDA 361 DO 20 I = 1, IZERO - 1 362 A( IOFF+I ) = CZERO 363 20 CONTINUE 364 IOFF = IOFF + IZERO 365 DO 30 I = IZERO, N 366 A( IOFF ) = CZERO 367 IOFF = IOFF + LDA 368 30 CONTINUE 369 ELSE 370 IOFF = IZERO 371 DO 40 I = 1, IZERO - 1 372 A( IOFF ) = CZERO 373 IOFF = IOFF + LDA 374 40 CONTINUE 375 IOFF = IOFF - IZERO 376 DO 50 I = IZERO, N 377 A( IOFF+I ) = CZERO 378 50 CONTINUE 379 END IF 380 ELSE 381 IF( IUPLO.EQ.1 ) THEN 382* 383* Set the first IZERO rows and columns to zero. 384* 385 IOFF = 0 386 DO 70 J = 1, N 387 I2 = MIN( J, IZERO ) 388 DO 60 I = 1, I2 389 A( IOFF+I ) = CZERO 390 60 CONTINUE 391 IOFF = IOFF + LDA 392 70 CONTINUE 393 ELSE 394* 395* Set the last IZERO rows and columns to zero. 396* 397 IOFF = 0 398 DO 90 J = 1, N 399 I1 = MAX( J, IZERO ) 400 DO 80 I = I1, N 401 A( IOFF+I ) = CZERO 402 80 CONTINUE 403 IOFF = IOFF + LDA 404 90 CONTINUE 405 END IF 406 END IF 407 ELSE 408 IZERO = 0 409 END IF 410* 411 ELSE 412* 413* For matrix kind IMAT = 11, generate special block 414* diagonal matrix to test alternate code 415* for the 2 x 2 blocks. 416* 417 CALL ZLATSY( UPLO, N, A, LDA, ISEED ) 418* 419 END IF 420* 421* End generate test matrix A. 422* 423* 424* Do for each value of NB in NBVAL 425* 426 DO 240 INB = 1, NNB 427* 428* Set the optimal blocksize, which will be later 429* returned by ILAENV. 430* 431 NB = NBVAL( INB ) 432 CALL XLAENV( 1, NB ) 433* 434* Copy the test matrix A into matrix AFAC which 435* will be factorized in place. This is needed to 436* preserve the test matrix A for subsequent tests. 437* 438 CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) 439* 440* Compute the L*D*L**T or U*D*U**T factorization of the 441* matrix. IWORK stores details of the interchanges and 442* the block structure of D. AINV is a work array for 443* block factorization, LWORK is the length of AINV. 444* 445 LWORK = MAX( 2, NB )*LDA 446 SRNAMT = 'ZSYTRF_ROOK' 447 CALL ZSYTRF_ROOK( UPLO, N, AFAC, LDA, IWORK, AINV, 448 $ LWORK, INFO ) 449* 450* Adjust the expected value of INFO to account for 451* pivoting. 452* 453 K = IZERO 454 IF( K.GT.0 ) THEN 455 100 CONTINUE 456 IF( IWORK( K ).LT.0 ) THEN 457 IF( IWORK( K ).NE.-K ) THEN 458 K = -IWORK( K ) 459 GO TO 100 460 END IF 461 ELSE IF( IWORK( K ).NE.K ) THEN 462 K = IWORK( K ) 463 GO TO 100 464 END IF 465 END IF 466* 467* Check error code from ZSYTRF_ROOK and handle error. 468* 469 IF( INFO.NE.K) 470 $ CALL ALAERH( PATH, 'ZSYTRF_ROOK', INFO, K, 471 $ UPLO, N, N, -1, -1, NB, IMAT, 472 $ NFAIL, NERRS, NOUT ) 473* 474* Set the condition estimate flag if the INFO is not 0. 475* 476 IF( INFO.NE.0 ) THEN 477 TRFCON = .TRUE. 478 ELSE 479 TRFCON = .FALSE. 480 END IF 481* 482*+ TEST 1 483* Reconstruct matrix from factors and compute residual. 484* 485 CALL ZSYT01_ROOK( UPLO, N, A, LDA, AFAC, LDA, IWORK, 486 $ AINV, LDA, RWORK, RESULT( 1 ) ) 487 NT = 1 488* 489*+ TEST 2 490* Form the inverse and compute the residual, 491* if the factorization was competed without INFO > 0 492* (i.e. there is no zero rows and columns). 493* Do it only for the first block size. 494* 495 IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN 496 CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) 497 SRNAMT = 'ZSYTRI_ROOK' 498 CALL ZSYTRI_ROOK( UPLO, N, AINV, LDA, IWORK, WORK, 499 $ INFO ) 500* 501* Check error code from ZSYTRI_ROOK and handle error. 502* 503 IF( INFO.NE.0 ) 504 $ CALL ALAERH( PATH, 'ZSYTRI_ROOK', INFO, -1, 505 $ UPLO, N, N, -1, -1, -1, IMAT, 506 $ NFAIL, NERRS, NOUT ) 507* 508* Compute the residual for a symmetric matrix times 509* its inverse. 510* 511 CALL ZSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, 512 $ RWORK, RCONDC, RESULT( 2 ) ) 513 NT = 2 514 END IF 515* 516* Print information about the tests that did not pass 517* the threshold. 518* 519 DO 110 K = 1, NT 520 IF( RESULT( K ).GE.THRESH ) THEN 521 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 522 $ CALL ALAHD( NOUT, PATH ) 523 WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, 524 $ RESULT( K ) 525 NFAIL = NFAIL + 1 526 END IF 527 110 CONTINUE 528 NRUN = NRUN + NT 529* 530*+ TEST 3 531* Compute largest element in U or L 532* 533 RESULT( 3 ) = ZERO 534 DTEMP = ZERO 535* 536 CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / 537 $ ( ONE-ALPHA ) 538* 539 IF( IUPLO.EQ.1 ) THEN 540* 541* Compute largest element in U 542* 543 K = N 544 120 CONTINUE 545 IF( K.LE.1 ) 546 $ GO TO 130 547* 548 IF( IWORK( K ).GT.ZERO ) THEN 549* 550* Get max absolute value from elements 551* in column k in in U 552* 553 DTEMP = ZLANGE( 'M', K-1, 1, 554 $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) 555 ELSE 556* 557* Get max absolute value from elements 558* in columns k and k-1 in U 559* 560 DTEMP = ZLANGE( 'M', K-2, 2, 561 $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) 562 K = K - 1 563* 564 END IF 565* 566* DTEMP should be bounded by CONST 567* 568 DTEMP = DTEMP - CONST + THRESH 569 IF( DTEMP.GT.RESULT( 3 ) ) 570 $ RESULT( 3 ) = DTEMP 571* 572 K = K - 1 573* 574 GO TO 120 575 130 CONTINUE 576* 577 ELSE 578* 579* Compute largest element in L 580* 581 K = 1 582 140 CONTINUE 583 IF( K.GE.N ) 584 $ GO TO 150 585* 586 IF( IWORK( K ).GT.ZERO ) THEN 587* 588* Get max absolute value from elements 589* in column k in in L 590* 591 DTEMP = ZLANGE( 'M', N-K, 1, 592 $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) 593 ELSE 594* 595* Get max absolute value from elements 596* in columns k and k+1 in L 597* 598 DTEMP = ZLANGE( 'M', N-K-1, 2, 599 $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) 600 K = K + 1 601* 602 END IF 603* 604* DTEMP should be bounded by CONST 605* 606 DTEMP = DTEMP - CONST + THRESH 607 IF( DTEMP.GT.RESULT( 3 ) ) 608 $ RESULT( 3 ) = DTEMP 609* 610 K = K + 1 611* 612 GO TO 140 613 150 CONTINUE 614 END IF 615* 616* 617*+ TEST 4 618* Compute largest 2-Norm (condition number) 619* of 2-by-2 diag blocks 620* 621 RESULT( 4 ) = ZERO 622 DTEMP = ZERO 623* 624 CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* 625 $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) 626* 627 IF( IUPLO.EQ.1 ) THEN 628* 629* Loop backward for UPLO = 'U' 630* 631 K = N 632 160 CONTINUE 633 IF( K.LE.1 ) 634 $ GO TO 170 635* 636 IF( IWORK( K ).LT.ZERO ) THEN 637* 638* Get the two singular values 639* (real and non-negative) of a 2-by-2 block, 640* store them in RWORK array 641* 642 BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) 643 BLOCK( 1, 2 ) = AFAC( (K-1)*LDA+K-1 ) 644 BLOCK( 2, 1 ) = BLOCK( 1, 2 ) 645 BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) 646* 647 CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, 648 $ ZDUMMY, 1, ZDUMMY, 1, 649 $ WORK, 6, RWORK( 3 ), INFO ) 650* 651* 652 SING_MAX = RWORK( 1 ) 653 SING_MIN = RWORK( 2 ) 654* 655 DTEMP = SING_MAX / SING_MIN 656* 657* DTEMP should be bounded by CONST 658* 659 DTEMP = DTEMP - CONST + THRESH 660 IF( DTEMP.GT.RESULT( 4 ) ) 661 $ RESULT( 4 ) = DTEMP 662 K = K - 1 663* 664 END IF 665* 666 K = K - 1 667* 668 GO TO 160 669 170 CONTINUE 670* 671 ELSE 672* 673* Loop forward for UPLO = 'L' 674* 675 K = 1 676 180 CONTINUE 677 IF( K.GE.N ) 678 $ GO TO 190 679* 680 IF( IWORK( K ).LT.ZERO ) THEN 681* 682* Get the two singular values 683* (real and non-negative) of a 2-by-2 block, 684* store them in RWORK array 685* 686 BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) 687 BLOCK( 2, 1 ) = AFAC( ( K-1 )*LDA+K+1 ) 688 BLOCK( 1, 2 ) = BLOCK( 2, 1 ) 689 BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) 690* 691 CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, 692 $ ZDUMMY, 1, ZDUMMY, 1, 693 $ WORK, 6, RWORK(3), INFO ) 694* 695 SING_MAX = RWORK( 1 ) 696 SING_MIN = RWORK( 2 ) 697* 698 DTEMP = SING_MAX / SING_MIN 699* 700* DTEMP should be bounded by CONST 701* 702 DTEMP = DTEMP - CONST + THRESH 703 IF( DTEMP.GT.RESULT( 4 ) ) 704 $ RESULT( 4 ) = DTEMP 705 K = K + 1 706* 707 END IF 708* 709 K = K + 1 710* 711 GO TO 180 712 190 CONTINUE 713 END IF 714* 715* Print information about the tests that did not pass 716* the threshold. 717* 718 DO 200 K = 3, 4 719 IF( RESULT( K ).GE.THRESH ) THEN 720 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 721 $ CALL ALAHD( NOUT, PATH ) 722 WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, 723 $ RESULT( K ) 724 NFAIL = NFAIL + 1 725 END IF 726 200 CONTINUE 727 NRUN = NRUN + 2 728* 729* Skip the other tests if this is not the first block 730* size. 731* 732 IF( INB.GT.1 ) 733 $ GO TO 240 734* 735* Do only the condition estimate if INFO is not 0. 736* 737 IF( TRFCON ) THEN 738 RCONDC = ZERO 739 GO TO 230 740 END IF 741* 742* Do for each value of NRHS in NSVAL. 743* 744 DO 220 IRHS = 1, NNS 745 NRHS = NSVAL( IRHS ) 746* 747*+ TEST 5 ( Using TRS_ROOK) 748* Solve and compute residual for A * X = B. 749* 750* Choose a set of NRHS random solution vectors 751* stored in XACT and set up the right hand side B 752* 753 SRNAMT = 'ZLARHS' 754 CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, 755 $ KL, KU, NRHS, A, LDA, XACT, LDA, 756 $ B, LDA, ISEED, INFO ) 757 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 758* 759 SRNAMT = 'ZSYTRS_ROOK' 760 CALL ZSYTRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK, 761 $ X, LDA, INFO ) 762* 763* Check error code from ZSYTRS_ROOK and handle error. 764* 765 IF( INFO.NE.0 ) 766 $ CALL ALAERH( PATH, 'ZSYTRS_ROOK', INFO, 0, 767 $ UPLO, N, N, -1, -1, NRHS, IMAT, 768 $ NFAIL, NERRS, NOUT ) 769* 770 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 771* 772* Compute the residual for the solution 773* 774 CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, 775 $ LDA, RWORK, RESULT( 5 ) ) 776* 777*+ TEST 6 778* Check solution from generated exact solution. 779* 780 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 781 $ RESULT( 6 ) ) 782* 783* Print information about the tests that did not pass 784* the threshold. 785* 786 DO 210 K = 5, 6 787 IF( RESULT( K ).GE.THRESH ) THEN 788 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 789 $ CALL ALAHD( NOUT, PATH ) 790 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, 791 $ IMAT, K, RESULT( K ) 792 NFAIL = NFAIL + 1 793 END IF 794 210 CONTINUE 795 NRUN = NRUN + 2 796* 797* End do for each value of NRHS in NSVAL. 798* 799 220 CONTINUE 800* 801*+ TEST 7 802* Get an estimate of RCOND = 1/CNDNUM. 803* 804 230 CONTINUE 805 ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK ) 806 SRNAMT = 'ZSYCON_ROOK' 807 CALL ZSYCON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM, 808 $ RCOND, WORK, INFO ) 809* 810* Check error code from ZSYCON_ROOK and handle error. 811* 812 IF( INFO.NE.0 ) 813 $ CALL ALAERH( PATH, 'ZSYCON_ROOK', INFO, 0, 814 $ UPLO, N, N, -1, -1, -1, IMAT, 815 $ NFAIL, NERRS, NOUT ) 816* 817* Compute the test ratio to compare values of RCOND 818* 819 RESULT( 7 ) = DGET06( RCOND, RCONDC ) 820* 821* Print information about the tests that did not pass 822* the threshold. 823* 824 IF( RESULT( 7 ).GE.THRESH ) THEN 825 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 826 $ CALL ALAHD( NOUT, PATH ) 827 WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, 828 $ RESULT( 7 ) 829 NFAIL = NFAIL + 1 830 END IF 831 NRUN = NRUN + 1 832 240 CONTINUE 833* 834 250 CONTINUE 835 260 CONTINUE 836 270 CONTINUE 837* 838* Print a summary of the results. 839* 840 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 841* 842 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', 843 $ I2, ', test ', I2, ', ratio =', G12.5 ) 844 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 845 $ I2, ', test(', I2, ') =', G12.5 ) 846 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, 847 $ ', test(', I2, ') =', G12.5 ) 848 RETURN 849* 850* End of ZCHKSY_ROOK 851* 852 END 853