 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE CDRVGE( 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 REAL THRESH 00013 * .. 00014 * .. Array Arguments .. 00015 LOGICAL DOTYPE( * ) 00016 INTEGER IWORK( * ), NVAL( * ) 00017 REAL RWORK( * ), S( * ) 00018 COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ), 00019 $ BSAV( * ), WORK( * ), X( * ), XACT( * ) 00020 * .. 00021 * 00022 * Purpose 00023 * ======= 00024 * 00025 * CDRVGE tests the driver routines CGESV, -SVX, and -SVXX. 00026 * 00027 * Note that this file is used only when the XBLAS are available, 00028 * otherwise cdrvge.f defines this subroutine. 00029 * 00030 * Arguments 00031 * ========= 00032 * 00033 * DOTYPE (input) LOGICAL array, dimension (NTYPES) 00034 * The matrix types to be used for testing. Matrices of type j 00035 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00036 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00037 * 00038 * NN (input) INTEGER 00039 * The number of values of N contained in the vector NVAL. 00040 * 00041 * NVAL (input) INTEGER array, dimension (NN) 00042 * The values of the matrix column dimension N. 00043 * 00044 * NRHS (input) INTEGER 00045 * The number of right hand side vectors to be generated for 00046 * each linear system. 00047 * 00048 * THRESH (input) REAL 00049 * The threshold value for the test ratios. A result is 00050 * included in the output file if RESULT >= THRESH. To have 00051 * every test ratio printed, use THRESH = 0. 00052 * 00053 * TSTERR (input) LOGICAL 00054 * Flag that indicates whether error exits are to be tested. 00055 * 00056 * NMAX (input) INTEGER 00057 * The maximum value permitted for N, used in dimensioning the 00058 * work arrays. 00059 * 00060 * A (workspace) COMPLEX array, dimension (NMAX*NMAX) 00061 * 00062 * AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) 00063 * 00064 * ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) 00065 * 00066 * B (workspace) COMPLEX array, dimension (NMAX*NRHS) 00067 * 00068 * BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) 00069 * 00070 * X (workspace) COMPLEX array, dimension (NMAX*NRHS) 00071 * 00072 * XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) 00073 * 00074 * S (workspace) REAL array, dimension (2*NMAX) 00075 * 00076 * WORK (workspace) COMPLEX array, dimension 00077 * (NMAX*max(3,NRHS)) 00078 * 00079 * RWORK (workspace) REAL array, dimension (2*NRHS+NMAX) 00080 * 00081 * IWORK (workspace) INTEGER array, dimension (NMAX) 00082 * 00083 * NOUT (input) INTEGER 00084 * The unit number for output. 00085 * 00086 * ===================================================================== 00087 * 00088 * .. Parameters .. 00089 REAL ONE, ZERO 00090 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+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 REAL 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 REAL RDUM( 1 ), RESULT( NTESTS ), BERR( NRHS ), 00114 $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) 00115 * .. 00116 * .. External Functions .. 00117 LOGICAL LSAME 00118 REAL CLANGE, CLANTR, SGET06, SLAMCH, CLA_RPVGRW 00119 EXTERNAL LSAME, CLANGE, CLANTR, SGET06, SLAMCH, 00120 $ CLA_RPVGRW 00121 * .. 00122 * .. External Subroutines .. 00123 EXTERNAL ALADHD, ALAERH, ALASVM, CERRVX, CGEEQU, CGESV, 00124 $ CGESVX, CGET01, CGET02, CGET04, CGET07, CGETRF, 00125 $ CGETRI, CLACPY, CLAQGE, CLARHS, CLASET, CLATB4, 00126 $ CLATMS, XLAENV, CGESVXX 00127 * .. 00128 * .. Intrinsic Functions .. 00129 INTRINSIC ABS, CMPLX, 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 ) = 'Complex 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 CERRVX( 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 CLATB4 and generate a test matrix 00196 * with CLATMS. 00197 * 00198 CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00199 $ CNDNUM, DIST ) 00200 RCONDC = ONE / CNDNUM 00201 * 00202 SRNAMT = 'CLATMS' 00203 CALL CLATMS( 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 CLATMS. 00208 * 00209 IF( INFO.NE.0 ) THEN 00210 CALL ALAERH( PATH, 'CLATMS', 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 CLASET( 'Full', N, N-IZERO+1, CMPLX( ZERO ), 00233 $ CMPLX( ZERO ), 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 CLACPY( '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 CGESVX (FACT = 'N' reuses 00267 * the condition number from the previous iteration 00268 * with FACT = 'F'). 00269 * 00270 CALL CLACPY( '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 CGEEQU( 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 CLAQGE( 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 CGET04. 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 = CLANGE( '1', N, N, AFAC, LDA, RWORK ) 00308 ANORMI = CLANGE( 'I', N, N, AFAC, LDA, RWORK ) 00309 * 00310 * Factor the matrix A. 00311 * 00312 CALL CGETRF( N, N, AFAC, LDA, IWORK, INFO ) 00313 * 00314 * Form the inverse of A. 00315 * 00316 CALL CLACPY( 'Full', N, N, AFAC, LDA, A, LDA ) 00317 LWORK = NMAX*MAX( 3, NRHS ) 00318 CALL CGETRI( N, A, LDA, IWORK, WORK, LWORK, INFO ) 00319 * 00320 * Compute the 1-norm condition number of A. 00321 * 00322 AINVNM = CLANGE( '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 = CLANGE( '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 CLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) 00353 * 00354 * Form an exact solution and set the right hand side. 00355 * 00356 SRNAMT = 'CLARHS' 00357 CALL CLARHS( PATH, XTYPE, 'Full', TRANS, N, N, KL, 00358 $ KU, NRHS, A, LDA, XACT, LDA, B, LDA, 00359 $ ISEED, INFO ) 00360 XTYPE = 'C' 00361 CALL CLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) 00362 * 00363 IF( NOFACT .AND. ITRAN.EQ.1 ) THEN 00364 * 00365 * --- Test CGESV --- 00366 * 00367 * Compute the LU factorization of the matrix and 00368 * solve the system. 00369 * 00370 CALL CLACPY( 'Full', N, N, A, LDA, AFAC, LDA ) 00371 CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 00372 * 00373 SRNAMT = 'CGESV ' 00374 CALL CGESV( N, NRHS, AFAC, LDA, IWORK, X, LDA, 00375 $ INFO ) 00376 * 00377 * Check error code from CGESV . 00378 * 00379 IF( INFO.NE.IZERO ) 00380 $ CALL ALAERH( PATH, 'CGESV ', 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 CGET01( 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 CLACPY( 'Full', N, NRHS, B, LDA, WORK, 00395 $ LDA ) 00396 CALL CGET02( '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 CGET04( 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 )'CGESV ', 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 CGESVX --- 00423 * 00424 IF( .NOT.PREFAC ) 00425 $ CALL CLASET( 'Full', N, N, CMPLX( ZERO ), 00426 $ CMPLX( ZERO ), AFAC, LDA ) 00427 CALL CLASET( 'Full', N, NRHS, CMPLX( ZERO ), 00428 $ CMPLX( ZERO ), X, LDA ) 00429 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 00430 * 00431 * Equilibrate the matrix if FACT = 'F' and 00432 * EQUED = 'R', 'C', or 'B'. 00433 * 00434 CALL CLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, 00435 $ COLCND, AMAX, EQUED ) 00436 END IF 00437 * 00438 * Solve the system and compute the condition number 00439 * and error bounds using CGESVX. 00440 * 00441 SRNAMT = 'CGESVX' 00442 CALL CGESVX( FACT, TRANS, N, NRHS, A, LDA, AFAC, 00443 $ LDA, IWORK, EQUED, S, S( N+1 ), B, 00444 $ LDA, X, LDA, RCOND, RWORK, 00445 $ RWORK( NRHS+1 ), WORK, 00446 $ RWORK( 2*NRHS+1 ), INFO ) 00447 * 00448 * Check the error code from CGESVX. 00449 * 00450 IF( INFO.NE.IZERO ) 00451 $ CALL ALAERH( PATH, 'CGESVX', INFO, IZERO, 00452 $ FACT // TRANS, N, N, -1, -1, NRHS, 00453 $ IMAT, NFAIL, NERRS, NOUT ) 00454 * 00455 * Compare RWORK(2*NRHS+1) from CGESVX with the 00456 * computed reciprocal pivot growth factor RPVGRW 00457 * 00458 IF( INFO.NE.0 ) THEN 00459 RPVGRW = CLANTR( 'M', 'U', 'N', INFO, INFO, 00460 $ AFAC, LDA, RDUM ) 00461 IF( RPVGRW.EQ.ZERO ) THEN 00462 RPVGRW = ONE 00463 ELSE 00464 RPVGRW = CLANGE( 'M', N, INFO, A, LDA, 00465 $ RDUM ) / RPVGRW 00466 END IF 00467 ELSE 00468 RPVGRW = CLANTR( 'M', 'U', 'N', N, N, AFAC, LDA, 00469 $ RDUM ) 00470 IF( RPVGRW.EQ.ZERO ) THEN 00471 RPVGRW = ONE 00472 ELSE 00473 RPVGRW = CLANGE( 'M', N, N, A, LDA, RDUM ) / 00474 $ RPVGRW 00475 END IF 00476 END IF 00477 RESULT( 7 ) = ABS( RPVGRW-RWORK( 2*NRHS+1 ) ) / 00478 $ MAX( RWORK( 2*NRHS+1 ), RPVGRW ) / 00479 $ SLAMCH( 'E' ) 00480 * 00481 IF( .NOT.PREFAC ) THEN 00482 * 00483 * Reconstruct matrix from factors and compute 00484 * residual. 00485 * 00486 CALL CGET01( N, N, A, LDA, AFAC, LDA, IWORK, 00487 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) 00488 K1 = 1 00489 ELSE 00490 K1 = 2 00491 END IF 00492 * 00493 IF( INFO.EQ.0 ) THEN 00494 TRFCON = .FALSE. 00495 * 00496 * Compute residual of the computed solution. 00497 * 00498 CALL CLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, 00499 $ LDA ) 00500 CALL CGET02( TRANS, N, N, NRHS, ASAV, LDA, X, 00501 $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), 00502 $ RESULT( 2 ) ) 00503 * 00504 * Check solution from generated exact solution. 00505 * 00506 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, 00507 $ 'N' ) ) ) THEN 00508 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, 00509 $ RCONDC, RESULT( 3 ) ) 00510 ELSE 00511 IF( ITRAN.EQ.1 ) THEN 00512 ROLDC = ROLDO 00513 ELSE 00514 ROLDC = ROLDI 00515 END IF 00516 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, 00517 $ ROLDC, RESULT( 3 ) ) 00518 END IF 00519 * 00520 * Check the error bounds from iterative 00521 * refinement. 00522 * 00523 CALL CGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA, 00524 $ X, LDA, XACT, LDA, RWORK, .TRUE., 00525 $ RWORK( NRHS+1 ), RESULT( 4 ) ) 00526 ELSE 00527 TRFCON = .TRUE. 00528 END IF 00529 * 00530 * Compare RCOND from CGESVX with the computed value 00531 * in RCONDC. 00532 * 00533 RESULT( 6 ) = SGET06( RCOND, RCONDC ) 00534 * 00535 * Print information about the tests that did not pass 00536 * the threshold. 00537 * 00538 IF( .NOT.TRFCON ) THEN 00539 DO 40 K = K1, NTESTS 00540 IF( RESULT( K ).GE.THRESH ) THEN 00541 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00542 $ CALL ALADHD( NOUT, PATH ) 00543 IF( PREFAC ) THEN 00544 WRITE( NOUT, FMT = 9997 )'CGESVX', 00545 $ FACT, TRANS, N, EQUED, IMAT, K, 00546 $ RESULT( K ) 00547 ELSE 00548 WRITE( NOUT, FMT = 9998 )'CGESVX', 00549 $ FACT, TRANS, N, IMAT, K, RESULT( K ) 00550 END IF 00551 NFAIL = NFAIL + 1 00552 END IF 00553 40 CONTINUE 00554 NRUN = NRUN + 7 - K1 00555 ELSE 00556 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) 00557 $ THEN 00558 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00559 $ CALL ALADHD( NOUT, PATH ) 00560 IF( PREFAC ) THEN 00561 WRITE( NOUT, FMT = 9997 )'CGESVX', FACT, 00562 $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) 00563 ELSE 00564 WRITE( NOUT, FMT = 9998 )'CGESVX', FACT, 00565 $ TRANS, N, IMAT, 1, RESULT( 1 ) 00566 END IF 00567 NFAIL = NFAIL + 1 00568 NRUN = NRUN + 1 00569 END IF 00570 IF( RESULT( 6 ).GE.THRESH ) THEN 00571 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00572 $ CALL ALADHD( NOUT, PATH ) 00573 IF( PREFAC ) THEN 00574 WRITE( NOUT, FMT = 9997 )'CGESVX', FACT, 00575 $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) 00576 ELSE 00577 WRITE( NOUT, FMT = 9998 )'CGESVX', FACT, 00578 $ TRANS, N, IMAT, 6, RESULT( 6 ) 00579 END IF 00580 NFAIL = NFAIL + 1 00581 NRUN = NRUN + 1 00582 END IF 00583 IF( RESULT( 7 ).GE.THRESH ) THEN 00584 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00585 $ CALL ALADHD( NOUT, PATH ) 00586 IF( PREFAC ) THEN 00587 WRITE( NOUT, FMT = 9997 )'CGESVX', FACT, 00588 $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) 00589 ELSE 00590 WRITE( NOUT, FMT = 9998 )'CGESVX', FACT, 00591 $ TRANS, N, IMAT, 7, RESULT( 7 ) 00592 END IF 00593 NFAIL = NFAIL + 1 00594 NRUN = NRUN + 1 00595 END IF 00596 * 00597 END IF 00598 * 00599 * --- Test CGESVXX --- 00600 * 00601 * Restore the matrices A and B. 00602 * 00603 00604 CALL CLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) 00605 CALL CLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA ) 00606 00607 IF( .NOT.PREFAC ) 00608 $ CALL CLASET( 'Full', N, N, ZERO, ZERO, AFAC, 00609 $ LDA ) 00610 CALL CLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) 00611 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 00612 * 00613 * Equilibrate the matrix if FACT = 'F' and 00614 * EQUED = 'R', 'C', or 'B'. 00615 * 00616 CALL CLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, 00617 $ COLCND, AMAX, EQUED ) 00618 END IF 00619 * 00620 * Solve the system and compute the condition number 00621 * and error bounds using CGESVXX. 00622 * 00623 SRNAMT = 'CGESVXX' 00624 N_ERR_BNDS = 3 00625 CALL CGESVXX( FACT, TRANS, N, NRHS, A, LDA, AFAC, 00626 $ LDA, IWORK, EQUED, S, S( N+1 ), B, LDA, X, 00627 $ LDA, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS, 00628 $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK, 00629 $ RWORK, INFO ) 00630 * 00631 * Check the error code from CGESVXX. 00632 * 00633 IF( INFO.EQ.N+1 ) GOTO 50 00634 IF( INFO.NE.IZERO ) THEN 00635 CALL ALAERH( PATH, 'CGESVXX', INFO, IZERO, 00636 $ FACT // TRANS, N, N, -1, -1, NRHS, 00637 $ IMAT, NFAIL, NERRS, NOUT ) 00638 GOTO 50 00639 END IF 00640 * 00641 * Compare rpvgrw_svxx from CGESVXX with the computed 00642 * reciprocal pivot growth factor RPVGRW 00643 * 00644 00645 IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN 00646 RPVGRW = CLA_RPVGRW(N, INFO, A, LDA, AFAC, LDA) 00647 ELSE 00648 RPVGRW = CLA_RPVGRW(N, N, A, LDA, AFAC, LDA) 00649 ENDIF 00650 00651 RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) / 00652 $ MAX( rpvgrw_svxx, RPVGRW ) / 00653 $ SLAMCH( 'E' ) 00654 * 00655 IF( .NOT.PREFAC ) THEN 00656 * 00657 * Reconstruct matrix from factors and compute 00658 * residual. 00659 * 00660 CALL CGET01( N, N, A, LDA, AFAC, LDA, IWORK, 00661 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) 00662 K1 = 1 00663 ELSE 00664 K1 = 2 00665 END IF 00666 * 00667 IF( INFO.EQ.0 ) THEN 00668 TRFCON = .FALSE. 00669 * 00670 * Compute residual of the computed solution. 00671 * 00672 CALL CLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, 00673 $ LDA ) 00674 CALL CGET02( TRANS, N, N, NRHS, ASAV, LDA, X, 00675 $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), 00676 $ RESULT( 2 ) ) 00677 * 00678 * Check solution from generated exact solution. 00679 * 00680 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, 00681 $ 'N' ) ) ) THEN 00682 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, 00683 $ RCONDC, RESULT( 3 ) ) 00684 ELSE 00685 IF( ITRAN.EQ.1 ) THEN 00686 ROLDC = ROLDO 00687 ELSE 00688 ROLDC = ROLDI 00689 END IF 00690 CALL CGET04( N, NRHS, X, LDA, XACT, LDA, 00691 $ ROLDC, RESULT( 3 ) ) 00692 END IF 00693 ELSE 00694 TRFCON = .TRUE. 00695 END IF 00696 * 00697 * Compare RCOND from CGESVXX with the computed value 00698 * in RCONDC. 00699 * 00700 RESULT( 6 ) = SGET06( RCOND, RCONDC ) 00701 * 00702 * Print information about the tests that did not pass 00703 * the threshold. 00704 * 00705 IF( .NOT.TRFCON ) THEN 00706 DO 45 K = K1, NTESTS 00707 IF( RESULT( K ).GE.THRESH ) THEN 00708 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00709 $ CALL ALADHD( NOUT, PATH ) 00710 IF( PREFAC ) THEN 00711 WRITE( NOUT, FMT = 9997 )'CGESVXX', 00712 $ FACT, TRANS, N, EQUED, IMAT, K, 00713 $ RESULT( K ) 00714 ELSE 00715 WRITE( NOUT, FMT = 9998 )'CGESVXX', 00716 $ FACT, TRANS, N, IMAT, K, RESULT( K ) 00717 END IF 00718 NFAIL = NFAIL + 1 00719 END IF 00720 45 CONTINUE 00721 NRUN = NRUN + 7 - K1 00722 ELSE 00723 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) 00724 $ THEN 00725 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00726 $ CALL ALADHD( NOUT, PATH ) 00727 IF( PREFAC ) THEN 00728 WRITE( NOUT, FMT = 9997 )'CGESVXX', FACT, 00729 $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) 00730 ELSE 00731 WRITE( NOUT, FMT = 9998 )'CGESVXX', FACT, 00732 $ TRANS, N, IMAT, 1, RESULT( 1 ) 00733 END IF 00734 NFAIL = NFAIL + 1 00735 NRUN = NRUN + 1 00736 END IF 00737 IF( RESULT( 6 ).GE.THRESH ) THEN 00738 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00739 $ CALL ALADHD( NOUT, PATH ) 00740 IF( PREFAC ) THEN 00741 WRITE( NOUT, FMT = 9997 )'CGESVXX', FACT, 00742 $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) 00743 ELSE 00744 WRITE( NOUT, FMT = 9998 )'CGESVXX', FACT, 00745 $ TRANS, N, IMAT, 6, RESULT( 6 ) 00746 END IF 00747 NFAIL = NFAIL + 1 00748 NRUN = NRUN + 1 00749 END IF 00750 IF( RESULT( 7 ).GE.THRESH ) THEN 00751 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00752 $ CALL ALADHD( NOUT, PATH ) 00753 IF( PREFAC ) THEN 00754 WRITE( NOUT, FMT = 9997 )'CGESVXX', FACT, 00755 $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) 00756 ELSE 00757 WRITE( NOUT, FMT = 9998 )'CGESVXX', FACT, 00758 $ TRANS, N, IMAT, 7, RESULT( 7 ) 00759 END IF 00760 NFAIL = NFAIL + 1 00761 NRUN = NRUN + 1 00762 END IF 00763 * 00764 END IF 00765 * 00766 50 CONTINUE 00767 60 CONTINUE 00768 70 CONTINUE 00769 80 CONTINUE 00770 90 CONTINUE 00771 * 00772 * Print a summary of the results. 00773 * 00774 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00775 * 00776 00777 * Test Error Bounds for CGESVXX 00778 00779 CALL CEBCHVXX(THRESH, PATH) 00780 00781 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =', 00782 $ G12.5 ) 00783 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, 00784 $ ', type ', I2, ', test(', I1, ')=', G12.5 ) 00785 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, 00786 $ ', EQUED=''', A1, ''', type ', I2, ', test(', I1, ')=', 00787 $ G12.5 ) 00788 RETURN 00789 * 00790 * End of CDRVGE 00791 * 00792 END
1.7.3 
