![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b DDRVAB 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 DDRVAB( DOTYPE, NM, MVAL, NNS, 00012 * NSVAL, THRESH, NMAX, A, AFAC, B, 00013 * X, WORK, RWORK, SWORK, IWORK, NOUT ) 00014 * 00015 * .. Scalar Arguments .. 00016 * INTEGER NM, NMAX, NNS, NOUT 00017 * DOUBLE PRECISION THRESH 00018 * .. 00019 * .. Array Arguments .. 00020 * LOGICAL DOTYPE( * ) 00021 * INTEGER MVAL( * ), NSVAL( * ), IWORK( * ) 00022 * REAL SWORK(*) 00023 * DOUBLE PRECISION A( * ), AFAC( * ), B( * ), 00024 * $ RWORK( * ), WORK( * ), X( * ) 00025 * .. 00026 * 00027 * 00028 *> \par Purpose: 00029 * ============= 00030 *> 00031 *> \verbatim 00032 *> 00033 *> DDRVAB tests DSGESV 00034 *> \endverbatim 00035 * 00036 * Arguments: 00037 * ========== 00038 * 00039 *> \param[in] DOTYPE 00040 *> \verbatim 00041 *> DOTYPE is LOGICAL array, dimension (NTYPES) 00042 *> The matrix types to be used for testing. Matrices of type j 00043 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00044 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00045 *> \endverbatim 00046 *> 00047 *> \param[in] NM 00048 *> \verbatim 00049 *> NM is INTEGER 00050 *> The number of values of M contained in the vector MVAL. 00051 *> \endverbatim 00052 *> 00053 *> \param[in] MVAL 00054 *> \verbatim 00055 *> MVAL is INTEGER array, dimension (NM) 00056 *> The values of the matrix row dimension M. 00057 *> \endverbatim 00058 *> 00059 *> \param[in] NNS 00060 *> \verbatim 00061 *> NNS is INTEGER 00062 *> The number of values of NRHS contained in the vector NSVAL. 00063 *> \endverbatim 00064 *> 00065 *> \param[in] NSVAL 00066 *> \verbatim 00067 *> NSVAL is INTEGER array, dimension (NNS) 00068 *> The values of the number of right hand sides NRHS. 00069 *> \endverbatim 00070 *> 00071 *> \param[in] THRESH 00072 *> \verbatim 00073 *> THRESH is DOUBLE PRECISION 00074 *> The threshold value for the test ratios. A result is 00075 *> included in the output file if RESULT >= THRESH. To have 00076 *> every test ratio printed, use THRESH = 0. 00077 *> \endverbatim 00078 *> 00079 *> \param[in] NMAX 00080 *> \verbatim 00081 *> NMAX is INTEGER 00082 *> The maximum value permitted for M or N, used in dimensioning 00083 *> the work arrays. 00084 *> \endverbatim 00085 *> 00086 *> \param[out] A 00087 *> \verbatim 00088 *> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) 00089 *> \endverbatim 00090 *> 00091 *> \param[out] AFAC 00092 *> \verbatim 00093 *> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) 00094 *> \endverbatim 00095 *> 00096 *> \param[out] B 00097 *> \verbatim 00098 *> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX) 00099 *> where NSMAX is the largest entry in NSVAL. 00100 *> \endverbatim 00101 *> 00102 *> \param[out] X 00103 *> \verbatim 00104 *> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX) 00105 *> \endverbatim 00106 *> 00107 *> \param[out] WORK 00108 *> \verbatim 00109 *> WORK is DOUBLE PRECISION array, dimension 00110 *> (NMAX*max(3,NSMAX)) 00111 *> \endverbatim 00112 *> 00113 *> \param[out] RWORK 00114 *> \verbatim 00115 *> RWORK is DOUBLE PRECISION array, dimension 00116 *> (max(2*NMAX,2*NSMAX+NWORK)) 00117 *> \endverbatim 00118 *> 00119 *> \param[out] SWORK 00120 *> \verbatim 00121 *> SWORK is REAL array, dimension 00122 *> (NMAX*(NSMAX+NMAX)) 00123 *> \endverbatim 00124 *> 00125 *> \param[out] IWORK 00126 *> \verbatim 00127 *> IWORK is INTEGER array, dimension 00128 *> NMAX 00129 *> \endverbatim 00130 *> 00131 *> \param[in] NOUT 00132 *> \verbatim 00133 *> NOUT is INTEGER 00134 *> The unit number for output. 00135 *> \endverbatim 00136 * 00137 * Authors: 00138 * ======== 00139 * 00140 *> \author Univ. of Tennessee 00141 *> \author Univ. of California Berkeley 00142 *> \author Univ. of Colorado Denver 00143 *> \author NAG Ltd. 00144 * 00145 *> \date November 2011 00146 * 00147 *> \ingroup double_lin 00148 * 00149 * ===================================================================== 00150 SUBROUTINE DDRVAB( DOTYPE, NM, MVAL, NNS, 00151 $ NSVAL, THRESH, NMAX, A, AFAC, B, 00152 $ X, WORK, RWORK, SWORK, IWORK, NOUT ) 00153 * 00154 * -- LAPACK test routine (version 3.4.0) -- 00155 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00156 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00157 * November 2011 00158 * 00159 * .. Scalar Arguments .. 00160 INTEGER NM, NMAX, NNS, NOUT 00161 DOUBLE PRECISION THRESH 00162 * .. 00163 * .. Array Arguments .. 00164 LOGICAL DOTYPE( * ) 00165 INTEGER MVAL( * ), NSVAL( * ), IWORK( * ) 00166 REAL SWORK(*) 00167 DOUBLE PRECISION A( * ), AFAC( * ), B( * ), 00168 $ RWORK( * ), WORK( * ), X( * ) 00169 * .. 00170 * 00171 * ===================================================================== 00172 * 00173 * .. Parameters .. 00174 DOUBLE PRECISION ZERO 00175 PARAMETER ( ZERO = 0.0D+0 ) 00176 INTEGER NTYPES 00177 PARAMETER ( NTYPES = 11 ) 00178 INTEGER NTESTS 00179 PARAMETER ( NTESTS = 1 ) 00180 * .. 00181 * .. Local Scalars .. 00182 LOGICAL ZEROT 00183 CHARACTER DIST, TRANS, TYPE, XTYPE 00184 CHARACTER*3 PATH 00185 INTEGER I, IM, IMAT, INFO, IOFF, IRHS, 00186 $ IZERO, KL, KU, LDA, M, MODE, N, 00187 $ NERRS, NFAIL, NIMAT, NRHS, NRUN 00188 DOUBLE PRECISION ANORM, CNDNUM 00189 * .. 00190 * .. Local Arrays .. 00191 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00192 DOUBLE PRECISION RESULT( NTESTS ) 00193 * .. 00194 * .. Local Variables .. 00195 INTEGER ITER, KASE 00196 * .. 00197 * .. External Subroutines .. 00198 EXTERNAL ALAERH, ALAHD, DGET08, DLACPY, DLARHS, DLASET, 00199 $ DLATB4, DLATMS 00200 * .. 00201 * .. Intrinsic Functions .. 00202 INTRINSIC DBLE, MAX, MIN, SQRT 00203 * .. 00204 * .. Scalars in Common .. 00205 LOGICAL LERR, OK 00206 CHARACTER*32 SRNAMT 00207 INTEGER INFOT, NUNIT 00208 * .. 00209 * .. Common blocks .. 00210 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00211 COMMON / SRNAMC / SRNAMT 00212 * .. 00213 * .. Data statements .. 00214 DATA ISEEDY / 2006, 2007, 2008, 2009 / 00215 * .. 00216 * .. Executable Statements .. 00217 * 00218 * Initialize constants and the random number seed. 00219 * 00220 KASE = 0 00221 PATH( 1: 1 ) = 'Double precision' 00222 PATH( 2: 3 ) = 'GE' 00223 NRUN = 0 00224 NFAIL = 0 00225 NERRS = 0 00226 DO 10 I = 1, 4 00227 ISEED( I ) = ISEEDY( I ) 00228 10 CONTINUE 00229 * 00230 INFOT = 0 00231 * 00232 * Do for each value of M in MVAL 00233 * 00234 DO 120 IM = 1, NM 00235 M = MVAL( IM ) 00236 LDA = MAX( 1, M ) 00237 * 00238 N = M 00239 NIMAT = NTYPES 00240 IF( M.LE.0 .OR. N.LE.0 ) 00241 $ NIMAT = 1 00242 * 00243 DO 100 IMAT = 1, NIMAT 00244 * 00245 * Do the tests only if DOTYPE( IMAT ) is true. 00246 * 00247 IF( .NOT.DOTYPE( IMAT ) ) 00248 $ GO TO 100 00249 * 00250 * Skip types 5, 6, or 7 if the matrix size is too small. 00251 * 00252 ZEROT = IMAT.GE.5 .AND. IMAT.LE.7 00253 IF( ZEROT .AND. N.LT.IMAT-4 ) 00254 $ GO TO 100 00255 * 00256 * Set up parameters with DLATB4 and generate a test matrix 00257 * with DLATMS. 00258 * 00259 CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, 00260 $ CNDNUM, DIST ) 00261 * 00262 SRNAMT = 'DLATMS' 00263 CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE, 00264 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA, 00265 $ WORK, INFO ) 00266 * 00267 * Check error code from DLATMS. 00268 * 00269 IF( INFO.NE.0 ) THEN 00270 CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, -1, 00271 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00272 GO TO 100 00273 END IF 00274 * 00275 * For types 5-7, zero one or more columns of the matrix to 00276 * test that INFO is returned correctly. 00277 * 00278 IF( ZEROT ) THEN 00279 IF( IMAT.EQ.5 ) THEN 00280 IZERO = 1 00281 ELSE IF( IMAT.EQ.6 ) THEN 00282 IZERO = MIN( M, N ) 00283 ELSE 00284 IZERO = MIN( M, N ) / 2 + 1 00285 END IF 00286 IOFF = ( IZERO-1 )*LDA 00287 IF( IMAT.LT.7 ) THEN 00288 DO 20 I = 1, M 00289 A( IOFF+I ) = ZERO 00290 20 CONTINUE 00291 ELSE 00292 CALL DLASET( 'Full', M, N-IZERO+1, ZERO, ZERO, 00293 $ A( IOFF+1 ), LDA ) 00294 END IF 00295 ELSE 00296 IZERO = 0 00297 END IF 00298 * 00299 DO 60 IRHS = 1, NNS 00300 NRHS = NSVAL( IRHS ) 00301 XTYPE = 'N' 00302 TRANS = 'N' 00303 * 00304 SRNAMT = 'DLARHS' 00305 CALL DLARHS( PATH, XTYPE, ' ', TRANS, N, N, KL, 00306 $ KU, NRHS, A, LDA, X, LDA, B, 00307 $ LDA, ISEED, INFO ) 00308 * 00309 SRNAMT = 'DSGESV' 00310 * 00311 KASE = KASE + 1 00312 * 00313 CALL DLACPY( 'Full', M, N, A, LDA, AFAC, LDA ) 00314 * 00315 CALL DSGESV( N, NRHS, A, LDA, IWORK, B, LDA, X, LDA, 00316 $ WORK, SWORK, ITER, INFO) 00317 * 00318 IF (ITER.LT.0) THEN 00319 CALL DLACPY( 'Full', M, N, AFAC, LDA, A, LDA ) 00320 ENDIF 00321 * 00322 * Check error code from DSGESV. This should be the same as 00323 * the one of DGETRF. 00324 * 00325 IF( INFO.NE.IZERO ) THEN 00326 * 00327 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00328 $ CALL ALAHD( NOUT, PATH ) 00329 NERRS = NERRS + 1 00330 * 00331 IF( INFO.NE.IZERO .AND. IZERO.NE.0 ) THEN 00332 WRITE( NOUT, FMT = 9988 )'DSGESV',INFO, 00333 $ IZERO,M,IMAT 00334 ELSE 00335 WRITE( NOUT, FMT = 9975 )'DSGESV',INFO, 00336 $ M, IMAT 00337 END IF 00338 END IF 00339 * 00340 * Skip the remaining test if the matrix is singular. 00341 * 00342 IF( INFO.NE.0 ) 00343 $ GO TO 100 00344 * 00345 * Check the quality of the solution 00346 * 00347 CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 00348 * 00349 CALL DGET08( TRANS, N, N, NRHS, A, LDA, X, LDA, WORK, 00350 $ LDA, RWORK, RESULT( 1 ) ) 00351 * 00352 * Check if the test passes the tesing. 00353 * Print information about the tests that did not 00354 * pass the testing. 00355 * 00356 * If iterative refinement has been used and claimed to 00357 * be successful (ITER>0), we want 00358 * NORMI(B - A*X)/(NORMI(A)*NORMI(X)*EPS*SRQT(N)) < 1 00359 * 00360 * If double precision has been used (ITER<0), we want 00361 * NORMI(B - A*X)/(NORMI(A)*NORMI(X)*EPS) < THRES 00362 * (Cf. the linear solver testing routines) 00363 * 00364 IF ((THRESH.LE.0.0E+00) 00365 $ .OR.((ITER.GE.0).AND.(N.GT.0) 00366 $ .AND.(RESULT(1).GE.SQRT(DBLE(N)))) 00367 $ .OR.((ITER.LT.0).AND.(RESULT(1).GE.THRESH))) THEN 00368 * 00369 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN 00370 WRITE( NOUT, FMT = 8999 )'DGE' 00371 WRITE( NOUT, FMT = '( '' Matrix types:'' )' ) 00372 WRITE( NOUT, FMT = 8979 ) 00373 WRITE( NOUT, FMT = '( '' Test ratios:'' )' ) 00374 WRITE( NOUT, FMT = 8960 )1 00375 WRITE( NOUT, FMT = '( '' Messages:'' )' ) 00376 END IF 00377 * 00378 WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS, 00379 $ IMAT, 1, RESULT( 1 ) 00380 NFAIL = NFAIL + 1 00381 END IF 00382 NRUN = NRUN + 1 00383 60 CONTINUE 00384 100 CONTINUE 00385 120 CONTINUE 00386 * 00387 * Print a summary of the results. 00388 * 00389 IF( NFAIL.GT.0 ) THEN 00390 WRITE( NOUT, FMT = 9996 )'DSGESV', NFAIL, NRUN 00391 ELSE 00392 WRITE( NOUT, FMT = 9995 )'DSGESV', NRUN 00393 END IF 00394 IF( NERRS.GT.0 ) THEN 00395 WRITE( NOUT, FMT = 9994 )NERRS 00396 END IF 00397 * 00398 9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 00399 $ I2, ', test(', I2, ') =', G12.5 ) 00400 9996 FORMAT( 1X, A6, ': ', I6, ' out of ', I6, 00401 $ ' tests failed to pass the threshold' ) 00402 9995 FORMAT( /1X, 'All tests for ', A6, 00403 $ ' routines passed the threshold ( ', I6, ' tests run)' ) 00404 9994 FORMAT( 6X, I6, ' error messages recorded' ) 00405 * 00406 * SUBNAM, INFO, INFOE, M, IMAT 00407 * 00408 9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', 00409 $ I5, / ' ==> M =', I5, ', type ', 00410 $ I2 ) 00411 * 00412 * SUBNAM, INFO, M, IMAT 00413 * 00414 9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5, 00415 $ ', type ', I2 ) 00416 8999 FORMAT( / 1X, A3, ': General dense matrices' ) 00417 8979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X, 00418 $ '2. Upper triangular', 16X, 00419 $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, 00420 $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS', 00421 $ / 4X, '4. Random, CNDNUM = 2', 13X, 00422 $ '10. Scaled near underflow', / 4X, '5. First column zero', 00423 $ 14X, '11. Scaled near overflow', / 4X, 00424 $ '6. Last column zero' ) 00425 8960 FORMAT( 3X, I2, ': norm_1( B - A * X ) / ', 00426 $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', 00427 $ / 4x, 'or norm_1( B - A * X ) / ', 00428 $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if DGETRF' ) 00429 RETURN 00430 * 00431 * End of DDRVAB 00432 * 00433 END