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*> \ingroup complex_lin 159* 160* ===================================================================== 161 SUBROUTINE CCHKHP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 162 $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, 163 $ IWORK, NOUT ) 164* 165* -- LAPACK test routine -- 166* -- LAPACK is a software package provided by Univ. of Tennessee, -- 167* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 168* 169* .. Scalar Arguments .. 170 LOGICAL TSTERR 171 INTEGER NMAX, NN, NNS, NOUT 172 REAL THRESH 173* .. 174* .. Array Arguments .. 175 LOGICAL DOTYPE( * ) 176 INTEGER IWORK( * ), NSVAL( * ), NVAL( * ) 177 REAL RWORK( * ) 178 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), 179 $ WORK( * ), X( * ), XACT( * ) 180* .. 181* 182* ===================================================================== 183* 184* .. Parameters .. 185 REAL ZERO 186 PARAMETER ( ZERO = 0.0E+0 ) 187 INTEGER NTYPES 188 PARAMETER ( NTYPES = 10 ) 189 INTEGER NTESTS 190 PARAMETER ( NTESTS = 8 ) 191* .. 192* .. Local Scalars .. 193 LOGICAL TRFCON, ZEROT 194 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE 195 CHARACTER*3 PATH 196 INTEGER I, I1, I2, IMAT, IN, INFO, IOFF, IRHS, IUPLO, 197 $ IZERO, J, K, KL, KU, LDA, MODE, N, NERRS, 198 $ NFAIL, NIMAT, NPP, NRHS, NRUN, NT 199 REAL ANORM, CNDNUM, RCOND, RCONDC 200* .. 201* .. Local Arrays .. 202 CHARACTER UPLOS( 2 ) 203 INTEGER ISEED( 4 ), ISEEDY( 4 ) 204 REAL RESULT( NTESTS ) 205* .. 206* .. External Functions .. 207 LOGICAL LSAME 208 REAL CLANHP, SGET06 209 EXTERNAL LSAME, CLANHP, SGET06 210* .. 211* .. External Subroutines .. 212 EXTERNAL ALAERH, ALAHD, ALASUM, CCOPY, CERRSY, CGET04, 213 $ CHPCON, CHPRFS, CHPT01, CHPTRF, CHPTRI, CHPTRS, 214 $ CLACPY, CLAIPD, CLARHS, CLATB4, CLATMS, CPPT02, 215 $ CPPT03, CPPT05 216* .. 217* .. Intrinsic Functions .. 218 INTRINSIC MAX, MIN 219* .. 220* .. Scalars in Common .. 221 LOGICAL LERR, OK 222 CHARACTER*32 SRNAMT 223 INTEGER INFOT, NUNIT 224* .. 225* .. Common blocks .. 226 COMMON / INFOC / INFOT, NUNIT, OK, LERR 227 COMMON / SRNAMC / SRNAMT 228* .. 229* .. Data statements .. 230 DATA ISEEDY / 1988, 1989, 1990, 1991 / 231 DATA UPLOS / 'U', 'L' / 232* .. 233* .. Executable Statements .. 234* 235* Initialize constants and the random number seed. 236* 237 PATH( 1: 1 ) = 'Complex precision' 238 PATH( 2: 3 ) = 'HP' 239 NRUN = 0 240 NFAIL = 0 241 NERRS = 0 242 DO 10 I = 1, 4 243 ISEED( I ) = ISEEDY( I ) 244 10 CONTINUE 245* 246* Test the error exits 247* 248 IF( TSTERR ) 249 $ CALL CERRSY( PATH, NOUT ) 250 INFOT = 0 251* 252* Do for each value of N in NVAL 253* 254 DO 170 IN = 1, NN 255 N = NVAL( IN ) 256 LDA = MAX( N, 1 ) 257 XTYPE = 'N' 258 NIMAT = NTYPES 259 IF( N.LE.0 ) 260 $ NIMAT = 1 261* 262 IZERO = 0 263 DO 160 IMAT = 1, NIMAT 264* 265* Do the tests only if DOTYPE( IMAT ) is true. 266* 267 IF( .NOT.DOTYPE( IMAT ) ) 268 $ GO TO 160 269* 270* Skip types 3, 4, 5, or 6 if the matrix size is too small. 271* 272 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 273 IF( ZEROT .AND. N.LT.IMAT-2 ) 274 $ GO TO 160 275* 276* Do first for UPLO = 'U', then for UPLO = 'L' 277* 278 DO 150 IUPLO = 1, 2 279 UPLO = UPLOS( IUPLO ) 280 IF( LSAME( UPLO, 'U' ) ) THEN 281 PACKIT = 'C' 282 ELSE 283 PACKIT = 'R' 284 END IF 285* 286* Set up parameters with CLATB4 and generate a test matrix 287* with CLATMS. 288* 289 CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 290 $ CNDNUM, DIST ) 291* 292 SRNAMT = 'CLATMS' 293 CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 294 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK, 295 $ INFO ) 296* 297* Check error code from CLATMS. 298* 299 IF( INFO.NE.0 ) THEN 300 CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, -1, 301 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 302 GO TO 150 303 END IF 304* 305* For types 3-6, zero one or more rows and columns of 306* the 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 CLAIPD( N, A, 2, 1 ) 376 ELSE 377 CALL CLAIPD( N, A, N, -1 ) 378 END IF 379* 380* Compute the L*D*L' or U*D*U' factorization of the matrix. 381* 382 NPP = N*( N+1 ) / 2 383 CALL CCOPY( NPP, A, 1, AFAC, 1 ) 384 SRNAMT = 'CHPTRF' 385 CALL CHPTRF( UPLO, N, AFAC, IWORK, INFO ) 386* 387* Adjust the expected value of INFO to account for 388* pivoting. 389* 390 K = IZERO 391 IF( K.GT.0 ) THEN 392 100 CONTINUE 393 IF( IWORK( K ).LT.0 ) THEN 394 IF( IWORK( K ).NE.-K ) THEN 395 K = -IWORK( K ) 396 GO TO 100 397 END IF 398 ELSE IF( IWORK( K ).NE.K ) THEN 399 K = IWORK( K ) 400 GO TO 100 401 END IF 402 END IF 403* 404* Check error code from CHPTRF. 405* 406 IF( INFO.NE.K ) 407 $ CALL ALAERH( PATH, 'CHPTRF', INFO, K, UPLO, N, N, -1, 408 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 409 IF( INFO.NE.0 ) THEN 410 TRFCON = .TRUE. 411 ELSE 412 TRFCON = .FALSE. 413 END IF 414* 415*+ TEST 1 416* Reconstruct matrix from factors and compute residual. 417* 418 CALL CHPT01( UPLO, N, A, AFAC, IWORK, AINV, LDA, RWORK, 419 $ RESULT( 1 ) ) 420 NT = 1 421* 422*+ TEST 2 423* Form the inverse and compute the residual. 424* 425 IF( .NOT.TRFCON ) THEN 426 CALL CCOPY( NPP, AFAC, 1, AINV, 1 ) 427 SRNAMT = 'CHPTRI' 428 CALL CHPTRI( UPLO, N, AINV, IWORK, WORK, INFO ) 429* 430* Check error code from CHPTRI. 431* 432 IF( INFO.NE.0 ) 433 $ CALL ALAERH( PATH, 'CHPTRI', INFO, 0, UPLO, N, N, 434 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 435* 436 CALL CPPT03( UPLO, N, A, AINV, WORK, LDA, RWORK, 437 $ RCONDC, RESULT( 2 ) ) 438 NT = 2 439 END IF 440* 441* Print information about the tests that did not pass 442* the threshold. 443* 444 DO 110 K = 1, NT 445 IF( RESULT( K ).GE.THRESH ) THEN 446 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 447 $ CALL ALAHD( NOUT, PATH ) 448 WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, K, 449 $ RESULT( K ) 450 NFAIL = NFAIL + 1 451 END IF 452 110 CONTINUE 453 NRUN = NRUN + NT 454* 455* Do only the condition estimate if INFO is not 0. 456* 457 IF( TRFCON ) THEN 458 RCONDC = ZERO 459 GO TO 140 460 END IF 461* 462 DO 130 IRHS = 1, NNS 463 NRHS = NSVAL( IRHS ) 464* 465*+ TEST 3 466* Solve and compute residual for A * X = B. 467* 468 SRNAMT = 'CLARHS' 469 CALL CLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 470 $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, 471 $ INFO ) 472 XTYPE = 'C' 473 CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 474* 475 SRNAMT = 'CHPTRS' 476 CALL CHPTRS( UPLO, N, NRHS, AFAC, IWORK, X, LDA, 477 $ INFO ) 478* 479* Check error code from CHPTRS. 480* 481 IF( INFO.NE.0 ) 482 $ CALL ALAERH( PATH, 'CHPTRS', INFO, 0, UPLO, N, N, 483 $ -1, -1, NRHS, IMAT, NFAIL, NERRS, 484 $ NOUT ) 485* 486 CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 487 CALL CPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA, 488 $ RWORK, RESULT( 3 ) ) 489* 490*+ TEST 4 491* Check solution from generated exact solution. 492* 493 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 494 $ RESULT( 4 ) ) 495* 496*+ TESTS 5, 6, and 7 497* Use iterative refinement to improve the solution. 498* 499 SRNAMT = 'CHPRFS' 500 CALL CHPRFS( UPLO, N, NRHS, A, AFAC, IWORK, B, LDA, X, 501 $ LDA, RWORK, RWORK( NRHS+1 ), WORK, 502 $ RWORK( 2*NRHS+1 ), INFO ) 503* 504* Check error code from CHPRFS. 505* 506 IF( INFO.NE.0 ) 507 $ CALL ALAERH( PATH, 'CHPRFS', INFO, 0, UPLO, N, N, 508 $ -1, -1, NRHS, IMAT, NFAIL, NERRS, 509 $ NOUT ) 510* 511 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 512 $ RESULT( 5 ) ) 513 CALL CPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA, XACT, 514 $ LDA, RWORK, RWORK( NRHS+1 ), 515 $ RESULT( 6 ) ) 516* 517* Print information about the tests that did not pass 518* the threshold. 519* 520 DO 120 K = 3, 7 521 IF( RESULT( K ).GE.THRESH ) THEN 522 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 523 $ CALL ALAHD( NOUT, PATH ) 524 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT, 525 $ K, RESULT( K ) 526 NFAIL = NFAIL + 1 527 END IF 528 120 CONTINUE 529 NRUN = NRUN + 5 530 130 CONTINUE 531* 532*+ TEST 8 533* Get an estimate of RCOND = 1/CNDNUM. 534* 535 140 CONTINUE 536 ANORM = CLANHP( '1', UPLO, N, A, RWORK ) 537 SRNAMT = 'CHPCON' 538 CALL CHPCON( UPLO, N, AFAC, IWORK, ANORM, RCOND, WORK, 539 $ INFO ) 540* 541* Check error code from CHPCON. 542* 543 IF( INFO.NE.0 ) 544 $ CALL ALAERH( PATH, 'CHPCON', INFO, 0, UPLO, N, N, -1, 545 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 546* 547 RESULT( 8 ) = SGET06( RCOND, RCONDC ) 548* 549* Print the test ratio if it is .GE. THRESH. 550* 551 IF( RESULT( 8 ).GE.THRESH ) THEN 552 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 553 $ CALL ALAHD( NOUT, PATH ) 554 WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, 8, 555 $ RESULT( 8 ) 556 NFAIL = NFAIL + 1 557 END IF 558 NRUN = NRUN + 1 559 150 CONTINUE 560 160 CONTINUE 561 170 CONTINUE 562* 563* Print a summary of the results. 564* 565 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 566* 567 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', type ', I2, ', test ', 568 $ I2, ', ratio =', G12.5 ) 569 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 570 $ I2, ', test(', I2, ') =', G12.5 ) 571 RETURN 572* 573* End of CCHKHP 574* 575 END 576