|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE DDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, 00002 $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, 00003 $ RWORK, IWORK, NOUT ) 00004 * 00005 * -- LAPACK test routine (version 3.2.1) -- 00006 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00007 * April 2009 00008 * 00009 * .. Scalar Arguments .. 00010 LOGICAL TSTERR 00011 INTEGER NMAX, NN, NOUT, NRHS 00012 DOUBLE PRECISION THRESH 00013 * .. 00014 * .. Array Arguments .. 00015 LOGICAL DOTYPE( * ) 00016 INTEGER IWORK( * ), NVAL( * ) 00017 DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ), 00018 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), 00019 $ X( * ), XACT( * ) 00020 * .. 00021 * 00022 * Purpose 00023 * ======= 00024 * 00025 * DDRVGE tests the driver routines DGESV, -SVX, and -SVXX. 00026 * 00027 * Note that this file is used only when the XBLAS are available, 00028 * otherwise ddrvge.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 * NMAX (input) INTEGER 00057 * The maximum value permitted for N, used in dimensioning the 00058 * work arrays. 00059 * 00060 * A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) 00061 * 00062 * AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) 00063 * 00064 * ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) 00065 * 00066 * B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) 00067 * 00068 * BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) 00069 * 00070 * X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) 00071 * 00072 * XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) 00073 * 00074 * S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) 00075 * 00076 * WORK (workspace) DOUBLE PRECISION array, dimension 00077 * (NMAX*max(3,NRHS)) 00078 * 00079 * RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX) 00080 * 00081 * IWORK (workspace) INTEGER array, dimension (2*NMAX) 00082 * 00083 * NOUT (input) INTEGER 00084 * The unit number for output. 00085 * 00086 * ===================================================================== 00087 * 00088 * .. Parameters .. 00089 DOUBLE PRECISION ONE, ZERO 00090 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 00091 INTEGER NTYPES 00092 PARAMETER ( NTYPES = 11 ) 00093 INTEGER NTESTS 00094 PARAMETER ( NTESTS = 7 ) 00095 INTEGER NTRAN 00096 PARAMETER ( NTRAN = 3 ) 00097 * .. 00098 * .. Local Scalars .. 00099 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT 00100 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE 00101 CHARACTER*3 PATH 00102 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN, 00103 $ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB, 00104 $ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT, 00105 $ N_ERR_BNDS 00106 DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM, 00107 $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC, 00108 $ ROLDI, ROLDO, ROWCND, RPVGRW, RPVGRW_SVXX 00109 * .. 00110 * .. Local Arrays .. 00111 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) 00112 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00113 DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ), 00114 $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) 00115 * .. 00116 * .. External Functions .. 00117 LOGICAL LSAME 00118 DOUBLE PRECISION DGET06, DLAMCH, DLANGE, DLANTR, DLA_RPVGRW 00119 EXTERNAL LSAME, DGET06, DLAMCH, DLANGE, DLANTR, 00120 $ DLA_RPVGRW 00121 * .. 00122 * .. External Subroutines .. 00123 EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGEEQU, DGESV, 00124 $ DGESVX, DGET01, DGET02, DGET04, DGET07, DGETRF, 00125 $ DGETRI, DLACPY, DLAQGE, DLARHS, DLASET, DLATB4, 00126 $ DLATMS, XLAENV, DGESVXX 00127 * .. 00128 * .. Intrinsic Functions .. 00129 INTRINSIC ABS, MAX 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 ) = 'GE' 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 90 IN = 1, NN 00175 N = NVAL( IN ) 00176 LDA = MAX( N, 1 ) 00177 XTYPE = 'N' 00178 NIMAT = NTYPES 00179 IF( N.LE.0 ) 00180 $ NIMAT = 1 00181 * 00182 DO 80 IMAT = 1, NIMAT 00183 * 00184 * Do the tests only if DOTYPE( IMAT ) is true. 00185 * 00186 IF( .NOT.DOTYPE( IMAT ) ) 00187 $ GO TO 80 00188 * 00189 * Skip types 5, 6, or 7 if the matrix size is too small. 00190 * 00191 ZEROT = IMAT.GE.5 .AND. IMAT.LE.7 00192 IF( ZEROT .AND. N.LT.IMAT-4 ) 00193 $ GO TO 80 00194 * 00195 * Set up parameters with DLATB4 and generate a test matrix 00196 * with DLATMS. 00197 * 00198 CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00199 $ CNDNUM, DIST ) 00200 RCONDC = ONE / CNDNUM 00201 * 00202 SRNAMT = 'DLATMS' 00203 CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, CNDNUM, 00204 $ ANORM, KL, KU, 'No packing', A, LDA, WORK, 00205 $ INFO ) 00206 * 00207 * Check error code from DLATMS. 00208 * 00209 IF( INFO.NE.0 ) THEN 00210 CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', N, N, -1, -1, 00211 $ -1, IMAT, NFAIL, NERRS, NOUT ) 00212 GO TO 80 00213 END IF 00214 * 00215 * For types 5-7, zero one or more columns of the matrix to 00216 * test that INFO is returned correctly. 00217 * 00218 IF( ZEROT ) THEN 00219 IF( IMAT.EQ.5 ) THEN 00220 IZERO = 1 00221 ELSE IF( IMAT.EQ.6 ) THEN 00222 IZERO = N 00223 ELSE 00224 IZERO = N / 2 + 1 00225 END IF 00226 IOFF = ( IZERO-1 )*LDA 00227 IF( IMAT.LT.7 ) THEN 00228 DO 20 I = 1, N 00229 A( IOFF+I ) = ZERO 00230 20 CONTINUE 00231 ELSE 00232 CALL DLASET( 'Full', N, N-IZERO+1, ZERO, ZERO, 00233 $ A( IOFF+1 ), LDA ) 00234 END IF 00235 ELSE 00236 IZERO = 0 00237 END IF 00238 * 00239 * Save a copy of the matrix A in ASAV. 00240 * 00241 CALL DLACPY( 'Full', N, N, A, LDA, ASAV, LDA ) 00242 * 00243 DO 70 IEQUED = 1, 4 00244 EQUED = EQUEDS( IEQUED ) 00245 IF( IEQUED.EQ.1 ) THEN 00246 NFACT = 3 00247 ELSE 00248 NFACT = 1 00249 END IF 00250 * 00251 DO 60 IFACT = 1, NFACT 00252 FACT = FACTS( IFACT ) 00253 PREFAC = LSAME( FACT, 'F' ) 00254 NOFACT = LSAME( FACT, 'N' ) 00255 EQUIL = LSAME( FACT, 'E' ) 00256 * 00257 IF( ZEROT ) THEN 00258 IF( PREFAC ) 00259 $ GO TO 60 00260 RCONDO = ZERO 00261 RCONDI = ZERO 00262 * 00263 ELSE IF( .NOT.NOFACT ) THEN 00264 * 00265 * Compute the condition number for comparison with 00266 * the value returned by DGESVX (FACT = 'N' reuses 00267 * the condition number from the previous iteration 00268 * with FACT = 'F'). 00269 * 00270 CALL DLACPY( 'Full', N, N, ASAV, LDA, AFAC, LDA ) 00271 IF( EQUIL .OR. IEQUED.GT.1 ) THEN 00272 * 00273 * Compute row and column scale factors to 00274 * equilibrate the matrix A. 00275 * 00276 CALL DGEEQU( N, N, AFAC, LDA, S, S( N+1 ), 00277 $ ROWCND, COLCND, AMAX, INFO ) 00278 IF( INFO.EQ.0 .AND. N.GT.0 ) THEN 00279 IF( LSAME( EQUED, 'R' ) ) THEN 00280 ROWCND = ZERO 00281 COLCND = ONE 00282 ELSE IF( LSAME( EQUED, 'C' ) ) THEN 00283 ROWCND = ONE 00284 COLCND = ZERO 00285 ELSE IF( LSAME( EQUED, 'B' ) ) THEN 00286 ROWCND = ZERO 00287 COLCND = ZERO 00288 END IF 00289 * 00290 * Equilibrate the matrix. 00291 * 00292 CALL DLAQGE( N, N, AFAC, LDA, S, S( N+1 ), 00293 $ ROWCND, COLCND, AMAX, EQUED ) 00294 END IF 00295 END IF 00296 * 00297 * Save the condition number of the non-equilibrated 00298 * system for use in DGET04. 00299 * 00300 IF( EQUIL ) THEN 00301 ROLDO = RCONDO 00302 ROLDI = RCONDI 00303 END IF 00304 * 00305 * Compute the 1-norm and infinity-norm of A. 00306 * 00307 ANORMO = DLANGE( '1', N, N, AFAC, LDA, RWORK ) 00308 ANORMI = DLANGE( 'I', N, N, AFAC, LDA, RWORK ) 00309 * 00310 * Factor the matrix A. 00311 * 00312 CALL DGETRF( N, N, AFAC, LDA, IWORK, INFO ) 00313 * 00314 * Form the inverse of A. 00315 * 00316 CALL DLACPY( 'Full', N, N, AFAC, LDA, A, LDA ) 00317 LWORK = NMAX*MAX( 3, NRHS ) 00318 CALL DGETRI( N, A, LDA, IWORK, WORK, LWORK, INFO ) 00319 * 00320 * Compute the 1-norm condition number of A. 00321 * 00322 AINVNM = DLANGE( '1', N, N, A, LDA, RWORK ) 00323 IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00324 RCONDO = ONE 00325 ELSE 00326 RCONDO = ( ONE / ANORMO ) / AINVNM 00327 END IF 00328 * 00329 * Compute the infinity-norm condition number of A. 00330 * 00331 AINVNM = DLANGE( 'I', N, N, A, LDA, RWORK ) 00332 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00333 RCONDI = ONE 00334 ELSE 00335 RCONDI = ( ONE / ANORMI ) / AINVNM 00336 END IF 00337 END IF 00338 * 00339 DO 50 ITRAN = 1, NTRAN 00340 * 00341 * Do for each value of TRANS. 00342 * 00343 TRANS = TRANSS( ITRAN ) 00344 IF( ITRAN.EQ.1 ) THEN 00345 RCONDC = RCONDO 00346 ELSE 00347 RCONDC = RCONDI 00348 END IF 00349 * 00350 * Restore the matrix A. 00351 * 00352 CALL DLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) 00353 * 00354 * Form an exact solution and set the right hand side. 00355 * 00356 SRNAMT = 'DLARHS' 00357 CALL DLARHS( PATH, XTYPE, 'Full', TRANS, N, N, KL, 00358 $ KU, NRHS, A, LDA, XACT, LDA, B, LDA, 00359 $ ISEED, INFO ) 00360 XTYPE = 'C' 00361 CALL DLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) 00362 * 00363 IF( NOFACT .AND. ITRAN.EQ.1 ) THEN 00364 * 00365 * --- Test DGESV --- 00366 * 00367 * Compute the LU factorization of the matrix and 00368 * solve the system. 00369 * 00370 CALL DLACPY( 'Full', N, N, A, LDA, AFAC, LDA ) 00371 CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 00372 * 00373 SRNAMT = 'DGESV ' 00374 CALL DGESV( N, NRHS, AFAC, LDA, IWORK, X, LDA, 00375 $ INFO ) 00376 * 00377 * Check error code from DGESV . 00378 * 00379 IF( INFO.NE.IZERO ) 00380 $ CALL ALAERH( PATH, 'DGESV ', INFO, IZERO, 00381 $ ' ', N, N, -1, -1, NRHS, IMAT, 00382 $ NFAIL, NERRS, NOUT ) 00383 * 00384 * Reconstruct matrix from factors and compute 00385 * residual. 00386 * 00387 CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK, 00388 $ RWORK, RESULT( 1 ) ) 00389 NT = 1 00390 IF( IZERO.EQ.0 ) THEN 00391 * 00392 * Compute residual of the computed solution. 00393 * 00394 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, 00395 $ LDA ) 00396 CALL DGET02( 'No transpose', N, N, NRHS, A, 00397 $ LDA, X, LDA, WORK, LDA, RWORK, 00398 $ RESULT( 2 ) ) 00399 * 00400 * Check solution from generated exact solution. 00401 * 00402 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, 00403 $ RCONDC, RESULT( 3 ) ) 00404 NT = 3 00405 END IF 00406 * 00407 * Print information about the tests that did not 00408 * pass the threshold. 00409 * 00410 DO 30 K = 1, NT 00411 IF( RESULT( K ).GE.THRESH ) THEN 00412 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00413 $ CALL ALADHD( NOUT, PATH ) 00414 WRITE( NOUT, FMT = 9999 )'DGESV ', N, 00415 $ IMAT, K, RESULT( K ) 00416 NFAIL = NFAIL + 1 00417 END IF 00418 30 CONTINUE 00419 NRUN = NRUN + NT 00420 END IF 00421 * 00422 * --- Test DGESVX --- 00423 * 00424 IF( .NOT.PREFAC ) 00425 $ CALL DLASET( 'Full', N, N, ZERO, ZERO, AFAC, 00426 $ LDA ) 00427 CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) 00428 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 00429 * 00430 * Equilibrate the matrix if FACT = 'F' and 00431 * EQUED = 'R', 'C', or 'B'. 00432 * 00433 CALL DLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, 00434 $ COLCND, AMAX, EQUED ) 00435 END IF 00436 * 00437 * Solve the system and compute the condition number 00438 * and error bounds using DGESVX. 00439 * 00440 SRNAMT = 'DGESVX' 00441 CALL DGESVX( FACT, TRANS, N, NRHS, A, LDA, AFAC, 00442 $ LDA, IWORK, EQUED, S, S( N+1 ), B, 00443 $ LDA, X, LDA, RCOND, RWORK, 00444 $ RWORK( NRHS+1 ), WORK, IWORK( N+1 ), 00445 $ INFO ) 00446 * 00447 * Check the error code from DGESVX. 00448 * 00449 IF( INFO.NE.IZERO ) 00450 $ CALL ALAERH( PATH, 'DGESVX', INFO, IZERO, 00451 $ FACT // TRANS, N, N, -1, -1, NRHS, 00452 $ IMAT, NFAIL, NERRS, NOUT ) 00453 * 00454 * Compare WORK(1) from DGESVX with the computed 00455 * reciprocal pivot growth factor RPVGRW 00456 * 00457 IF( INFO.NE.0 ) THEN 00458 RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, 00459 $ AFAC, LDA, WORK ) 00460 IF( RPVGRW.EQ.ZERO ) THEN 00461 RPVGRW = ONE 00462 ELSE 00463 RPVGRW = DLANGE( 'M', N, INFO, A, LDA, 00464 $ WORK ) / RPVGRW 00465 END IF 00466 ELSE 00467 RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AFAC, LDA, 00468 $ WORK ) 00469 IF( RPVGRW.EQ.ZERO ) THEN 00470 RPVGRW = ONE 00471 ELSE 00472 RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) / 00473 $ RPVGRW 00474 END IF 00475 END IF 00476 RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) / 00477 $ MAX( WORK( 1 ), RPVGRW ) / 00478 $ DLAMCH( 'E' ) 00479 * 00480 IF( .NOT.PREFAC ) THEN 00481 * 00482 * Reconstruct matrix from factors and compute 00483 * residual. 00484 * 00485 CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK, 00486 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) 00487 K1 = 1 00488 ELSE 00489 K1 = 2 00490 END IF 00491 * 00492 IF( INFO.EQ.0 ) THEN 00493 TRFCON = .FALSE. 00494 * 00495 * Compute residual of the computed solution. 00496 * 00497 CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, 00498 $ LDA ) 00499 CALL DGET02( TRANS, N, N, NRHS, ASAV, LDA, X, 00500 $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), 00501 $ RESULT( 2 ) ) 00502 * 00503 * Check solution from generated exact solution. 00504 * 00505 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, 00506 $ 'N' ) ) ) THEN 00507 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, 00508 $ RCONDC, RESULT( 3 ) ) 00509 ELSE 00510 IF( ITRAN.EQ.1 ) THEN 00511 ROLDC = ROLDO 00512 ELSE 00513 ROLDC = ROLDI 00514 END IF 00515 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, 00516 $ ROLDC, RESULT( 3 ) ) 00517 END IF 00518 * 00519 * Check the error bounds from iterative 00520 * refinement. 00521 * 00522 CALL DGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA, 00523 $ X, LDA, XACT, LDA, RWORK, .TRUE., 00524 $ RWORK( NRHS+1 ), RESULT( 4 ) ) 00525 ELSE 00526 TRFCON = .TRUE. 00527 END IF 00528 * 00529 * Compare RCOND from DGESVX with the computed value 00530 * in RCONDC. 00531 * 00532 RESULT( 6 ) = DGET06( RCOND, RCONDC ) 00533 * 00534 * Print information about the tests that did not pass 00535 * the threshold. 00536 * 00537 IF( .NOT.TRFCON ) THEN 00538 DO 40 K = K1, NTESTS 00539 IF( RESULT( K ).GE.THRESH ) THEN 00540 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00541 $ CALL ALADHD( NOUT, PATH ) 00542 IF( PREFAC ) THEN 00543 WRITE( NOUT, FMT = 9997 )'DGESVX', 00544 $ FACT, TRANS, N, EQUED, IMAT, K, 00545 $ RESULT( K ) 00546 ELSE 00547 WRITE( NOUT, FMT = 9998 )'DGESVX', 00548 $ FACT, TRANS, N, IMAT, K, RESULT( K ) 00549 END IF 00550 NFAIL = NFAIL + 1 00551 END IF 00552 40 CONTINUE 00553 NRUN = NRUN + 7 - K1 00554 ELSE 00555 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) 00556 $ THEN 00557 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00558 $ CALL ALADHD( NOUT, PATH ) 00559 IF( PREFAC ) THEN 00560 WRITE( NOUT, FMT = 9997 )'DGESVX', FACT, 00561 $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) 00562 ELSE 00563 WRITE( NOUT, FMT = 9998 )'DGESVX', FACT, 00564 $ TRANS, N, IMAT, 1, RESULT( 1 ) 00565 END IF 00566 NFAIL = NFAIL + 1 00567 NRUN = NRUN + 1 00568 END IF 00569 IF( RESULT( 6 ).GE.THRESH ) THEN 00570 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00571 $ CALL ALADHD( NOUT, PATH ) 00572 IF( PREFAC ) THEN 00573 WRITE( NOUT, FMT = 9997 )'DGESVX', FACT, 00574 $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) 00575 ELSE 00576 WRITE( NOUT, FMT = 9998 )'DGESVX', FACT, 00577 $ TRANS, N, IMAT, 6, RESULT( 6 ) 00578 END IF 00579 NFAIL = NFAIL + 1 00580 NRUN = NRUN + 1 00581 END IF 00582 IF( RESULT( 7 ).GE.THRESH ) THEN 00583 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00584 $ CALL ALADHD( NOUT, PATH ) 00585 IF( PREFAC ) THEN 00586 WRITE( NOUT, FMT = 9997 )'DGESVX', FACT, 00587 $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) 00588 ELSE 00589 WRITE( NOUT, FMT = 9998 )'DGESVX', FACT, 00590 $ TRANS, N, IMAT, 7, RESULT( 7 ) 00591 END IF 00592 NFAIL = NFAIL + 1 00593 NRUN = NRUN + 1 00594 END IF 00595 * 00596 END IF 00597 * 00598 * --- Test DGESVXX --- 00599 * 00600 * Restore the matrices A and B. 00601 * 00602 CALL DLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) 00603 CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA ) 00604 00605 IF( .NOT.PREFAC ) 00606 $ CALL DLASET( 'Full', N, N, ZERO, ZERO, AFAC, 00607 $ LDA ) 00608 CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) 00609 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 00610 * 00611 * Equilibrate the matrix if FACT = 'F' and 00612 * EQUED = 'R', 'C', or 'B'. 00613 * 00614 CALL DLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, 00615 $ COLCND, AMAX, EQUED ) 00616 END IF 00617 * 00618 * Solve the system and compute the condition number 00619 * and error bounds using DGESVXX. 00620 * 00621 SRNAMT = 'DGESVXX' 00622 N_ERR_BNDS = 3 00623 CALL DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AFAC, 00624 $ LDA, IWORK, EQUED, S, S( N+1 ), B, LDA, X, 00625 $ LDA, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS, 00626 $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK, 00627 $ IWORK( N+1 ), INFO ) 00628 * 00629 * Check the error code from DGESVXX. 00630 * 00631 IF( INFO.EQ.N+1 ) GOTO 50 00632 IF( INFO.NE.IZERO ) THEN 00633 CALL ALAERH( PATH, 'DGESVXX', INFO, IZERO, 00634 $ FACT // TRANS, N, N, -1, -1, NRHS, 00635 $ IMAT, NFAIL, NERRS, NOUT ) 00636 GOTO 50 00637 END IF 00638 * 00639 * Compare rpvgrw_svxx from DGESVXX with the computed 00640 * reciprocal pivot growth factor RPVGRW 00641 * 00642 00643 IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN 00644 RPVGRW = DLA_RPVGRW(N, INFO, A, LDA, AFAC, LDA) 00645 ELSE 00646 RPVGRW = DLA_RPVGRW(N, N, A, LDA, AFAC, LDA) 00647 ENDIF 00648 00649 RESULT( 7 ) = ABS( RPVGRW-RPVGRW_SVXX ) / 00650 $ MAX( RPVGRW_SVXX, RPVGRW ) / 00651 $ DLAMCH( 'E' ) 00652 * 00653 IF( .NOT.PREFAC ) THEN 00654 * 00655 * Reconstruct matrix from factors and compute 00656 * residual. 00657 * 00658 CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK, 00659 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) 00660 K1 = 1 00661 ELSE 00662 K1 = 2 00663 END IF 00664 * 00665 IF( INFO.EQ.0 ) THEN 00666 TRFCON = .FALSE. 00667 * 00668 * Compute residual of the computed solution. 00669 * 00670 CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, 00671 $ LDA ) 00672 CALL DGET02( TRANS, N, N, NRHS, ASAV, LDA, X, 00673 $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), 00674 $ RESULT( 2 ) ) 00675 * 00676 * Check solution from generated exact solution. 00677 * 00678 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, 00679 $ 'N' ) ) ) THEN 00680 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, 00681 $ RCONDC, RESULT( 3 ) ) 00682 ELSE 00683 IF( ITRAN.EQ.1 ) THEN 00684 ROLDC = ROLDO 00685 ELSE 00686 ROLDC = ROLDI 00687 END IF 00688 CALL DGET04( N, NRHS, X, LDA, XACT, LDA, 00689 $ ROLDC, RESULT( 3 ) ) 00690 END IF 00691 ELSE 00692 TRFCON = .TRUE. 00693 END IF 00694 * 00695 * Compare RCOND from DGESVXX with the computed value 00696 * in RCONDC. 00697 * 00698 RESULT( 6 ) = DGET06( RCOND, RCONDC ) 00699 * 00700 * Print information about the tests that did not pass 00701 * the threshold. 00702 * 00703 IF( .NOT.TRFCON ) THEN 00704 DO 45 K = K1, NTESTS 00705 IF( RESULT( K ).GE.THRESH ) THEN 00706 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00707 $ CALL ALADHD( NOUT, PATH ) 00708 IF( PREFAC ) THEN 00709 WRITE( NOUT, FMT = 9997 )'DGESVXX', 00710 $ FACT, TRANS, N, EQUED, IMAT, K, 00711 $ RESULT( K ) 00712 ELSE 00713 WRITE( NOUT, FMT = 9998 )'DGESVXX', 00714 $ FACT, TRANS, N, IMAT, K, RESULT( K ) 00715 END IF 00716 NFAIL = NFAIL + 1 00717 END IF 00718 45 CONTINUE 00719 NRUN = NRUN + 7 - K1 00720 ELSE 00721 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) 00722 $ THEN 00723 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00724 $ CALL ALADHD( NOUT, PATH ) 00725 IF( PREFAC ) THEN 00726 WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT, 00727 $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) 00728 ELSE 00729 WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT, 00730 $ TRANS, N, IMAT, 1, RESULT( 1 ) 00731 END IF 00732 NFAIL = NFAIL + 1 00733 NRUN = NRUN + 1 00734 END IF 00735 IF( RESULT( 6 ).GE.THRESH ) THEN 00736 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00737 $ CALL ALADHD( NOUT, PATH ) 00738 IF( PREFAC ) THEN 00739 WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT, 00740 $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) 00741 ELSE 00742 WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT, 00743 $ TRANS, N, IMAT, 6, RESULT( 6 ) 00744 END IF 00745 NFAIL = NFAIL + 1 00746 NRUN = NRUN + 1 00747 END IF 00748 IF( RESULT( 7 ).GE.THRESH ) THEN 00749 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00750 $ CALL ALADHD( NOUT, PATH ) 00751 IF( PREFAC ) THEN 00752 WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT, 00753 $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) 00754 ELSE 00755 WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT, 00756 $ TRANS, N, IMAT, 7, RESULT( 7 ) 00757 END IF 00758 NFAIL = NFAIL + 1 00759 NRUN = NRUN + 1 00760 END IF 00761 * 00762 END IF 00763 * 00764 50 CONTINUE 00765 60 CONTINUE 00766 70 CONTINUE 00767 80 CONTINUE 00768 90 CONTINUE 00769 * 00770 * Print a summary of the results. 00771 * 00772 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00773 * 00774 00775 * Test Error Bounds from DGESVXX 00776 00777 CALL DEBCHVXX( THRESH, PATH ) 00778 00779 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =', 00780 $ G12.5 ) 00781 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, 00782 $ ', type ', I2, ', test(', I1, ')=', G12.5 ) 00783 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, 00784 $ ', EQUED=''', A1, ''', type ', I2, ', test(', I1, ')=', 00785 $ G12.5 ) 00786 RETURN 00787 * 00788 * End of DDRVGE 00789 * 00790 END
1.7.3 
