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