|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, 00002 $ A, AFAC, B, X, WORK, 00003 $ RWORK, SWORK, NOUT ) 00004 * 00005 * -- LAPACK test routine (version 3.1.2) -- 00006 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00007 * May 2007 00008 * 00009 * .. Scalar Arguments .. 00010 INTEGER NMAX, NM, NNS, NOUT 00011 DOUBLE PRECISION THRESH 00012 * .. 00013 * .. Array Arguments .. 00014 LOGICAL DOTYPE( * ) 00015 INTEGER MVAL( * ), NSVAL( * ) 00016 DOUBLE PRECISION RWORK( * ) 00017 COMPLEX SWORK(*) 00018 COMPLEX*16 A( * ), AFAC( * ), B( * ), 00019 $ WORK( * ), X( * ) 00020 * .. 00021 * 00022 * Purpose 00023 * ======= 00024 * 00025 * ZDRVAC tests ZCPOSV. 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 N contained in the vector MVAL. 00037 * 00038 * MVAL (input) INTEGER array, dimension (NM) 00039 * The values of the matrix dimension N. 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 N, used in dimensioning the 00054 * work arrays. 00055 * 00056 * A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) 00057 * 00058 * AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) 00059 * 00060 * B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) 00061 * 00062 * X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) 00063 * 00064 * WORK (workspace) COMPLEX*16 array, dimension 00065 * (NMAX*max(3,NSMAX)) 00066 * 00067 * RWORK (workspace) DOUBLE PRECISION array, dimension 00068 * (max(2*NMAX,2*NSMAX+NWORK)) 00069 * 00070 * SWORK (workspace) COMPLEX array, dimension 00071 * (NMAX*(NSMAX+NMAX)) 00072 * 00073 * NOUT (input) INTEGER 00074 * The unit number for output. 00075 * 00076 * ===================================================================== 00077 * 00078 * .. Parameters .. 00079 DOUBLE PRECISION ONE, ZERO 00080 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) 00081 INTEGER NTYPES 00082 PARAMETER ( NTYPES = 9 ) 00083 INTEGER NTESTS 00084 PARAMETER ( NTESTS = 1 ) 00085 * .. 00086 * .. Local Scalars .. 00087 LOGICAL ZEROT 00088 CHARACTER DIST, TYPE, UPLO, XTYPE 00089 CHARACTER*3 PATH 00090 INTEGER I, IM, IMAT, INFO, IOFF, IRHS, IUPLO, 00091 $ IZERO, KL, KU, LDA, MODE, N, 00092 $ NERRS, NFAIL, NIMAT, NRHS, NRUN 00093 DOUBLE PRECISION ANORM, CNDNUM 00094 * .. 00095 * .. Local Arrays .. 00096 CHARACTER UPLOS( 2 ) 00097 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00098 DOUBLE PRECISION RESULT( NTESTS ) 00099 * .. 00100 * .. Local Variables .. 00101 INTEGER ITER, KASE 00102 * .. 00103 * .. External Functions .. 00104 LOGICAL LSAME 00105 EXTERNAL LSAME 00106 * .. 00107 * .. External Subroutines .. 00108 EXTERNAL ALAERH, ZLACPY, ZLAIPD, 00109 $ ZLARHS, ZLATB4, ZLATMS, 00110 $ ZPOT06, ZCPOSV 00111 * .. 00112 * .. Intrinsic Functions .. 00113 INTRINSIC DBLE, MAX, SQRT 00114 * .. 00115 * .. Scalars in Common .. 00116 LOGICAL LERR, OK 00117 CHARACTER*32 SRNAMT 00118 INTEGER INFOT, NUNIT 00119 * .. 00120 * .. Common blocks .. 00121 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00122 COMMON / SRNAMC / SRNAMT 00123 * .. 00124 * .. Data statements .. 00125 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00126 DATA UPLOS / 'U', 'L' / 00127 * .. 00128 * .. Executable Statements .. 00129 * 00130 * Initialize constants and the random number seed. 00131 * 00132 KASE = 0 00133 PATH( 1: 1 ) = 'Zomplex precision' 00134 PATH( 2: 3 ) = 'PO' 00135 NRUN = 0 00136 NFAIL = 0 00137 NERRS = 0 00138 DO 10 I = 1, 4 00139 ISEED( I ) = ISEEDY( I ) 00140 10 CONTINUE 00141 * 00142 INFOT = 0 00143 * 00144 * Do for each value of N in MVAL 00145 * 00146 DO 120 IM = 1, NM 00147 N = MVAL( IM ) 00148 LDA = MAX( N, 1 ) 00149 NIMAT = NTYPES 00150 IF( N.LE.0 ) 00151 $ NIMAT = 1 00152 * 00153 DO 110 IMAT = 1, NIMAT 00154 * 00155 * Do the tests only if DOTYPE( IMAT ) is true. 00156 * 00157 IF( .NOT.DOTYPE( IMAT ) ) 00158 $ GO TO 110 00159 * 00160 * Skip types 3, 4, or 5 if the matrix size is too small. 00161 * 00162 ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 00163 IF( ZEROT .AND. N.LT.IMAT-2 ) 00164 $ GO TO 110 00165 * 00166 * Do first for UPLO = 'U', then for UPLO = 'L' 00167 * 00168 DO 100 IUPLO = 1, 2 00169 UPLO = UPLOS( IUPLO ) 00170 * 00171 * Set up parameters with ZLATB4 and generate a test matrix 00172 * with ZLATMS. 00173 * 00174 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00175 $ CNDNUM, DIST ) 00176 * 00177 SRNAMT = 'ZLATMS' 00178 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 00179 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, 00180 $ INFO ) 00181 * 00182 * Check error code from ZLATMS. 00183 * 00184 IF( INFO.NE.0 ) THEN 00185 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1, 00186 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00187 GO TO 100 00188 END IF 00189 * 00190 * For types 3-5, zero one row and column of the matrix to 00191 * test that INFO is returned correctly. 00192 * 00193 IF( ZEROT ) THEN 00194 IF( IMAT.EQ.3 ) THEN 00195 IZERO = 1 00196 ELSE IF( IMAT.EQ.4 ) THEN 00197 IZERO = N 00198 ELSE 00199 IZERO = N / 2 + 1 00200 END IF 00201 IOFF = ( IZERO-1 )*LDA 00202 * 00203 * Set row and column IZERO of A to 0. 00204 * 00205 IF( IUPLO.EQ.1 ) THEN 00206 DO 20 I = 1, IZERO - 1 00207 A( IOFF+I ) = ZERO 00208 20 CONTINUE 00209 IOFF = IOFF + IZERO 00210 DO 30 I = IZERO, N 00211 A( IOFF ) = ZERO 00212 IOFF = IOFF + LDA 00213 30 CONTINUE 00214 ELSE 00215 IOFF = IZERO 00216 DO 40 I = 1, IZERO - 1 00217 A( IOFF ) = ZERO 00218 IOFF = IOFF + LDA 00219 40 CONTINUE 00220 IOFF = IOFF - IZERO 00221 DO 50 I = IZERO, N 00222 A( IOFF+I ) = ZERO 00223 50 CONTINUE 00224 END IF 00225 ELSE 00226 IZERO = 0 00227 END IF 00228 * 00229 * Set the imaginary part of the diagonals. 00230 * 00231 CALL ZLAIPD( N, A, LDA+1, 0 ) 00232 * 00233 DO 60 IRHS = 1, NNS 00234 NRHS = NSVAL( IRHS ) 00235 XTYPE = 'N' 00236 * 00237 * Form an exact solution and set the right hand side. 00238 * 00239 SRNAMT = 'ZLARHS' 00240 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 00241 $ NRHS, A, LDA, X, LDA, B, LDA, 00242 $ ISEED, INFO ) 00243 * 00244 * Compute the L*L' or U'*U factorization of the 00245 * matrix and solve the system. 00246 * 00247 SRNAMT = 'ZCPOSV ' 00248 KASE = KASE + 1 00249 * 00250 CALL ZLACPY( 'All', N, N, A, LDA, AFAC, LDA) 00251 * 00252 CALL ZCPOSV( UPLO, N, NRHS, AFAC, LDA, B, LDA, X, LDA, 00253 $ WORK, SWORK, RWORK, ITER, INFO ) 00254 * 00255 IF (ITER.LT.0) THEN 00256 CALL ZLACPY( 'All', N, N, A, LDA, AFAC, LDA ) 00257 ENDIF 00258 * 00259 * Check error code from ZCPOSV . 00260 * 00261 IF( INFO.NE.IZERO ) THEN 00262 * 00263 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00264 $ CALL ALAHD( NOUT, PATH ) 00265 NERRS = NERRS + 1 00266 * 00267 IF( INFO.NE.IZERO .AND. IZERO.NE.0 ) THEN 00268 WRITE( NOUT, FMT = 9988 )'ZCPOSV',INFO,IZERO,N, 00269 $ IMAT 00270 ELSE 00271 WRITE( NOUT, FMT = 9975 )'ZCPOSV',INFO,N,IMAT 00272 END IF 00273 END IF 00274 * 00275 * Skip the remaining test if the matrix is singular. 00276 * 00277 IF( INFO.NE.0 ) 00278 $ GO TO 110 00279 * 00280 * Check the quality of the solution 00281 * 00282 CALL ZLACPY( 'All', N, NRHS, B, LDA, WORK, LDA ) 00283 * 00284 CALL ZPOT06( UPLO, N, NRHS, A, LDA, X, LDA, WORK, 00285 $ LDA, RWORK, RESULT( 1 ) ) 00286 * 00287 * Check if the test passes the tesing. 00288 * Print information about the tests that did not 00289 * pass the testing. 00290 * 00291 * If iterative refinement has been used and claimed to 00292 * be successful (ITER>0), we want 00293 * NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 00294 * 00295 * If double precision has been used (ITER<0), we want 00296 * NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES 00297 * (Cf. the linear solver testing routines) 00298 * 00299 IF ((THRESH.LE.0.0E+00) 00300 $ .OR.((ITER.GE.0).AND.(N.GT.0) 00301 $ .AND.(RESULT(1).GE.SQRT(DBLE(N)))) 00302 $ .OR.((ITER.LT.0).AND.(RESULT(1).GE.THRESH))) THEN 00303 * 00304 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN 00305 WRITE( NOUT, FMT = 8999 )'ZPO' 00306 WRITE( NOUT, FMT = '( '' Matrix types:'' )' ) 00307 WRITE( NOUT, FMT = 8979 ) 00308 WRITE( NOUT, FMT = '( '' Test ratios:'' )' ) 00309 WRITE( NOUT, FMT = 8960 )1 00310 WRITE( NOUT, FMT = '( '' Messages:'' )' ) 00311 END IF 00312 * 00313 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT, 1, 00314 $ RESULT( 1 ) 00315 * 00316 NFAIL = NFAIL + 1 00317 * 00318 END IF 00319 * 00320 NRUN = NRUN + 1 00321 * 00322 60 CONTINUE 00323 100 CONTINUE 00324 110 CONTINUE 00325 120 CONTINUE 00326 * 00327 130 CONTINUE 00328 * 00329 * Print a summary of the results. 00330 * 00331 IF( NFAIL.GT.0 ) THEN 00332 WRITE( NOUT, FMT = 9996 )'ZCPOSV', NFAIL, NRUN 00333 ELSE 00334 WRITE( NOUT, FMT = 9995 )'ZCPOSV', NRUN 00335 END IF 00336 IF( NERRS.GT.0 ) THEN 00337 WRITE( NOUT, FMT = 9994 )NERRS 00338 END IF 00339 * 00340 9998 FORMAT( ' UPLO=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 00341 $ I2, ', test(', I2, ') =', G12.5 ) 00342 9996 FORMAT( 1X, A6, ': ', I6, ' out of ', I6, 00343 $ ' tests failed to pass the threshold' ) 00344 9995 FORMAT( /1X, 'All tests for ', A6, 00345 $ ' routines passed the threshold (', I6, ' tests run)' ) 00346 9994 FORMAT( 6X, I6, ' error messages recorded' ) 00347 * 00348 * SUBNAM, INFO, INFOE, N, IMAT 00349 * 00350 9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', 00351 $ I5, / ' ==> N =', I5, ', type ', 00352 $ I2 ) 00353 * 00354 * SUBNAM, INFO, N, IMAT 00355 * 00356 9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5, 00357 $ ', type ', I2 ) 00358 8999 FORMAT( / 1X, A3, ': positive definite dense matrices' ) 00359 8979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X, 00360 $ '2. Upper triangular', 16X, 00361 $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, 00362 $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS', 00363 $ / 4X, '4. Random, CNDNUM = 2', 13X, 00364 $ '10. Scaled near underflow', / 4X, '5. First column zero', 00365 $ 14X, '11. Scaled near overflow', / 4X, 00366 $ '6. Last column zero' ) 00367 8960 FORMAT( 3X, I2, ': norm_1( B - A * X ) / ', 00368 $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', 00369 $ / 4x, 'or norm_1( B - A * X ) / ', 00370 $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if ZPOTRF' ) 00371 00372 RETURN 00373 * 00374 * End of ZDRVAC 00375 * 00376 END
1.7.3 
