 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE CCHKPO( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, 00002 $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, 00003 $ XACT, WORK, RWORK, NOUT ) 00004 * 00005 * -- LAPACK test routine (version 3.1) -- 00006 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00007 * November 2006 00008 * 00009 * .. Scalar Arguments .. 00010 LOGICAL TSTERR 00011 INTEGER NMAX, NN, NNB, NNS, NOUT 00012 REAL THRESH 00013 * .. 00014 * .. Array Arguments .. 00015 LOGICAL DOTYPE( * ) 00016 INTEGER NBVAL( * ), NSVAL( * ), NVAL( * ) 00017 REAL RWORK( * ) 00018 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), 00019 $ WORK( * ), X( * ), XACT( * ) 00020 * .. 00021 * 00022 * Purpose 00023 * ======= 00024 * 00025 * CCHKPO tests CPOTRF, -TRI, -TRS, -RFS, and -CON 00026 * 00027 * Arguments 00028 * ========= 00029 * 00030 * DOTYPE (input) LOGICAL array, dimension (NTYPES) 00031 * The matrix types to be used for testing. Matrices of type j 00032 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00033 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00034 * 00035 * NN (input) INTEGER 00036 * The number of values of N contained in the vector NVAL. 00037 * 00038 * NVAL (input) INTEGER array, dimension (NN) 00039 * The values of the matrix dimension N. 00040 * 00041 * NNB (input) INTEGER 00042 * The number of values of NB contained in the vector NBVAL. 00043 * 00044 * NBVAL (input) INTEGER array, dimension (NBVAL) 00045 * The values of the blocksize NB. 00046 * 00047 * NNS (input) INTEGER 00048 * The number of values of NRHS contained in the vector NSVAL. 00049 * 00050 * NSVAL (input) INTEGER array, dimension (NNS) 00051 * The values of the number of right hand sides NRHS. 00052 * 00053 * THRESH (input) REAL 00054 * The threshold value for the test ratios. A result is 00055 * included in the output file if RESULT >= THRESH. To have 00056 * every test ratio printed, use THRESH = 0. 00057 * 00058 * TSTERR (input) LOGICAL 00059 * Flag that indicates whether error exits are to be tested. 00060 * 00061 * NMAX (input) INTEGER 00062 * The maximum value permitted for N, used in dimensioning the 00063 * work arrays. 00064 * 00065 * A (workspace) COMPLEX array, dimension (NMAX*NMAX) 00066 * 00067 * AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) 00068 * 00069 * AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) 00070 * 00071 * B (workspace) COMPLEX array, dimension (NMAX*NSMAX) 00072 * where NSMAX is the largest entry in NSVAL. 00073 * 00074 * X (workspace) COMPLEX array, dimension (NMAX*NSMAX) 00075 * 00076 * XACT (workspace) COMPLEX array, dimension (NMAX*NSMAX) 00077 * 00078 * WORK (workspace) COMPLEX array, dimension 00079 * (NMAX*max(3,NSMAX)) 00080 * 00081 * RWORK (workspace) REAL array, dimension 00082 * (NMAX+2*NSMAX) 00083 * 00084 * NOUT (input) INTEGER 00085 * The unit number for output. 00086 * 00087 * ===================================================================== 00088 * 00089 * .. Parameters .. 00090 COMPLEX CZERO 00091 PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) 00092 INTEGER NTYPES 00093 PARAMETER ( NTYPES = 9 ) 00094 INTEGER NTESTS 00095 PARAMETER ( NTESTS = 8 ) 00096 * .. 00097 * .. Local Scalars .. 00098 LOGICAL ZEROT 00099 CHARACTER DIST, TYPE, UPLO, XTYPE 00100 CHARACTER*3 PATH 00101 INTEGER I, IMAT, IN, INB, INFO, IOFF, IRHS, IUPLO, 00102 $ IZERO, K, KL, KU, LDA, MODE, N, NB, NERRS, 00103 $ NFAIL, NIMAT, NRHS, NRUN 00104 REAL ANORM, CNDNUM, RCOND, RCONDC 00105 * .. 00106 * .. Local Arrays .. 00107 CHARACTER UPLOS( 2 ) 00108 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00109 REAL RESULT( NTESTS ) 00110 * .. 00111 * .. External Functions .. 00112 REAL CLANHE, SGET06 00113 EXTERNAL CLANHE, SGET06 00114 * .. 00115 * .. External Subroutines .. 00116 EXTERNAL ALAERH, ALAHD, ALASUM, CERRPO, CGET04, CLACPY, 00117 $ CLAIPD, CLARHS, CLATB4, CLATMS, CPOCON, CPORFS, 00118 $ CPOT01, CPOT02, CPOT03, CPOT05, CPOTRF, CPOTRI, 00119 $ CPOTRS, XLAENV 00120 * .. 00121 * .. Scalars in Common .. 00122 LOGICAL LERR, OK 00123 CHARACTER*32 SRNAMT 00124 INTEGER INFOT, NUNIT 00125 * .. 00126 * .. Common blocks .. 00127 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00128 COMMON / SRNAMC / SRNAMT 00129 * .. 00130 * .. Intrinsic Functions .. 00131 INTRINSIC MAX 00132 * .. 00133 * .. Data statements .. 00134 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00135 DATA UPLOS / 'U', 'L' / 00136 * .. 00137 * .. Executable Statements .. 00138 * 00139 * Initialize constants and the random number seed. 00140 * 00141 PATH( 1: 1 ) = 'Complex precision' 00142 PATH( 2: 3 ) = 'PO' 00143 NRUN = 0 00144 NFAIL = 0 00145 NERRS = 0 00146 DO 10 I = 1, 4 00147 ISEED( I ) = ISEEDY( I ) 00148 10 CONTINUE 00149 * 00150 * Test the error exits 00151 * 00152 IF( TSTERR ) 00153 $ CALL CERRPO( PATH, NOUT ) 00154 INFOT = 0 00155 * 00156 * Do for each value of N in NVAL 00157 * 00158 DO 120 IN = 1, NN 00159 N = NVAL( IN ) 00160 LDA = MAX( N, 1 ) 00161 XTYPE = 'N' 00162 NIMAT = NTYPES 00163 IF( N.LE.0 ) 00164 $ NIMAT = 1 00165 * 00166 IZERO = 0 00167 DO 110 IMAT = 1, NIMAT 00168 * 00169 * Do the tests only if DOTYPE( IMAT ) is true. 00170 * 00171 IF( .NOT.DOTYPE( IMAT ) ) 00172 $ GO TO 110 00173 * 00174 * Skip types 3, 4, or 5 if the matrix size is too small. 00175 * 00176 ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 00177 IF( ZEROT .AND. N.LT.IMAT-2 ) 00178 $ GO TO 110 00179 * 00180 * Do first for UPLO = 'U', then for UPLO = 'L' 00181 * 00182 DO 100 IUPLO = 1, 2 00183 UPLO = UPLOS( IUPLO ) 00184 * 00185 * Set up parameters with CLATB4 and generate a test matrix 00186 * with CLATMS. 00187 * 00188 CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00189 $ CNDNUM, DIST ) 00190 * 00191 SRNAMT = 'CLATMS' 00192 CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 00193 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, 00194 $ INFO ) 00195 * 00196 * Check error code from CLATMS. 00197 * 00198 IF( INFO.NE.0 ) THEN 00199 CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, -1, 00200 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00201 GO TO 100 00202 END IF 00203 * 00204 * For types 3-5, zero one row and column of the matrix to 00205 * test that INFO is returned correctly. 00206 * 00207 IF( ZEROT ) THEN 00208 IF( IMAT.EQ.3 ) THEN 00209 IZERO = 1 00210 ELSE IF( IMAT.EQ.4 ) THEN 00211 IZERO = N 00212 ELSE 00213 IZERO = N / 2 + 1 00214 END IF 00215 IOFF = ( IZERO-1 )*LDA 00216 * 00217 * Set row and column IZERO of A to 0. 00218 * 00219 IF( IUPLO.EQ.1 ) THEN 00220 DO 20 I = 1, IZERO - 1 00221 A( IOFF+I ) = CZERO 00222 20 CONTINUE 00223 IOFF = IOFF + IZERO 00224 DO 30 I = IZERO, N 00225 A( IOFF ) = CZERO 00226 IOFF = IOFF + LDA 00227 30 CONTINUE 00228 ELSE 00229 IOFF = IZERO 00230 DO 40 I = 1, IZERO - 1 00231 A( IOFF ) = CZERO 00232 IOFF = IOFF + LDA 00233 40 CONTINUE 00234 IOFF = IOFF - IZERO 00235 DO 50 I = IZERO, N 00236 A( IOFF+I ) = CZERO 00237 50 CONTINUE 00238 END IF 00239 ELSE 00240 IZERO = 0 00241 END IF 00242 * 00243 * Set the imaginary part of the diagonals. 00244 * 00245 CALL CLAIPD( N, A, LDA+1, 0 ) 00246 * 00247 * Do for each value of NB in NBVAL 00248 * 00249 DO 90 INB = 1, NNB 00250 NB = NBVAL( INB ) 00251 CALL XLAENV( 1, NB ) 00252 * 00253 * Compute the L*L' or U'*U factorization of the matrix. 00254 * 00255 CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) 00256 SRNAMT = 'CPOTRF' 00257 CALL CPOTRF( UPLO, N, AFAC, LDA, INFO ) 00258 * 00259 * Check error code from CPOTRF. 00260 * 00261 IF( INFO.NE.IZERO ) THEN 00262 CALL ALAERH( PATH, 'CPOTRF', INFO, IZERO, UPLO, N, 00263 $ N, -1, -1, NB, IMAT, NFAIL, NERRS, 00264 $ NOUT ) 00265 GO TO 90 00266 END IF 00267 * 00268 * Skip the tests if INFO is not 0. 00269 * 00270 IF( INFO.NE.0 ) 00271 $ GO TO 90 00272 * 00273 *+ TEST 1 00274 * Reconstruct matrix from factors and compute residual. 00275 * 00276 CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) 00277 CALL CPOT01( UPLO, N, A, LDA, AINV, LDA, RWORK, 00278 $ RESULT( 1 ) ) 00279 * 00280 *+ TEST 2 00281 * Form the inverse and compute the residual. 00282 * 00283 CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) 00284 SRNAMT = 'CPOTRI' 00285 CALL CPOTRI( UPLO, N, AINV, LDA, INFO ) 00286 * 00287 * Check error code from CPOTRI. 00288 * 00289 IF( INFO.NE.0 ) 00290 $ CALL ALAERH( PATH, 'CPOTRI', INFO, 0, UPLO, N, N, 00291 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00292 * 00293 CALL CPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, 00294 $ RWORK, RCONDC, RESULT( 2 ) ) 00295 * 00296 * Print information about the tests that did not pass 00297 * the threshold. 00298 * 00299 DO 60 K = 1, 2 00300 IF( RESULT( K ).GE.THRESH ) THEN 00301 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00302 $ CALL ALAHD( NOUT, PATH ) 00303 WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, 00304 $ RESULT( K ) 00305 NFAIL = NFAIL + 1 00306 END IF 00307 60 CONTINUE 00308 NRUN = NRUN + 2 00309 * 00310 * Skip the rest of the tests unless this is the first 00311 * blocksize. 00312 * 00313 IF( INB.NE.1 ) 00314 $ GO TO 90 00315 * 00316 DO 80 IRHS = 1, NNS 00317 NRHS = NSVAL( IRHS ) 00318 * 00319 *+ TEST 3 00320 * Solve and compute residual for A * X = B . 00321 * 00322 SRNAMT = 'CLARHS' 00323 CALL CLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 00324 $ NRHS, A, LDA, XACT, LDA, B, LDA, 00325 $ ISEED, INFO ) 00326 CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 00327 * 00328 SRNAMT = 'CPOTRS' 00329 CALL CPOTRS( UPLO, N, NRHS, AFAC, LDA, X, LDA, 00330 $ INFO ) 00331 * 00332 * Check error code from CPOTRS. 00333 * 00334 IF( INFO.NE.0 ) 00335 $ CALL ALAERH( PATH, 'CPOTRS', INFO, 0, UPLO, N, 00336 $ N, -1, -1, NRHS, IMAT, NFAIL, 00337 $ NERRS, NOUT ) 00338 * 00339 CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 00340 CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, 00341 $ LDA, RWORK, RESULT( 3 ) ) 00342 * 00343 *+ TEST 4 00344 * Check solution from generated exact solution. 00345 * 00346 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00347 $ RESULT( 4 ) ) 00348 * 00349 *+ TESTS 5, 6, and 7 00350 * Use iterative refinement to improve the solution. 00351 * 00352 SRNAMT = 'CPORFS' 00353 CALL CPORFS( UPLO, N, NRHS, A, LDA, AFAC, LDA, B, 00354 $ LDA, X, LDA, RWORK, RWORK( NRHS+1 ), 00355 $ WORK, RWORK( 2*NRHS+1 ), INFO ) 00356 * 00357 * Check error code from CPORFS. 00358 * 00359 IF( INFO.NE.0 ) 00360 $ CALL ALAERH( PATH, 'CPORFS', INFO, 0, UPLO, N, 00361 $ N, -1, -1, NRHS, IMAT, NFAIL, 00362 $ NERRS, NOUT ) 00363 * 00364 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00365 $ RESULT( 5 ) ) 00366 CALL CPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA, 00367 $ XACT, LDA, RWORK, RWORK( NRHS+1 ), 00368 $ RESULT( 6 ) ) 00369 * 00370 * Print information about the tests that did not pass 00371 * the threshold. 00372 * 00373 DO 70 K = 3, 7 00374 IF( RESULT( K ).GE.THRESH ) THEN 00375 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00376 $ CALL ALAHD( NOUT, PATH ) 00377 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, 00378 $ IMAT, K, RESULT( K ) 00379 NFAIL = NFAIL + 1 00380 END IF 00381 70 CONTINUE 00382 NRUN = NRUN + 5 00383 80 CONTINUE 00384 * 00385 *+ TEST 8 00386 * Get an estimate of RCOND = 1/CNDNUM. 00387 * 00388 ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) 00389 SRNAMT = 'CPOCON' 00390 CALL CPOCON( UPLO, N, AFAC, LDA, ANORM, RCOND, WORK, 00391 $ RWORK, INFO ) 00392 * 00393 * Check error code from CPOCON. 00394 * 00395 IF( INFO.NE.0 ) 00396 $ CALL ALAERH( PATH, 'CPOCON', INFO, 0, UPLO, N, N, 00397 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00398 * 00399 RESULT( 8 ) = SGET06( RCOND, RCONDC ) 00400 * 00401 * Print the test ratio if it is .GE. THRESH. 00402 * 00403 IF( RESULT( 8 ).GE.THRESH ) THEN 00404 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00405 $ CALL ALAHD( NOUT, PATH ) 00406 WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 8, 00407 $ RESULT( 8 ) 00408 NFAIL = NFAIL + 1 00409 END IF 00410 NRUN = NRUN + 1 00411 90 CONTINUE 00412 100 CONTINUE 00413 110 CONTINUE 00414 120 CONTINUE 00415 * 00416 * Print a summary of the results. 00417 * 00418 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00419 * 00420 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', 00421 $ I2, ', test ', I2, ', ratio =', G12.5 ) 00422 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 00423 $ I2, ', test(', I2, ') =', G12.5 ) 00424 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, 00425 $ ', test(', I2, ') =', G12.5 ) 00426 RETURN 00427 * 00428 * End of CCHKPO 00429 * 00430 END
1.7.3 
