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