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