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