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