|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE SCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 00002 $ NMAX, AB, AINV, B, X, XACT, WORK, RWORK, IWORK, 00003 $ 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 AB( * ), AINV( * ), B( * ), RWORK( * ), 00018 $ WORK( * ), X( * ), XACT( * ) 00019 * .. 00020 * 00021 * Purpose 00022 * ======= 00023 * 00024 * SCHKTB tests STBTRS, -RFS, and -CON, and SLATBS. 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 column 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 leading dimension of the work arrays. 00056 * NMAX >= the maximum value of N in NVAL. 00057 * 00058 * AB (workspace) REAL array, dimension (NMAX*NMAX) 00059 * 00060 * AINV (workspace) REAL array, dimension (NMAX*NMAX) 00061 * 00062 * B (workspace) REAL array, dimension (NMAX*NSMAX) 00063 * where NSMAX is the largest entry in NSVAL. 00064 * 00065 * X (workspace) REAL array, dimension (NMAX*NSMAX) 00066 * 00067 * XACT (workspace) REAL array, dimension (NMAX*NSMAX) 00068 * 00069 * WORK (workspace) REAL array, dimension 00070 * (NMAX*max(3,NSMAX)) 00071 * 00072 * RWORK (workspace) REAL array, dimension 00073 * (max(NMAX,2*NSMAX)) 00074 * 00075 * IWORK (workspace) INTEGER array, dimension (NMAX) 00076 * 00077 * NOUT (input) INTEGER 00078 * The unit number for output. 00079 * 00080 * ===================================================================== 00081 * 00082 * .. Parameters .. 00083 INTEGER NTYPE1, NTYPES 00084 PARAMETER ( NTYPE1 = 9, NTYPES = 17 ) 00085 INTEGER NTESTS 00086 PARAMETER ( NTESTS = 8 ) 00087 INTEGER NTRAN 00088 PARAMETER ( NTRAN = 3 ) 00089 REAL ONE, ZERO 00090 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00091 * .. 00092 * .. Local Scalars .. 00093 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE 00094 CHARACTER*3 PATH 00095 INTEGER I, IDIAG, IK, IMAT, IN, INFO, IRHS, ITRAN, 00096 $ IUPLO, J, K, KD, LDA, LDAB, N, NERRS, NFAIL, 00097 $ NIMAT, NIMAT2, NK, NRHS, NRUN 00098 REAL AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO, 00099 $ SCALE 00100 * .. 00101 * .. Local Arrays .. 00102 CHARACTER TRANSS( NTRAN ), UPLOS( 2 ) 00103 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00104 REAL RESULT( NTESTS ) 00105 * .. 00106 * .. External Functions .. 00107 LOGICAL LSAME 00108 REAL SLANTB, SLANTR 00109 EXTERNAL LSAME, SLANTB, SLANTR 00110 * .. 00111 * .. External Subroutines .. 00112 EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRTR, SGET04, 00113 $ SLACPY, SLARHS, SLASET, SLATBS, SLATTB, STBCON, 00114 $ STBRFS, STBSV, STBT02, STBT03, STBT05, STBT06, 00115 $ STBTRS 00116 * .. 00117 * .. Scalars in Common .. 00118 LOGICAL LERR, OK 00119 CHARACTER*32 SRNAMT 00120 INTEGER INFOT, IOUNIT 00121 * .. 00122 * .. Common blocks .. 00123 COMMON / INFOC / INFOT, IOUNIT, OK, LERR 00124 COMMON / SRNAMC / SRNAMT 00125 * .. 00126 * .. Intrinsic Functions .. 00127 INTRINSIC MAX, MIN 00128 * .. 00129 * .. Data statements .. 00130 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00131 DATA UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' / 00132 * .. 00133 * .. Executable Statements .. 00134 * 00135 * Initialize constants and the random number seed. 00136 * 00137 PATH( 1: 1 ) = 'Single precision' 00138 PATH( 2: 3 ) = 'TB' 00139 NRUN = 0 00140 NFAIL = 0 00141 NERRS = 0 00142 DO 10 I = 1, 4 00143 ISEED( I ) = ISEEDY( I ) 00144 10 CONTINUE 00145 * 00146 * Test the error exits 00147 * 00148 IF( TSTERR ) 00149 $ CALL SERRTR( PATH, NOUT ) 00150 INFOT = 0 00151 * 00152 DO 140 IN = 1, NN 00153 * 00154 * Do for each value of N in NVAL 00155 * 00156 N = NVAL( IN ) 00157 LDA = MAX( 1, N ) 00158 XTYPE = 'N' 00159 NIMAT = NTYPE1 00160 NIMAT2 = NTYPES 00161 IF( N.LE.0 ) THEN 00162 NIMAT = 1 00163 NIMAT2 = NTYPE1 + 1 00164 END IF 00165 * 00166 NK = MIN( N+1, 4 ) 00167 DO 130 IK = 1, NK 00168 * 00169 * Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes 00170 * it easier to skip redundant values for small values of N. 00171 * 00172 IF( IK.EQ.1 ) THEN 00173 KD = 0 00174 ELSE IF( IK.EQ.2 ) THEN 00175 KD = MAX( N, 0 ) 00176 ELSE IF( IK.EQ.3 ) THEN 00177 KD = ( 3*N-1 ) / 4 00178 ELSE IF( IK.EQ.4 ) THEN 00179 KD = ( N+1 ) / 4 00180 END IF 00181 LDAB = KD + 1 00182 * 00183 DO 90 IMAT = 1, NIMAT 00184 * 00185 * Do the tests only if DOTYPE( IMAT ) is true. 00186 * 00187 IF( .NOT.DOTYPE( IMAT ) ) 00188 $ GO TO 90 00189 * 00190 DO 80 IUPLO = 1, 2 00191 * 00192 * Do first for UPLO = 'U', then for UPLO = 'L' 00193 * 00194 UPLO = UPLOS( IUPLO ) 00195 * 00196 * Call SLATTB to generate a triangular test matrix. 00197 * 00198 SRNAMT = 'SLATTB' 00199 CALL SLATTB( IMAT, UPLO, 'No transpose', DIAG, ISEED, 00200 $ N, KD, AB, LDAB, X, WORK, INFO ) 00201 * 00202 * Set IDIAG = 1 for non-unit matrices, 2 for unit. 00203 * 00204 IF( LSAME( DIAG, 'N' ) ) THEN 00205 IDIAG = 1 00206 ELSE 00207 IDIAG = 2 00208 END IF 00209 * 00210 * Form the inverse of A so we can get a good estimate 00211 * of RCONDC = 1/(norm(A) * norm(inv(A))). 00212 * 00213 CALL SLASET( 'Full', N, N, ZERO, ONE, AINV, LDA ) 00214 IF( LSAME( UPLO, 'U' ) ) THEN 00215 DO 20 J = 1, N 00216 CALL STBSV( UPLO, 'No transpose', DIAG, J, KD, 00217 $ AB, LDAB, AINV( ( J-1 )*LDA+1 ), 1 ) 00218 20 CONTINUE 00219 ELSE 00220 DO 30 J = 1, N 00221 CALL STBSV( UPLO, 'No transpose', DIAG, N-J+1, 00222 $ KD, AB( ( J-1 )*LDAB+1 ), LDAB, 00223 $ AINV( ( J-1 )*LDA+J ), 1 ) 00224 30 CONTINUE 00225 END IF 00226 * 00227 * Compute the 1-norm condition number of A. 00228 * 00229 ANORM = SLANTB( '1', UPLO, DIAG, N, KD, AB, LDAB, 00230 $ RWORK ) 00231 AINVNM = SLANTR( '1', UPLO, DIAG, N, N, AINV, LDA, 00232 $ RWORK ) 00233 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00234 RCONDO = ONE 00235 ELSE 00236 RCONDO = ( ONE / ANORM ) / AINVNM 00237 END IF 00238 * 00239 * Compute the infinity-norm condition number of A. 00240 * 00241 ANORM = SLANTB( 'I', UPLO, DIAG, N, KD, AB, LDAB, 00242 $ RWORK ) 00243 AINVNM = SLANTR( 'I', UPLO, DIAG, N, N, AINV, LDA, 00244 $ RWORK ) 00245 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00246 RCONDI = ONE 00247 ELSE 00248 RCONDI = ( ONE / ANORM ) / AINVNM 00249 END IF 00250 * 00251 DO 60 IRHS = 1, NNS 00252 NRHS = NSVAL( IRHS ) 00253 XTYPE = 'N' 00254 * 00255 DO 50 ITRAN = 1, NTRAN 00256 * 00257 * Do for op(A) = A, A**T, or A**H. 00258 * 00259 TRANS = TRANSS( ITRAN ) 00260 IF( ITRAN.EQ.1 ) THEN 00261 NORM = 'O' 00262 RCONDC = RCONDO 00263 ELSE 00264 NORM = 'I' 00265 RCONDC = RCONDI 00266 END IF 00267 * 00268 *+ TEST 1 00269 * Solve and compute residual for op(A)*x = b. 00270 * 00271 SRNAMT = 'SLARHS' 00272 CALL SLARHS( PATH, XTYPE, UPLO, TRANS, N, N, KD, 00273 $ IDIAG, NRHS, AB, LDAB, XACT, LDA, 00274 $ B, LDA, ISEED, INFO ) 00275 XTYPE = 'C' 00276 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 00277 * 00278 SRNAMT = 'STBTRS' 00279 CALL STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, 00280 $ LDAB, X, LDA, INFO ) 00281 * 00282 * Check error code from STBTRS. 00283 * 00284 IF( INFO.NE.0 ) 00285 $ CALL ALAERH( PATH, 'STBTRS', INFO, 0, 00286 $ UPLO // TRANS // DIAG, N, N, KD, 00287 $ KD, NRHS, IMAT, NFAIL, NERRS, 00288 $ NOUT ) 00289 * 00290 CALL STBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB, 00291 $ LDAB, X, LDA, B, LDA, WORK, 00292 $ RESULT( 1 ) ) 00293 * 00294 *+ TEST 2 00295 * Check solution from generated exact solution. 00296 * 00297 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00298 $ RESULT( 2 ) ) 00299 * 00300 *+ TESTS 3, 4, and 5 00301 * Use iterative refinement to improve the solution 00302 * and compute error bounds. 00303 * 00304 SRNAMT = 'STBRFS' 00305 CALL STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, 00306 $ LDAB, B, LDA, X, LDA, RWORK, 00307 $ RWORK( NRHS+1 ), WORK, IWORK, 00308 $ INFO ) 00309 * 00310 * Check error code from STBRFS. 00311 * 00312 IF( INFO.NE.0 ) 00313 $ CALL ALAERH( PATH, 'STBRFS', INFO, 0, 00314 $ UPLO // TRANS // DIAG, N, N, KD, 00315 $ KD, NRHS, IMAT, NFAIL, NERRS, 00316 $ NOUT ) 00317 * 00318 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00319 $ RESULT( 3 ) ) 00320 CALL STBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB, 00321 $ LDAB, B, LDA, X, LDA, XACT, LDA, 00322 $ RWORK, RWORK( NRHS+1 ), 00323 $ RESULT( 4 ) ) 00324 * 00325 * Print information about the tests that did not 00326 * pass the threshold. 00327 * 00328 DO 40 K = 1, 5 00329 IF( RESULT( K ).GE.THRESH ) THEN 00330 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00331 $ CALL ALAHD( NOUT, PATH ) 00332 WRITE( NOUT, FMT = 9999 )UPLO, TRANS, 00333 $ DIAG, N, KD, NRHS, IMAT, K, RESULT( K ) 00334 NFAIL = NFAIL + 1 00335 END IF 00336 40 CONTINUE 00337 NRUN = NRUN + 5 00338 50 CONTINUE 00339 60 CONTINUE 00340 * 00341 *+ TEST 6 00342 * Get an estimate of RCOND = 1/CNDNUM. 00343 * 00344 DO 70 ITRAN = 1, 2 00345 IF( ITRAN.EQ.1 ) THEN 00346 NORM = 'O' 00347 RCONDC = RCONDO 00348 ELSE 00349 NORM = 'I' 00350 RCONDC = RCONDI 00351 END IF 00352 SRNAMT = 'STBCON' 00353 CALL STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, 00354 $ RCOND, WORK, IWORK, INFO ) 00355 * 00356 * Check error code from STBCON. 00357 * 00358 IF( INFO.NE.0 ) 00359 $ CALL ALAERH( PATH, 'STBCON', INFO, 0, 00360 $ NORM // UPLO // DIAG, N, N, KD, KD, 00361 $ -1, IMAT, NFAIL, NERRS, NOUT ) 00362 * 00363 CALL STBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB, 00364 $ LDAB, RWORK, RESULT( 6 ) ) 00365 * 00366 * Print information about the tests that did not pass 00367 * the threshold. 00368 * 00369 IF( RESULT( 6 ).GE.THRESH ) THEN 00370 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00371 $ CALL ALAHD( NOUT, PATH ) 00372 WRITE( NOUT, FMT = 9998 ) 'STBCON', NORM, UPLO, 00373 $ DIAG, N, KD, IMAT, 6, RESULT( 6 ) 00374 NFAIL = NFAIL + 1 00375 END IF 00376 NRUN = NRUN + 1 00377 70 CONTINUE 00378 80 CONTINUE 00379 90 CONTINUE 00380 * 00381 * Use pathological test matrices to test SLATBS. 00382 * 00383 DO 120 IMAT = NTYPE1 + 1, NIMAT2 00384 * 00385 * Do the tests only if DOTYPE( IMAT ) is true. 00386 * 00387 IF( .NOT.DOTYPE( IMAT ) ) 00388 $ GO TO 120 00389 * 00390 DO 110 IUPLO = 1, 2 00391 * 00392 * Do first for UPLO = 'U', then for UPLO = 'L' 00393 * 00394 UPLO = UPLOS( IUPLO ) 00395 DO 100 ITRAN = 1, NTRAN 00396 * 00397 * Do for op(A) = A, A**T, and A**H. 00398 * 00399 TRANS = TRANSS( ITRAN ) 00400 * 00401 * Call SLATTB to generate a triangular test matrix. 00402 * 00403 SRNAMT = 'SLATTB' 00404 CALL SLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, 00405 $ AB, LDAB, X, WORK, INFO ) 00406 * 00407 *+ TEST 7 00408 * Solve the system op(A)*x = b 00409 * 00410 SRNAMT = 'SLATBS' 00411 CALL SCOPY( N, X, 1, B, 1 ) 00412 CALL SLATBS( UPLO, TRANS, DIAG, 'N', N, KD, AB, 00413 $ LDAB, B, SCALE, RWORK, INFO ) 00414 * 00415 * Check error code from SLATBS. 00416 * 00417 IF( INFO.NE.0 ) 00418 $ CALL ALAERH( PATH, 'SLATBS', INFO, 0, 00419 $ UPLO // TRANS // DIAG // 'N', N, N, 00420 $ KD, KD, -1, IMAT, NFAIL, NERRS, 00421 $ NOUT ) 00422 * 00423 CALL STBT03( UPLO, TRANS, DIAG, N, KD, 1, AB, LDAB, 00424 $ SCALE, RWORK, ONE, B, LDA, X, LDA, 00425 $ WORK, RESULT( 7 ) ) 00426 * 00427 *+ TEST 8 00428 * Solve op(A)*x = b again with NORMIN = 'Y'. 00429 * 00430 CALL SCOPY( N, X, 1, B, 1 ) 00431 CALL SLATBS( UPLO, TRANS, DIAG, 'Y', N, KD, AB, 00432 $ LDAB, B, SCALE, RWORK, INFO ) 00433 * 00434 * Check error code from SLATBS. 00435 * 00436 IF( INFO.NE.0 ) 00437 $ CALL ALAERH( PATH, 'SLATBS', INFO, 0, 00438 $ UPLO // TRANS // DIAG // 'Y', N, N, 00439 $ KD, KD, -1, IMAT, NFAIL, NERRS, 00440 $ NOUT ) 00441 * 00442 CALL STBT03( UPLO, TRANS, DIAG, N, KD, 1, AB, LDAB, 00443 $ SCALE, RWORK, ONE, B, LDA, X, LDA, 00444 $ WORK, RESULT( 8 ) ) 00445 * 00446 * Print information about the tests that did not pass 00447 * the threshold. 00448 * 00449 IF( RESULT( 7 ).GE.THRESH ) THEN 00450 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00451 $ CALL ALAHD( NOUT, PATH ) 00452 WRITE( NOUT, FMT = 9997 )'SLATBS', UPLO, TRANS, 00453 $ DIAG, 'N', N, KD, IMAT, 7, RESULT( 7 ) 00454 NFAIL = NFAIL + 1 00455 END IF 00456 IF( RESULT( 8 ).GE.THRESH ) THEN 00457 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00458 $ CALL ALAHD( NOUT, PATH ) 00459 WRITE( NOUT, FMT = 9997 )'SLATBS', UPLO, TRANS, 00460 $ DIAG, 'Y', N, KD, IMAT, 8, RESULT( 8 ) 00461 NFAIL = NFAIL + 1 00462 END IF 00463 NRUN = NRUN + 2 00464 100 CONTINUE 00465 110 CONTINUE 00466 120 CONTINUE 00467 130 CONTINUE 00468 140 CONTINUE 00469 * 00470 * Print a summary of the results. 00471 * 00472 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00473 * 00474 9999 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, '' 00475 ', $ DIAG=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=', I5, 00476 $ ', type ', I2, ', test(', I2, ')=', G12.5 ) 00477 9998 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',', 00478 $ I5, ',', I5, ', ... ), type ', I2, ', test(', I2, ')=', 00479 $ G12.5 ) 00480 9997 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''', 00481 $ A1, ''',', I5, ',', I5, ', ... ), type ', I2, ', test(', 00482 $ I1, ')=', G12.5 ) 00483 RETURN 00484 * 00485 * End of SCHKTB 00486 * 00487 END
1.7.3 
