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