![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b CCHKTP 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE CCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 00012 * NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, 00013 * NOUT ) 00014 * 00015 * .. Scalar Arguments .. 00016 * LOGICAL TSTERR 00017 * INTEGER NMAX, NN, NNS, NOUT 00018 * REAL THRESH 00019 * .. 00020 * .. Array Arguments .. 00021 * LOGICAL DOTYPE( * ) 00022 * INTEGER NSVAL( * ), NVAL( * ) 00023 * REAL RWORK( * ) 00024 * COMPLEX AINVP( * ), AP( * ), B( * ), WORK( * ), X( * ), 00025 * $ XACT( * ) 00026 * .. 00027 * 00028 * 00029 *> \par Purpose: 00030 * ============= 00031 *> 00032 *> \verbatim 00033 *> 00034 *> CCHKTP tests CTPTRI, -TRS, -RFS, and -CON, and CLATPS 00035 *> \endverbatim 00036 * 00037 * Arguments: 00038 * ========== 00039 * 00040 *> \param[in] DOTYPE 00041 *> \verbatim 00042 *> DOTYPE is LOGICAL array, dimension (NTYPES) 00043 *> The matrix types to be used for testing. Matrices of type j 00044 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00045 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00046 *> \endverbatim 00047 *> 00048 *> \param[in] NN 00049 *> \verbatim 00050 *> NN is INTEGER 00051 *> The number of values of N contained in the vector NVAL. 00052 *> \endverbatim 00053 *> 00054 *> \param[in] NVAL 00055 *> \verbatim 00056 *> NVAL is INTEGER array, dimension (NN) 00057 *> The values of the matrix column dimension N. 00058 *> \endverbatim 00059 *> 00060 *> \param[in] NNS 00061 *> \verbatim 00062 *> NNS is INTEGER 00063 *> The number of values of NRHS contained in the vector NSVAL. 00064 *> \endverbatim 00065 *> 00066 *> \param[in] NSVAL 00067 *> \verbatim 00068 *> NSVAL is INTEGER array, dimension (NNS) 00069 *> The values of the number of right hand sides NRHS. 00070 *> \endverbatim 00071 *> 00072 *> \param[in] THRESH 00073 *> \verbatim 00074 *> THRESH is REAL 00075 *> The threshold value for the test ratios. A result is 00076 *> included in the output file if RESULT >= THRESH. To have 00077 *> every test ratio printed, use THRESH = 0. 00078 *> \endverbatim 00079 *> 00080 *> \param[in] TSTERR 00081 *> \verbatim 00082 *> TSTERR is LOGICAL 00083 *> Flag that indicates whether error exits are to be tested. 00084 *> \endverbatim 00085 *> 00086 *> \param[in] NMAX 00087 *> \verbatim 00088 *> NMAX is INTEGER 00089 *> The leading dimension of the work arrays. NMAX >= the 00090 *> maximumm value of N in NVAL. 00091 *> \endverbatim 00092 *> 00093 *> \param[out] AP 00094 *> \verbatim 00095 *> AP is COMPLEX array, dimension (NMAX*(NMAX+1)/2) 00096 *> \endverbatim 00097 *> 00098 *> \param[out] AINVP 00099 *> \verbatim 00100 *> AINVP is COMPLEX array, dimension (NMAX*(NMAX+1)/2) 00101 *> \endverbatim 00102 *> 00103 *> \param[out] B 00104 *> \verbatim 00105 *> B is COMPLEX array, dimension (NMAX*NSMAX) 00106 *> where NSMAX is the largest entry in NSVAL. 00107 *> \endverbatim 00108 *> 00109 *> \param[out] X 00110 *> \verbatim 00111 *> X is COMPLEX array, dimension (NMAX*NSMAX) 00112 *> \endverbatim 00113 *> 00114 *> \param[out] XACT 00115 *> \verbatim 00116 *> XACT is COMPLEX array, dimension (NMAX*NSMAX) 00117 *> \endverbatim 00118 *> 00119 *> \param[out] WORK 00120 *> \verbatim 00121 *> WORK is COMPLEX array, dimension 00122 *> (NMAX*max(3,NSMAX)) 00123 *> \endverbatim 00124 *> 00125 *> \param[out] RWORK 00126 *> \verbatim 00127 *> RWORK is REAL array, dimension 00128 *> (max(NMAX,2*NSMAX)) 00129 *> \endverbatim 00130 *> 00131 *> \param[in] NOUT 00132 *> \verbatim 00133 *> NOUT is INTEGER 00134 *> The unit number for output. 00135 *> \endverbatim 00136 * 00137 * Authors: 00138 * ======== 00139 * 00140 *> \author Univ. of Tennessee 00141 *> \author Univ. of California Berkeley 00142 *> \author Univ. of Colorado Denver 00143 *> \author NAG Ltd. 00144 * 00145 *> \date November 2011 00146 * 00147 *> \ingroup complex_lin 00148 * 00149 * ===================================================================== 00150 SUBROUTINE CCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 00151 $ NMAX, AP, AINVP, B, X, XACT, WORK, RWORK, 00152 $ NOUT ) 00153 * 00154 * -- LAPACK test routine (version 3.4.0) -- 00155 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00156 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00157 * November 2011 00158 * 00159 * .. Scalar Arguments .. 00160 LOGICAL TSTERR 00161 INTEGER NMAX, NN, NNS, NOUT 00162 REAL THRESH 00163 * .. 00164 * .. Array Arguments .. 00165 LOGICAL DOTYPE( * ) 00166 INTEGER NSVAL( * ), NVAL( * ) 00167 REAL RWORK( * ) 00168 COMPLEX AINVP( * ), AP( * ), B( * ), WORK( * ), X( * ), 00169 $ XACT( * ) 00170 * .. 00171 * 00172 * ===================================================================== 00173 * 00174 * .. Parameters .. 00175 INTEGER NTYPE1, NTYPES 00176 PARAMETER ( NTYPE1 = 10, NTYPES = 18 ) 00177 INTEGER NTESTS 00178 PARAMETER ( NTESTS = 9 ) 00179 INTEGER NTRAN 00180 PARAMETER ( NTRAN = 3 ) 00181 REAL ONE, ZERO 00182 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00183 * .. 00184 * .. Local Scalars .. 00185 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE 00186 CHARACTER*3 PATH 00187 INTEGER I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO, 00188 $ K, LAP, LDA, N, NERRS, NFAIL, NRHS, NRUN 00189 REAL AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO, 00190 $ SCALE 00191 * .. 00192 * .. Local Arrays .. 00193 CHARACTER TRANSS( NTRAN ), UPLOS( 2 ) 00194 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00195 REAL RESULT( NTESTS ) 00196 * .. 00197 * .. External Functions .. 00198 LOGICAL LSAME 00199 REAL CLANTP 00200 EXTERNAL LSAME, CLANTP 00201 * .. 00202 * .. External Subroutines .. 00203 EXTERNAL ALAERH, ALAHD, ALASUM, CCOPY, CERRTR, CGET04, 00204 $ CLACPY, CLARHS, CLATPS, CLATTP, CTPCON, CTPRFS, 00205 $ CTPT01, CTPT02, CTPT03, CTPT05, CTPT06, CTPTRI, 00206 $ CTPTRS 00207 * .. 00208 * .. Scalars in Common .. 00209 LOGICAL LERR, OK 00210 CHARACTER*32 SRNAMT 00211 INTEGER INFOT, IOUNIT 00212 * .. 00213 * .. Common blocks .. 00214 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 00215 COMMON / SRNAMC / SRNAMT 00216 * .. 00217 * .. Intrinsic Functions .. 00218 INTRINSIC MAX 00219 * .. 00220 * .. Data statements .. 00221 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00222 DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' / 00223 * .. 00224 * .. Executable Statements .. 00225 * 00226 * Initialize constants and the random number seed. 00227 * 00228 PATH( 1: 1 ) = 'Complex precision' 00229 PATH( 2: 3 ) = 'TP' 00230 NRUN = 0 00231 NFAIL = 0 00232 NERRS = 0 00233 DO 10 I = 1, 4 00234 ISEED( I ) = ISEEDY( I ) 00235 10 CONTINUE 00236 * 00237 * Test the error exits 00238 * 00239 IF( TSTERR ) 00240 $ CALL CERRTR( PATH, NOUT ) 00241 INFOT = 0 00242 * 00243 DO 110 IN = 1, NN 00244 * 00245 * Do for each value of N in NVAL 00246 * 00247 N = NVAL( IN ) 00248 LDA = MAX( 1, N ) 00249 LAP = LDA*( LDA+1 ) / 2 00250 XTYPE = 'N' 00251 * 00252 DO 70 IMAT = 1, NTYPE1 00253 * 00254 * Do the tests only if DOTYPE( IMAT ) is true. 00255 * 00256 IF( .NOT.DOTYPE( IMAT ) ) 00257 $ GO TO 70 00258 * 00259 DO 60 IUPLO = 1, 2 00260 * 00261 * Do first for UPLO = 'U', then for UPLO = 'L' 00262 * 00263 UPLO = UPLOS( IUPLO ) 00264 * 00265 * Call CLATTP to generate a triangular test matrix. 00266 * 00267 SRNAMT = 'CLATTP' 00268 CALL CLATTP( IMAT, UPLO, 'No transpose', DIAG, ISEED, N, 00269 $ AP, X, WORK, RWORK, INFO ) 00270 * 00271 * Set IDIAG = 1 for non-unit matrices, 2 for unit. 00272 * 00273 IF( LSAME( DIAG, 'N' ) ) THEN 00274 IDIAG = 1 00275 ELSE 00276 IDIAG = 2 00277 END IF 00278 * 00279 *+ TEST 1 00280 * Form the inverse of A. 00281 * 00282 IF( N.GT.0 ) 00283 $ CALL CCOPY( LAP, AP, 1, AINVP, 1 ) 00284 SRNAMT = 'CTPTRI' 00285 CALL CTPTRI( UPLO, DIAG, N, AINVP, INFO ) 00286 * 00287 * Check error code from CTPTRI. 00288 * 00289 IF( INFO.NE.0 ) 00290 $ CALL ALAERH( PATH, 'CTPTRI', INFO, 0, UPLO // DIAG, N, 00291 $ N, -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00292 * 00293 * Compute the infinity-norm condition number of A. 00294 * 00295 ANORM = CLANTP( 'I', UPLO, DIAG, N, AP, RWORK ) 00296 AINVNM = CLANTP( 'I', UPLO, DIAG, N, AINVP, RWORK ) 00297 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00298 RCONDI = ONE 00299 ELSE 00300 RCONDI = ( ONE / ANORM ) / AINVNM 00301 END IF 00302 * 00303 * Compute the residual for the triangular matrix times its 00304 * inverse. Also compute the 1-norm condition number of A. 00305 * 00306 CALL CTPT01( UPLO, DIAG, N, AP, AINVP, RCONDO, RWORK, 00307 $ RESULT( 1 ) ) 00308 * 00309 * Print the test ratio if it is .GE. THRESH. 00310 * 00311 IF( RESULT( 1 ).GE.THRESH ) THEN 00312 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00313 $ CALL ALAHD( NOUT, PATH ) 00314 WRITE( NOUT, FMT = 9999 )UPLO, DIAG, N, IMAT, 1, 00315 $ RESULT( 1 ) 00316 NFAIL = NFAIL + 1 00317 END IF 00318 NRUN = NRUN + 1 00319 * 00320 DO 40 IRHS = 1, NNS 00321 NRHS = NSVAL( IRHS ) 00322 XTYPE = 'N' 00323 * 00324 DO 30 ITRAN = 1, NTRAN 00325 * 00326 * Do for op(A) = A, A**T, or A**H. 00327 * 00328 TRANS = TRANSS( ITRAN ) 00329 IF( ITRAN.EQ.1 ) THEN 00330 NORM = 'O' 00331 RCONDC = RCONDO 00332 ELSE 00333 NORM = 'I' 00334 RCONDC = RCONDI 00335 END IF 00336 * 00337 *+ TEST 2 00338 * Solve and compute residual for op(A)*x = b. 00339 * 00340 SRNAMT = 'CLARHS' 00341 CALL CLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0, 00342 $ IDIAG, NRHS, AP, LAP, XACT, LDA, B, 00343 $ LDA, ISEED, INFO ) 00344 XTYPE = 'C' 00345 CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 00346 * 00347 SRNAMT = 'CTPTRS' 00348 CALL CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, X, 00349 $ LDA, INFO ) 00350 * 00351 * Check error code from CTPTRS. 00352 * 00353 IF( INFO.NE.0 ) 00354 $ CALL ALAERH( PATH, 'CTPTRS', INFO, 0, 00355 $ UPLO // TRANS // DIAG, N, N, -1, 00356 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00357 * 00358 CALL CTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X, 00359 $ LDA, B, LDA, WORK, RWORK, 00360 $ RESULT( 2 ) ) 00361 * 00362 *+ TEST 3 00363 * Check solution from generated exact solution. 00364 * 00365 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00366 $ RESULT( 3 ) ) 00367 * 00368 *+ TESTS 4, 5, and 6 00369 * Use iterative refinement to improve the solution and 00370 * compute error bounds. 00371 * 00372 SRNAMT = 'CTPRFS' 00373 CALL CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, 00374 $ LDA, X, LDA, RWORK, RWORK( NRHS+1 ), 00375 $ WORK, RWORK( 2*NRHS+1 ), INFO ) 00376 * 00377 * Check error code from CTPRFS. 00378 * 00379 IF( INFO.NE.0 ) 00380 $ CALL ALAERH( PATH, 'CTPRFS', INFO, 0, 00381 $ UPLO // TRANS // DIAG, N, N, -1, 00382 $ -1, NRHS, IMAT, NFAIL, NERRS, 00383 $ NOUT ) 00384 * 00385 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00386 $ RESULT( 4 ) ) 00387 CALL CTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B, 00388 $ LDA, X, LDA, XACT, LDA, RWORK, 00389 $ RWORK( NRHS+1 ), RESULT( 5 ) ) 00390 * 00391 * Print information about the tests that did not pass 00392 * the threshold. 00393 * 00394 DO 20 K = 2, 6 00395 IF( RESULT( K ).GE.THRESH ) THEN 00396 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00397 $ CALL ALAHD( NOUT, PATH ) 00398 WRITE( NOUT, FMT = 9998 )UPLO, TRANS, DIAG, 00399 $ N, NRHS, IMAT, K, RESULT( K ) 00400 NFAIL = NFAIL + 1 00401 END IF 00402 20 CONTINUE 00403 NRUN = NRUN + 5 00404 30 CONTINUE 00405 40 CONTINUE 00406 * 00407 *+ TEST 7 00408 * Get an estimate of RCOND = 1/CNDNUM. 00409 * 00410 DO 50 ITRAN = 1, 2 00411 IF( ITRAN.EQ.1 ) THEN 00412 NORM = 'O' 00413 RCONDC = RCONDO 00414 ELSE 00415 NORM = 'I' 00416 RCONDC = RCONDI 00417 END IF 00418 SRNAMT = 'CTPCON' 00419 CALL CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, 00420 $ RWORK, INFO ) 00421 * 00422 * Check error code from CTPCON. 00423 * 00424 IF( INFO.NE.0 ) 00425 $ CALL ALAERH( PATH, 'CTPCON', INFO, 0, 00426 $ NORM // UPLO // DIAG, N, N, -1, -1, 00427 $ -1, IMAT, NFAIL, NERRS, NOUT ) 00428 * 00429 CALL CTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK, 00430 $ RESULT( 7 ) ) 00431 * 00432 * Print the test ratio if it is .GE. THRESH. 00433 * 00434 IF( RESULT( 7 ).GE.THRESH ) THEN 00435 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00436 $ CALL ALAHD( NOUT, PATH ) 00437 WRITE( NOUT, FMT = 9997 ) 'CTPCON', NORM, UPLO, 00438 $ DIAG, N, IMAT, 7, RESULT( 7 ) 00439 NFAIL = NFAIL + 1 00440 END IF 00441 NRUN = NRUN + 1 00442 50 CONTINUE 00443 60 CONTINUE 00444 70 CONTINUE 00445 * 00446 * Use pathological test matrices to test CLATPS. 00447 * 00448 DO 100 IMAT = NTYPE1 + 1, NTYPES 00449 * 00450 * Do the tests only if DOTYPE( IMAT ) is true. 00451 * 00452 IF( .NOT.DOTYPE( IMAT ) ) 00453 $ GO TO 100 00454 * 00455 DO 90 IUPLO = 1, 2 00456 * 00457 * Do first for UPLO = 'U', then for UPLO = 'L' 00458 * 00459 UPLO = UPLOS( IUPLO ) 00460 DO 80 ITRAN = 1, NTRAN 00461 * 00462 * Do for op(A) = A, A**T, or A**H. 00463 * 00464 TRANS = TRANSS( ITRAN ) 00465 * 00466 * Call CLATTP to generate a triangular test matrix. 00467 * 00468 SRNAMT = 'CLATTP' 00469 CALL CLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, X, 00470 $ WORK, RWORK, INFO ) 00471 * 00472 *+ TEST 8 00473 * Solve the system op(A)*x = b. 00474 * 00475 SRNAMT = 'CLATPS' 00476 CALL CCOPY( N, X, 1, B, 1 ) 00477 CALL CLATPS( UPLO, TRANS, DIAG, 'N', N, AP, B, SCALE, 00478 $ RWORK, INFO ) 00479 * 00480 * Check error code from CLATPS. 00481 * 00482 IF( INFO.NE.0 ) 00483 $ CALL ALAERH( PATH, 'CLATPS', INFO, 0, 00484 $ UPLO // TRANS // DIAG // 'N', N, N, 00485 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00486 * 00487 CALL CTPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE, 00488 $ RWORK, ONE, B, LDA, X, LDA, WORK, 00489 $ RESULT( 8 ) ) 00490 * 00491 *+ TEST 9 00492 * Solve op(A)*x = b again with NORMIN = 'Y'. 00493 * 00494 CALL CCOPY( N, X, 1, B( N+1 ), 1 ) 00495 CALL CLATPS( UPLO, TRANS, DIAG, 'Y', N, AP, B( N+1 ), 00496 $ SCALE, RWORK, INFO ) 00497 * 00498 * Check error code from CLATPS. 00499 * 00500 IF( INFO.NE.0 ) 00501 $ CALL ALAERH( PATH, 'CLATPS', INFO, 0, 00502 $ UPLO // TRANS // DIAG // 'Y', N, N, 00503 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00504 * 00505 CALL CTPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE, 00506 $ RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK, 00507 $ RESULT( 9 ) ) 00508 * 00509 * Print information about the tests that did not pass 00510 * the threshold. 00511 * 00512 IF( RESULT( 8 ).GE.THRESH ) THEN 00513 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00514 $ CALL ALAHD( NOUT, PATH ) 00515 WRITE( NOUT, FMT = 9996 )'CLATPS', UPLO, TRANS, 00516 $ DIAG, 'N', N, IMAT, 8, RESULT( 8 ) 00517 NFAIL = NFAIL + 1 00518 END IF 00519 IF( RESULT( 9 ).GE.THRESH ) THEN 00520 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00521 $ CALL ALAHD( NOUT, PATH ) 00522 WRITE( NOUT, FMT = 9996 )'CLATPS', UPLO, TRANS, 00523 $ DIAG, 'Y', N, IMAT, 9, RESULT( 9 ) 00524 NFAIL = NFAIL + 1 00525 END IF 00526 NRUN = NRUN + 2 00527 80 CONTINUE 00528 90 CONTINUE 00529 100 CONTINUE 00530 110 CONTINUE 00531 * 00532 * Print a summary of the results. 00533 * 00534 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00535 * 00536 9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5, 00537 $ ', type ', I2, ', test(', I2, ')= ', G12.5 ) 00538 9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1, 00539 $ ''', N=', I5, ''', NRHS=', I5, ', type ', I2, ', test(', 00540 $ I2, ')= ', G12.5 ) 00541 9997 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',', 00542 $ I5, ', ... ), type ', I2, ', test(', I2, ')=', G12.5 ) 00543 9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''', 00544 $ A1, ''',', I5, ', ... ), type ', I2, ', test(', I2, ')=', 00545 $ G12.5 ) 00546 RETURN 00547 * 00548 * End of CCHKTP 00549 * 00550 END