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