 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE CDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, 00002 $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, 00003 $ RWORK, IWORK, NOUT ) 00004 * 00005 * -- LAPACK test routine (version 3.2.2) -- 00006 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00007 * April 2009 00008 * 00009 * .. Scalar Arguments .. 00010 LOGICAL TSTERR 00011 INTEGER LA, LAFB, NN, NOUT, NRHS 00012 REAL THRESH 00013 * .. 00014 * .. Array Arguments .. 00015 LOGICAL DOTYPE( * ) 00016 INTEGER IWORK( * ), NVAL( * ) 00017 REAL RWORK( * ), S( * ) 00018 COMPLEX A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), 00019 $ WORK( * ), X( * ), XACT( * ) 00020 * .. 00021 * 00022 * Purpose 00023 * ======= 00024 * 00025 * CDRVGB tests the driver routines CGBSV, -SVX, and -SVXX. 00026 * 00027 * Note that this file is used only when the XBLAS are available, 00028 * otherwise cdrvgb.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 * A (workspace) COMPLEX array, dimension (LA) 00057 * 00058 * LA (input) INTEGER 00059 * The length of the array A. LA >= (2*NMAX-1)*NMAX 00060 * where NMAX is the largest entry in NVAL. 00061 * 00062 * AFB (workspace) COMPLEX array, dimension (LAFB) 00063 * 00064 * LAFB (input) INTEGER 00065 * The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX 00066 * where NMAX is the largest entry in NVAL. 00067 * 00068 * ASAV (workspace) COMPLEX array, dimension (LA) 00069 * 00070 * B (workspace) COMPLEX array, dimension (NMAX*NRHS) 00071 * 00072 * BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) 00073 * 00074 * X (workspace) COMPLEX array, dimension (NMAX*NRHS) 00075 * 00076 * XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) 00077 * 00078 * S (workspace) REAL array, dimension (2*NMAX) 00079 * 00080 * WORK (workspace) COMPLEX array, dimension 00081 * (NMAX*max(3,NRHS,NMAX)) 00082 * 00083 * RWORK (workspace) REAL array, dimension 00084 * (max(NMAX,2*NRHS)) 00085 * 00086 * IWORK (workspace) INTEGER array, dimension (NMAX) 00087 * 00088 * NOUT (input) INTEGER 00089 * The unit number for output. 00090 * 00091 * ===================================================================== 00092 * 00093 * .. Parameters .. 00094 REAL ONE, ZERO 00095 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00096 INTEGER NTYPES 00097 PARAMETER ( NTYPES = 8 ) 00098 INTEGER NTESTS 00099 PARAMETER ( NTESTS = 7 ) 00100 INTEGER NTRAN 00101 PARAMETER ( NTRAN = 3 ) 00102 * .. 00103 * .. Local Scalars .. 00104 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT 00105 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE 00106 CHARACTER*3 PATH 00107 INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN, 00108 $ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU, 00109 $ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS, 00110 $ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT, 00111 $ N_ERR_BNDS 00112 REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV, 00113 $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO, 00114 $ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW, 00115 $ RPVGRW_SVXX 00116 * .. 00117 * .. Local Arrays .. 00118 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) 00119 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00120 REAL RDUM( 1 ), RESULT( NTESTS ), BERR( NRHS ), 00121 $ ERRBNDS_N( NRHS,3 ), ERRBNDS_C( NRHS, 3 ) 00122 * .. 00123 * .. External Functions .. 00124 LOGICAL LSAME 00125 REAL CLANGB, CLANGE, CLANTB, SGET06, SLAMCH, 00126 $ CLA_GBRPVGRW 00127 EXTERNAL LSAME, CLANGB, CLANGE, CLANTB, SGET06, SLAMCH, 00128 $ CLA_GBRPVGRW 00129 * .. 00130 * .. External Subroutines .. 00131 EXTERNAL ALADHD, ALAERH, ALASVM, CERRVX, CGBEQU, CGBSV, 00132 $ CGBSVX, CGBT01, CGBT02, CGBT05, CGBTRF, CGBTRS, 00133 $ CGET04, CLACPY, CLAQGB, CLARHS, CLASET, CLATB4, 00134 $ CLATMS, XLAENV, CGBSVXX 00135 * .. 00136 * .. Intrinsic Functions .. 00137 INTRINSIC ABS, CMPLX, MAX, MIN 00138 * .. 00139 * .. Scalars in Common .. 00140 LOGICAL LERR, OK 00141 CHARACTER*32 SRNAMT 00142 INTEGER INFOT, NUNIT 00143 * .. 00144 * .. Common blocks .. 00145 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00146 COMMON / SRNAMC / SRNAMT 00147 * .. 00148 * .. Data statements .. 00149 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00150 DATA TRANSS / 'N', 'T', 'C' / 00151 DATA FACTS / 'F', 'N', 'E' / 00152 DATA EQUEDS / 'N', 'R', 'C', 'B' / 00153 * .. 00154 * .. Executable Statements .. 00155 * 00156 * Initialize constants and the random number seed. 00157 * 00158 PATH( 1: 1 ) = 'Complex precision' 00159 PATH( 2: 3 ) = 'GB' 00160 NRUN = 0 00161 NFAIL = 0 00162 NERRS = 0 00163 DO 10 I = 1, 4 00164 ISEED( I ) = ISEEDY( I ) 00165 10 CONTINUE 00166 * 00167 * Test the error exits 00168 * 00169 IF( TSTERR ) 00170 $ CALL CERRVX( PATH, NOUT ) 00171 INFOT = 0 00172 * 00173 * Set the block size and minimum block size for testing. 00174 * 00175 NB = 1 00176 NBMIN = 2 00177 CALL XLAENV( 1, NB ) 00178 CALL XLAENV( 2, NBMIN ) 00179 * 00180 * Do for each value of N in NVAL 00181 * 00182 DO 150 IN = 1, NN 00183 N = NVAL( IN ) 00184 LDB = MAX( N, 1 ) 00185 XTYPE = 'N' 00186 * 00187 * Set limits on the number of loop iterations. 00188 * 00189 NKL = MAX( 1, MIN( N, 4 ) ) 00190 IF( N.EQ.0 ) 00191 $ NKL = 1 00192 NKU = NKL 00193 NIMAT = NTYPES 00194 IF( N.LE.0 ) 00195 $ NIMAT = 1 00196 * 00197 DO 140 IKL = 1, NKL 00198 * 00199 * Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes 00200 * it easier to skip redundant values for small values of N. 00201 * 00202 IF( IKL.EQ.1 ) THEN 00203 KL = 0 00204 ELSE IF( IKL.EQ.2 ) THEN 00205 KL = MAX( N-1, 0 ) 00206 ELSE IF( IKL.EQ.3 ) THEN 00207 KL = ( 3*N-1 ) / 4 00208 ELSE IF( IKL.EQ.4 ) THEN 00209 KL = ( N+1 ) / 4 00210 END IF 00211 DO 130 IKU = 1, NKU 00212 * 00213 * Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order 00214 * makes it easier to skip redundant values for small 00215 * values of N. 00216 * 00217 IF( IKU.EQ.1 ) THEN 00218 KU = 0 00219 ELSE IF( IKU.EQ.2 ) THEN 00220 KU = MAX( N-1, 0 ) 00221 ELSE IF( IKU.EQ.3 ) THEN 00222 KU = ( 3*N-1 ) / 4 00223 ELSE IF( IKU.EQ.4 ) THEN 00224 KU = ( N+1 ) / 4 00225 END IF 00226 * 00227 * Check that A and AFB are big enough to generate this 00228 * matrix. 00229 * 00230 LDA = KL + KU + 1 00231 LDAFB = 2*KL + KU + 1 00232 IF( LDA*N.GT.LA .OR. LDAFB*N.GT.LAFB ) THEN 00233 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00234 $ CALL ALADHD( NOUT, PATH ) 00235 IF( LDA*N.GT.LA ) THEN 00236 WRITE( NOUT, FMT = 9999 )LA, N, KL, KU, 00237 $ N*( KL+KU+1 ) 00238 NERRS = NERRS + 1 00239 END IF 00240 IF( LDAFB*N.GT.LAFB ) THEN 00241 WRITE( NOUT, FMT = 9998 )LAFB, N, KL, KU, 00242 $ N*( 2*KL+KU+1 ) 00243 NERRS = NERRS + 1 00244 END IF 00245 GO TO 130 00246 END IF 00247 * 00248 DO 120 IMAT = 1, NIMAT 00249 * 00250 * Do the tests only if DOTYPE( IMAT ) is true. 00251 * 00252 IF( .NOT.DOTYPE( IMAT ) ) 00253 $ GO TO 120 00254 * 00255 * Skip types 2, 3, or 4 if the matrix is too small. 00256 * 00257 ZEROT = IMAT.GE.2 .AND. IMAT.LE.4 00258 IF( ZEROT .AND. N.LT.IMAT-1 ) 00259 $ GO TO 120 00260 * 00261 * Set up parameters with CLATB4 and generate a 00262 * test matrix with CLATMS. 00263 * 00264 CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, 00265 $ MODE, CNDNUM, DIST ) 00266 RCONDC = ONE / CNDNUM 00267 * 00268 SRNAMT = 'CLATMS' 00269 CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 00270 $ CNDNUM, ANORM, KL, KU, 'Z', A, LDA, WORK, 00271 $ INFO ) 00272 * 00273 * Check the error code from CLATMS. 00274 * 00275 IF( INFO.NE.0 ) THEN 00276 CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', N, N, 00277 $ KL, KU, -1, IMAT, NFAIL, NERRS, NOUT ) 00278 GO TO 120 00279 END IF 00280 * 00281 * For types 2, 3, and 4, zero one or more columns of 00282 * the matrix to test that INFO is returned correctly. 00283 * 00284 IZERO = 0 00285 IF( ZEROT ) THEN 00286 IF( IMAT.EQ.2 ) THEN 00287 IZERO = 1 00288 ELSE IF( IMAT.EQ.3 ) THEN 00289 IZERO = N 00290 ELSE 00291 IZERO = N / 2 + 1 00292 END IF 00293 IOFF = ( IZERO-1 )*LDA 00294 IF( IMAT.LT.4 ) THEN 00295 I1 = MAX( 1, KU+2-IZERO ) 00296 I2 = MIN( KL+KU+1, KU+1+( N-IZERO ) ) 00297 DO 20 I = I1, I2 00298 A( IOFF+I ) = ZERO 00299 20 CONTINUE 00300 ELSE 00301 DO 40 J = IZERO, N 00302 DO 30 I = MAX( 1, KU+2-J ), 00303 $ MIN( KL+KU+1, KU+1+( N-J ) ) 00304 A( IOFF+I ) = ZERO 00305 30 CONTINUE 00306 IOFF = IOFF + LDA 00307 40 CONTINUE 00308 END IF 00309 END IF 00310 * 00311 * Save a copy of the matrix A in ASAV. 00312 * 00313 CALL CLACPY( 'Full', KL+KU+1, N, A, LDA, ASAV, LDA ) 00314 * 00315 DO 110 IEQUED = 1, 4 00316 EQUED = EQUEDS( IEQUED ) 00317 IF( IEQUED.EQ.1 ) THEN 00318 NFACT = 3 00319 ELSE 00320 NFACT = 1 00321 END IF 00322 * 00323 DO 100 IFACT = 1, NFACT 00324 FACT = FACTS( IFACT ) 00325 PREFAC = LSAME( FACT, 'F' ) 00326 NOFACT = LSAME( FACT, 'N' ) 00327 EQUIL = LSAME( FACT, 'E' ) 00328 * 00329 IF( ZEROT ) THEN 00330 IF( PREFAC ) 00331 $ GO TO 100 00332 RCONDO = ZERO 00333 RCONDI = ZERO 00334 * 00335 ELSE IF( .NOT.NOFACT ) THEN 00336 * 00337 * Compute the condition number for comparison 00338 * with the value returned by SGESVX (FACT = 00339 * 'N' reuses the condition number from the 00340 * previous iteration with FACT = 'F'). 00341 * 00342 CALL CLACPY( 'Full', KL+KU+1, N, ASAV, LDA, 00343 $ AFB( KL+1 ), LDAFB ) 00344 IF( EQUIL .OR. IEQUED.GT.1 ) THEN 00345 * 00346 * Compute row and column scale factors to 00347 * equilibrate the matrix A. 00348 * 00349 CALL CGBEQU( N, N, KL, KU, AFB( KL+1 ), 00350 $ LDAFB, S, S( N+1 ), ROWCND, 00351 $ COLCND, AMAX, INFO ) 00352 IF( INFO.EQ.0 .AND. N.GT.0 ) THEN 00353 IF( LSAME( EQUED, 'R' ) ) THEN 00354 ROWCND = ZERO 00355 COLCND = ONE 00356 ELSE IF( LSAME( EQUED, 'C' ) ) THEN 00357 ROWCND = ONE 00358 COLCND = ZERO 00359 ELSE IF( LSAME( EQUED, 'B' ) ) THEN 00360 ROWCND = ZERO 00361 COLCND = ZERO 00362 END IF 00363 * 00364 * Equilibrate the matrix. 00365 * 00366 CALL CLAQGB( N, N, KL, KU, AFB( KL+1 ), 00367 $ LDAFB, S, S( N+1 ), 00368 $ ROWCND, COLCND, AMAX, 00369 $ EQUED ) 00370 END IF 00371 END IF 00372 * 00373 * Save the condition number of the 00374 * non-equilibrated system for use in CGET04. 00375 * 00376 IF( EQUIL ) THEN 00377 ROLDO = RCONDO 00378 ROLDI = RCONDI 00379 END IF 00380 * 00381 * Compute the 1-norm and infinity-norm of A. 00382 * 00383 ANORMO = CLANGB( '1', N, KL, KU, AFB( KL+1 ), 00384 $ LDAFB, RWORK ) 00385 ANORMI = CLANGB( 'I', N, KL, KU, AFB( KL+1 ), 00386 $ LDAFB, RWORK ) 00387 * 00388 * Factor the matrix A. 00389 * 00390 CALL CGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK, 00391 $ INFO ) 00392 * 00393 * Form the inverse of A. 00394 * 00395 CALL CLASET( 'Full', N, N, CMPLX( ZERO ), 00396 $ CMPLX( ONE ), WORK, LDB ) 00397 SRNAMT = 'CGBTRS' 00398 CALL CGBTRS( 'No transpose', N, KL, KU, N, 00399 $ AFB, LDAFB, IWORK, WORK, LDB, 00400 $ INFO ) 00401 * 00402 * Compute the 1-norm condition number of A. 00403 * 00404 AINVNM = CLANGE( '1', N, N, WORK, LDB, 00405 $ RWORK ) 00406 IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00407 RCONDO = ONE 00408 ELSE 00409 RCONDO = ( ONE / ANORMO ) / AINVNM 00410 END IF 00411 * 00412 * Compute the infinity-norm condition number 00413 * of A. 00414 * 00415 AINVNM = CLANGE( 'I', N, N, WORK, LDB, 00416 $ RWORK ) 00417 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00418 RCONDI = ONE 00419 ELSE 00420 RCONDI = ( ONE / ANORMI ) / AINVNM 00421 END IF 00422 END IF 00423 * 00424 DO 90 ITRAN = 1, NTRAN 00425 * 00426 * Do for each value of TRANS. 00427 * 00428 TRANS = TRANSS( ITRAN ) 00429 IF( ITRAN.EQ.1 ) THEN 00430 RCONDC = RCONDO 00431 ELSE 00432 RCONDC = RCONDI 00433 END IF 00434 * 00435 * Restore the matrix A. 00436 * 00437 CALL CLACPY( 'Full', KL+KU+1, N, ASAV, LDA, 00438 $ A, LDA ) 00439 * 00440 * Form an exact solution and set the right hand 00441 * side. 00442 * 00443 SRNAMT = 'CLARHS' 00444 CALL CLARHS( PATH, XTYPE, 'Full', TRANS, N, 00445 $ N, KL, KU, NRHS, A, LDA, XACT, 00446 $ LDB, B, LDB, ISEED, INFO ) 00447 XTYPE = 'C' 00448 CALL CLACPY( 'Full', N, NRHS, B, LDB, BSAV, 00449 $ LDB ) 00450 * 00451 IF( NOFACT .AND. ITRAN.EQ.1 ) THEN 00452 * 00453 * --- Test CGBSV --- 00454 * 00455 * Compute the LU factorization of the matrix 00456 * and solve the system. 00457 * 00458 CALL CLACPY( 'Full', KL+KU+1, N, A, LDA, 00459 $ AFB( KL+1 ), LDAFB ) 00460 CALL CLACPY( 'Full', N, NRHS, B, LDB, X, 00461 $ LDB ) 00462 * 00463 SRNAMT = 'CGBSV ' 00464 CALL CGBSV( N, KL, KU, NRHS, AFB, LDAFB, 00465 $ IWORK, X, LDB, INFO ) 00466 * 00467 * Check error code from CGBSV . 00468 * 00469 IF( INFO.NE.IZERO ) 00470 $ CALL ALAERH( PATH, 'CGBSV ', INFO, 00471 $ IZERO, ' ', N, N, KL, KU, 00472 $ NRHS, IMAT, NFAIL, NERRS, 00473 $ NOUT ) 00474 * 00475 * Reconstruct matrix from factors and 00476 * compute residual. 00477 * 00478 CALL CGBT01( N, N, KL, KU, A, LDA, AFB, 00479 $ LDAFB, IWORK, WORK, 00480 $ RESULT( 1 ) ) 00481 NT = 1 00482 IF( IZERO.EQ.0 ) THEN 00483 * 00484 * Compute residual of the computed 00485 * solution. 00486 * 00487 CALL CLACPY( 'Full', N, NRHS, B, LDB, 00488 $ WORK, LDB ) 00489 CALL CGBT02( 'No transpose', N, N, KL, 00490 $ KU, NRHS, A, LDA, X, LDB, 00491 $ WORK, LDB, RESULT( 2 ) ) 00492 * 00493 * Check solution from generated exact 00494 * solution. 00495 * 00496 CALL CGET04( N, NRHS, X, LDB, XACT, 00497 $ LDB, RCONDC, RESULT( 3 ) ) 00498 NT = 3 00499 END IF 00500 * 00501 * Print information about the tests that did 00502 * not pass the threshold. 00503 * 00504 DO 50 K = 1, NT 00505 IF( RESULT( K ).GE.THRESH ) THEN 00506 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00507 $ CALL ALADHD( NOUT, PATH ) 00508 WRITE( NOUT, FMT = 9997 )'CGBSV ', 00509 $ N, KL, KU, IMAT, K, RESULT( K ) 00510 NFAIL = NFAIL + 1 00511 END IF 00512 50 CONTINUE 00513 NRUN = NRUN + NT 00514 END IF 00515 * 00516 * --- Test CGBSVX --- 00517 * 00518 IF( .NOT.PREFAC ) 00519 $ CALL CLASET( 'Full', 2*KL+KU+1, N, 00520 $ CMPLX( ZERO ), CMPLX( ZERO ), 00521 $ AFB, LDAFB ) 00522 CALL CLASET( 'Full', N, NRHS, CMPLX( ZERO ), 00523 $ CMPLX( ZERO ), X, LDB ) 00524 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 00525 * 00526 * Equilibrate the matrix if FACT = 'F' and 00527 * EQUED = 'R', 'C', or 'B'. 00528 * 00529 CALL CLAQGB( N, N, KL, KU, A, LDA, S, 00530 $ S( N+1 ), ROWCND, COLCND, 00531 $ AMAX, EQUED ) 00532 END IF 00533 * 00534 * Solve the system and compute the condition 00535 * number and error bounds using CGBSVX. 00536 * 00537 SRNAMT = 'CGBSVX' 00538 CALL CGBSVX( FACT, TRANS, N, KL, KU, NRHS, A, 00539 $ LDA, AFB, LDAFB, IWORK, EQUED, 00540 $ S, S( LDB+1 ), B, LDB, X, LDB, 00541 $ RCOND, RWORK, RWORK( NRHS+1 ), 00542 $ WORK, RWORK( 2*NRHS+1 ), INFO ) 00543 * 00544 * Check the error code from CGBSVX. 00545 * 00546 IF( INFO.NE.IZERO ) 00547 $ CALL ALAERH( PATH, 'CGBSVX', INFO, IZERO, 00548 $ FACT // TRANS, N, N, KL, KU, 00549 $ NRHS, IMAT, NFAIL, NERRS, 00550 $ NOUT ) 00551 * 00552 * Compare RWORK(2*NRHS+1) from CGBSVX with the 00553 * computed reciprocal pivot growth RPVGRW 00554 * 00555 IF( INFO.NE.0 ) THEN 00556 ANRMPV = ZERO 00557 DO 70 J = 1, INFO 00558 DO 60 I = MAX( KU+2-J, 1 ), 00559 $ MIN( N+KU+1-J, KL+KU+1 ) 00560 ANRMPV = MAX( ANRMPV, 00561 $ ABS( A( I+( J-1 )*LDA ) ) ) 00562 60 CONTINUE 00563 70 CONTINUE 00564 RPVGRW = CLANTB( 'M', 'U', 'N', INFO, 00565 $ MIN( INFO-1, KL+KU ), 00566 $ AFB( MAX( 1, KL+KU+2-INFO ) ), 00567 $ LDAFB, RDUM ) 00568 IF( RPVGRW.EQ.ZERO ) THEN 00569 RPVGRW = ONE 00570 ELSE 00571 RPVGRW = ANRMPV / RPVGRW 00572 END IF 00573 ELSE 00574 RPVGRW = CLANTB( 'M', 'U', 'N', N, KL+KU, 00575 $ AFB, LDAFB, RDUM ) 00576 IF( RPVGRW.EQ.ZERO ) THEN 00577 RPVGRW = ONE 00578 ELSE 00579 RPVGRW = CLANGB( 'M', N, KL, KU, A, 00580 $ LDA, RDUM ) / RPVGRW 00581 END IF 00582 END IF 00583 RESULT( 7 ) = ABS( RPVGRW-RWORK( 2*NRHS+1 ) ) 00584 $ / MAX( RWORK( 2*NRHS+1 ), 00585 $ RPVGRW ) / SLAMCH( 'E' ) 00586 * 00587 IF( .NOT.PREFAC ) THEN 00588 * 00589 * Reconstruct matrix from factors and 00590 * compute residual. 00591 * 00592 CALL CGBT01( N, N, KL, KU, A, LDA, AFB, 00593 $ LDAFB, IWORK, WORK, 00594 $ RESULT( 1 ) ) 00595 K1 = 1 00596 ELSE 00597 K1 = 2 00598 END IF 00599 * 00600 IF( INFO.EQ.0 ) THEN 00601 TRFCON = .FALSE. 00602 * 00603 * Compute residual of the computed solution. 00604 * 00605 CALL CLACPY( 'Full', N, NRHS, BSAV, LDB, 00606 $ WORK, LDB ) 00607 CALL CGBT02( TRANS, N, N, KL, KU, NRHS, 00608 $ ASAV, LDA, X, LDB, WORK, LDB, 00609 $ RESULT( 2 ) ) 00610 * 00611 * Check solution from generated exact 00612 * solution. 00613 * 00614 IF( NOFACT .OR. ( PREFAC .AND. 00615 $ LSAME( EQUED, 'N' ) ) ) THEN 00616 CALL CGET04( N, NRHS, X, LDB, XACT, 00617 $ LDB, RCONDC, RESULT( 3 ) ) 00618 ELSE 00619 IF( ITRAN.EQ.1 ) THEN 00620 ROLDC = ROLDO 00621 ELSE 00622 ROLDC = ROLDI 00623 END IF 00624 CALL CGET04( N, NRHS, X, LDB, XACT, 00625 $ LDB, ROLDC, RESULT( 3 ) ) 00626 END IF 00627 * 00628 * Check the error bounds from iterative 00629 * refinement. 00630 * 00631 CALL CGBT05( TRANS, N, KL, KU, NRHS, ASAV, 00632 $ LDA, BSAV, LDB, X, LDB, XACT, 00633 $ LDB, RWORK, RWORK( NRHS+1 ), 00634 $ RESULT( 4 ) ) 00635 ELSE 00636 TRFCON = .TRUE. 00637 END IF 00638 * 00639 * Compare RCOND from CGBSVX with the computed 00640 * value in RCONDC. 00641 * 00642 RESULT( 6 ) = SGET06( RCOND, RCONDC ) 00643 * 00644 * Print information about the tests that did 00645 * not pass the threshold. 00646 * 00647 IF( .NOT.TRFCON ) THEN 00648 DO 80 K = K1, NTESTS 00649 IF( RESULT( K ).GE.THRESH ) THEN 00650 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00651 $ CALL ALADHD( NOUT, PATH ) 00652 IF( PREFAC ) THEN 00653 WRITE( NOUT, FMT = 9995 ) 00654 $ 'CGBSVX', FACT, TRANS, N, KL, 00655 $ KU, EQUED, IMAT, K, 00656 $ RESULT( K ) 00657 ELSE 00658 WRITE( NOUT, FMT = 9996 ) 00659 $ 'CGBSVX', FACT, TRANS, N, KL, 00660 $ KU, IMAT, K, RESULT( K ) 00661 END IF 00662 NFAIL = NFAIL + 1 00663 END IF 00664 80 CONTINUE 00665 NRUN = NRUN + 7 - K1 00666 ELSE 00667 IF( RESULT( 1 ).GE.THRESH .AND. .NOT. 00668 $ PREFAC ) THEN 00669 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00670 $ CALL ALADHD( NOUT, PATH ) 00671 IF( PREFAC ) THEN 00672 WRITE( NOUT, FMT = 9995 )'CGBSVX', 00673 $ FACT, TRANS, N, KL, KU, EQUED, 00674 $ IMAT, 1, RESULT( 1 ) 00675 ELSE 00676 WRITE( NOUT, FMT = 9996 )'CGBSVX', 00677 $ FACT, TRANS, N, KL, KU, IMAT, 1, 00678 $ RESULT( 1 ) 00679 END IF 00680 NFAIL = NFAIL + 1 00681 NRUN = NRUN + 1 00682 END IF 00683 IF( RESULT( 6 ).GE.THRESH ) THEN 00684 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00685 $ CALL ALADHD( NOUT, PATH ) 00686 IF( PREFAC ) THEN 00687 WRITE( NOUT, FMT = 9995 )'CGBSVX', 00688 $ FACT, TRANS, N, KL, KU, EQUED, 00689 $ IMAT, 6, RESULT( 6 ) 00690 ELSE 00691 WRITE( NOUT, FMT = 9996 )'CGBSVX', 00692 $ FACT, TRANS, N, KL, KU, IMAT, 6, 00693 $ RESULT( 6 ) 00694 END IF 00695 NFAIL = NFAIL + 1 00696 NRUN = NRUN + 1 00697 END IF 00698 IF( RESULT( 7 ).GE.THRESH ) THEN 00699 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00700 $ CALL ALADHD( NOUT, PATH ) 00701 IF( PREFAC ) THEN 00702 WRITE( NOUT, FMT = 9995 )'CGBSVX', 00703 $ FACT, TRANS, N, KL, KU, EQUED, 00704 $ IMAT, 7, RESULT( 7 ) 00705 ELSE 00706 WRITE( NOUT, FMT = 9996 )'CGBSVX', 00707 $ FACT, TRANS, N, KL, KU, IMAT, 7, 00708 $ RESULT( 7 ) 00709 END IF 00710 NFAIL = NFAIL + 1 00711 NRUN = NRUN + 1 00712 END IF 00713 END IF 00714 00715 * --- Test CGBSVXX --- 00716 00717 * Restore the matrices A and B. 00718 00719 c write(*,*) 'begin cgbsvxx testing' 00720 00721 CALL CLACPY( 'Full', KL+KU+1, N, ASAV, LDA, A, 00722 $ LDA ) 00723 CALL CLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB ) 00724 00725 IF( .NOT.PREFAC ) 00726 $ CALL CLASET( 'Full', 2*KL+KU+1, N, ZERO, ZERO, 00727 $ AFB, LDAFB ) 00728 CALL CLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDB ) 00729 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 00730 * 00731 * Equilibrate the matrix if FACT = 'F' and 00732 * EQUED = 'R', 'C', or 'B'. 00733 * 00734 CALL CLAQGB( N, N, KL, KU, A, LDA, S, 00735 $ S( N+1 ), ROWCND, COLCND, AMAX, EQUED ) 00736 END IF 00737 * 00738 * Solve the system and compute the condition number 00739 * and error bounds using CGBSVXX. 00740 * 00741 SRNAMT = 'CGBSVXX' 00742 N_ERR_BNDS = 3 00743 CALL CGBSVXX( FACT, TRANS, N, KL, KU, NRHS, A, LDA, 00744 $ AFB, LDAFB, IWORK, EQUED, S, S( N+1 ), B, LDB, 00745 $ X, LDB, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS, 00746 $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK, 00747 $ RWORK, INFO ) 00748 * 00749 * Check the error code from CGBSVXX. 00750 * 00751 IF( INFO.EQ.N+1 ) GOTO 90 00752 IF( INFO.NE.IZERO ) THEN 00753 CALL ALAERH( PATH, 'CGBSVXX', INFO, IZERO, 00754 $ FACT // TRANS, N, N, -1, -1, NRHS, 00755 $ IMAT, NFAIL, NERRS, NOUT ) 00756 GOTO 90 00757 END IF 00758 * 00759 * Compare rpvgrw_svxx from CGESVXX with the computed 00760 * reciprocal pivot growth factor RPVGRW 00761 * 00762 00763 IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN 00764 RPVGRW = CLA_GBRPVGRW(N, KL, KU, INFO, A, LDA, 00765 $ AFB, LDAFB) 00766 ELSE 00767 RPVGRW = CLA_GBRPVGRW(N, KL, KU, N, A, LDA, 00768 $ AFB, LDAFB) 00769 ENDIF 00770 00771 RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) / 00772 $ MAX( rpvgrw_svxx, RPVGRW ) / 00773 $ SLAMCH( 'E' ) 00774 * 00775 IF( .NOT.PREFAC ) THEN 00776 * 00777 * Reconstruct matrix from factors and compute 00778 * residual. 00779 * 00780 CALL CGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB, 00781 $ IWORK, RWORK( 2*NRHS+1 ), RESULT( 1 ) ) 00782 K1 = 1 00783 ELSE 00784 K1 = 2 00785 END IF 00786 * 00787 IF( INFO.EQ.0 ) THEN 00788 TRFCON = .FALSE. 00789 * 00790 * Compute residual of the computed solution. 00791 * 00792 CALL CLACPY( 'Full', N, NRHS, BSAV, LDB, WORK, 00793 $ LDB ) 00794 CALL CGBT02( TRANS, N, N, KL, KU, NRHS, ASAV, 00795 $ LDA, X, LDB, WORK, LDB, RWORK( 2*NRHS+1 ), 00796 $ RESULT( 2 ) ) 00797 * 00798 * Check solution from generated exact solution. 00799 * 00800 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, 00801 $ 'N' ) ) ) THEN 00802 CALL CGET04( N, NRHS, X, LDB, XACT, LDB, 00803 $ RCONDC, RESULT( 3 ) ) 00804 ELSE 00805 IF( ITRAN.EQ.1 ) THEN 00806 ROLDC = ROLDO 00807 ELSE 00808 ROLDC = ROLDI 00809 END IF 00810 CALL CGET04( N, NRHS, X, LDB, XACT, LDB, 00811 $ ROLDC, RESULT( 3 ) ) 00812 END IF 00813 ELSE 00814 TRFCON = .TRUE. 00815 END IF 00816 * 00817 * Compare RCOND from CGBSVXX with the computed value 00818 * in RCONDC. 00819 * 00820 RESULT( 6 ) = SGET06( RCOND, RCONDC ) 00821 * 00822 * Print information about the tests that did not pass 00823 * the threshold. 00824 * 00825 IF( .NOT.TRFCON ) THEN 00826 DO 45 K = K1, NTESTS 00827 IF( RESULT( K ).GE.THRESH ) THEN 00828 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00829 $ CALL ALADHD( NOUT, PATH ) 00830 IF( PREFAC ) THEN 00831 WRITE( NOUT, FMT = 9995 )'CGBSVXX', 00832 $ FACT, TRANS, N, KL, KU, EQUED, 00833 $ IMAT, K, RESULT( K ) 00834 ELSE 00835 WRITE( NOUT, FMT = 9996 )'CGBSVXX', 00836 $ FACT, TRANS, N, KL, KU, IMAT, K, 00837 $ RESULT( K ) 00838 END IF 00839 NFAIL = NFAIL + 1 00840 END IF 00841 45 CONTINUE 00842 NRUN = NRUN + 7 - K1 00843 ELSE 00844 IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) 00845 $ THEN 00846 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00847 $ CALL ALADHD( NOUT, PATH ) 00848 IF( PREFAC ) THEN 00849 WRITE( NOUT, FMT = 9995 )'CGBSVXX', FACT, 00850 $ TRANS, N, KL, KU, EQUED, IMAT, 1, 00851 $ RESULT( 1 ) 00852 ELSE 00853 WRITE( NOUT, FMT = 9996 )'CGBSVXX', FACT, 00854 $ TRANS, N, KL, KU, IMAT, 1, 00855 $ RESULT( 1 ) 00856 END IF 00857 NFAIL = NFAIL + 1 00858 NRUN = NRUN + 1 00859 END IF 00860 IF( RESULT( 6 ).GE.THRESH ) THEN 00861 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00862 $ CALL ALADHD( NOUT, PATH ) 00863 IF( PREFAC ) THEN 00864 WRITE( NOUT, FMT = 9995 )'CGBSVXX', FACT, 00865 $ TRANS, N, KL, KU, EQUED, IMAT, 6, 00866 $ RESULT( 6 ) 00867 ELSE 00868 WRITE( NOUT, FMT = 9996 )'CGBSVXX', FACT, 00869 $ TRANS, N, KL, KU, IMAT, 6, 00870 $ RESULT( 6 ) 00871 END IF 00872 NFAIL = NFAIL + 1 00873 NRUN = NRUN + 1 00874 END IF 00875 IF( RESULT( 7 ).GE.THRESH ) THEN 00876 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00877 $ CALL ALADHD( NOUT, PATH ) 00878 IF( PREFAC ) THEN 00879 WRITE( NOUT, FMT = 9995 )'CGBSVXX', FACT, 00880 $ TRANS, N, KL, KU, EQUED, IMAT, 7, 00881 $ RESULT( 7 ) 00882 ELSE 00883 WRITE( NOUT, FMT = 9996 )'CGBSVXX', FACT, 00884 $ TRANS, N, KL, KU, IMAT, 7, 00885 $ RESULT( 7 ) 00886 END IF 00887 NFAIL = NFAIL + 1 00888 NRUN = NRUN + 1 00889 END IF 00890 * 00891 END IF 00892 * 00893 90 CONTINUE 00894 100 CONTINUE 00895 110 CONTINUE 00896 120 CONTINUE 00897 130 CONTINUE 00898 140 CONTINUE 00899 150 CONTINUE 00900 * 00901 * Print a summary of the results. 00902 * 00903 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00904 * 00905 00906 * Test Error Bounds from CGBSVXX 00907 00908 CALL CEBCHVXX(THRESH, PATH) 00909 00910 9999 FORMAT( ' *** In CDRVGB, LA=', I5, ' is too small for N=', I5, 00911 $ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ', 00912 $ I5 ) 00913 9998 FORMAT( ' *** In CDRVGB, LAFB=', I5, ' is too small for N=', I5, 00914 $ ', KU=', I5, ', KL=', I5, / 00915 $ ' ==> Increase LAFB to at least ', I5 ) 00916 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ', 00917 $ I1, ', test(', I1, ')=', G12.5 ) 00918 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', 00919 $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 ) 00920 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', 00921 $ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1, 00922 $ ')=', G12.5 ) 00923 * 00924 RETURN 00925 * 00926 * End of CDRVGB 00927 * 00928 END
1.7.3 
