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