1*> \brief \b ZDRVPP 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 ZDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, 12* A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, 13* RWORK, NOUT ) 14* 15* .. Scalar Arguments .. 16* LOGICAL TSTERR 17* INTEGER NMAX, NN, NOUT, NRHS 18* DOUBLE PRECISION THRESH 19* .. 20* .. Array Arguments .. 21* LOGICAL DOTYPE( * ) 22* INTEGER NVAL( * ) 23* DOUBLE PRECISION RWORK( * ), S( * ) 24* COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ), 25* $ BSAV( * ), WORK( * ), X( * ), XACT( * ) 26* .. 27* 28* 29*> \par Purpose: 30* ============= 31*> 32*> \verbatim 33*> 34*> ZDRVPP tests the driver routines ZPPSV and -SVX. 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 dimension N. 58*> \endverbatim 59*> 60*> \param[in] NRHS 61*> \verbatim 62*> NRHS is INTEGER 63*> The number of right hand side vectors to be generated for 64*> each linear system. 65*> \endverbatim 66*> 67*> \param[in] THRESH 68*> \verbatim 69*> THRESH is DOUBLE PRECISION 70*> The threshold value for the test ratios. A result is 71*> included in the output file if RESULT >= THRESH. To have 72*> every test ratio printed, use THRESH = 0. 73*> \endverbatim 74*> 75*> \param[in] TSTERR 76*> \verbatim 77*> TSTERR is LOGICAL 78*> Flag that indicates whether error exits are to be tested. 79*> \endverbatim 80*> 81*> \param[in] NMAX 82*> \verbatim 83*> NMAX is INTEGER 84*> The maximum value permitted for N, used in dimensioning the 85*> work arrays. 86*> \endverbatim 87*> 88*> \param[out] A 89*> \verbatim 90*> A is COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) 91*> \endverbatim 92*> 93*> \param[out] AFAC 94*> \verbatim 95*> AFAC is COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) 96*> \endverbatim 97*> 98*> \param[out] ASAV 99*> \verbatim 100*> ASAV is COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2) 101*> \endverbatim 102*> 103*> \param[out] B 104*> \verbatim 105*> B is COMPLEX*16 array, dimension (NMAX*NRHS) 106*> \endverbatim 107*> 108*> \param[out] BSAV 109*> \verbatim 110*> BSAV is COMPLEX*16 array, dimension (NMAX*NRHS) 111*> \endverbatim 112*> 113*> \param[out] X 114*> \verbatim 115*> X is COMPLEX*16 array, dimension (NMAX*NRHS) 116*> \endverbatim 117*> 118*> \param[out] XACT 119*> \verbatim 120*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS) 121*> \endverbatim 122*> 123*> \param[out] S 124*> \verbatim 125*> S is DOUBLE PRECISION array, dimension (NMAX) 126*> \endverbatim 127*> 128*> \param[out] WORK 129*> \verbatim 130*> WORK is COMPLEX*16 array, dimension 131*> (NMAX*max(3,NRHS)) 132*> \endverbatim 133*> 134*> \param[out] RWORK 135*> \verbatim 136*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) 137*> \endverbatim 138*> 139*> \param[in] NOUT 140*> \verbatim 141*> NOUT is INTEGER 142*> The unit number for output. 143*> \endverbatim 144* 145* Authors: 146* ======== 147* 148*> \author Univ. of Tennessee 149*> \author Univ. of California Berkeley 150*> \author Univ. of Colorado Denver 151*> \author NAG Ltd. 152* 153*> \ingroup complex16_lin 154* 155* ===================================================================== 156 SUBROUTINE ZDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, 157 $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, 158 $ RWORK, NOUT ) 159* 160* -- LAPACK test routine -- 161* -- LAPACK is a software package provided by Univ. of Tennessee, -- 162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 163* 164* .. Scalar Arguments .. 165 LOGICAL TSTERR 166 INTEGER NMAX, NN, NOUT, NRHS 167 DOUBLE PRECISION THRESH 168* .. 169* .. Array Arguments .. 170 LOGICAL DOTYPE( * ) 171 INTEGER NVAL( * ) 172 DOUBLE PRECISION RWORK( * ), S( * ) 173 COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ), 174 $ BSAV( * ), WORK( * ), X( * ), XACT( * ) 175* .. 176* 177* ===================================================================== 178* 179* .. Parameters .. 180 DOUBLE PRECISION ONE, ZERO 181 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 182 INTEGER NTYPES 183 PARAMETER ( NTYPES = 9 ) 184 INTEGER NTESTS 185 PARAMETER ( NTESTS = 6 ) 186* .. 187* .. Local Scalars .. 188 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT 189 CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE 190 CHARACTER*3 PATH 191 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO, 192 $ IZERO, K, K1, KL, KU, LDA, MODE, N, NERRS, 193 $ NFACT, NFAIL, NIMAT, NPP, NRUN, NT 194 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC, 195 $ ROLDC, SCOND 196* .. 197* .. Local Arrays .. 198 CHARACTER EQUEDS( 2 ), FACTS( 3 ), PACKS( 2 ), UPLOS( 2 ) 199 INTEGER ISEED( 4 ), ISEEDY( 4 ) 200 DOUBLE PRECISION RESULT( NTESTS ) 201* .. 202* .. External Functions .. 203 LOGICAL LSAME 204 DOUBLE PRECISION DGET06, ZLANHP 205 EXTERNAL LSAME, DGET06, ZLANHP 206* .. 207* .. External Subroutines .. 208 EXTERNAL ALADHD, ALAERH, ALASVM, ZCOPY, ZERRVX, ZGET04, 209 $ ZLACPY, ZLAIPD, ZLAQHP, ZLARHS, ZLASET, ZLATB4, 210 $ ZLATMS, ZPPEQU, ZPPSV, ZPPSVX, ZPPT01, ZPPT02, 211 $ ZPPT05, ZPPTRF, ZPPTRI 212* .. 213* .. Scalars in Common .. 214 LOGICAL LERR, OK 215 CHARACTER*32 SRNAMT 216 INTEGER INFOT, NUNIT 217* .. 218* .. Common blocks .. 219 COMMON / INFOC / INFOT, NUNIT, OK, LERR 220 COMMON / SRNAMC / SRNAMT 221* .. 222* .. Intrinsic Functions .. 223 INTRINSIC DCMPLX, MAX 224* .. 225* .. Data statements .. 226 DATA ISEEDY / 1988, 1989, 1990, 1991 / 227 DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N', 'E' / , 228 $ PACKS / 'C', 'R' / , EQUEDS / 'N', 'Y' / 229* .. 230* .. Executable Statements .. 231* 232* Initialize constants and the random number seed. 233* 234 PATH( 1: 1 ) = 'Zomplex precision' 235 PATH( 2: 3 ) = 'PP' 236 NRUN = 0 237 NFAIL = 0 238 NERRS = 0 239 DO 10 I = 1, 4 240 ISEED( I ) = ISEEDY( I ) 241 10 CONTINUE 242* 243* Test the error exits 244* 245 IF( TSTERR ) 246 $ CALL ZERRVX( PATH, NOUT ) 247 INFOT = 0 248* 249* Do for each value of N in NVAL 250* 251 DO 140 IN = 1, NN 252 N = NVAL( IN ) 253 LDA = MAX( N, 1 ) 254 NPP = N*( N+1 ) / 2 255 XTYPE = 'N' 256 NIMAT = NTYPES 257 IF( N.LE.0 ) 258 $ NIMAT = 1 259* 260 DO 130 IMAT = 1, NIMAT 261* 262* Do the tests only if DOTYPE( IMAT ) is true. 263* 264 IF( .NOT.DOTYPE( IMAT ) ) 265 $ GO TO 130 266* 267* Skip types 3, 4, or 5 if the matrix size is too small. 268* 269 ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 270 IF( ZEROT .AND. N.LT.IMAT-2 ) 271 $ GO TO 130 272* 273* Do first for UPLO = 'U', then for UPLO = 'L' 274* 275 DO 120 IUPLO = 1, 2 276 UPLO = UPLOS( IUPLO ) 277 PACKIT = PACKS( IUPLO ) 278* 279* Set up parameters with ZLATB4 and generate a test matrix 280* with ZLATMS. 281* 282 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 283 $ CNDNUM, DIST ) 284 RCONDC = ONE / CNDNUM 285* 286 SRNAMT = 'ZLATMS' 287 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 288 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK, 289 $ INFO ) 290* 291* Check error code from ZLATMS. 292* 293 IF( INFO.NE.0 ) THEN 294 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1, 295 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 296 GO TO 120 297 END IF 298* 299* For types 3-5, zero one row and column of the matrix to 300* test that INFO is returned correctly. 301* 302 IF( ZEROT ) THEN 303 IF( IMAT.EQ.3 ) THEN 304 IZERO = 1 305 ELSE IF( IMAT.EQ.4 ) THEN 306 IZERO = N 307 ELSE 308 IZERO = N / 2 + 1 309 END IF 310* 311* Set row and column IZERO of A to 0. 312* 313 IF( IUPLO.EQ.1 ) THEN 314 IOFF = ( IZERO-1 )*IZERO / 2 315 DO 20 I = 1, IZERO - 1 316 A( IOFF+I ) = ZERO 317 20 CONTINUE 318 IOFF = IOFF + IZERO 319 DO 30 I = IZERO, N 320 A( IOFF ) = ZERO 321 IOFF = IOFF + I 322 30 CONTINUE 323 ELSE 324 IOFF = IZERO 325 DO 40 I = 1, IZERO - 1 326 A( IOFF ) = ZERO 327 IOFF = IOFF + N - I 328 40 CONTINUE 329 IOFF = IOFF - IZERO 330 DO 50 I = IZERO, N 331 A( IOFF+I ) = ZERO 332 50 CONTINUE 333 END IF 334 ELSE 335 IZERO = 0 336 END IF 337* 338* Set the imaginary part of the diagonals. 339* 340 IF( IUPLO.EQ.1 ) THEN 341 CALL ZLAIPD( N, A, 2, 1 ) 342 ELSE 343 CALL ZLAIPD( N, A, N, -1 ) 344 END IF 345* 346* Save a copy of the matrix A in ASAV. 347* 348 CALL ZCOPY( NPP, A, 1, ASAV, 1 ) 349* 350 DO 110 IEQUED = 1, 2 351 EQUED = EQUEDS( IEQUED ) 352 IF( IEQUED.EQ.1 ) THEN 353 NFACT = 3 354 ELSE 355 NFACT = 1 356 END IF 357* 358 DO 100 IFACT = 1, NFACT 359 FACT = FACTS( IFACT ) 360 PREFAC = LSAME( FACT, 'F' ) 361 NOFACT = LSAME( FACT, 'N' ) 362 EQUIL = LSAME( FACT, 'E' ) 363* 364 IF( ZEROT ) THEN 365 IF( PREFAC ) 366 $ GO TO 100 367 RCONDC = ZERO 368* 369 ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN 370* 371* Compute the condition number for comparison with 372* the value returned by ZPPSVX (FACT = 'N' reuses 373* the condition number from the previous iteration 374* with FACT = 'F'). 375* 376 CALL ZCOPY( NPP, ASAV, 1, AFAC, 1 ) 377 IF( EQUIL .OR. IEQUED.GT.1 ) THEN 378* 379* Compute row and column scale factors to 380* equilibrate the matrix A. 381* 382 CALL ZPPEQU( UPLO, N, AFAC, S, SCOND, AMAX, 383 $ INFO ) 384 IF( INFO.EQ.0 .AND. N.GT.0 ) THEN 385 IF( IEQUED.GT.1 ) 386 $ SCOND = ZERO 387* 388* Equilibrate the matrix. 389* 390 CALL ZLAQHP( UPLO, N, AFAC, S, SCOND, 391 $ AMAX, EQUED ) 392 END IF 393 END IF 394* 395* Save the condition number of the 396* non-equilibrated system for use in ZGET04. 397* 398 IF( EQUIL ) 399 $ ROLDC = RCONDC 400* 401* Compute the 1-norm of A. 402* 403 ANORM = ZLANHP( '1', UPLO, N, AFAC, RWORK ) 404* 405* Factor the matrix A. 406* 407 CALL ZPPTRF( UPLO, N, AFAC, INFO ) 408* 409* Form the inverse of A. 410* 411 CALL ZCOPY( NPP, AFAC, 1, A, 1 ) 412 CALL ZPPTRI( UPLO, N, A, INFO ) 413* 414* Compute the 1-norm condition number of A. 415* 416 AINVNM = ZLANHP( '1', UPLO, N, A, RWORK ) 417 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 418 RCONDC = ONE 419 ELSE 420 RCONDC = ( ONE / ANORM ) / AINVNM 421 END IF 422 END IF 423* 424* Restore the matrix A. 425* 426 CALL ZCOPY( NPP, ASAV, 1, A, 1 ) 427* 428* Form an exact solution and set the right hand side. 429* 430 SRNAMT = 'ZLARHS' 431 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 432 $ NRHS, A, LDA, XACT, LDA, B, LDA, 433 $ ISEED, INFO ) 434 XTYPE = 'C' 435 CALL ZLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) 436* 437 IF( NOFACT ) THEN 438* 439* --- Test ZPPSV --- 440* 441* Compute the L*L' or U'*U factorization of the 442* matrix and solve the system. 443* 444 CALL ZCOPY( NPP, A, 1, AFAC, 1 ) 445 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 446* 447 SRNAMT = 'ZPPSV ' 448 CALL ZPPSV( UPLO, N, NRHS, AFAC, X, LDA, INFO ) 449* 450* Check error code from ZPPSV . 451* 452 IF( INFO.NE.IZERO ) THEN 453 CALL ALAERH( PATH, 'ZPPSV ', INFO, IZERO, 454 $ UPLO, N, N, -1, -1, NRHS, IMAT, 455 $ NFAIL, NERRS, NOUT ) 456 GO TO 70 457 ELSE IF( INFO.NE.0 ) THEN 458 GO TO 70 459 END IF 460* 461* Reconstruct matrix from factors and compute 462* residual. 463* 464 CALL ZPPT01( UPLO, N, A, AFAC, RWORK, 465 $ RESULT( 1 ) ) 466* 467* Compute residual of the computed solution. 468* 469 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, 470 $ LDA ) 471 CALL ZPPT02( UPLO, N, NRHS, A, X, LDA, WORK, 472 $ LDA, RWORK, RESULT( 2 ) ) 473* 474* Check solution from generated exact solution. 475* 476 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 477 $ RESULT( 3 ) ) 478 NT = 3 479* 480* Print information about the tests that did not 481* pass the threshold. 482* 483 DO 60 K = 1, NT 484 IF( RESULT( K ).GE.THRESH ) THEN 485 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 486 $ CALL ALADHD( NOUT, PATH ) 487 WRITE( NOUT, FMT = 9999 )'ZPPSV ', UPLO, 488 $ N, IMAT, K, RESULT( K ) 489 NFAIL = NFAIL + 1 490 END IF 491 60 CONTINUE 492 NRUN = NRUN + NT 493 70 CONTINUE 494 END IF 495* 496* --- Test ZPPSVX --- 497* 498 IF( .NOT.PREFAC .AND. NPP.GT.0 ) 499 $ CALL ZLASET( 'Full', NPP, 1, DCMPLX( ZERO ), 500 $ DCMPLX( ZERO ), AFAC, NPP ) 501 CALL ZLASET( 'Full', N, NRHS, DCMPLX( ZERO ), 502 $ DCMPLX( ZERO ), X, LDA ) 503 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 504* 505* Equilibrate the matrix if FACT='F' and 506* EQUED='Y'. 507* 508 CALL ZLAQHP( UPLO, N, A, S, SCOND, AMAX, EQUED ) 509 END IF 510* 511* Solve the system and compute the condition number 512* and error bounds using ZPPSVX. 513* 514 SRNAMT = 'ZPPSVX' 515 CALL ZPPSVX( FACT, UPLO, N, NRHS, A, AFAC, EQUED, 516 $ S, B, LDA, X, LDA, RCOND, RWORK, 517 $ RWORK( NRHS+1 ), WORK, 518 $ RWORK( 2*NRHS+1 ), INFO ) 519* 520* Check the error code from ZPPSVX. 521* 522 IF( INFO.NE.IZERO ) THEN 523 CALL ALAERH( PATH, 'ZPPSVX', INFO, IZERO, 524 $ FACT // UPLO, N, N, -1, -1, NRHS, 525 $ IMAT, NFAIL, NERRS, NOUT ) 526 GO TO 90 527 END IF 528* 529 IF( INFO.EQ.0 ) THEN 530 IF( .NOT.PREFAC ) THEN 531* 532* Reconstruct matrix from factors and compute 533* residual. 534* 535 CALL ZPPT01( UPLO, N, A, AFAC, 536 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) 537 K1 = 1 538 ELSE 539 K1 = 2 540 END IF 541* 542* Compute residual of the computed solution. 543* 544 CALL ZLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, 545 $ LDA ) 546 CALL ZPPT02( UPLO, N, NRHS, ASAV, X, LDA, WORK, 547 $ LDA, RWORK( 2*NRHS+1 ), 548 $ RESULT( 2 ) ) 549* 550* Check solution from generated exact solution. 551* 552 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, 553 $ 'N' ) ) ) THEN 554 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, 555 $ RCONDC, RESULT( 3 ) ) 556 ELSE 557 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, 558 $ ROLDC, RESULT( 3 ) ) 559 END IF 560* 561* Check the error bounds from iterative 562* refinement. 563* 564 CALL ZPPT05( UPLO, N, NRHS, ASAV, B, LDA, X, 565 $ LDA, XACT, LDA, RWORK, 566 $ RWORK( NRHS+1 ), RESULT( 4 ) ) 567 ELSE 568 K1 = 6 569 END IF 570* 571* Compare RCOND from ZPPSVX with the computed value 572* in RCONDC. 573* 574 RESULT( 6 ) = DGET06( RCOND, RCONDC ) 575* 576* Print information about the tests that did not pass 577* the threshold. 578* 579 DO 80 K = K1, 6 580 IF( RESULT( K ).GE.THRESH ) THEN 581 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 582 $ CALL ALADHD( NOUT, PATH ) 583 IF( PREFAC ) THEN 584 WRITE( NOUT, FMT = 9997 )'ZPPSVX', FACT, 585 $ UPLO, N, EQUED, IMAT, K, RESULT( K ) 586 ELSE 587 WRITE( NOUT, FMT = 9998 )'ZPPSVX', FACT, 588 $ UPLO, N, IMAT, K, RESULT( K ) 589 END IF 590 NFAIL = NFAIL + 1 591 END IF 592 80 CONTINUE 593 NRUN = NRUN + 7 - K1 594 90 CONTINUE 595 100 CONTINUE 596 110 CONTINUE 597 120 CONTINUE 598 130 CONTINUE 599 140 CONTINUE 600* 601* Print a summary of the results. 602* 603 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 604* 605 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I1, 606 $ ', test(', I1, ')=', G12.5 ) 607 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, 608 $ ', type ', I1, ', test(', I1, ')=', G12.5 ) 609 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, 610 $ ', EQUED=''', A1, ''', type ', I1, ', test(', I1, ')=', 611 $ G12.5 ) 612 RETURN 613* 614* End of ZDRVPP 615* 616 END 617