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