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