1*> \brief \b CCHKHP 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 CCHKHP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 12* NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, 13* IWORK, NOUT ) 14* 15* .. Scalar Arguments .. 16* LOGICAL TSTERR 17* INTEGER NMAX, NN, NNS, NOUT 18* REAL THRESH 19* .. 20* .. Array Arguments .. 21* LOGICAL DOTYPE( * ) 22* INTEGER IWORK( * ), NSVAL( * ), NVAL( * ) 23* REAL RWORK( * ) 24* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), 25* $ WORK( * ), X( * ), XACT( * ) 26* .. 27* 28* 29*> \par Purpose: 30* ============= 31*> 32*> \verbatim 33*> 34*> CCHKHP tests CHPTRF, -TRI, -TRS, -RFS, and -CON 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] NNS 61*> \verbatim 62*> NNS is INTEGER 63*> The number of values of NRHS contained in the vector NSVAL. 64*> \endverbatim 65*> 66*> \param[in] NSVAL 67*> \verbatim 68*> NSVAL is INTEGER array, dimension (NNS) 69*> The values of the number of right hand sides NRHS. 70*> \endverbatim 71*> 72*> \param[in] THRESH 73*> \verbatim 74*> THRESH is REAL 75*> The threshold value for the test ratios. A result is 76*> included in the output file if RESULT >= THRESH. To have 77*> every test ratio printed, use THRESH = 0. 78*> \endverbatim 79*> 80*> \param[in] TSTERR 81*> \verbatim 82*> TSTERR is LOGICAL 83*> Flag that indicates whether error exits are to be tested. 84*> \endverbatim 85*> 86*> \param[in] NMAX 87*> \verbatim 88*> NMAX is INTEGER 89*> The maximum value permitted for N, used in dimensioning the 90*> work arrays. 91*> \endverbatim 92*> 93*> \param[out] A 94*> \verbatim 95*> A is COMPLEX array, dimension 96*> (NMAX*(NMAX+1)/2) 97*> \endverbatim 98*> 99*> \param[out] AFAC 100*> \verbatim 101*> AFAC is COMPLEX array, dimension 102*> (NMAX*(NMAX+1)/2) 103*> \endverbatim 104*> 105*> \param[out] AINV 106*> \verbatim 107*> AINV is COMPLEX array, dimension 108*> (NMAX*(NMAX+1)/2) 109*> \endverbatim 110*> 111*> \param[out] B 112*> \verbatim 113*> B is COMPLEX array, dimension (NMAX*NSMAX) 114*> where NSMAX is the largest entry in NSVAL. 115*> \endverbatim 116*> 117*> \param[out] X 118*> \verbatim 119*> X is COMPLEX array, dimension (NMAX*NSMAX) 120*> \endverbatim 121*> 122*> \param[out] XACT 123*> \verbatim 124*> XACT is COMPLEX array, dimension (NMAX*NSMAX) 125*> \endverbatim 126*> 127*> \param[out] WORK 128*> \verbatim 129*> WORK is COMPLEX array, dimension 130*> (NMAX*max(2,NSMAX)) 131*> \endverbatim 132*> 133*> \param[out] RWORK 134*> \verbatim 135*> RWORK is REAL array, 136*> dimension (NMAX+2*NSMAX) 137*> \endverbatim 138*> 139*> \param[out] IWORK 140*> \verbatim 141*> IWORK is INTEGER array, dimension (NMAX) 142*> \endverbatim 143*> 144*> \param[in] NOUT 145*> \verbatim 146*> NOUT is INTEGER 147*> The unit number for output. 148*> \endverbatim 149* 150* Authors: 151* ======== 152* 153*> \author Univ. of Tennessee 154*> \author Univ. of California Berkeley 155*> \author Univ. of Colorado Denver 156*> \author NAG Ltd. 157* 158*> \date November 2011 159* 160*> \ingroup complex_lin 161* 162* ===================================================================== 163 SUBROUTINE CCHKHP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 164 $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, 165 $ IWORK, NOUT ) 166* 167* -- LAPACK test routine (version 3.4.0) -- 168* -- LAPACK is a software package provided by Univ. of Tennessee, -- 169* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 170* November 2011 171* 172* .. Scalar Arguments .. 173 LOGICAL TSTERR 174 INTEGER NMAX, NN, NNS, NOUT 175 REAL THRESH 176* .. 177* .. Array Arguments .. 178 LOGICAL DOTYPE( * ) 179 INTEGER IWORK( * ), NSVAL( * ), NVAL( * ) 180 REAL RWORK( * ) 181 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), 182 $ WORK( * ), X( * ), XACT( * ) 183* .. 184* 185* ===================================================================== 186* 187* .. Parameters .. 188 REAL ZERO 189 PARAMETER ( ZERO = 0.0E+0 ) 190 INTEGER NTYPES 191 PARAMETER ( NTYPES = 10 ) 192 INTEGER NTESTS 193 PARAMETER ( NTESTS = 8 ) 194* .. 195* .. Local Scalars .. 196 LOGICAL TRFCON, ZEROT 197 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE 198 CHARACTER*3 PATH 199 INTEGER I, I1, I2, IMAT, IN, INFO, IOFF, IRHS, IUPLO, 200 $ IZERO, J, K, KL, KU, LDA, MODE, N, NERRS, 201 $ NFAIL, NIMAT, NPP, NRHS, NRUN, NT 202 REAL ANORM, CNDNUM, RCOND, RCONDC 203* .. 204* .. Local Arrays .. 205 CHARACTER UPLOS( 2 ) 206 INTEGER ISEED( 4 ), ISEEDY( 4 ) 207 REAL RESULT( NTESTS ) 208* .. 209* .. External Functions .. 210 LOGICAL LSAME 211 REAL CLANHP, SGET06 212 EXTERNAL LSAME, CLANHP, SGET06 213* .. 214* .. External Subroutines .. 215 EXTERNAL ALAERH, ALAHD, ALASUM, CCOPY, CERRSY, CGET04, 216 $ CHPCON, CHPRFS, CHPT01, CHPTRF, CHPTRI, CHPTRS, 217 $ CLACPY, CLAIPD, CLARHS, CLATB4, CLATMS, CPPT02, 218 $ CPPT03, CPPT05 219* .. 220* .. Intrinsic Functions .. 221 INTRINSIC MAX, MIN 222* .. 223* .. Scalars in Common .. 224 LOGICAL LERR, OK 225 CHARACTER*32 SRNAMT 226 INTEGER INFOT, NUNIT 227* .. 228* .. Common blocks .. 229 COMMON / INFOC / INFOT, NUNIT, OK, LERR 230 COMMON / SRNAMC / SRNAMT 231* .. 232* .. Data statements .. 233 DATA ISEEDY / 1988, 1989, 1990, 1991 / 234 DATA UPLOS / 'U', 'L' / 235* .. 236* .. Executable Statements .. 237* 238* Initialize constants and the random number seed. 239* 240 PATH( 1: 1 ) = 'Complex precision' 241 PATH( 2: 3 ) = 'HP' 242 NRUN = 0 243 NFAIL = 0 244 NERRS = 0 245 DO 10 I = 1, 4 246 ISEED( I ) = ISEEDY( I ) 247 10 CONTINUE 248* 249* Test the error exits 250* 251 IF( TSTERR ) 252 $ CALL CERRSY( PATH, NOUT ) 253 INFOT = 0 254* 255* Do for each value of N in NVAL 256* 257 DO 170 IN = 1, NN 258 N = NVAL( IN ) 259 LDA = MAX( N, 1 ) 260 XTYPE = 'N' 261 NIMAT = NTYPES 262 IF( N.LE.0 ) 263 $ NIMAT = 1 264* 265 IZERO = 0 266 DO 160 IMAT = 1, NIMAT 267* 268* Do the tests only if DOTYPE( IMAT ) is true. 269* 270 IF( .NOT.DOTYPE( IMAT ) ) 271 $ GO TO 160 272* 273* Skip types 3, 4, 5, or 6 if the matrix size is too small. 274* 275 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 276 IF( ZEROT .AND. N.LT.IMAT-2 ) 277 $ GO TO 160 278* 279* Do first for UPLO = 'U', then for UPLO = 'L' 280* 281 DO 150 IUPLO = 1, 2 282 UPLO = UPLOS( IUPLO ) 283 IF( LSAME( UPLO, 'U' ) ) THEN 284 PACKIT = 'C' 285 ELSE 286 PACKIT = 'R' 287 END IF 288* 289* Set up parameters with CLATB4 and generate a test matrix 290* with CLATMS. 291* 292 CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 293 $ CNDNUM, DIST ) 294* 295 SRNAMT = 'CLATMS' 296 CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 297 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK, 298 $ INFO ) 299* 300* Check error code from CLATMS. 301* 302 IF( INFO.NE.0 ) THEN 303 CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, -1, 304 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 305 GO TO 150 306 END IF 307* 308* For types 3-6, zero one or more rows and columns of 309* the 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 CLAIPD( N, A, 2, 1 ) 379 ELSE 380 CALL CLAIPD( N, A, N, -1 ) 381 END IF 382* 383* Compute the L*D*L' or U*D*U' factorization of the matrix. 384* 385 NPP = N*( N+1 ) / 2 386 CALL CCOPY( NPP, A, 1, AFAC, 1 ) 387 SRNAMT = 'CHPTRF' 388 CALL CHPTRF( UPLO, N, AFAC, IWORK, INFO ) 389* 390* Adjust the expected value of INFO to account for 391* pivoting. 392* 393 K = IZERO 394 IF( K.GT.0 ) THEN 395 100 CONTINUE 396 IF( IWORK( K ).LT.0 ) THEN 397 IF( IWORK( K ).NE.-K ) THEN 398 K = -IWORK( K ) 399 GO TO 100 400 END IF 401 ELSE IF( IWORK( K ).NE.K ) THEN 402 K = IWORK( K ) 403 GO TO 100 404 END IF 405 END IF 406* 407* Check error code from CHPTRF. 408* 409 IF( INFO.NE.K ) 410 $ CALL ALAERH( PATH, 'CHPTRF', INFO, K, UPLO, N, N, -1, 411 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 412 IF( INFO.NE.0 ) THEN 413 TRFCON = .TRUE. 414 ELSE 415 TRFCON = .FALSE. 416 END IF 417* 418*+ TEST 1 419* Reconstruct matrix from factors and compute residual. 420* 421 CALL CHPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA, RWORK, 422 $ RESULT( 1 ) ) 423 NT = 1 424* 425*+ TEST 2 426* Form the inverse and compute the residual. 427* 428 IF( .NOT.TRFCON ) THEN 429 CALL CCOPY( NPP, AFAC, 1, AINV, 1 ) 430 SRNAMT = 'CHPTRI' 431 CALL CHPTRI( UPLO, N, AINV, IWORK, WORK, INFO ) 432* 433* Check error code from CHPTRI. 434* 435 IF( INFO.NE.0 ) 436 $ CALL ALAERH( PATH, 'CHPTRI', INFO, 0, UPLO, N, N, 437 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 438* 439 CALL CPPT03( UPLO, N, A, AINV, WORK, LDA, RWORK, 440 $ RCONDC, RESULT( 2 ) ) 441 NT = 2 442 END IF 443* 444* Print information about the tests that did not pass 445* the threshold. 446* 447 DO 110 K = 1, NT 448 IF( RESULT( K ).GE.THRESH ) THEN 449 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 450 $ CALL ALAHD( NOUT, PATH ) 451 WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, K, 452 $ RESULT( K ) 453 NFAIL = NFAIL + 1 454 END IF 455 110 CONTINUE 456 NRUN = NRUN + NT 457* 458* Do only the condition estimate if INFO is not 0. 459* 460 IF( TRFCON ) THEN 461 RCONDC = ZERO 462 GO TO 140 463 END IF 464* 465 DO 130 IRHS = 1, NNS 466 NRHS = NSVAL( IRHS ) 467* 468*+ TEST 3 469* Solve and compute residual for A * X = B. 470* 471 SRNAMT = 'CLARHS' 472 CALL CLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 473 $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, 474 $ INFO ) 475 XTYPE = 'C' 476 CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 477* 478 SRNAMT = 'CHPTRS' 479 CALL CHPTRS( UPLO, N, NRHS, AFAC, IWORK, X, LDA, 480 $ INFO ) 481* 482* Check error code from CHPTRS. 483* 484 IF( INFO.NE.0 ) 485 $ CALL ALAERH( PATH, 'CHPTRS', INFO, 0, UPLO, N, N, 486 $ -1, -1, NRHS, IMAT, NFAIL, NERRS, 487 $ NOUT ) 488* 489 CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 490 CALL CPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA, 491 $ RWORK, RESULT( 3 ) ) 492* 493*+ TEST 4 494* Check solution from generated exact solution. 495* 496 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 497 $ RESULT( 4 ) ) 498* 499*+ TESTS 5, 6, and 7 500* Use iterative refinement to improve the solution. 501* 502 SRNAMT = 'CHPRFS' 503 CALL CHPRFS( UPLO, N, NRHS, A, AFAC, IWORK, B, LDA, X, 504 $ LDA, RWORK, RWORK( NRHS+1 ), WORK, 505 $ RWORK( 2*NRHS+1 ), INFO ) 506* 507* Check error code from CHPRFS. 508* 509 IF( INFO.NE.0 ) 510 $ CALL ALAERH( PATH, 'CHPRFS', INFO, 0, UPLO, N, N, 511 $ -1, -1, NRHS, IMAT, NFAIL, NERRS, 512 $ NOUT ) 513* 514 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 515 $ RESULT( 5 ) ) 516 CALL CPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA, XACT, 517 $ LDA, RWORK, RWORK( NRHS+1 ), 518 $ RESULT( 6 ) ) 519* 520* Print information about the tests that did not pass 521* the threshold. 522* 523 DO 120 K = 3, 7 524 IF( RESULT( K ).GE.THRESH ) THEN 525 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 526 $ CALL ALAHD( NOUT, PATH ) 527 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT, 528 $ K, RESULT( K ) 529 NFAIL = NFAIL + 1 530 END IF 531 120 CONTINUE 532 NRUN = NRUN + 5 533 130 CONTINUE 534* 535*+ TEST 8 536* Get an estimate of RCOND = 1/CNDNUM. 537* 538 140 CONTINUE 539 ANORM = CLANHP( '1', UPLO, N, A, RWORK ) 540 SRNAMT = 'CHPCON' 541 CALL CHPCON( UPLO, N, AFAC, IWORK, ANORM, RCOND, WORK, 542 $ INFO ) 543* 544* Check error code from CHPCON. 545* 546 IF( INFO.NE.0 ) 547 $ CALL ALAERH( PATH, 'CHPCON', INFO, 0, UPLO, N, N, -1, 548 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 549* 550 RESULT( 8 ) = SGET06( RCOND, RCONDC ) 551* 552* Print the test ratio if it is .GE. THRESH. 553* 554 IF( RESULT( 8 ).GE.THRESH ) THEN 555 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 556 $ CALL ALAHD( NOUT, PATH ) 557 WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, 8, 558 $ RESULT( 8 ) 559 NFAIL = NFAIL + 1 560 END IF 561 NRUN = NRUN + 1 562 150 CONTINUE 563 160 CONTINUE 564 170 CONTINUE 565* 566* Print a summary of the results. 567* 568 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 569* 570 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', type ', I2, ', test ', 571 $ I2, ', ratio =', G12.5 ) 572 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 573 $ I2, ', test(', I2, ') =', G12.5 ) 574 RETURN 575* 576* End of CCHKHP 577* 578 END 579