![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b ZDRVGBX 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 ZDRVGB( 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 RWORK( * ), S( * ) 00024 * COMPLEX*16 A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), 00025 * $ WORK( * ), X( * ), XACT( * ) 00026 * .. 00027 * 00028 * 00029 *> \par Purpose: 00030 * ============= 00031 *> 00032 *> \verbatim 00033 *> 00034 *> ZDRVGB tests the driver routines ZGBSV, -SVX, and -SVXX. 00035 *> 00036 *> Note that this file is used only when the XBLAS are available, 00037 *> otherwise zdrvgb.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 COMPLEX*16 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 COMPLEX*16 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 COMPLEX*16 array, dimension (LA) 00111 *> \endverbatim 00112 *> 00113 *> \param[out] B 00114 *> \verbatim 00115 *> B is COMPLEX*16 array, dimension (NMAX*NRHS) 00116 *> \endverbatim 00117 *> 00118 *> \param[out] BSAV 00119 *> \verbatim 00120 *> BSAV is COMPLEX*16 array, dimension (NMAX*NRHS) 00121 *> \endverbatim 00122 *> 00123 *> \param[out] X 00124 *> \verbatim 00125 *> X is COMPLEX*16 array, dimension (NMAX*NRHS) 00126 *> \endverbatim 00127 *> 00128 *> \param[out] XACT 00129 *> \verbatim 00130 *> XACT is COMPLEX*16 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 COMPLEX*16 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 (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 complex16_lin 00172 * 00173 * ===================================================================== 00174 SUBROUTINE ZDRVGB( 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 RWORK( * ), S( * ) 00192 COMPLEX*16 A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), 00193 $ WORK( * ), X( * ), 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 RDUM( 1 ), 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, ZLANGB, ZLANGE, ZLANTB, 00231 $ ZLA_GBRPVGRW 00232 EXTERNAL LSAME, DGET06, DLAMCH, ZLANGB, ZLANGE, ZLANTB, 00233 $ ZLA_GBRPVGRW 00234 * .. 00235 * .. External Subroutines .. 00236 EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGBEQU, 00237 $ ZGBSV, ZGBSVX, ZGBT01, ZGBT02, ZGBT05, ZGBTRF, 00238 $ ZGBTRS, ZGET04, ZLACPY, ZLAQGB, ZLARHS, ZLASET, 00239 $ ZLATB4, ZLATMS, ZGBSVXX 00240 * .. 00241 * .. Intrinsic Functions .. 00242 INTRINSIC ABS, DCMPLX, 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 ) = 'Zomplex 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 ZERRVX( 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 ZLATB4 and generate a 00367 * test matrix with ZLATMS. 00368 * 00369 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, 00370 $ MODE, CNDNUM, DIST ) 00371 RCONDC = ONE / CNDNUM 00372 * 00373 SRNAMT = 'ZLATMS' 00374 CALL ZLATMS( 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 ZLATMS. 00379 * 00380 IF( INFO.NE.0 ) THEN 00381 CALL ALAERH( PATH, 'ZLATMS', 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 ZLACPY( '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 ZLACPY( '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 ZGBEQU( 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 ZLAQGB( 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 ZGET04. 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 = ZLANGB( '1', N, KL, KU, AFB( KL+1 ), 00489 $ LDAFB, RWORK ) 00490 ANORMI = ZLANGB( 'I', N, KL, KU, AFB( KL+1 ), 00491 $ LDAFB, RWORK ) 00492 * 00493 * Factor the matrix A. 00494 * 00495 CALL ZGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK, 00496 $ INFO ) 00497 * 00498 * Form the inverse of A. 00499 * 00500 CALL ZLASET( 'Full', N, N, DCMPLX( ZERO ), 00501 $ DCMPLX( ONE ), WORK, LDB ) 00502 SRNAMT = 'ZGBTRS' 00503 CALL ZGBTRS( '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 = ZLANGE( '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 = ZLANGE( '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 ZLACPY( '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 = 'ZLARHS' 00549 CALL ZLARHS( PATH, XTYPE, 'Full', TRANS, N, 00550 $ N, KL, KU, NRHS, A, LDA, XACT, 00551 $ LDB, B, LDB, ISEED, INFO ) 00552 XTYPE = 'C' 00553 CALL ZLACPY( 'Full', N, NRHS, B, LDB, BSAV, 00554 $ LDB ) 00555 * 00556 IF( NOFACT .AND. ITRAN.EQ.1 ) THEN 00557 * 00558 * --- Test ZGBSV --- 00559 * 00560 * Compute the LU factorization of the matrix 00561 * and solve the system. 00562 * 00563 CALL ZLACPY( 'Full', KL+KU+1, N, A, LDA, 00564 $ AFB( KL+1 ), LDAFB ) 00565 CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, 00566 $ LDB ) 00567 * 00568 SRNAMT = 'ZGBSV ' 00569 CALL ZGBSV( N, KL, KU, NRHS, AFB, LDAFB, 00570 $ IWORK, X, LDB, INFO ) 00571 * 00572 * Check error code from ZGBSV . 00573 * 00574 IF( INFO.NE.IZERO ) 00575 $ CALL ALAERH( PATH, 'ZGBSV ', 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 ZGBT01( 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 ZLACPY( 'Full', N, NRHS, B, LDB, 00593 $ WORK, LDB ) 00594 CALL ZGBT02( '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 ZGET04( 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 )'ZGBSV ', 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 ZGBSVX --- 00622 * 00623 IF( .NOT.PREFAC ) 00624 $ CALL ZLASET( 'Full', 2*KL+KU+1, N, 00625 $ DCMPLX( ZERO ), 00626 $ DCMPLX( ZERO ), AFB, LDAFB ) 00627 CALL ZLASET( 'Full', N, NRHS, DCMPLX( ZERO ), 00628 $ DCMPLX( ZERO ), X, LDB ) 00629 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 00630 * 00631 * Equilibrate the matrix if FACT = 'F' and 00632 * EQUED = 'R', 'C', or 'B'. 00633 * 00634 CALL ZLAQGB( N, N, KL, KU, A, LDA, S, 00635 $ S( N+1 ), ROWCND, COLCND, 00636 $ AMAX, EQUED ) 00637 END IF 00638 * 00639 * Solve the system and compute the condition 00640 * number and error bounds using ZGBSVX. 00641 * 00642 SRNAMT = 'ZGBSVX' 00643 CALL ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, A, 00644 $ LDA, AFB, LDAFB, IWORK, EQUED, 00645 $ S, S( LDB+1 ), B, LDB, X, LDB, 00646 $ RCOND, RWORK, RWORK( NRHS+1 ), 00647 $ WORK, RWORK( 2*NRHS+1 ), INFO ) 00648 * 00649 * Check the error code from ZGBSVX. 00650 * 00651 IF( INFO.NE.IZERO ) 00652 $ CALL ALAERH( PATH, 'ZGBSVX', INFO, IZERO, 00653 $ FACT // TRANS, N, N, KL, KU, 00654 $ NRHS, IMAT, NFAIL, NERRS, 00655 $ NOUT ) 00656 * 00657 * Compare RWORK(2*NRHS+1) from ZGBSVX with the 00658 * computed reciprocal pivot growth RPVGRW 00659 * 00660 IF( INFO.NE.0 ) THEN 00661 ANRMPV = ZERO 00662 DO 70 J = 1, INFO 00663 DO 60 I = MAX( KU+2-J, 1 ), 00664 $ MIN( N+KU+1-J, KL+KU+1 ) 00665 ANRMPV = MAX( ANRMPV, 00666 $ ABS( A( I+( J-1 )*LDA ) ) ) 00667 60 CONTINUE 00668 70 CONTINUE 00669 RPVGRW = ZLANTB( 'M', 'U', 'N', INFO, 00670 $ MIN( INFO-1, KL+KU ), 00671 $ AFB( MAX( 1, KL+KU+2-INFO ) ), 00672 $ LDAFB, RDUM ) 00673 IF( RPVGRW.EQ.ZERO ) THEN 00674 RPVGRW = ONE 00675 ELSE 00676 RPVGRW = ANRMPV / RPVGRW 00677 END IF 00678 ELSE 00679 RPVGRW = ZLANTB( 'M', 'U', 'N', N, KL+KU, 00680 $ AFB, LDAFB, RDUM ) 00681 IF( RPVGRW.EQ.ZERO ) THEN 00682 RPVGRW = ONE 00683 ELSE 00684 RPVGRW = ZLANGB( 'M', N, KL, KU, A, 00685 $ LDA, RDUM ) / RPVGRW 00686 END IF 00687 END IF 00688 RESULT( 7 ) = ABS( RPVGRW-RWORK( 2*NRHS+1 ) ) 00689 $ / MAX( RWORK( 2*NRHS+1 ), 00690 $ RPVGRW ) / DLAMCH( 'E' ) 00691 * 00692 IF( .NOT.PREFAC ) THEN 00693 * 00694 * Reconstruct matrix from factors and 00695 * compute residual. 00696 * 00697 CALL ZGBT01( N, N, KL, KU, A, LDA, AFB, 00698 $ LDAFB, IWORK, WORK, 00699 $ RESULT( 1 ) ) 00700 K1 = 1 00701 ELSE 00702 K1 = 2 00703 END IF 00704 * 00705 IF( INFO.EQ.0 ) THEN 00706 TRFCON = .FALSE. 00707 * 00708 * Compute residual of the computed solution. 00709 * 00710 CALL ZLACPY( 'Full', N, NRHS, BSAV, LDB, 00711 $ WORK, LDB ) 00712 CALL ZGBT02( TRANS, N, N, KL, KU, NRHS, 00713 $ ASAV, LDA, X, LDB, WORK, LDB, 00714 $ RESULT( 2 ) ) 00715 * 00716 * Check solution from generated exact 00717 * solution. 00718 * 00719 IF( NOFACT .OR. ( PREFAC .AND. 00720 $ LSAME( EQUED, 'N' ) ) ) THEN 00721 CALL ZGET04( N, NRHS, X, LDB, XACT, 00722 $ LDB, RCONDC, RESULT( 3 ) ) 00723 ELSE 00724 IF( ITRAN.EQ.1 ) THEN 00725 ROLDC = ROLDO 00726 ELSE 00727 ROLDC = ROLDI 00728 END IF 00729 CALL ZGET04( N, NRHS, X, LDB, XACT, 00730 $ LDB, ROLDC, RESULT( 3 ) ) 00731 END IF 00732 * 00733 * Check the error bounds from iterative 00734 * refinement. 00735 * 00736 CALL ZGBT05( TRANS, N, KL, KU, NRHS, ASAV, 00737 $ LDA, BSAV, LDB, X, LDB, XACT, 00738 $ LDB, RWORK, RWORK( NRHS+1 ), 00739 $ RESULT( 4 ) ) 00740 ELSE 00741 TRFCON = .TRUE. 00742 END IF 00743 * 00744 * Compare RCOND from ZGBSVX with the computed 00745 * value in RCONDC. 00746 * 00747 RESULT( 6 ) = DGET06( RCOND, RCONDC ) 00748 * 00749 * Print information about the tests that did 00750 * not pass the threshold. 00751 * 00752 IF( .NOT.TRFCON ) THEN 00753 DO 80 K = K1, NTESTS 00754 IF( RESULT( K ).GE.THRESH ) THEN 00755 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00756 $ CALL ALADHD( NOUT, PATH ) 00757 IF( PREFAC ) THEN 00758 WRITE( NOUT, FMT = 9995 ) 00759 $ 'ZGBSVX', FACT, TRANS, N, KL, 00760 $ KU, EQUED, IMAT, K, 00761 $ RESULT( K ) 00762 ELSE 00763 WRITE( NOUT, FMT = 9996 ) 00764 $ 'ZGBSVX', FACT, TRANS, N, KL, 00765 $ KU, IMAT, K, RESULT( K ) 00766 END IF 00767 NFAIL = NFAIL + 1 00768 END IF 00769 80 CONTINUE 00770 NRUN = NRUN + 7 - K1 00771 ELSE 00772 IF( RESULT( 1 ).GE.THRESH .AND. .NOT. 00773 $ PREFAC ) THEN 00774 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00775 $ CALL ALADHD( NOUT, PATH ) 00776 IF( PREFAC ) THEN 00777 WRITE( NOUT, FMT = 9995 )'ZGBSVX', 00778 $ FACT, TRANS, N, KL, KU, EQUED, 00779 $ IMAT, 1, RESULT( 1 ) 00780 ELSE 00781 WRITE( NOUT, FMT = 9996 )'ZGBSVX', 00782 $ FACT, TRANS, N, KL, KU, IMAT, 1, 00783 $ RESULT( 1 ) 00784 END IF 00785 NFAIL = NFAIL + 1 00786 NRUN = NRUN + 1 00787 END IF 00788 IF( RESULT( 6 ).GE.THRESH ) THEN 00789 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00790 $ CALL ALADHD( NOUT, PATH ) 00791 IF( PREFAC ) THEN 00792 WRITE( NOUT, FMT = 9995 )'ZGBSVX', 00793 $ FACT, TRANS, N, KL, KU, EQUED, 00794 $ IMAT, 6, RESULT( 6 ) 00795 ELSE 00796 WRITE( NOUT, FMT = 9996 )'ZGBSVX', 00797 $ FACT, TRANS, N, KL, KU, IMAT, 6, 00798 $ RESULT( 6 ) 00799 END IF 00800 NFAIL = NFAIL + 1 00801 NRUN = NRUN + 1 00802 END IF 00803 IF( RESULT( 7 ).GE.THRESH ) THEN 00804 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00805 $ CALL ALADHD( NOUT, PATH ) 00806 IF( PREFAC ) THEN 00807 WRITE( NOUT, FMT = 9995 )'ZGBSVX', 00808 $ FACT, TRANS, N, KL, KU, EQUED, 00809 $ IMAT, 7, RESULT( 7 ) 00810 ELSE 00811 WRITE( NOUT, FMT = 9996 )'ZGBSVX', 00812 $ FACT, TRANS, N, KL, KU, IMAT, 7, 00813 $ RESULT( 7 ) 00814 END IF 00815 NFAIL = NFAIL + 1 00816 NRUN = NRUN + 1 00817 END IF 00818 END IF 00819 00820 * --- Test ZGBSVXX --- 00821 00822 * Restore the matrices A and B. 00823 00824 c write(*,*) 'begin zgbsvxx testing' 00825 00826 CALL ZLACPY( 'Full', KL+KU+1, N, ASAV, LDA, A, 00827 $ LDA ) 00828 CALL ZLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB ) 00829 00830 IF( .NOT.PREFAC ) 00831 $ CALL ZLASET( 'Full', 2*KL+KU+1, N, 00832 $ DCMPLX( ZERO ), DCMPLX( ZERO ), 00833 $ AFB, LDAFB ) 00834 CALL ZLASET( 'Full', N, NRHS, 00835 $ DCMPLX( ZERO ), DCMPLX( ZERO ), 00836 $ X, LDB ) 00837 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 00838 * 00839 * Equilibrate the matrix if FACT = 'F' and 00840 * EQUED = 'R', 'C', or 'B'. 00841 * 00842 CALL ZLAQGB( N, N, KL, KU, A, LDA, S, 00843 $ S( N+1 ), ROWCND, COLCND, AMAX, EQUED ) 00844 END IF 00845 * 00846 * Solve the system and compute the condition number 00847 * and error bounds using ZGBSVXX. 00848 * 00849 SRNAMT = 'ZGBSVXX' 00850 N_ERR_BNDS = 3 00851 CALL ZGBSVXX( FACT, TRANS, N, KL, KU, NRHS, A, LDA, 00852 $ AFB, LDAFB, IWORK, EQUED, S, S( N+1 ), B, LDB, 00853 $ X, LDB, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS, 00854 $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK, 00855 $ RWORK, INFO ) 00856 * 00857 * Check the error code from ZGBSVXX. 00858 * 00859 IF( INFO.EQ.N+1 ) GOTO 90 00860 IF( INFO.NE.IZERO ) THEN 00861 CALL ALAERH( PATH, 'ZGBSVXX', INFO, IZERO, 00862 $ FACT // TRANS, N, N, -1, -1, NRHS, 00863 $ IMAT, NFAIL, NERRS, NOUT ) 00864 GOTO 90 00865 END IF 00866 * 00867 * Compare rpvgrw_svxx from ZGESVXX with the computed 00868 * reciprocal pivot growth factor RPVGRW 00869 * 00870 00871 IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN 00872 RPVGRW = ZLA_GBRPVGRW(N, KL, KU, INFO, A, LDA, 00873 $ AFB, LDAFB) 00874 ELSE 00875 RPVGRW = ZLA_GBRPVGRW(N, KL, KU, N, A, LDA, 00876 $ AFB, LDAFB) 00877 ENDIF 00878 00879 RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) / 00880 $ MAX( rpvgrw_svxx, RPVGRW ) / 00881 $ DLAMCH( 'E' ) 00882 * 00883 IF( .NOT.PREFAC ) THEN 00884 * 00885 * Reconstruct matrix from factors and compute 00886 * residual. 00887 * 00888 CALL ZGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB, 00889 $ IWORK, WORK( 2*NRHS+1 ), RESULT( 1 ) ) 00890 K1 = 1 00891 ELSE 00892 K1 = 2 00893 END IF 00894 * 00895 IF( INFO.EQ.0 ) THEN 00896 TRFCON = .FALSE. 00897 * 00898 * Compute residual of the computed solution. 00899 * 00900 CALL ZLACPY( 'Full', N, NRHS, BSAV, LDB, WORK, 00901 $ LDB ) 00902 CALL ZGBT02( TRANS, N, N, KL, KU, NRHS, ASAV, 00903 $ LDA, X, LDB, WORK, LDB, RESULT( 2 ) ) 00904 * 00905 * Check solution from generated exact solution. 00906 * 00907 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, 00908 $ 'N' ) ) ) THEN 00909 CALL ZGET04( N, NRHS, X, LDB, XACT, LDB, 00910 $ RCONDC, RESULT( 3 ) ) 00911 ELSE 00912 IF( ITRAN.EQ.1 ) THEN 00913 ROLDC = ROLDO 00914 ELSE 00915 ROLDC = ROLDI 00916 END IF 00917 CALL ZGET04( N, NRHS, X, LDB, XACT, LDB, 00918 $ ROLDC, RESULT( 3 ) ) 00919 END IF 00920 ELSE 00921 TRFCON = .TRUE. 00922 END IF 00923 * 00924 * Compare RCOND from ZGBSVXX with the computed value 00925 * in RCONDC. 00926 * 00927 RESULT( 6 ) = DGET06( RCOND, RCONDC ) 00928 * 00929 * Print information about the tests that did not pass 00930 * the threshold. 00931 * 00932 IF( .NOT.TRFCON ) THEN 00933 DO 45 K = K1, NTESTS 00934 IF( RESULT( K ).GE.THRESH ) THEN 00935 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00936 $ CALL ALADHD( NOUT, PATH ) 00937 IF( PREFAC ) THEN 00938 WRITE( NOUT, FMT = 9995 )'ZGBSVXX', 00939 $ FACT, TRANS, N, KL, KU, EQUED, 00940 $ IMAT, K, RESULT( K ) 00941 ELSE 00942 WRITE( NOUT, FMT = 9996 )'ZGBSVXX', 00943 $ FACT, TRANS, N, KL, KU, IMAT, K, 00944 $ RESULT( K ) 00945 END IF 00946 NFAIL = NFAIL + 1 00947 END IF 00948 45 CONTINUE 00949 NRUN = NRUN + 7 - K1 00950 ELSE 00951 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) 00952 $ THEN 00953 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00954 $ CALL ALADHD( NOUT, PATH ) 00955 IF( PREFAC ) THEN 00956 WRITE( NOUT, FMT = 9995 )'ZGBSVXX', FACT, 00957 $ TRANS, N, KL, KU, EQUED, IMAT, 1, 00958 $ RESULT( 1 ) 00959 ELSE 00960 WRITE( NOUT, FMT = 9996 )'ZGBSVXX', FACT, 00961 $ TRANS, N, KL, KU, IMAT, 1, 00962 $ RESULT( 1 ) 00963 END IF 00964 NFAIL = NFAIL + 1 00965 NRUN = NRUN + 1 00966 END IF 00967 IF( RESULT( 6 ).GE.THRESH ) THEN 00968 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00969 $ CALL ALADHD( NOUT, PATH ) 00970 IF( PREFAC ) THEN 00971 WRITE( NOUT, FMT = 9995 )'ZGBSVXX', FACT, 00972 $ TRANS, N, KL, KU, EQUED, IMAT, 6, 00973 $ RESULT( 6 ) 00974 ELSE 00975 WRITE( NOUT, FMT = 9996 )'ZGBSVXX', FACT, 00976 $ TRANS, N, KL, KU, IMAT, 6, 00977 $ RESULT( 6 ) 00978 END IF 00979 NFAIL = NFAIL + 1 00980 NRUN = NRUN + 1 00981 END IF 00982 IF( RESULT( 7 ).GE.THRESH ) THEN 00983 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00984 $ CALL ALADHD( NOUT, PATH ) 00985 IF( PREFAC ) THEN 00986 WRITE( NOUT, FMT = 9995 )'ZGBSVXX', FACT, 00987 $ TRANS, N, KL, KU, EQUED, IMAT, 7, 00988 $ RESULT( 7 ) 00989 ELSE 00990 WRITE( NOUT, FMT = 9996 )'ZGBSVXX', FACT, 00991 $ TRANS, N, KL, KU, IMAT, 7, 00992 $ RESULT( 7 ) 00993 END IF 00994 NFAIL = NFAIL + 1 00995 NRUN = NRUN + 1 00996 END IF 00997 * 00998 END IF 00999 * 01000 90 CONTINUE 01001 100 CONTINUE 01002 110 CONTINUE 01003 120 CONTINUE 01004 130 CONTINUE 01005 140 CONTINUE 01006 150 CONTINUE 01007 * 01008 * Print a summary of the results. 01009 * 01010 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 01011 * 01012 01013 * Test Error Bounds from ZGBSVXX 01014 01015 CALL ZEBCHVXX(THRESH, PATH) 01016 01017 9999 FORMAT( ' *** In ZDRVGB, LA=', I5, ' is too small for N=', I5, 01018 $ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ', 01019 $ I5 ) 01020 9998 FORMAT( ' *** In ZDRVGB, LAFB=', I5, ' is too small for N=', I5, 01021 $ ', KU=', I5, ', KL=', I5, / 01022 $ ' ==> Increase LAFB to at least ', I5 ) 01023 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ', 01024 $ I1, ', test(', I1, ')=', G12.5 ) 01025 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', 01026 $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 ) 01027 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', 01028 $ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1, 01029 $ ')=', G12.5 ) 01030 * 01031 RETURN 01032 * 01033 * End of ZDRVGB 01034 * 01035 END