![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SCHKGB 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 SCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, 00012 * NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B, 00013 * X, XACT, WORK, RWORK, IWORK, NOUT ) 00014 * 00015 * .. Scalar Arguments .. 00016 * LOGICAL TSTERR 00017 * INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT 00018 * REAL THRESH 00019 * .. 00020 * .. Array Arguments .. 00021 * LOGICAL DOTYPE( * ) 00022 * INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), 00023 * $ NVAL( * ) 00024 * REAL A( * ), AFAC( * ), B( * ), RWORK( * ), 00025 * $ WORK( * ), X( * ), XACT( * ) 00026 * .. 00027 * 00028 * 00029 *> \par Purpose: 00030 * ============= 00031 *> 00032 *> \verbatim 00033 *> 00034 *> SCHKGB tests SGBTRF, -TRS, -RFS, and -CON 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] NM 00049 *> \verbatim 00050 *> NM is INTEGER 00051 *> The number of values of M contained in the vector MVAL. 00052 *> \endverbatim 00053 *> 00054 *> \param[in] MVAL 00055 *> \verbatim 00056 *> MVAL is INTEGER array, dimension (NM) 00057 *> The values of the matrix row dimension M. 00058 *> \endverbatim 00059 *> 00060 *> \param[in] NN 00061 *> \verbatim 00062 *> NN is INTEGER 00063 *> The number of values of N contained in the vector NVAL. 00064 *> \endverbatim 00065 *> 00066 *> \param[in] NVAL 00067 *> \verbatim 00068 *> NVAL is INTEGER array, dimension (NN) 00069 *> The values of the matrix column dimension N. 00070 *> \endverbatim 00071 *> 00072 *> \param[in] NNB 00073 *> \verbatim 00074 *> NNB is INTEGER 00075 *> The number of values of NB contained in the vector NBVAL. 00076 *> \endverbatim 00077 *> 00078 *> \param[in] NBVAL 00079 *> \verbatim 00080 *> NBVAL is INTEGER array, dimension (NNB) 00081 *> The values of the blocksize NB. 00082 *> \endverbatim 00083 *> 00084 *> \param[in] NNS 00085 *> \verbatim 00086 *> NNS is INTEGER 00087 *> The number of values of NRHS contained in the vector NSVAL. 00088 *> \endverbatim 00089 *> 00090 *> \param[in] NSVAL 00091 *> \verbatim 00092 *> NSVAL is INTEGER array, dimension (NNS) 00093 *> The values of the number of right hand sides NRHS. 00094 *> \endverbatim 00095 *> 00096 *> \param[in] THRESH 00097 *> \verbatim 00098 *> THRESH is REAL 00099 *> The threshold value for the test ratios. A result is 00100 *> included in the output file if RESULT >= THRESH. To have 00101 *> every test ratio printed, use THRESH = 0. 00102 *> \endverbatim 00103 *> 00104 *> \param[in] TSTERR 00105 *> \verbatim 00106 *> TSTERR is LOGICAL 00107 *> Flag that indicates whether error exits are to be tested. 00108 *> \endverbatim 00109 *> 00110 *> \param[out] A 00111 *> \verbatim 00112 *> A is REAL array, dimension (LA) 00113 *> \endverbatim 00114 *> 00115 *> \param[in] LA 00116 *> \verbatim 00117 *> LA is INTEGER 00118 *> The length of the array A. LA >= (KLMAX+KUMAX+1)*NMAX 00119 *> where KLMAX is the largest entry in the local array KLVAL, 00120 *> KUMAX is the largest entry in the local array KUVAL and 00121 *> NMAX is the largest entry in the input array NVAL. 00122 *> \endverbatim 00123 *> 00124 *> \param[out] AFAC 00125 *> \verbatim 00126 *> AFAC is REAL array, dimension (LAFAC) 00127 *> \endverbatim 00128 *> 00129 *> \param[in] LAFAC 00130 *> \verbatim 00131 *> LAFAC is INTEGER 00132 *> The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX 00133 *> where KLMAX is the largest entry in the local array KLVAL, 00134 *> KUMAX is the largest entry in the local array KUVAL and 00135 *> NMAX is the largest entry in the input array NVAL. 00136 *> \endverbatim 00137 *> 00138 *> \param[out] B 00139 *> \verbatim 00140 *> B is REAL array, dimension (NMAX*NSMAX) 00141 *> where NSMAX is the largest entry in NSVAL. 00142 *> \endverbatim 00143 *> 00144 *> \param[out] X 00145 *> \verbatim 00146 *> X is REAL array, dimension (NMAX*NSMAX) 00147 *> \endverbatim 00148 *> 00149 *> \param[out] XACT 00150 *> \verbatim 00151 *> XACT is REAL array, dimension (NMAX*NSMAX) 00152 *> \endverbatim 00153 *> 00154 *> \param[out] WORK 00155 *> \verbatim 00156 *> WORK is REAL array, dimension 00157 *> (NMAX*max(3,NSMAX,NMAX)) 00158 *> \endverbatim 00159 *> 00160 *> \param[out] RWORK 00161 *> \verbatim 00162 *> RWORK is REAL array, dimension 00163 *> (max(NMAX,2*NSMAX)) 00164 *> \endverbatim 00165 *> 00166 *> \param[out] IWORK 00167 *> \verbatim 00168 *> IWORK is INTEGER array, dimension (2*NMAX) 00169 *> \endverbatim 00170 *> 00171 *> \param[in] NOUT 00172 *> \verbatim 00173 *> NOUT is INTEGER 00174 *> The unit number for output. 00175 *> \endverbatim 00176 * 00177 * Authors: 00178 * ======== 00179 * 00180 *> \author Univ. of Tennessee 00181 *> \author Univ. of California Berkeley 00182 *> \author Univ. of Colorado Denver 00183 *> \author NAG Ltd. 00184 * 00185 *> \date November 2011 00186 * 00187 *> \ingroup single_lin 00188 * 00189 * ===================================================================== 00190 SUBROUTINE SCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS, 00191 $ NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B, 00192 $ X, XACT, WORK, RWORK, IWORK, NOUT ) 00193 * 00194 * -- LAPACK test routine (version 3.4.0) -- 00195 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00196 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00197 * November 2011 00198 * 00199 * .. Scalar Arguments .. 00200 LOGICAL TSTERR 00201 INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT 00202 REAL THRESH 00203 * .. 00204 * .. Array Arguments .. 00205 LOGICAL DOTYPE( * ) 00206 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), 00207 $ NVAL( * ) 00208 REAL A( * ), AFAC( * ), B( * ), RWORK( * ), 00209 $ WORK( * ), X( * ), XACT( * ) 00210 * .. 00211 * 00212 * ===================================================================== 00213 * 00214 * .. Parameters .. 00215 REAL ONE, ZERO 00216 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00217 INTEGER NTYPES, NTESTS 00218 PARAMETER ( NTYPES = 8, NTESTS = 7 ) 00219 INTEGER NBW, NTRAN 00220 PARAMETER ( NBW = 4, NTRAN = 3 ) 00221 * .. 00222 * .. Local Scalars .. 00223 LOGICAL TRFCON, ZEROT 00224 CHARACTER DIST, NORM, TRANS, TYPE, XTYPE 00225 CHARACTER*3 PATH 00226 INTEGER I, I1, I2, IKL, IKU, IM, IMAT, IN, INB, INFO, 00227 $ IOFF, IRHS, ITRAN, IZERO, J, K, KL, KOFF, KU, 00228 $ LDA, LDAFAC, LDB, M, MODE, N, NB, NERRS, NFAIL, 00229 $ NIMAT, NKL, NKU, NRHS, NRUN 00230 REAL AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, RCOND, 00231 $ RCONDC, RCONDI, RCONDO 00232 * .. 00233 * .. Local Arrays .. 00234 CHARACTER TRANSS( NTRAN ) 00235 INTEGER ISEED( 4 ), ISEEDY( 4 ), KLVAL( NBW ), 00236 $ KUVAL( NBW ) 00237 REAL RESULT( NTESTS ) 00238 * .. 00239 * .. External Functions .. 00240 REAL SGET06, SLANGB, SLANGE 00241 EXTERNAL SGET06, SLANGB, SLANGE 00242 * .. 00243 * .. External Subroutines .. 00244 EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRGE, SGBCON, 00245 $ SGBRFS, SGBT01, SGBT02, SGBT05, SGBTRF, SGBTRS, 00246 $ SGET04, SLACPY, SLARHS, SLASET, SLATB4, SLATMS, 00247 $ XLAENV 00248 * .. 00249 * .. Intrinsic Functions .. 00250 INTRINSIC MAX, MIN 00251 * .. 00252 * .. Scalars in Common .. 00253 LOGICAL LERR, OK 00254 CHARACTER*32 SRNAMT 00255 INTEGER INFOT, NUNIT 00256 * .. 00257 * .. Common blocks .. 00258 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00259 COMMON / SRNAMC / SRNAMT 00260 * .. 00261 * .. Data statements .. 00262 DATA ISEEDY / 1988, 1989, 1990, 1991 / , 00263 $ TRANSS / 'N', 'T', 'C' / 00264 * .. 00265 * .. Executable Statements .. 00266 * 00267 * Initialize constants and the random number seed. 00268 * 00269 PATH( 1: 1 ) = 'Single precision' 00270 PATH( 2: 3 ) = 'GB' 00271 NRUN = 0 00272 NFAIL = 0 00273 NERRS = 0 00274 DO 10 I = 1, 4 00275 ISEED( I ) = ISEEDY( I ) 00276 10 CONTINUE 00277 * 00278 * Test the error exits 00279 * 00280 IF( TSTERR ) 00281 $ CALL SERRGE( PATH, NOUT ) 00282 INFOT = 0 00283 CALL XLAENV( 2, 2 ) 00284 * 00285 * Initialize the first value for the lower and upper bandwidths. 00286 * 00287 KLVAL( 1 ) = 0 00288 KUVAL( 1 ) = 0 00289 * 00290 * Do for each value of M in MVAL 00291 * 00292 DO 160 IM = 1, NM 00293 M = MVAL( IM ) 00294 * 00295 * Set values to use for the lower bandwidth. 00296 * 00297 KLVAL( 2 ) = M + ( M+1 ) / 4 00298 * 00299 * KLVAL( 2 ) = MAX( M-1, 0 ) 00300 * 00301 KLVAL( 3 ) = ( 3*M-1 ) / 4 00302 KLVAL( 4 ) = ( M+1 ) / 4 00303 * 00304 * Do for each value of N in NVAL 00305 * 00306 DO 150 IN = 1, NN 00307 N = NVAL( IN ) 00308 XTYPE = 'N' 00309 * 00310 * Set values to use for the upper bandwidth. 00311 * 00312 KUVAL( 2 ) = N + ( N+1 ) / 4 00313 * 00314 * KUVAL( 2 ) = MAX( N-1, 0 ) 00315 * 00316 KUVAL( 3 ) = ( 3*N-1 ) / 4 00317 KUVAL( 4 ) = ( N+1 ) / 4 00318 * 00319 * Set limits on the number of loop iterations. 00320 * 00321 NKL = MIN( M+1, 4 ) 00322 IF( N.EQ.0 ) 00323 $ NKL = 2 00324 NKU = MIN( N+1, 4 ) 00325 IF( M.EQ.0 ) 00326 $ NKU = 2 00327 NIMAT = NTYPES 00328 IF( M.LE.0 .OR. N.LE.0 ) 00329 $ NIMAT = 1 00330 * 00331 DO 140 IKL = 1, NKL 00332 * 00333 * Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This 00334 * order makes it easier to skip redundant values for small 00335 * values of M. 00336 * 00337 KL = KLVAL( IKL ) 00338 DO 130 IKU = 1, NKU 00339 * 00340 * Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This 00341 * order makes it easier to skip redundant values for 00342 * small values of N. 00343 * 00344 KU = KUVAL( IKU ) 00345 * 00346 * Check that A and AFAC are big enough to generate this 00347 * matrix. 00348 * 00349 LDA = KL + KU + 1 00350 LDAFAC = 2*KL + KU + 1 00351 IF( ( LDA*N ).GT.LA .OR. ( LDAFAC*N ).GT.LAFAC ) THEN 00352 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00353 $ CALL ALAHD( NOUT, PATH ) 00354 IF( N*( KL+KU+1 ).GT.LA ) THEN 00355 WRITE( NOUT, FMT = 9999 )LA, M, N, KL, KU, 00356 $ N*( KL+KU+1 ) 00357 NERRS = NERRS + 1 00358 END IF 00359 IF( N*( 2*KL+KU+1 ).GT.LAFAC ) THEN 00360 WRITE( NOUT, FMT = 9998 )LAFAC, M, N, KL, KU, 00361 $ N*( 2*KL+KU+1 ) 00362 NERRS = NERRS + 1 00363 END IF 00364 GO TO 130 00365 END IF 00366 * 00367 DO 120 IMAT = 1, NIMAT 00368 * 00369 * Do the tests only if DOTYPE( IMAT ) is true. 00370 * 00371 IF( .NOT.DOTYPE( IMAT ) ) 00372 $ GO TO 120 00373 * 00374 * Skip types 2, 3, or 4 if the matrix size is too 00375 * small. 00376 * 00377 ZEROT = IMAT.GE.2 .AND. IMAT.LE.4 00378 IF( ZEROT .AND. N.LT.IMAT-1 ) 00379 $ GO TO 120 00380 * 00381 IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 1 ) ) THEN 00382 * 00383 * Set up parameters with SLATB4 and generate a 00384 * test matrix with SLATMS. 00385 * 00386 CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, 00387 $ ANORM, MODE, CNDNUM, DIST ) 00388 * 00389 KOFF = MAX( 1, KU+2-N ) 00390 DO 20 I = 1, KOFF - 1 00391 A( I ) = ZERO 00392 20 CONTINUE 00393 SRNAMT = 'SLATMS' 00394 CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, 00395 $ MODE, CNDNUM, ANORM, KL, KU, 'Z', 00396 $ A( KOFF ), LDA, WORK, INFO ) 00397 * 00398 * Check the error code from SLATMS. 00399 * 00400 IF( INFO.NE.0 ) THEN 00401 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, 00402 $ N, KL, KU, -1, IMAT, NFAIL, 00403 $ NERRS, NOUT ) 00404 GO TO 120 00405 END IF 00406 ELSE IF( IZERO.GT.0 ) THEN 00407 * 00408 * Use the same matrix for types 3 and 4 as for 00409 * type 2 by copying back the zeroed out column. 00410 * 00411 CALL SCOPY( I2-I1+1, B, 1, A( IOFF+I1 ), 1 ) 00412 END IF 00413 * 00414 * For types 2, 3, and 4, zero one or more columns of 00415 * the matrix to test that INFO is returned correctly. 00416 * 00417 IZERO = 0 00418 IF( ZEROT ) THEN 00419 IF( IMAT.EQ.2 ) THEN 00420 IZERO = 1 00421 ELSE IF( IMAT.EQ.3 ) THEN 00422 IZERO = MIN( M, N ) 00423 ELSE 00424 IZERO = MIN( M, N ) / 2 + 1 00425 END IF 00426 IOFF = ( IZERO-1 )*LDA 00427 IF( IMAT.LT.4 ) THEN 00428 * 00429 * Store the column to be zeroed out in B. 00430 * 00431 I1 = MAX( 1, KU+2-IZERO ) 00432 I2 = MIN( KL+KU+1, KU+1+( M-IZERO ) ) 00433 CALL SCOPY( I2-I1+1, A( IOFF+I1 ), 1, B, 1 ) 00434 * 00435 DO 30 I = I1, I2 00436 A( IOFF+I ) = ZERO 00437 30 CONTINUE 00438 ELSE 00439 DO 50 J = IZERO, N 00440 DO 40 I = MAX( 1, KU+2-J ), 00441 $ MIN( KL+KU+1, KU+1+( M-J ) ) 00442 A( IOFF+I ) = ZERO 00443 40 CONTINUE 00444 IOFF = IOFF + LDA 00445 50 CONTINUE 00446 END IF 00447 END IF 00448 * 00449 * These lines, if used in place of the calls in the 00450 * loop over INB, cause the code to bomb on a Sun 00451 * SPARCstation. 00452 * 00453 * ANORMO = SLANGB( 'O', N, KL, KU, A, LDA, RWORK ) 00454 * ANORMI = SLANGB( 'I', N, KL, KU, A, LDA, RWORK ) 00455 * 00456 * Do for each blocksize in NBVAL 00457 * 00458 DO 110 INB = 1, NNB 00459 NB = NBVAL( INB ) 00460 CALL XLAENV( 1, NB ) 00461 * 00462 * Compute the LU factorization of the band matrix. 00463 * 00464 IF( M.GT.0 .AND. N.GT.0 ) 00465 $ CALL SLACPY( 'Full', KL+KU+1, N, A, LDA, 00466 $ AFAC( KL+1 ), LDAFAC ) 00467 SRNAMT = 'SGBTRF' 00468 CALL SGBTRF( M, N, KL, KU, AFAC, LDAFAC, IWORK, 00469 $ INFO ) 00470 * 00471 * Check error code from SGBTRF. 00472 * 00473 IF( INFO.NE.IZERO ) 00474 $ CALL ALAERH( PATH, 'SGBTRF', INFO, IZERO, 00475 $ ' ', M, N, KL, KU, NB, IMAT, 00476 $ NFAIL, NERRS, NOUT ) 00477 TRFCON = .FALSE. 00478 * 00479 *+ TEST 1 00480 * Reconstruct matrix from factors and compute 00481 * residual. 00482 * 00483 CALL SGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC, 00484 $ IWORK, WORK, RESULT( 1 ) ) 00485 * 00486 * Print information about the tests so far that 00487 * did not pass the threshold. 00488 * 00489 IF( RESULT( 1 ).GE.THRESH ) THEN 00490 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00491 $ CALL ALAHD( NOUT, PATH ) 00492 WRITE( NOUT, FMT = 9997 )M, N, KL, KU, NB, 00493 $ IMAT, 1, RESULT( 1 ) 00494 NFAIL = NFAIL + 1 00495 END IF 00496 NRUN = NRUN + 1 00497 * 00498 * Skip the remaining tests if this is not the 00499 * first block size or if M .ne. N. 00500 * 00501 IF( INB.GT.1 .OR. M.NE.N ) 00502 $ GO TO 110 00503 * 00504 ANORMO = SLANGB( 'O', N, KL, KU, A, LDA, RWORK ) 00505 ANORMI = SLANGB( 'I', N, KL, KU, A, LDA, RWORK ) 00506 * 00507 IF( INFO.EQ.0 ) THEN 00508 * 00509 * Form the inverse of A so we can get a good 00510 * estimate of CNDNUM = norm(A) * norm(inv(A)). 00511 * 00512 LDB = MAX( 1, N ) 00513 CALL SLASET( 'Full', N, N, ZERO, ONE, WORK, 00514 $ LDB ) 00515 SRNAMT = 'SGBTRS' 00516 CALL SGBTRS( 'No transpose', N, KL, KU, N, 00517 $ AFAC, LDAFAC, IWORK, WORK, LDB, 00518 $ INFO ) 00519 * 00520 * Compute the 1-norm condition number of A. 00521 * 00522 AINVNM = SLANGE( 'O', N, N, WORK, LDB, 00523 $ RWORK ) 00524 IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00525 RCONDO = ONE 00526 ELSE 00527 RCONDO = ( ONE / ANORMO ) / AINVNM 00528 END IF 00529 * 00530 * Compute the infinity-norm condition number of 00531 * A. 00532 * 00533 AINVNM = SLANGE( 'I', N, N, WORK, LDB, 00534 $ RWORK ) 00535 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00536 RCONDI = ONE 00537 ELSE 00538 RCONDI = ( ONE / ANORMI ) / AINVNM 00539 END IF 00540 ELSE 00541 * 00542 * Do only the condition estimate if INFO.NE.0. 00543 * 00544 TRFCON = .TRUE. 00545 RCONDO = ZERO 00546 RCONDI = ZERO 00547 END IF 00548 * 00549 * Skip the solve tests if the matrix is singular. 00550 * 00551 IF( TRFCON ) 00552 $ GO TO 90 00553 * 00554 DO 80 IRHS = 1, NNS 00555 NRHS = NSVAL( IRHS ) 00556 XTYPE = 'N' 00557 * 00558 DO 70 ITRAN = 1, NTRAN 00559 TRANS = TRANSS( ITRAN ) 00560 IF( ITRAN.EQ.1 ) THEN 00561 RCONDC = RCONDO 00562 NORM = 'O' 00563 ELSE 00564 RCONDC = RCONDI 00565 NORM = 'I' 00566 END IF 00567 * 00568 *+ TEST 2: 00569 * Solve and compute residual for A * X = B. 00570 * 00571 SRNAMT = 'SLARHS' 00572 CALL SLARHS( PATH, XTYPE, ' ', TRANS, N, 00573 $ N, KL, KU, NRHS, A, LDA, 00574 $ XACT, LDB, B, LDB, ISEED, 00575 $ INFO ) 00576 XTYPE = 'C' 00577 CALL SLACPY( 'Full', N, NRHS, B, LDB, X, 00578 $ LDB ) 00579 * 00580 SRNAMT = 'SGBTRS' 00581 CALL SGBTRS( TRANS, N, KL, KU, NRHS, AFAC, 00582 $ LDAFAC, IWORK, X, LDB, INFO ) 00583 * 00584 * Check error code from SGBTRS. 00585 * 00586 IF( INFO.NE.0 ) 00587 $ CALL ALAERH( PATH, 'SGBTRS', INFO, 0, 00588 $ TRANS, N, N, KL, KU, -1, 00589 $ IMAT, NFAIL, NERRS, NOUT ) 00590 * 00591 CALL SLACPY( 'Full', N, NRHS, B, LDB, 00592 $ WORK, LDB ) 00593 CALL SGBT02( TRANS, M, N, KL, KU, NRHS, A, 00594 $ LDA, X, LDB, WORK, LDB, 00595 $ RESULT( 2 ) ) 00596 * 00597 *+ TEST 3: 00598 * Check solution from generated exact 00599 * solution. 00600 * 00601 CALL SGET04( N, NRHS, X, LDB, XACT, LDB, 00602 $ RCONDC, RESULT( 3 ) ) 00603 * 00604 *+ TESTS 4, 5, 6: 00605 * Use iterative refinement to improve the 00606 * solution. 00607 * 00608 SRNAMT = 'SGBRFS' 00609 CALL SGBRFS( TRANS, N, KL, KU, NRHS, A, 00610 $ LDA, AFAC, LDAFAC, IWORK, B, 00611 $ LDB, X, LDB, RWORK, 00612 $ RWORK( NRHS+1 ), WORK, 00613 $ IWORK( N+1 ), INFO ) 00614 * 00615 * Check error code from SGBRFS. 00616 * 00617 IF( INFO.NE.0 ) 00618 $ CALL ALAERH( PATH, 'SGBRFS', INFO, 0, 00619 $ TRANS, N, N, KL, KU, NRHS, 00620 $ IMAT, NFAIL, NERRS, NOUT ) 00621 * 00622 CALL SGET04( N, NRHS, X, LDB, XACT, LDB, 00623 $ RCONDC, RESULT( 4 ) ) 00624 CALL SGBT05( TRANS, N, KL, KU, NRHS, A, 00625 $ LDA, B, LDB, X, LDB, XACT, 00626 $ LDB, RWORK, RWORK( NRHS+1 ), 00627 $ RESULT( 5 ) ) 00628 DO 60 K = 2, 6 00629 IF( RESULT( K ).GE.THRESH ) THEN 00630 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00631 $ CALL ALAHD( NOUT, PATH ) 00632 WRITE( NOUT, FMT = 9996 )TRANS, N, 00633 $ KL, KU, NRHS, IMAT, K, 00634 $ RESULT( K ) 00635 NFAIL = NFAIL + 1 00636 END IF 00637 60 CONTINUE 00638 NRUN = NRUN + 5 00639 70 CONTINUE 00640 80 CONTINUE 00641 * 00642 *+ TEST 7: 00643 * Get an estimate of RCOND = 1/CNDNUM. 00644 * 00645 90 CONTINUE 00646 DO 100 ITRAN = 1, 2 00647 IF( ITRAN.EQ.1 ) THEN 00648 ANORM = ANORMO 00649 RCONDC = RCONDO 00650 NORM = 'O' 00651 ELSE 00652 ANORM = ANORMI 00653 RCONDC = RCONDI 00654 NORM = 'I' 00655 END IF 00656 SRNAMT = 'SGBCON' 00657 CALL SGBCON( NORM, N, KL, KU, AFAC, LDAFAC, 00658 $ IWORK, ANORM, RCOND, WORK, 00659 $ IWORK( N+1 ), INFO ) 00660 * 00661 * Check error code from SGBCON. 00662 * 00663 IF( INFO.NE.0 ) 00664 $ CALL ALAERH( PATH, 'SGBCON', INFO, 0, 00665 $ NORM, N, N, KL, KU, -1, IMAT, 00666 $ NFAIL, NERRS, NOUT ) 00667 * 00668 RESULT( 7 ) = SGET06( RCOND, RCONDC ) 00669 * 00670 * Print information about the tests that did 00671 * not pass the threshold. 00672 * 00673 IF( RESULT( 7 ).GE.THRESH ) THEN 00674 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00675 $ CALL ALAHD( NOUT, PATH ) 00676 WRITE( NOUT, FMT = 9995 )NORM, N, KL, KU, 00677 $ IMAT, 7, RESULT( 7 ) 00678 NFAIL = NFAIL + 1 00679 END IF 00680 NRUN = NRUN + 1 00681 100 CONTINUE 00682 * 00683 110 CONTINUE 00684 120 CONTINUE 00685 130 CONTINUE 00686 140 CONTINUE 00687 150 CONTINUE 00688 160 CONTINUE 00689 * 00690 * Print a summary of the results. 00691 * 00692 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00693 * 00694 9999 FORMAT( ' *** In SCHKGB, LA=', I5, ' is too small for M=', I5, 00695 $ ', N=', I5, ', KL=', I4, ', KU=', I4, 00696 $ / ' ==> Increase LA to at least ', I5 ) 00697 9998 FORMAT( ' *** In SCHKGB, LAFAC=', I5, ' is too small for M=', I5, 00698 $ ', N=', I5, ', KL=', I4, ', KU=', I4, 00699 $ / ' ==> Increase LAFAC to at least ', I5 ) 00700 9997 FORMAT( ' M =', I5, ', N =', I5, ', KL=', I5, ', KU=', I5, 00701 $ ', NB =', I4, ', type ', I1, ', test(', I1, ')=', G12.5 ) 00702 9996 FORMAT( ' TRANS=''', A1, ''', N=', I5, ', KL=', I5, ', KU=', I5, 00703 $ ', NRHS=', I3, ', type ', I1, ', test(', I1, ')=', G12.5 ) 00704 9995 FORMAT( ' NORM =''', A1, ''', N=', I5, ', KL=', I5, ', KU=', I5, 00705 $ ',', 10X, ' type ', I1, ', test(', I1, ')=', G12.5 ) 00706 * 00707 RETURN 00708 * 00709 * End of SCHKGB 00710 * 00711 END