|
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.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 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, -SVX, and -SVXX. 00026 * 00027 * Note that this file is used only when the XBLAS are available, 00028 * otherwise ddrvgb.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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LA) 00069 * 00070 * B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) 00071 * 00072 * BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) 00073 * 00074 * X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) 00075 * 00076 * XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) 00077 * 00078 * S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) 00079 * 00080 * WORK (workspace) DOUBLE PRECISION array, dimension 00081 * (NMAX*max(3,NRHS,NMAX)) 00082 * 00083 * RWORK (workspace) DOUBLE PRECISION 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 DOUBLE PRECISION ONE, ZERO 00095 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+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 DOUBLE PRECISION 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 DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ), 00121 $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) 00122 * .. 00123 * .. External Functions .. 00124 LOGICAL LSAME 00125 DOUBLE PRECISION DGET06, DLAMCH, DLANGB, DLANGE, DLANTB, 00126 $ DLA_GBRPVGRW 00127 EXTERNAL LSAME, DGET06, DLAMCH, DLANGB, DLANGE, DLANTB, 00128 $ DLA_GBRPVGRW 00129 * .. 00130 * .. External Subroutines .. 00131 EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGBEQU, DGBSV, 00132 $ DGBSVX, DGBT01, DGBT02, DGBT05, DGBTRF, DGBTRS, 00133 $ DGET04, DLACPY, DLAQGB, DLARHS, DLASET, DLATB4, 00134 $ DLATMS, XLAENV, DGBSVXX, DGBEQUB 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 ) = 'Double 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 DERRVX( 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 DLATB4 and generate a 00262 * test matrix with DLATMS. 00263 * 00264 CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, 00265 $ MODE, CNDNUM, DIST ) 00266 RCONDC = ONE / CNDNUM 00267 * 00268 SRNAMT = 'DLATMS' 00269 CALL DLATMS( 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 DLATMS. 00274 * 00275 IF( INFO.NE.0 ) THEN 00276 CALL ALAERH( PATH, 'DLATMS', 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 DLACPY( '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 DGESVX (FACT = 00339 * 'N' reuses the condition number from the 00340 * previous iteration with FACT = 'F'). 00341 * 00342 CALL DLACPY( '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 DGBEQU( 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 DLAQGB( 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 DGET04. 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 = DLANGB( '1', N, KL, KU, AFB( KL+1 ), 00384 $ LDAFB, RWORK ) 00385 ANORMI = DLANGB( 'I', N, KL, KU, AFB( KL+1 ), 00386 $ LDAFB, RWORK ) 00387 * 00388 * Factor the matrix A. 00389 * 00390 CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK, 00391 $ INFO ) 00392 * 00393 * Form the inverse of A. 00394 * 00395 CALL DLASET( 'Full', N, N, ZERO, ONE, WORK, 00396 $ LDB ) 00397 SRNAMT = 'DGBTRS' 00398 CALL DGBTRS( '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 = DLANGE( '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 = DLANGE( '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 DLACPY( '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 = 'DLARHS' 00444 CALL DLARHS( PATH, XTYPE, 'Full', TRANS, N, 00445 $ N, KL, KU, NRHS, A, LDA, XACT, 00446 $ LDB, B, LDB, ISEED, INFO ) 00447 XTYPE = 'C' 00448 CALL DLACPY( 'Full', N, NRHS, B, LDB, BSAV, 00449 $ LDB ) 00450 * 00451 IF( NOFACT .AND. ITRAN.EQ.1 ) THEN 00452 * 00453 * --- Test DGBSV --- 00454 * 00455 * Compute the LU factorization of the matrix 00456 * and solve the system. 00457 * 00458 CALL DLACPY( 'Full', KL+KU+1, N, A, LDA, 00459 $ AFB( KL+1 ), LDAFB ) 00460 CALL DLACPY( 'Full', N, NRHS, B, LDB, X, 00461 $ LDB ) 00462 * 00463 SRNAMT = 'DGBSV ' 00464 CALL DGBSV( N, KL, KU, NRHS, AFB, LDAFB, 00465 $ IWORK, X, LDB, INFO ) 00466 * 00467 * Check error code from DGBSV . 00468 * 00469 IF( INFO.NE.IZERO ) 00470 $ CALL ALAERH( PATH, 'DGBSV ', 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 DGBT01( 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 DLACPY( 'Full', N, NRHS, B, LDB, 00488 $ WORK, LDB ) 00489 CALL DGBT02( '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 DGET04( 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 )'DGBSV ', 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 DGBSVX --- 00517 * 00518 IF( .NOT.PREFAC ) 00519 $ CALL DLASET( 'Full', 2*KL+KU+1, N, ZERO, 00520 $ ZERO, AFB, LDAFB ) 00521 CALL DLASET( '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 DLAQGB( 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 DGBSVX. 00535 * 00536 SRNAMT = 'DGBSVX' 00537 CALL DGBSVX( 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 DGBSVX. 00544 * 00545 IF( INFO.NE.IZERO ) 00546 $ CALL ALAERH( PATH, 'DGBSVX', INFO, IZERO, 00547 $ FACT // TRANS, N, N, KL, KU, 00548 $ NRHS, IMAT, NFAIL, NERRS, 00549 $ NOUT ) 00550 * 00551 * Compare WORK(1) from DGBSVX 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 = DLANTB( '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 = DLANTB( 'M', 'U', 'N', N, KL+KU, 00574 $ AFB, LDAFB, WORK ) 00575 IF( RPVGRW.EQ.ZERO ) THEN 00576 RPVGRW = ONE 00577 ELSE 00578 RPVGRW = DLANGB( '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 $ DLAMCH( 'E' ) 00585 * 00586 IF( .NOT.PREFAC ) THEN 00587 * 00588 * Reconstruct matrix from factors and 00589 * compute residual. 00590 * 00591 CALL DGBT01( 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 DLACPY( 'Full', N, NRHS, BSAV, LDB, 00605 $ WORK, LDB ) 00606 CALL DGBT02( 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 DGET04( 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 DGET04( 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 DGBT05( 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 DGBSVX with the computed 00639 * value in RCONDC. 00640 * 00641 RESULT( 6 ) = DGET06( 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 $ 'DGBSVX', FACT, TRANS, N, KL, 00654 $ KU, EQUED, IMAT, K, 00655 $ RESULT( K ) 00656 ELSE 00657 WRITE( NOUT, FMT = 9996 ) 00658 $ 'DGBSVX', 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 )'DGBSVX', 00672 $ FACT, TRANS, N, KL, KU, EQUED, 00673 $ IMAT, 1, RESULT( 1 ) 00674 ELSE 00675 WRITE( NOUT, FMT = 9996 )'DGBSVX', 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 )'DGBSVX', 00687 $ FACT, TRANS, N, KL, KU, EQUED, 00688 $ IMAT, 6, RESULT( 6 ) 00689 ELSE 00690 WRITE( NOUT, FMT = 9996 )'DGBSVX', 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 )'DGBSVX', 00702 $ FACT, TRANS, N, KL, KU, EQUED, 00703 $ IMAT, 7, RESULT( 7 ) 00704 ELSE 00705 WRITE( NOUT, FMT = 9996 )'DGBSVX', 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 DGBSVXX --- 00716 * 00717 * Restore the matrices A and B. 00718 * 00719 CALL DLACPY( 'Full', KL+KU+1, N, ASAV, LDA, A, 00720 $ LDA ) 00721 CALL DLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB ) 00722 00723 IF( .NOT.PREFAC ) 00724 $ CALL DLASET( 'Full', 2*KL+KU+1, N, ZERO, ZERO, 00725 $ AFB, LDAFB ) 00726 CALL DLASET( '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 DLAQGB( N, N, KL, KU, A, LDA, S, S( N+1 ), 00733 $ ROWCND, COLCND, AMAX, EQUED ) 00734 END IF 00735 * 00736 * Solve the system and compute the condition number 00737 * and error bounds using DGBSVXX. 00738 * 00739 SRNAMT = 'DGBSVXX' 00740 N_ERR_BNDS = 3 00741 CALL DGBSVXX( 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 DGBSVXX. 00748 * 00749 IF( INFO.EQ.N+1 ) GOTO 90 00750 IF( INFO.NE.IZERO ) THEN 00751 CALL ALAERH( PATH, 'DGBSVXX', 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 DGBSVXX with the computed 00758 * reciprocal pivot growth factor RPVGRW 00759 * 00760 00761 IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN 00762 RPVGRW = DLA_GBRPVGRW(N, KL, KU, INFO, A, LDA, 00763 $ AFB, LDAFB) 00764 ELSE 00765 RPVGRW = DLA_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 $ DLAMCH( 'E' ) 00772 * 00773 IF( .NOT.PREFAC ) THEN 00774 * 00775 * Reconstruct matrix from factors and compute 00776 * residual. 00777 * 00778 CALL DGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB, 00779 $ IWORK, WORK, RESULT( 1 ) ) 00780 K1 = 1 00781 ELSE 00782 K1 = 2 00783 END IF 00784 * 00785 IF( INFO.EQ.0 ) THEN 00786 TRFCON = .FALSE. 00787 * 00788 * Compute residual of the computed solution. 00789 * 00790 CALL DLACPY( 'Full', N, NRHS, BSAV, LDB, WORK, 00791 $ LDB ) 00792 CALL DGBT02( TRANS, N, N, KL, KU, NRHS, ASAV, 00793 $ LDA, X, LDB, WORK, LDB, 00794 $ WORK, RESULT( 2 ) ) 00795 * 00796 * Check solution from generated exact solution. 00797 * 00798 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, 00799 $ 'N' ) ) ) THEN 00800 CALL DGET04( N, NRHS, X, LDB, XACT, LDB, 00801 $ RCONDC, RESULT( 3 ) ) 00802 ELSE 00803 IF( ITRAN.EQ.1 ) THEN 00804 ROLDC = ROLDO 00805 ELSE 00806 ROLDC = ROLDI 00807 END IF 00808 CALL DGET04( N, NRHS, X, LDB, XACT, LDB, 00809 $ ROLDC, RESULT( 3 ) ) 00810 END IF 00811 ELSE 00812 TRFCON = .TRUE. 00813 END IF 00814 * 00815 * Compare RCOND from DGBSVXX with the computed value 00816 * in RCONDC. 00817 * 00818 RESULT( 6 ) = DGET06( RCOND, RCONDC ) 00819 * 00820 * Print information about the tests that did not pass 00821 * the threshold. 00822 * 00823 IF( .NOT.TRFCON ) THEN 00824 DO 45 K = K1, NTESTS 00825 IF( RESULT( K ).GE.THRESH ) THEN 00826 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00827 $ CALL ALADHD( NOUT, PATH ) 00828 IF( PREFAC ) THEN 00829 WRITE( NOUT, FMT = 9995 )'DGBSVXX', 00830 $ FACT, TRANS, N, KL, KU, EQUED, 00831 $ IMAT, K, RESULT( K ) 00832 ELSE 00833 WRITE( NOUT, FMT = 9996 )'DGBSVXX', 00834 $ FACT, TRANS, N, KL, KU, IMAT, K, 00835 $ RESULT( K ) 00836 END IF 00837 NFAIL = NFAIL + 1 00838 END IF 00839 45 CONTINUE 00840 NRUN = NRUN + 7 - K1 00841 ELSE 00842 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) 00843 $ THEN 00844 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00845 $ CALL ALADHD( NOUT, PATH ) 00846 IF( PREFAC ) THEN 00847 WRITE( NOUT, FMT = 9995 )'DGBSVXX', FACT, 00848 $ TRANS, N, KL, KU, EQUED, IMAT, 1, 00849 $ RESULT( 1 ) 00850 ELSE 00851 WRITE( NOUT, FMT = 9996 )'DGBSVXX', FACT, 00852 $ TRANS, N, KL, KU, IMAT, 1, 00853 $ RESULT( 1 ) 00854 END IF 00855 NFAIL = NFAIL + 1 00856 NRUN = NRUN + 1 00857 END IF 00858 IF( RESULT( 6 ).GE.THRESH ) THEN 00859 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00860 $ CALL ALADHD( NOUT, PATH ) 00861 IF( PREFAC ) THEN 00862 WRITE( NOUT, FMT = 9995 )'DGBSVXX', FACT, 00863 $ TRANS, N, KL, KU, EQUED, IMAT, 6, 00864 $ RESULT( 6 ) 00865 ELSE 00866 WRITE( NOUT, FMT = 9996 )'DGBSVXX', FACT, 00867 $ TRANS, N, KL, KU, IMAT, 6, 00868 $ RESULT( 6 ) 00869 END IF 00870 NFAIL = NFAIL + 1 00871 NRUN = NRUN + 1 00872 END IF 00873 IF( RESULT( 7 ).GE.THRESH ) THEN 00874 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00875 $ CALL ALADHD( NOUT, PATH ) 00876 IF( PREFAC ) THEN 00877 WRITE( NOUT, FMT = 9995 )'DGBSVXX', FACT, 00878 $ TRANS, N, KL, KU, EQUED, IMAT, 7, 00879 $ RESULT( 7 ) 00880 ELSE 00881 WRITE( NOUT, FMT = 9996 )'DGBSVXX', FACT, 00882 $ TRANS, N, KL, KU, IMAT, 7, 00883 $ RESULT( 7 ) 00884 END IF 00885 NFAIL = NFAIL + 1 00886 NRUN = NRUN + 1 00887 END IF 00888 * 00889 END IF 00890 90 CONTINUE 00891 100 CONTINUE 00892 110 CONTINUE 00893 120 CONTINUE 00894 130 CONTINUE 00895 140 CONTINUE 00896 150 CONTINUE 00897 * 00898 * Print a summary of the results. 00899 * 00900 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00901 00902 * Test Error Bounds from DGBSVXX 00903 00904 CALL DEBCHVXX(THRESH, PATH) 00905 00906 9999 FORMAT( ' *** In DDRVGB, LA=', I5, ' is too small for N=', I5, 00907 $ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ', 00908 $ I5 ) 00909 9998 FORMAT( ' *** In DDRVGB, LAFB=', I5, ' is too small for N=', I5, 00910 $ ', KU=', I5, ', KL=', I5, / 00911 $ ' ==> Increase LAFB to at least ', I5 ) 00912 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ', 00913 $ I1, ', test(', I1, ')=', G12.5 ) 00914 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', 00915 $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 ) 00916 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', 00917 $ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1, 00918 $ ')=', G12.5 ) 00919 * 00920 RETURN 00921 * 00922 * End of DDRVGB 00923 * 00924 END
1.7.3 
