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