![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SDRVGB 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 SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, 00012 * AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, 00013 * RWORK, IWORK, NOUT ) 00014 * 00015 * .. Scalar Arguments .. 00016 * LOGICAL TSTERR 00017 * INTEGER LA, LAFB, NN, NOUT, NRHS 00018 * REAL THRESH 00019 * .. 00020 * .. Array Arguments .. 00021 * LOGICAL DOTYPE( * ) 00022 * INTEGER IWORK( * ), NVAL( * ) 00023 * REAL A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), 00024 * $ RWORK( * ), S( * ), WORK( * ), X( * ), 00025 * $ XACT( * ) 00026 * .. 00027 * 00028 * 00029 *> \par Purpose: 00030 * ============= 00031 *> 00032 *> \verbatim 00033 *> 00034 *> SDRVGB tests the driver routines SGBSV and -SVX. 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] NRHS 00061 *> \verbatim 00062 *> NRHS is INTEGER 00063 *> The number of right hand side vectors to be generated for 00064 *> each linear system. 00065 *> \endverbatim 00066 *> 00067 *> \param[in] THRESH 00068 *> \verbatim 00069 *> THRESH is REAL 00070 *> The threshold value for the test ratios. A result is 00071 *> included in the output file if RESULT >= THRESH. To have 00072 *> every test ratio printed, use THRESH = 0. 00073 *> \endverbatim 00074 *> 00075 *> \param[in] TSTERR 00076 *> \verbatim 00077 *> TSTERR is LOGICAL 00078 *> Flag that indicates whether error exits are to be tested. 00079 *> \endverbatim 00080 *> 00081 *> \param[out] A 00082 *> \verbatim 00083 *> A is REAL array, dimension (LA) 00084 *> \endverbatim 00085 *> 00086 *> \param[in] LA 00087 *> \verbatim 00088 *> LA is INTEGER 00089 *> The length of the array A. LA >= (2*NMAX-1)*NMAX 00090 *> where NMAX is the largest entry in NVAL. 00091 *> \endverbatim 00092 *> 00093 *> \param[out] AFB 00094 *> \verbatim 00095 *> AFB is REAL array, dimension (LAFB) 00096 *> \endverbatim 00097 *> 00098 *> \param[in] LAFB 00099 *> \verbatim 00100 *> LAFB is INTEGER 00101 *> The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX 00102 *> where NMAX is the largest entry in NVAL. 00103 *> \endverbatim 00104 *> 00105 *> \param[out] ASAV 00106 *> \verbatim 00107 *> ASAV is REAL array, dimension (LA) 00108 *> \endverbatim 00109 *> 00110 *> \param[out] B 00111 *> \verbatim 00112 *> B is REAL array, dimension (NMAX*NRHS) 00113 *> \endverbatim 00114 *> 00115 *> \param[out] BSAV 00116 *> \verbatim 00117 *> BSAV is REAL array, dimension (NMAX*NRHS) 00118 *> \endverbatim 00119 *> 00120 *> \param[out] X 00121 *> \verbatim 00122 *> X is REAL array, dimension (NMAX*NRHS) 00123 *> \endverbatim 00124 *> 00125 *> \param[out] XACT 00126 *> \verbatim 00127 *> XACT is REAL array, dimension (NMAX*NRHS) 00128 *> \endverbatim 00129 *> 00130 *> \param[out] S 00131 *> \verbatim 00132 *> S is REAL array, dimension (2*NMAX) 00133 *> \endverbatim 00134 *> 00135 *> \param[out] WORK 00136 *> \verbatim 00137 *> WORK is REAL array, dimension 00138 *> (NMAX*max(3,NRHS,NMAX)) 00139 *> \endverbatim 00140 *> 00141 *> \param[out] RWORK 00142 *> \verbatim 00143 *> RWORK is REAL array, dimension 00144 *> (max(NMAX,2*NRHS)) 00145 *> \endverbatim 00146 *> 00147 *> \param[out] IWORK 00148 *> \verbatim 00149 *> IWORK is INTEGER array, dimension (2*NMAX) 00150 *> \endverbatim 00151 *> 00152 *> \param[in] NOUT 00153 *> \verbatim 00154 *> NOUT is INTEGER 00155 *> The unit number for output. 00156 *> \endverbatim 00157 * 00158 * Authors: 00159 * ======== 00160 * 00161 *> \author Univ. of Tennessee 00162 *> \author Univ. of California Berkeley 00163 *> \author Univ. of Colorado Denver 00164 *> \author NAG Ltd. 00165 * 00166 *> \date November 2011 00167 * 00168 *> \ingroup single_lin 00169 * 00170 * ===================================================================== 00171 SUBROUTINE SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, 00172 $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, 00173 $ RWORK, IWORK, NOUT ) 00174 * 00175 * -- LAPACK test routine (version 3.4.0) -- 00176 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00177 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00178 * November 2011 00179 * 00180 * .. Scalar Arguments .. 00181 LOGICAL TSTERR 00182 INTEGER LA, LAFB, NN, NOUT, NRHS 00183 REAL THRESH 00184 * .. 00185 * .. Array Arguments .. 00186 LOGICAL DOTYPE( * ) 00187 INTEGER IWORK( * ), NVAL( * ) 00188 REAL A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), 00189 $ RWORK( * ), S( * ), WORK( * ), X( * ), 00190 $ XACT( * ) 00191 * .. 00192 * 00193 * ===================================================================== 00194 * 00195 * .. Parameters .. 00196 REAL ONE, ZERO 00197 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00198 INTEGER NTYPES 00199 PARAMETER ( NTYPES = 8 ) 00200 INTEGER NTESTS 00201 PARAMETER ( NTESTS = 7 ) 00202 INTEGER NTRAN 00203 PARAMETER ( NTRAN = 3 ) 00204 * .. 00205 * .. Local Scalars .. 00206 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT 00207 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE 00208 CHARACTER*3 PATH 00209 INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN, 00210 $ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU, 00211 $ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS, 00212 $ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT 00213 REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV, 00214 $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO, 00215 $ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW 00216 * .. 00217 * .. Local Arrays .. 00218 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) 00219 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00220 REAL RESULT( NTESTS ) 00221 * .. 00222 * .. External Functions .. 00223 LOGICAL LSAME 00224 REAL SGET06, SLAMCH, SLANGB, SLANGE, SLANTB 00225 EXTERNAL LSAME, SGET06, SLAMCH, SLANGB, SLANGE, SLANTB 00226 * .. 00227 * .. External Subroutines .. 00228 EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGBEQU, SGBSV, 00229 $ SGBSVX, SGBT01, SGBT02, SGBT05, SGBTRF, SGBTRS, 00230 $ SGET04, SLACPY, SLAQGB, SLARHS, SLASET, SLATB4, 00231 $ SLATMS, XLAENV 00232 * .. 00233 * .. Intrinsic Functions .. 00234 INTRINSIC ABS, MAX, MIN 00235 * .. 00236 * .. Scalars in Common .. 00237 LOGICAL LERR, OK 00238 CHARACTER*32 SRNAMT 00239 INTEGER INFOT, NUNIT 00240 * .. 00241 * .. Common blocks .. 00242 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00243 COMMON / SRNAMC / SRNAMT 00244 * .. 00245 * .. Data statements .. 00246 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00247 DATA TRANSS / 'N', 'T', 'C' / 00248 DATA FACTS / 'F', 'N', 'E' / 00249 DATA EQUEDS / 'N', 'R', 'C', 'B' / 00250 * .. 00251 * .. Executable Statements .. 00252 * 00253 * Initialize constants and the random number seed. 00254 * 00255 PATH( 1: 1 ) = 'Single precision' 00256 PATH( 2: 3 ) = 'GB' 00257 NRUN = 0 00258 NFAIL = 0 00259 NERRS = 0 00260 DO 10 I = 1, 4 00261 ISEED( I ) = ISEEDY( I ) 00262 10 CONTINUE 00263 * 00264 * Test the error exits 00265 * 00266 IF( TSTERR ) 00267 $ CALL SERRVX( PATH, NOUT ) 00268 INFOT = 0 00269 * 00270 * Set the block size and minimum block size for testing. 00271 * 00272 NB = 1 00273 NBMIN = 2 00274 CALL XLAENV( 1, NB ) 00275 CALL XLAENV( 2, NBMIN ) 00276 * 00277 * Do for each value of N in NVAL 00278 * 00279 DO 150 IN = 1, NN 00280 N = NVAL( IN ) 00281 LDB = MAX( N, 1 ) 00282 XTYPE = 'N' 00283 * 00284 * Set limits on the number of loop iterations. 00285 * 00286 NKL = MAX( 1, MIN( N, 4 ) ) 00287 IF( N.EQ.0 ) 00288 $ NKL = 1 00289 NKU = NKL 00290 NIMAT = NTYPES 00291 IF( N.LE.0 ) 00292 $ NIMAT = 1 00293 * 00294 DO 140 IKL = 1, NKL 00295 * 00296 * Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes 00297 * it easier to skip redundant values for small values of N. 00298 * 00299 IF( IKL.EQ.1 ) THEN 00300 KL = 0 00301 ELSE IF( IKL.EQ.2 ) THEN 00302 KL = MAX( N-1, 0 ) 00303 ELSE IF( IKL.EQ.3 ) THEN 00304 KL = ( 3*N-1 ) / 4 00305 ELSE IF( IKL.EQ.4 ) THEN 00306 KL = ( N+1 ) / 4 00307 END IF 00308 DO 130 IKU = 1, NKU 00309 * 00310 * Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order 00311 * makes it easier to skip redundant values for small 00312 * values of N. 00313 * 00314 IF( IKU.EQ.1 ) THEN 00315 KU = 0 00316 ELSE IF( IKU.EQ.2 ) THEN 00317 KU = MAX( N-1, 0 ) 00318 ELSE IF( IKU.EQ.3 ) THEN 00319 KU = ( 3*N-1 ) / 4 00320 ELSE IF( IKU.EQ.4 ) THEN 00321 KU = ( N+1 ) / 4 00322 END IF 00323 * 00324 * Check that A and AFB are big enough to generate this 00325 * matrix. 00326 * 00327 LDA = KL + KU + 1 00328 LDAFB = 2*KL + KU + 1 00329 IF( LDA*N.GT.LA .OR. LDAFB*N.GT.LAFB ) THEN 00330 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00331 $ CALL ALADHD( NOUT, PATH ) 00332 IF( LDA*N.GT.LA ) THEN 00333 WRITE( NOUT, FMT = 9999 )LA, N, KL, KU, 00334 $ N*( KL+KU+1 ) 00335 NERRS = NERRS + 1 00336 END IF 00337 IF( LDAFB*N.GT.LAFB ) THEN 00338 WRITE( NOUT, FMT = 9998 )LAFB, N, KL, KU, 00339 $ N*( 2*KL+KU+1 ) 00340 NERRS = NERRS + 1 00341 END IF 00342 GO TO 130 00343 END IF 00344 * 00345 DO 120 IMAT = 1, NIMAT 00346 * 00347 * Do the tests only if DOTYPE( IMAT ) is true. 00348 * 00349 IF( .NOT.DOTYPE( IMAT ) ) 00350 $ GO TO 120 00351 * 00352 * Skip types 2, 3, or 4 if the matrix is too small. 00353 * 00354 ZEROT = IMAT.GE.2 .AND. IMAT.LE.4 00355 IF( ZEROT .AND. N.LT.IMAT-1 ) 00356 $ GO TO 120 00357 * 00358 * Set up parameters with SLATB4 and generate a 00359 * test matrix with SLATMS. 00360 * 00361 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, 00362 $ MODE, CNDNUM, DIST ) 00363 RCONDC = ONE / CNDNUM 00364 * 00365 SRNAMT = 'SLATMS' 00366 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 00367 $ CNDNUM, ANORM, KL, KU, 'Z', A, LDA, WORK, 00368 $ INFO ) 00369 * 00370 * Check the error code from SLATMS. 00371 * 00372 IF( INFO.NE.0 ) THEN 00373 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, 00374 $ KL, KU, -1, IMAT, NFAIL, NERRS, NOUT ) 00375 GO TO 120 00376 END IF 00377 * 00378 * For types 2, 3, and 4, zero one or more columns of 00379 * the matrix to test that INFO is returned correctly. 00380 * 00381 IZERO = 0 00382 IF( ZEROT ) THEN 00383 IF( IMAT.EQ.2 ) THEN 00384 IZERO = 1 00385 ELSE IF( IMAT.EQ.3 ) THEN 00386 IZERO = N 00387 ELSE 00388 IZERO = N / 2 + 1 00389 END IF 00390 IOFF = ( IZERO-1 )*LDA 00391 IF( IMAT.LT.4 ) THEN 00392 I1 = MAX( 1, KU+2-IZERO ) 00393 I2 = MIN( KL+KU+1, KU+1+( N-IZERO ) ) 00394 DO 20 I = I1, I2 00395 A( IOFF+I ) = ZERO 00396 20 CONTINUE 00397 ELSE 00398 DO 40 J = IZERO, N 00399 DO 30 I = MAX( 1, KU+2-J ), 00400 $ MIN( KL+KU+1, KU+1+( N-J ) ) 00401 A( IOFF+I ) = ZERO 00402 30 CONTINUE 00403 IOFF = IOFF + LDA 00404 40 CONTINUE 00405 END IF 00406 END IF 00407 * 00408 * Save a copy of the matrix A in ASAV. 00409 * 00410 CALL SLACPY( 'Full', KL+KU+1, N, A, LDA, ASAV, LDA ) 00411 * 00412 DO 110 IEQUED = 1, 4 00413 EQUED = EQUEDS( IEQUED ) 00414 IF( IEQUED.EQ.1 ) THEN 00415 NFACT = 3 00416 ELSE 00417 NFACT = 1 00418 END IF 00419 * 00420 DO 100 IFACT = 1, NFACT 00421 FACT = FACTS( IFACT ) 00422 PREFAC = LSAME( FACT, 'F' ) 00423 NOFACT = LSAME( FACT, 'N' ) 00424 EQUIL = LSAME( FACT, 'E' ) 00425 * 00426 IF( ZEROT ) THEN 00427 IF( PREFAC ) 00428 $ GO TO 100 00429 RCONDO = ZERO 00430 RCONDI = ZERO 00431 * 00432 ELSE IF( .NOT.NOFACT ) THEN 00433 * 00434 * Compute the condition number for comparison 00435 * with the value returned by SGESVX (FACT = 00436 * 'N' reuses the condition number from the 00437 * previous iteration with FACT = 'F'). 00438 * 00439 CALL SLACPY( 'Full', KL+KU+1, N, ASAV, LDA, 00440 $ AFB( KL+1 ), LDAFB ) 00441 IF( EQUIL .OR. IEQUED.GT.1 ) THEN 00442 * 00443 * Compute row and column scale factors to 00444 * equilibrate the matrix A. 00445 * 00446 CALL SGBEQU( N, N, KL, KU, AFB( KL+1 ), 00447 $ LDAFB, S, S( N+1 ), ROWCND, 00448 $ COLCND, AMAX, INFO ) 00449 IF( INFO.EQ.0 .AND. N.GT.0 ) THEN 00450 IF( LSAME( EQUED, 'R' ) ) THEN 00451 ROWCND = ZERO 00452 COLCND = ONE 00453 ELSE IF( LSAME( EQUED, 'C' ) ) THEN 00454 ROWCND = ONE 00455 COLCND = ZERO 00456 ELSE IF( LSAME( EQUED, 'B' ) ) THEN 00457 ROWCND = ZERO 00458 COLCND = ZERO 00459 END IF 00460 * 00461 * Equilibrate the matrix. 00462 * 00463 CALL SLAQGB( N, N, KL, KU, AFB( KL+1 ), 00464 $ LDAFB, S, S( N+1 ), 00465 $ ROWCND, COLCND, AMAX, 00466 $ EQUED ) 00467 END IF 00468 END IF 00469 * 00470 * Save the condition number of the 00471 * non-equilibrated system for use in SGET04. 00472 * 00473 IF( EQUIL ) THEN 00474 ROLDO = RCONDO 00475 ROLDI = RCONDI 00476 END IF 00477 * 00478 * Compute the 1-norm and infinity-norm of A. 00479 * 00480 ANORMO = SLANGB( '1', N, KL, KU, AFB( KL+1 ), 00481 $ LDAFB, RWORK ) 00482 ANORMI = SLANGB( 'I', N, KL, KU, AFB( KL+1 ), 00483 $ LDAFB, RWORK ) 00484 * 00485 * Factor the matrix A. 00486 * 00487 CALL SGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK, 00488 $ INFO ) 00489 * 00490 * Form the inverse of A. 00491 * 00492 CALL SLASET( 'Full', N, N, ZERO, ONE, WORK, 00493 $ LDB ) 00494 SRNAMT = 'SGBTRS' 00495 CALL SGBTRS( 'No transpose', N, KL, KU, N, 00496 $ AFB, LDAFB, IWORK, WORK, LDB, 00497 $ INFO ) 00498 * 00499 * Compute the 1-norm condition number of A. 00500 * 00501 AINVNM = SLANGE( '1', N, N, WORK, LDB, 00502 $ RWORK ) 00503 IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00504 RCONDO = ONE 00505 ELSE 00506 RCONDO = ( ONE / ANORMO ) / AINVNM 00507 END IF 00508 * 00509 * Compute the infinity-norm condition number 00510 * of A. 00511 * 00512 AINVNM = SLANGE( 'I', N, N, WORK, LDB, 00513 $ RWORK ) 00514 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00515 RCONDI = ONE 00516 ELSE 00517 RCONDI = ( ONE / ANORMI ) / AINVNM 00518 END IF 00519 END IF 00520 * 00521 DO 90 ITRAN = 1, NTRAN 00522 * 00523 * Do for each value of TRANS. 00524 * 00525 TRANS = TRANSS( ITRAN ) 00526 IF( ITRAN.EQ.1 ) THEN 00527 RCONDC = RCONDO 00528 ELSE 00529 RCONDC = RCONDI 00530 END IF 00531 * 00532 * Restore the matrix A. 00533 * 00534 CALL SLACPY( 'Full', KL+KU+1, N, ASAV, LDA, 00535 $ A, LDA ) 00536 * 00537 * Form an exact solution and set the right hand 00538 * side. 00539 * 00540 SRNAMT = 'SLARHS' 00541 CALL SLARHS( PATH, XTYPE, 'Full', TRANS, N, 00542 $ N, KL, KU, NRHS, A, LDA, XACT, 00543 $ LDB, B, LDB, ISEED, INFO ) 00544 XTYPE = 'C' 00545 CALL SLACPY( 'Full', N, NRHS, B, LDB, BSAV, 00546 $ LDB ) 00547 * 00548 IF( NOFACT .AND. ITRAN.EQ.1 ) THEN 00549 * 00550 * --- Test SGBSV --- 00551 * 00552 * Compute the LU factorization of the matrix 00553 * and solve the system. 00554 * 00555 CALL SLACPY( 'Full', KL+KU+1, N, A, LDA, 00556 $ AFB( KL+1 ), LDAFB ) 00557 CALL SLACPY( 'Full', N, NRHS, B, LDB, X, 00558 $ LDB ) 00559 * 00560 SRNAMT = 'SGBSV ' 00561 CALL SGBSV( N, KL, KU, NRHS, AFB, LDAFB, 00562 $ IWORK, X, LDB, INFO ) 00563 * 00564 * Check error code from SGBSV . 00565 * 00566 IF( INFO.NE.IZERO ) 00567 $ CALL ALAERH( PATH, 'SGBSV ', INFO, 00568 $ IZERO, ' ', N, N, KL, KU, 00569 $ NRHS, IMAT, NFAIL, NERRS, 00570 $ NOUT ) 00571 * 00572 * Reconstruct matrix from factors and 00573 * compute residual. 00574 * 00575 CALL SGBT01( N, N, KL, KU, A, LDA, AFB, 00576 $ LDAFB, IWORK, WORK, 00577 $ RESULT( 1 ) ) 00578 NT = 1 00579 IF( IZERO.EQ.0 ) THEN 00580 * 00581 * Compute residual of the computed 00582 * solution. 00583 * 00584 CALL SLACPY( 'Full', N, NRHS, B, LDB, 00585 $ WORK, LDB ) 00586 CALL SGBT02( 'No transpose', N, N, KL, 00587 $ KU, NRHS, A, LDA, X, LDB, 00588 $ WORK, LDB, RESULT( 2 ) ) 00589 * 00590 * Check solution from generated exact 00591 * solution. 00592 * 00593 CALL SGET04( N, NRHS, X, LDB, XACT, 00594 $ LDB, RCONDC, RESULT( 3 ) ) 00595 NT = 3 00596 END IF 00597 * 00598 * Print information about the tests that did 00599 * not pass the threshold. 00600 * 00601 DO 50 K = 1, NT 00602 IF( RESULT( K ).GE.THRESH ) THEN 00603 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00604 $ CALL ALADHD( NOUT, PATH ) 00605 WRITE( NOUT, FMT = 9997 )'SGBSV ', 00606 $ N, KL, KU, IMAT, K, RESULT( K ) 00607 NFAIL = NFAIL + 1 00608 END IF 00609 50 CONTINUE 00610 NRUN = NRUN + NT 00611 END IF 00612 * 00613 * --- Test SGBSVX --- 00614 * 00615 IF( .NOT.PREFAC ) 00616 $ CALL SLASET( 'Full', 2*KL+KU+1, N, ZERO, 00617 $ ZERO, AFB, LDAFB ) 00618 CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, 00619 $ LDB ) 00620 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 00621 * 00622 * Equilibrate the matrix if FACT = 'F' and 00623 * EQUED = 'R', 'C', or 'B'. 00624 * 00625 CALL SLAQGB( N, N, KL, KU, A, LDA, S, 00626 $ S( N+1 ), ROWCND, COLCND, 00627 $ AMAX, EQUED ) 00628 END IF 00629 * 00630 * Solve the system and compute the condition 00631 * number and error bounds using SGBSVX. 00632 * 00633 SRNAMT = 'SGBSVX' 00634 CALL SGBSVX( FACT, TRANS, N, KL, KU, NRHS, A, 00635 $ LDA, AFB, LDAFB, IWORK, EQUED, 00636 $ S, S( N+1 ), B, LDB, X, LDB, 00637 $ RCOND, RWORK, RWORK( NRHS+1 ), 00638 $ WORK, IWORK( N+1 ), INFO ) 00639 * 00640 * Check the error code from SGBSVX. 00641 * 00642 IF( INFO.NE.IZERO ) 00643 $ CALL ALAERH( PATH, 'SGBSVX', INFO, IZERO, 00644 $ FACT // TRANS, N, N, KL, KU, 00645 $ NRHS, IMAT, NFAIL, NERRS, 00646 $ NOUT ) 00647 * 00648 * Compare WORK(1) from SGBSVX with the computed 00649 * reciprocal pivot growth factor RPVGRW 00650 * 00651 IF( INFO.NE.0 ) THEN 00652 ANRMPV = ZERO 00653 DO 70 J = 1, INFO 00654 DO 60 I = MAX( KU+2-J, 1 ), 00655 $ MIN( N+KU+1-J, KL+KU+1 ) 00656 ANRMPV = MAX( ANRMPV, 00657 $ ABS( A( I+( J-1 )*LDA ) ) ) 00658 60 CONTINUE 00659 70 CONTINUE 00660 RPVGRW = SLANTB( 'M', 'U', 'N', INFO, 00661 $ MIN( INFO-1, KL+KU ), 00662 $ AFB( MAX( 1, KL+KU+2-INFO ) ), 00663 $ LDAFB, WORK ) 00664 IF( RPVGRW.EQ.ZERO ) THEN 00665 RPVGRW = ONE 00666 ELSE 00667 RPVGRW = ANRMPV / RPVGRW 00668 END IF 00669 ELSE 00670 RPVGRW = SLANTB( 'M', 'U', 'N', N, KL+KU, 00671 $ AFB, LDAFB, WORK ) 00672 IF( RPVGRW.EQ.ZERO ) THEN 00673 RPVGRW = ONE 00674 ELSE 00675 RPVGRW = SLANGB( 'M', N, KL, KU, A, 00676 $ LDA, WORK ) / RPVGRW 00677 END IF 00678 END IF 00679 RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) / 00680 $ MAX( WORK( 1 ), RPVGRW ) / 00681 $ SLAMCH( 'E' ) 00682 * 00683 IF( .NOT.PREFAC ) THEN 00684 * 00685 * Reconstruct matrix from factors and 00686 * compute residual. 00687 * 00688 CALL SGBT01( N, N, KL, KU, A, LDA, AFB, 00689 $ LDAFB, IWORK, WORK, 00690 $ RESULT( 1 ) ) 00691 K1 = 1 00692 ELSE 00693 K1 = 2 00694 END IF 00695 * 00696 IF( INFO.EQ.0 ) THEN 00697 TRFCON = .FALSE. 00698 * 00699 * Compute residual of the computed solution. 00700 * 00701 CALL SLACPY( 'Full', N, NRHS, BSAV, LDB, 00702 $ WORK, LDB ) 00703 CALL SGBT02( TRANS, N, N, KL, KU, NRHS, 00704 $ ASAV, LDA, X, LDB, WORK, LDB, 00705 $ RESULT( 2 ) ) 00706 * 00707 * Check solution from generated exact 00708 * solution. 00709 * 00710 IF( NOFACT .OR. ( PREFAC .AND. 00711 $ LSAME( EQUED, 'N' ) ) ) THEN 00712 CALL SGET04( N, NRHS, X, LDB, XACT, 00713 $ LDB, RCONDC, RESULT( 3 ) ) 00714 ELSE 00715 IF( ITRAN.EQ.1 ) THEN 00716 ROLDC = ROLDO 00717 ELSE 00718 ROLDC = ROLDI 00719 END IF 00720 CALL SGET04( N, NRHS, X, LDB, XACT, 00721 $ LDB, ROLDC, RESULT( 3 ) ) 00722 END IF 00723 * 00724 * Check the error bounds from iterative 00725 * refinement. 00726 * 00727 CALL SGBT05( TRANS, N, KL, KU, NRHS, ASAV, 00728 $ LDA, B, LDB, X, LDB, XACT, 00729 $ LDB, RWORK, RWORK( NRHS+1 ), 00730 $ RESULT( 4 ) ) 00731 ELSE 00732 TRFCON = .TRUE. 00733 END IF 00734 * 00735 * Compare RCOND from SGBSVX with the computed 00736 * value in RCONDC. 00737 * 00738 RESULT( 6 ) = SGET06( RCOND, RCONDC ) 00739 * 00740 * Print information about the tests that did 00741 * not pass the threshold. 00742 * 00743 IF( .NOT.TRFCON ) THEN 00744 DO 80 K = K1, NTESTS 00745 IF( RESULT( K ).GE.THRESH ) THEN 00746 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00747 $ CALL ALADHD( NOUT, PATH ) 00748 IF( PREFAC ) THEN 00749 WRITE( NOUT, FMT = 9995 ) 00750 $ 'SGBSVX', FACT, TRANS, N, KL, 00751 $ KU, EQUED, IMAT, K, 00752 $ RESULT( K ) 00753 ELSE 00754 WRITE( NOUT, FMT = 9996 ) 00755 $ 'SGBSVX', FACT, TRANS, N, KL, 00756 $ KU, IMAT, K, RESULT( K ) 00757 END IF 00758 NFAIL = NFAIL + 1 00759 END IF 00760 80 CONTINUE 00761 NRUN = NRUN + 7 - K1 00762 ELSE 00763 IF( RESULT( 1 ).GE.THRESH .AND. .NOT. 00764 $ PREFAC ) THEN 00765 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00766 $ CALL ALADHD( NOUT, PATH ) 00767 IF( PREFAC ) THEN 00768 WRITE( NOUT, FMT = 9995 )'SGBSVX', 00769 $ FACT, TRANS, N, KL, KU, EQUED, 00770 $ IMAT, 1, RESULT( 1 ) 00771 ELSE 00772 WRITE( NOUT, FMT = 9996 )'SGBSVX', 00773 $ FACT, TRANS, N, KL, KU, IMAT, 1, 00774 $ RESULT( 1 ) 00775 END IF 00776 NFAIL = NFAIL + 1 00777 NRUN = NRUN + 1 00778 END IF 00779 IF( RESULT( 6 ).GE.THRESH ) THEN 00780 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00781 $ CALL ALADHD( NOUT, PATH ) 00782 IF( PREFAC ) THEN 00783 WRITE( NOUT, FMT = 9995 )'SGBSVX', 00784 $ FACT, TRANS, N, KL, KU, EQUED, 00785 $ IMAT, 6, RESULT( 6 ) 00786 ELSE 00787 WRITE( NOUT, FMT = 9996 )'SGBSVX', 00788 $ FACT, TRANS, N, KL, KU, IMAT, 6, 00789 $ RESULT( 6 ) 00790 END IF 00791 NFAIL = NFAIL + 1 00792 NRUN = NRUN + 1 00793 END IF 00794 IF( RESULT( 7 ).GE.THRESH ) THEN 00795 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00796 $ CALL ALADHD( NOUT, PATH ) 00797 IF( PREFAC ) THEN 00798 WRITE( NOUT, FMT = 9995 )'SGBSVX', 00799 $ FACT, TRANS, N, KL, KU, EQUED, 00800 $ IMAT, 7, RESULT( 7 ) 00801 ELSE 00802 WRITE( NOUT, FMT = 9996 )'SGBSVX', 00803 $ FACT, TRANS, N, KL, KU, IMAT, 7, 00804 $ RESULT( 7 ) 00805 END IF 00806 NFAIL = NFAIL + 1 00807 NRUN = NRUN + 1 00808 END IF 00809 * 00810 END IF 00811 90 CONTINUE 00812 100 CONTINUE 00813 110 CONTINUE 00814 120 CONTINUE 00815 130 CONTINUE 00816 140 CONTINUE 00817 150 CONTINUE 00818 * 00819 * Print a summary of the results. 00820 * 00821 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00822 * 00823 9999 FORMAT( ' *** In SDRVGB, LA=', I5, ' is too small for N=', I5, 00824 $ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ', 00825 $ I5 ) 00826 9998 FORMAT( ' *** In SDRVGB, LAFB=', I5, ' is too small for N=', I5, 00827 $ ', KU=', I5, ', KL=', I5, / 00828 $ ' ==> Increase LAFB to at least ', I5 ) 00829 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ', 00830 $ I1, ', test(', I1, ')=', G12.5 ) 00831 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', 00832 $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 ) 00833 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', 00834 $ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1, 00835 $ ')=', G12.5 ) 00836 * 00837 RETURN 00838 * 00839 * End of SDRVGB 00840 * 00841 END