1*> \brief \b CCHKTP 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 CCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 12* NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, 13* 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 NSVAL( * ), NVAL( * ) 23* REAL RWORK( * ) 24* COMPLEX AINVP( * ), AP( * ), B( * ), WORK( * ), X( * ), 25* $ XACT( * ) 26* .. 27* 28* 29*> \par Purpose: 30* ============= 31*> 32*> \verbatim 33*> 34*> CCHKTP tests CTPTRI, -TRS, -RFS, and -CON, and CLATPS 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 column 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 leading dimension of the work arrays. NMAX >= the 90*> maximumm value of N in NVAL. 91*> \endverbatim 92*> 93*> \param[out] AP 94*> \verbatim 95*> AP is COMPLEX array, dimension (NMAX*(NMAX+1)/2) 96*> \endverbatim 97*> 98*> \param[out] AINVP 99*> \verbatim 100*> AINVP is COMPLEX array, dimension (NMAX*(NMAX+1)/2) 101*> \endverbatim 102*> 103*> \param[out] B 104*> \verbatim 105*> B is COMPLEX array, dimension (NMAX*NSMAX) 106*> where NSMAX is the largest entry in NSVAL. 107*> \endverbatim 108*> 109*> \param[out] X 110*> \verbatim 111*> X is COMPLEX array, dimension (NMAX*NSMAX) 112*> \endverbatim 113*> 114*> \param[out] XACT 115*> \verbatim 116*> XACT is COMPLEX array, dimension (NMAX*NSMAX) 117*> \endverbatim 118*> 119*> \param[out] WORK 120*> \verbatim 121*> WORK is COMPLEX array, dimension 122*> (NMAX*max(3,NSMAX)) 123*> \endverbatim 124*> 125*> \param[out] RWORK 126*> \verbatim 127*> RWORK is REAL array, dimension 128*> (max(NMAX,2*NSMAX)) 129*> \endverbatim 130*> 131*> \param[in] NOUT 132*> \verbatim 133*> NOUT is INTEGER 134*> The unit number for output. 135*> \endverbatim 136* 137* Authors: 138* ======== 139* 140*> \author Univ. of Tennessee 141*> \author Univ. of California Berkeley 142*> \author Univ. of Colorado Denver 143*> \author NAG Ltd. 144* 145*> \ingroup complex_lin 146* 147* ===================================================================== 148 SUBROUTINE CCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 149 $ NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, 150 $ NOUT ) 151* 152* -- LAPACK test routine -- 153* -- LAPACK is a software package provided by Univ. of Tennessee, -- 154* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 155* 156* .. Scalar Arguments .. 157 LOGICAL TSTERR 158 INTEGER NMAX, NN, NNS, NOUT 159 REAL THRESH 160* .. 161* .. Array Arguments .. 162 LOGICAL DOTYPE( * ) 163 INTEGER NSVAL( * ), NVAL( * ) 164 REAL RWORK( * ) 165 COMPLEX AINVP( * ), AP( * ), B( * ), WORK( * ), X( * ), 166 $ XACT( * ) 167* .. 168* 169* ===================================================================== 170* 171* .. Parameters .. 172 INTEGER NTYPE1, NTYPES 173 PARAMETER ( NTYPE1 = 10, NTYPES = 18 ) 174 INTEGER NTESTS 175 PARAMETER ( NTESTS = 9 ) 176 INTEGER NTRAN 177 PARAMETER ( NTRAN = 3 ) 178 REAL ONE, ZERO 179 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 180* .. 181* .. Local Scalars .. 182 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE 183 CHARACTER*3 PATH 184 INTEGER I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO, 185 $ K, LAP, LDA, N, NERRS, NFAIL, NRHS, NRUN 186 REAL AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO, 187 $ SCALE 188* .. 189* .. Local Arrays .. 190 CHARACTER TRANSS( NTRAN ), UPLOS( 2 ) 191 INTEGER ISEED( 4 ), ISEEDY( 4 ) 192 REAL RESULT( NTESTS ) 193* .. 194* .. External Functions .. 195 LOGICAL LSAME 196 REAL CLANTP 197 EXTERNAL LSAME, CLANTP 198* .. 199* .. External Subroutines .. 200 EXTERNAL ALAERH, ALAHD, ALASUM, CCOPY, CERRTR, CGET04, 201 $ CLACPY, CLARHS, CLATPS, CLATTP, CTPCON, CTPRFS, 202 $ CTPT01, CTPT02, CTPT03, CTPT05, CTPT06, CTPTRI, 203 $ CTPTRS 204* .. 205* .. Scalars in Common .. 206 LOGICAL LERR, OK 207 CHARACTER*32 SRNAMT 208 INTEGER INFOT, IOUNIT 209* .. 210* .. Common blocks .. 211 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 212 COMMON / SRNAMC / SRNAMT 213* .. 214* .. Intrinsic Functions .. 215 INTRINSIC MAX 216* .. 217* .. Data statements .. 218 DATA ISEEDY / 1988, 1989, 1990, 1991 / 219 DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' / 220* .. 221* .. Executable Statements .. 222* 223* Initialize constants and the random number seed. 224* 225 PATH( 1: 1 ) = 'Complex precision' 226 PATH( 2: 3 ) = 'TP' 227 NRUN = 0 228 NFAIL = 0 229 NERRS = 0 230 DO 10 I = 1, 4 231 ISEED( I ) = ISEEDY( I ) 232 10 CONTINUE 233* 234* Test the error exits 235* 236 IF( TSTERR ) 237 $ CALL CERRTR( PATH, NOUT ) 238 INFOT = 0 239* 240 DO 110 IN = 1, NN 241* 242* Do for each value of N in NVAL 243* 244 N = NVAL( IN ) 245 LDA = MAX( 1, N ) 246 LAP = LDA*( LDA+1 ) / 2 247 XTYPE = 'N' 248* 249 DO 70 IMAT = 1, NTYPE1 250* 251* Do the tests only if DOTYPE( IMAT ) is true. 252* 253 IF( .NOT.DOTYPE( IMAT ) ) 254 $ GO TO 70 255* 256 DO 60 IUPLO = 1, 2 257* 258* Do first for UPLO = 'U', then for UPLO = 'L' 259* 260 UPLO = UPLOS( IUPLO ) 261* 262* Call CLATTP to generate a triangular test matrix. 263* 264 SRNAMT = 'CLATTP' 265 CALL CLATTP( IMAT, UPLO, 'No transpose', DIAG, ISEED, N, 266 $ AP, X, WORK, RWORK, INFO ) 267* 268* Set IDIAG = 1 for non-unit matrices, 2 for unit. 269* 270 IF( LSAME( DIAG, 'N' ) ) THEN 271 IDIAG = 1 272 ELSE 273 IDIAG = 2 274 END IF 275* 276*+ TEST 1 277* Form the inverse of A. 278* 279 IF( N.GT.0 ) 280 $ CALL CCOPY( LAP, AP, 1, AINVP, 1 ) 281 SRNAMT = 'CTPTRI' 282 CALL CTPTRI( UPLO, DIAG, N, AINVP, INFO ) 283* 284* Check error code from CTPTRI. 285* 286 IF( INFO.NE.0 ) 287 $ CALL ALAERH( PATH, 'CTPTRI', INFO, 0, UPLO // DIAG, N, 288 $ N, -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 289* 290* Compute the infinity-norm condition number of A. 291* 292 ANORM = CLANTP( 'I', UPLO, DIAG, N, AP, RWORK ) 293 AINVNM = CLANTP( 'I', UPLO, DIAG, N, AINVP, RWORK ) 294 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 295 RCONDI = ONE 296 ELSE 297 RCONDI = ( ONE / ANORM ) / AINVNM 298 END IF 299* 300* Compute the residual for the triangular matrix times its 301* inverse. Also compute the 1-norm condition number of A. 302* 303 CALL CTPT01( UPLO, DIAG, N, AP, AINVP, RCONDO, RWORK, 304 $ RESULT( 1 ) ) 305* 306* Print the test ratio if it is .GE. THRESH. 307* 308 IF( RESULT( 1 ).GE.THRESH ) THEN 309 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 310 $ CALL ALAHD( NOUT, PATH ) 311 WRITE( NOUT, FMT = 9999 )UPLO, DIAG, N, IMAT, 1, 312 $ RESULT( 1 ) 313 NFAIL = NFAIL + 1 314 END IF 315 NRUN = NRUN + 1 316* 317 DO 40 IRHS = 1, NNS 318 NRHS = NSVAL( IRHS ) 319 XTYPE = 'N' 320* 321 DO 30 ITRAN = 1, NTRAN 322* 323* Do for op(A) = A, A**T, or A**H. 324* 325 TRANS = TRANSS( ITRAN ) 326 IF( ITRAN.EQ.1 ) THEN 327 NORM = 'O' 328 RCONDC = RCONDO 329 ELSE 330 NORM = 'I' 331 RCONDC = RCONDI 332 END IF 333* 334*+ TEST 2 335* Solve and compute residual for op(A)*x = b. 336* 337 SRNAMT = 'CLARHS' 338 CALL CLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0, 339 $ IDIAG, NRHS, AP, LAP, XACT, LDA, B, 340 $ LDA, ISEED, INFO ) 341 XTYPE = 'C' 342 CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 343* 344 SRNAMT = 'CTPTRS' 345 CALL CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, X, 346 $ LDA, INFO ) 347* 348* Check error code from CTPTRS. 349* 350 IF( INFO.NE.0 ) 351 $ CALL ALAERH( PATH, 'CTPTRS', INFO, 0, 352 $ UPLO // TRANS // DIAG, N, N, -1, 353 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 354* 355 CALL CTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, 356 $ LDA, B, LDA, WORK, RWORK, 357 $ RESULT( 2 ) ) 358* 359*+ TEST 3 360* Check solution from generated exact solution. 361* 362 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 363 $ RESULT( 3 ) ) 364* 365*+ TESTS 4, 5, and 6 366* Use iterative refinement to improve the solution and 367* compute error bounds. 368* 369 SRNAMT = 'CTPRFS' 370 CALL CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, 371 $ LDA, X, LDA, RWORK, RWORK( NRHS+1 ), 372 $ WORK, RWORK( 2*NRHS+1 ), INFO ) 373* 374* Check error code from CTPRFS. 375* 376 IF( INFO.NE.0 ) 377 $ CALL ALAERH( PATH, 'CTPRFS', INFO, 0, 378 $ UPLO // TRANS // DIAG, N, N, -1, 379 $ -1, NRHS, IMAT, NFAIL, NERRS, 380 $ NOUT ) 381* 382 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 383 $ RESULT( 4 ) ) 384 CALL CTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, 385 $ LDA, X, LDA, XACT, LDA, RWORK, 386 $ RWORK( NRHS+1 ), RESULT( 5 ) ) 387* 388* Print information about the tests that did not pass 389* the threshold. 390* 391 DO 20 K = 2, 6 392 IF( RESULT( K ).GE.THRESH ) THEN 393 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 394 $ CALL ALAHD( NOUT, PATH ) 395 WRITE( NOUT, FMT = 9998 )UPLO, TRANS, DIAG, 396 $ N, NRHS, IMAT, K, RESULT( K ) 397 NFAIL = NFAIL + 1 398 END IF 399 20 CONTINUE 400 NRUN = NRUN + 5 401 30 CONTINUE 402 40 CONTINUE 403* 404*+ TEST 7 405* Get an estimate of RCOND = 1/CNDNUM. 406* 407 DO 50 ITRAN = 1, 2 408 IF( ITRAN.EQ.1 ) THEN 409 NORM = 'O' 410 RCONDC = RCONDO 411 ELSE 412 NORM = 'I' 413 RCONDC = RCONDI 414 END IF 415 SRNAMT = 'CTPCON' 416 CALL CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, 417 $ RWORK, INFO ) 418* 419* Check error code from CTPCON. 420* 421 IF( INFO.NE.0 ) 422 $ CALL ALAERH( PATH, 'CTPCON', INFO, 0, 423 $ NORM // UPLO // DIAG, N, N, -1, -1, 424 $ -1, IMAT, NFAIL, NERRS, NOUT ) 425* 426 CALL CTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK, 427 $ RESULT( 7 ) ) 428* 429* Print the test ratio if it is .GE. THRESH. 430* 431 IF( RESULT( 7 ).GE.THRESH ) THEN 432 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 433 $ CALL ALAHD( NOUT, PATH ) 434 WRITE( NOUT, FMT = 9997 ) 'CTPCON', NORM, UPLO, 435 $ DIAG, N, IMAT, 7, RESULT( 7 ) 436 NFAIL = NFAIL + 1 437 END IF 438 NRUN = NRUN + 1 439 50 CONTINUE 440 60 CONTINUE 441 70 CONTINUE 442* 443* Use pathological test matrices to test CLATPS. 444* 445 DO 100 IMAT = NTYPE1 + 1, NTYPES 446* 447* Do the tests only if DOTYPE( IMAT ) is true. 448* 449 IF( .NOT.DOTYPE( IMAT ) ) 450 $ GO TO 100 451* 452 DO 90 IUPLO = 1, 2 453* 454* Do first for UPLO = 'U', then for UPLO = 'L' 455* 456 UPLO = UPLOS( IUPLO ) 457 DO 80 ITRAN = 1, NTRAN 458* 459* Do for op(A) = A, A**T, or A**H. 460* 461 TRANS = TRANSS( ITRAN ) 462* 463* Call CLATTP to generate a triangular test matrix. 464* 465 SRNAMT = 'CLATTP' 466 CALL CLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, X, 467 $ WORK, RWORK, INFO ) 468* 469*+ TEST 8 470* Solve the system op(A)*x = b. 471* 472 SRNAMT = 'CLATPS' 473 CALL CCOPY( N, X, 1, B, 1 ) 474 CALL CLATPS( UPLO, TRANS, DIAG, 'N', N, AP, B, SCALE, 475 $ RWORK, INFO ) 476* 477* Check error code from CLATPS. 478* 479 IF( INFO.NE.0 ) 480 $ CALL ALAERH( PATH, 'CLATPS', INFO, 0, 481 $ UPLO // TRANS // DIAG // 'N', N, N, 482 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 483* 484 CALL CTPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE, 485 $ RWORK, ONE, B, LDA, X, LDA, WORK, 486 $ RESULT( 8 ) ) 487* 488*+ TEST 9 489* Solve op(A)*x = b again with NORMIN = 'Y'. 490* 491 CALL CCOPY( N, X, 1, B( N+1 ), 1 ) 492 CALL CLATPS( UPLO, TRANS, DIAG, 'Y', N, AP, B( N+1 ), 493 $ SCALE, RWORK, INFO ) 494* 495* Check error code from CLATPS. 496* 497 IF( INFO.NE.0 ) 498 $ CALL ALAERH( PATH, 'CLATPS', INFO, 0, 499 $ UPLO // TRANS // DIAG // 'Y', N, N, 500 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 501* 502 CALL CTPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE, 503 $ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK, 504 $ RESULT( 9 ) ) 505* 506* Print information about the tests that did not pass 507* the threshold. 508* 509 IF( RESULT( 8 ).GE.THRESH ) THEN 510 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 511 $ CALL ALAHD( NOUT, PATH ) 512 WRITE( NOUT, FMT = 9996 )'CLATPS', UPLO, TRANS, 513 $ DIAG, 'N', N, IMAT, 8, RESULT( 8 ) 514 NFAIL = NFAIL + 1 515 END IF 516 IF( RESULT( 9 ).GE.THRESH ) THEN 517 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 518 $ CALL ALAHD( NOUT, PATH ) 519 WRITE( NOUT, FMT = 9996 )'CLATPS', UPLO, TRANS, 520 $ DIAG, 'Y', N, IMAT, 9, RESULT( 9 ) 521 NFAIL = NFAIL + 1 522 END IF 523 NRUN = NRUN + 2 524 80 CONTINUE 525 90 CONTINUE 526 100 CONTINUE 527 110 CONTINUE 528* 529* Print a summary of the results. 530* 531 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 532* 533 9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, 534 $ ', type ', I2, ', test(', I2, ')= ', G12.5 ) 535 9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1, 536 $ ''', N=', I5, ''', NRHS=', I5, ', type ', I2, ', test(', 537 $ I2, ')= ', G12.5 ) 538 9997 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',', 539 $ I5, ', ... ), type ', I2, ', test(', I2, ')=', G12.5 ) 540 9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''', 541 $ A1, ''',', I5, ', ... ), type ', I2, ', test(', I2, ')=', 542 $ G12.5 ) 543 RETURN 544* 545* End of CCHKTP 546* 547 END 548