1 SUBROUTINE SDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, 2 $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, 3 $ RWORK, IWORK, NOUT, INFO90) 4* 5* -- LAPACK test routine (version 3.0) -- 6* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., 7* Courant Institute, Argonne National Lab, and Rice University 8* April 30, 1999 9* 10* .. Scalar Arguments .. 11 LOGICAL TSTERR 12 INTEGER NMAX, NN, NOUT, NRHS, INFO90 13 REAL THRESH 14* .. 15* .. Array Arguments .. 16 LOGICAL DOTYPE( * ) 17 INTEGER IWORK( * ), NVAL( * ) 18 REAL A( * ), AFAC( * ), ASAV( * ), B( * ), 19 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), 20 $ X( * ), XACT( * ) 21* .. 22* 23* Purpose 24* ======= 25* 26* SDRVPP tests the driver routines SPPSV and -SVX. 27* 28* Arguments 29* ========= 30* 31* DOTYPE (input) LOGICAL array, dimension (NTYPES) 32* The matrix types to be used for testing. Matrices of type j 33* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 34* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 35* 36* NN (input) INTEGER 37* The number of values of N contained in the vector NVAL. 38* 39* NVAL (input) INTEGER array, dimension (NN) 40* The values of the matrix dimension N. 41* 42* NRHS (input) INTEGER 43* The number of right hand side vectors to be generated for 44* each linear system. 45* 46* THRESH (input) REAL 47* The threshold value for the test ratios. A result is 48* included in the output file if RESULT >= THRESH. To have 49* every test ratio printed, use THRESH = 0. 50* 51* TSTERR (input) LOGICAL 52* Flag that indicates whether error exits are to be tested. 53* 54* NMAX (input) INTEGER 55* The maximum value permitted for N, used in dimensioning the 56* work arrays. 57* 58* A (workspace) REAL array, dimension 59* (NMAX*(NMAX+1)/2) 60* 61* AFAC (workspace) REAL array, dimension 62* (NMAX*(NMAX+1)/2) 63* 64* ASAV (workspace) REAL array, dimension 65* (NMAX*(NMAX+1)/2) 66* 67* B (workspace) REAL array, dimension (NMAX*NRHS) 68* 69* BSAV (workspace) REAL array, dimension (NMAX*NRHS) 70* 71* X (workspace) REAL array, dimension (NMAX*NRHS) 72* 73* XACT (workspace) REAL array, dimension (NMAX*NRHS) 74* 75* S (workspace) REAL array, dimension (NMAX) 76* 77* WORK (workspace) REAL array, dimension 78* (NMAX*max(3,NRHS)) 79* 80* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) 81* 82* IWORK (workspace) INTEGER array, dimension (NMAX) 83* 84* NOUT (input) INTEGER 85* The unit number for output. 86* 87* INFO90 (input) INTEGER 88* Specifies the test to be performed. 89* ===================================================================== 90* 91* .. Parameters .. 92 REAL ONE, ZERO 93 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 94 INTEGER NTYPES 95 PARAMETER ( NTYPES = 9 ) 96 INTEGER NTESTS 97 PARAMETER ( NTESTS = 6 ) 98* .. 99* .. Local Scalars .. 100 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT 101 CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE 102 CHARACTER*3 PATH 103 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO, 104 $ IZERO, K, K1, KL, KU, LDA, MODE, N, NERRS, 105 $ NFACT, NFAIL, NIMAT, NPP, NRUN, NT 106 REAL AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC, 107 $ ROLDC, SCOND 108* .. 109* .. Local Arrays .. 110 CHARACTER EQUEDS( 2 ), FACTS( 3 ), PACKS( 2 ), UPLOS( 2 ) 111 INTEGER ISEED( 4 ), ISEEDY( 4 ) 112 REAL RESULT( NTESTS ) 113* .. 114* .. External Functions .. 115 LOGICAL LSAME 116 REAL SGET06, SLANSP 117 EXTERNAL LSAME, SGET06, SLANSP 118* .. 119* .. External Subroutines .. 120 EXTERNAL ALADHD, ALAERH, ALASVM, SCOPY, SERRVX, SGET04, 121 $ SLACPY, SLAQSP, SLARHS, SLASET, SLATB4, SLATMS, 122 $ SPPEQU, LA_TEST_SPPSV, LA_TEST_SPPSVX, SPPT01, 123 & SPPT02, SPPT05, SPPTRF, SPPTRI 124* .. 125* .. Scalars in Common .. 126 LOGICAL LERR, OK 127 CHARACTER*6 SRNAMT 128 INTEGER INFOT, NUNIT 129* .. 130* .. Common blocks .. 131 COMMON / INFOC / INFOT, NUNIT, OK, LERR 132 COMMON / SRNAMC / SRNAMT 133* .. 134* .. Intrinsic Functions .. 135 INTRINSIC MAX 136* .. 137* .. Data statements .. 138 DATA ISEEDY / 1988, 1989, 1990, 1991 / 139 DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N', 'E' / , 140 $ PACKS / 'C', 'R' / , EQUEDS / 'N', 'Y' / 141* .. 142* .. Executable Statements .. 143* 144* Initialize constants and the random number seed. 145* 146 INFO = 0 147 PATH( 1: 1 ) = 'Single precision' 148 PATH( 2: 3 ) = 'PP' 149 NRUN = 0 150 NFAIL = 0 151 NERRS = 0 152 DO 10 I = 1, 4 153 ISEED( I ) = ISEEDY( I ) 154 10 CONTINUE 155* 156* Test the error exits 157* 158 IF( TSTERR ) 159 $ CALL SERRVX( PATH, NOUT ) 160 INFOT = 0 161* 162* Do for each value of N in NVAL 163* 164 DO 140 IN = 1, NN 165 N = NVAL( IN ) 166 LDA = MAX( N, 1 ) 167 NPP = N*( N+1 ) / 2 168 XTYPE = 'N' 169 NIMAT = NTYPES 170 IF( N.LE.0 ) 171 $ NIMAT = 1 172* 173 DO 130 IMAT = 1, NIMAT 174* 175* Do the tests only if DOTYPE( IMAT ) is true. 176* 177 IF( .NOT.DOTYPE( IMAT ) ) 178 $ GO TO 130 179* 180* Skip types 3, 4, or 5 if the matrix size is too small. 181* 182 ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 183 IF( ZEROT .AND. N.LT.IMAT-2 ) 184 $ GO TO 130 185* 186* Do first for UPLO = 'U', then for UPLO = 'L' 187* 188 DO 120 IUPLO = 1, 2 189 UPLO = UPLOS( IUPLO ) 190 PACKIT = PACKS( IUPLO ) 191* 192* Set up parameters with SLATB4 and generate a test matrix 193* with SLATMS. 194* 195 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 196 $ CNDNUM, DIST ) 197 RCONDC = ONE / CNDNUM 198* 199 SRNAMT = 'SLATMS' 200 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 201 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK, 202 $ INFO ) 203* 204* Check error code from SLATMS. 205* 206 IF( INFO.NE.0 ) THEN 207 CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, 208 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 209 GO TO 120 210 END IF 211* 212* For types 3-5, zero one row and column of the matrix to 213* test that INFO is returned correctly. 214* 215 IF( ZEROT ) THEN 216 IF( IMAT.EQ.3 ) THEN 217 IZERO = 1 218 ELSE IF( IMAT.EQ.4 ) THEN 219 IZERO = N 220 ELSE 221 IZERO = N / 2 + 1 222 END IF 223* 224* Set row and column IZERO of A to 0. 225* 226 IF( IUPLO.EQ.1 ) THEN 227 IOFF = ( IZERO-1 )*IZERO / 2 228 DO 20 I = 1, IZERO - 1 229 A( IOFF+I ) = ZERO 230 20 CONTINUE 231 IOFF = IOFF + IZERO 232 DO 30 I = IZERO, N 233 A( IOFF ) = ZERO 234 IOFF = IOFF + I 235 30 CONTINUE 236 ELSE 237 IOFF = IZERO 238 DO 40 I = 1, IZERO - 1 239 A( IOFF ) = ZERO 240 IOFF = IOFF + N - I 241 40 CONTINUE 242 IOFF = IOFF - IZERO 243 DO 50 I = IZERO, N 244 A( IOFF+I ) = ZERO 245 50 CONTINUE 246 END IF 247 ELSE 248 IZERO = 0 249 END IF 250* 251* Save a copy of the matrix A in ASAV. 252* 253 CALL SCOPY( NPP, A, 1, ASAV, 1 ) 254* 255 DO 110 IEQUED = 1, 2 256 EQUED = EQUEDS( IEQUED ) 257 IF( IEQUED.EQ.1 ) THEN 258 NFACT = 3 259 ELSE 260 NFACT = 1 261 END IF 262* 263 DO 100 IFACT = 1, NFACT 264 FACT = FACTS( IFACT ) 265 PREFAC = LSAME( FACT, 'F' ) 266 NOFACT = LSAME( FACT, 'N' ) 267 EQUIL = LSAME( FACT, 'E' ) 268* 269 IF( ZEROT ) THEN 270 IF( PREFAC ) 271 $ GO TO 100 272 RCONDC = ZERO 273* 274 ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN 275* 276* Compute the condition number for comparison with 277* the value returned by SPPSVX (FACT = 'N' reuses 278* the condition number from the previous iteration 279* with FACT = 'F'). 280* 281 CALL SCOPY( NPP, ASAV, 1, AFAC, 1 ) 282 IF( EQUIL .OR. IEQUED.GT.1 ) THEN 283* 284* Compute row and column scale factors to 285* equilibrate the matrix A. 286* 287 CALL SPPEQU( UPLO, N, AFAC, S, SCOND, AMAX, 288 $ INFO ) 289 IF( INFO.EQ.0 .AND. N.GT.0 ) THEN 290 IF( IEQUED.GT.1 ) 291 $ SCOND = ZERO 292* 293* Equilibrate the matrix. 294* 295 CALL SLAQSP( UPLO, N, AFAC, S, SCOND, 296 $ AMAX, EQUED ) 297 END IF 298 END IF 299* 300* Save the condition number of the 301* non-equilibrated system for use in SGET04. 302* 303 IF( EQUIL ) 304 $ ROLDC = RCONDC 305* 306* Compute the 1-norm of A. 307* 308 ANORM = SLANSP( '1', UPLO, N, AFAC, RWORK ) 309* 310* Factor the matrix A. 311* 312 CALL SPPTRF( UPLO, N, AFAC, INFO ) 313* 314* Form the inverse of A. 315* 316 CALL SCOPY( NPP, AFAC, 1, A, 1 ) 317 CALL SPPTRI( UPLO, N, A, INFO ) 318* 319* Compute the 1-norm condition number of A. 320* 321 AINVNM = SLANSP( '1', UPLO, N, A, RWORK ) 322 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 323 RCONDC = ONE 324 ELSE 325 RCONDC = ( ONE / ANORM ) / AINVNM 326 END IF 327 END IF 328* 329* Restore the matrix A. 330* 331 CALL SCOPY( NPP, ASAV, 1, A, 1 ) 332* 333* Form an exact solution and set the right hand side. 334* 335 SRNAMT = 'SLARHS' 336 CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 337 $ NRHS, A, LDA, XACT, LDA, B, LDA, 338 $ ISEED, INFO ) 339 XTYPE = 'C' 340 CALL SLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) 341* 342 IF( NOFACT ) THEN 343* 344* --- Test SPPSV --- 345* 346* Compute the L*L' or U'*U factorization of the 347* matrix and solve the system. 348* 349 CALL SCOPY( NPP, A, 1, AFAC, 1 ) 350 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 351* 352 SRNAMT = 'SPPSV ' 353 INFO = INFO90 354 CALL LA_TEST_SPPSV( UPLO, N, NRHS, AFAC, X, 355 $ LDA, INFO ) 356* 357* Check error code from SPPSV . 358* 359 IF( INFO.NE.IZERO ) THEN 360 CALL ALAERH( PATH, 'SPPSV ', INFO, IZERO, 361 $ UPLO, N, N, -1, -1, NRHS, IMAT, 362 $ NFAIL, NERRS, NOUT ) 363 GO TO 70 364 ELSE IF( INFO.NE.0 ) THEN 365 GO TO 70 366 END IF 367* 368* Reconstruct matrix from factors and compute 369* residual. 370* 371 CALL SPPT01( UPLO, N, A, AFAC, RWORK, 372 $ RESULT( 1 ) ) 373* 374* Compute residual of the computed solution. 375* 376 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, 377 $ LDA ) 378 CALL SPPT02( UPLO, N, NRHS, A, X, LDA, WORK, 379 $ LDA, RWORK, RESULT( 2 ) ) 380* 381* Check solution from generated exact solution. 382* 383 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 384 $ RESULT( 3 ) ) 385 NT = 3 386* 387* Print information about the tests that did not 388* pass the threshold. 389* 390 DO 60 K = 1, NT 391 IF( RESULT( K ).GE.THRESH ) THEN 392 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 393 $ CALL ALADHD( NOUT, PATH ) 394 WRITE( NOUT, FMT = 9999 )'SPPSV ', UPLO, 395 $ N, IMAT, K, RESULT( K ) 396 NFAIL = NFAIL + 1 397 END IF 398 60 CONTINUE 399 NRUN = NRUN + NT 400 70 CONTINUE 401 END IF 402* 403* --- Test SPPSVX --- 404* 405 IF( .NOT.PREFAC .AND. NPP.GT.0 ) 406 $ CALL SLASET( 'Full', NPP, 1, ZERO, ZERO, AFAC, 407 $ NPP ) 408 CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) 409 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 410* 411* Equilibrate the matrix if FACT='F' and 412* EQUED='Y'. 413* 414 CALL SLAQSP( UPLO, N, A, S, SCOND, AMAX, EQUED ) 415 END IF 416* 417* Solve the system and compute the condition number 418* and error bounds using SPPSVX. 419* 420 SRNAMT = 'SPPSVX' 421 INFO = 0 422 CALL LA_TEST_SPPSVX( FACT, UPLO, N, NRHS, A, 423 & AFAC, EQUED, 424 $ S, B, LDA, X, LDA, RCOND, RWORK, 425 $ RWORK( NRHS+1 ), WORK, IWORK, INFO ) 426* 427* Check the error code from SPPSVX. 428* 429 IF( INFO.NE.IZERO ) THEN 430 CALL ALAERH( PATH, 'SPPSVX', INFO, IZERO, 431 $ FACT // UPLO, N, N, -1, -1, NRHS, 432 $ IMAT, NFAIL, NERRS, NOUT ) 433 GO TO 90 434 END IF 435* 436 IF( INFO.EQ.0 ) THEN 437 IF( .NOT.PREFAC ) THEN 438* 439* Reconstruct matrix from factors and compute 440* residual. 441* 442 CALL SPPT01( UPLO, N, A, AFAC, 443 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) 444 K1 = 1 445 ELSE 446 K1 = 2 447 END IF 448* 449* Compute residual of the computed solution. 450* 451 CALL SLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, 452 $ LDA ) 453 CALL SPPT02( UPLO, N, NRHS, ASAV, X, LDA, WORK, 454 $ LDA, RWORK( 2*NRHS+1 ), 455 $ RESULT( 2 ) ) 456* 457* Check solution from generated exact solution. 458* 459 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, 460 $ 'N' ) ) ) THEN 461 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, 462 $ RCONDC, RESULT( 3 ) ) 463 ELSE 464 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, 465 $ ROLDC, RESULT( 3 ) ) 466 END IF 467* 468* Check the error bounds from iterative 469* refinement. 470* 471 CALL SPPT05( UPLO, N, NRHS, ASAV, B, LDA, X, 472 $ LDA, XACT, LDA, RWORK, 473 $ RWORK( NRHS+1 ), RESULT( 4 ) ) 474 ELSE 475 K1 = 6 476 END IF 477* 478* Compare RCOND from SPPSVX with the computed value 479* in RCONDC. 480* 481 RESULT( 6 ) = SGET06( RCOND, RCONDC ) 482* 483* Print information about the tests that did not pass 484* the threshold. 485* 486 DO 80 K = K1, 6 487 IF( RESULT( K ).GE.THRESH ) THEN 488 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 489 $ CALL ALADHD( NOUT, PATH ) 490 IF( PREFAC ) THEN 491 WRITE( NOUT, FMT = 9997 )'SPPSVX', FACT, 492 $ UPLO, N, EQUED, IMAT, K, RESULT( K ) 493 ELSE 494 WRITE( NOUT, FMT = 9998 )'SPPSVX', FACT, 495 $ UPLO, N, IMAT, K, RESULT( K ) 496 END IF 497 NFAIL = NFAIL + 1 498 END IF 499 80 CONTINUE 500 NRUN = NRUN + 7 - K1 501 90 CONTINUE 502 100 CONTINUE 503 110 CONTINUE 504 120 CONTINUE 505 130 CONTINUE 506 140 CONTINUE 507* 508* Print a summary of the results. 509* 510 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 511* 512 9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I1, 513 $ ', test(', I1, ')=', G12.5 ) 514 9998 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, 515 $ ', type ', I1, ', test(', I1, ')=', G12.5 ) 516 9997 FORMAT( 1X, A6, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, 517 $ ', EQUED=''', A1, ''', type ', I1, ', test(', I1, ')=', 518 $ G12.5 ) 519 RETURN 520* 521* End of SDRVPP 522* 523 END 524