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