![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b DDRVAC 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 DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, 00012 * A, AFAC, B, X, WORK, 00013 * RWORK, SWORK, NOUT ) 00014 * 00015 * .. Scalar Arguments .. 00016 * INTEGER NMAX, NM, NNS, NOUT 00017 * DOUBLE PRECISION THRESH 00018 * .. 00019 * .. Array Arguments .. 00020 * LOGICAL DOTYPE( * ) 00021 * INTEGER MVAL( * ), NSVAL( * ) 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 *> DDRVAC tests DSPOSV. 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 N 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 dimension N. 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 N, used in dimensioning the 00083 *> 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 *> \endverbatim 00100 *> 00101 *> \param[out] X 00102 *> \verbatim 00103 *> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX) 00104 *> \endverbatim 00105 *> 00106 *> \param[out] WORK 00107 *> \verbatim 00108 *> WORK is DOUBLE PRECISION array, dimension 00109 *> (NMAX*max(3,NSMAX)) 00110 *> \endverbatim 00111 *> 00112 *> \param[out] RWORK 00113 *> \verbatim 00114 *> RWORK is DOUBLE PRECISION array, dimension 00115 *> (max(2*NMAX,2*NSMAX+NWORK)) 00116 *> \endverbatim 00117 *> 00118 *> \param[out] SWORK 00119 *> \verbatim 00120 *> SWORK is REAL array, dimension 00121 *> (NMAX*(NSMAX+NMAX)) 00122 *> \endverbatim 00123 *> 00124 *> \param[in] NOUT 00125 *> \verbatim 00126 *> NOUT is INTEGER 00127 *> The unit number for output. 00128 *> \endverbatim 00129 * 00130 * Authors: 00131 * ======== 00132 * 00133 *> \author Univ. of Tennessee 00134 *> \author Univ. of California Berkeley 00135 *> \author Univ. of Colorado Denver 00136 *> \author NAG Ltd. 00137 * 00138 *> \date November 2011 00139 * 00140 *> \ingroup double_lin 00141 * 00142 * ===================================================================== 00143 SUBROUTINE DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, 00144 $ A, AFAC, B, X, WORK, 00145 $ RWORK, SWORK, NOUT ) 00146 * 00147 * -- LAPACK test routine (version 3.4.0) -- 00148 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00149 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00150 * November 2011 00151 * 00152 * .. Scalar Arguments .. 00153 INTEGER NMAX, NM, NNS, NOUT 00154 DOUBLE PRECISION THRESH 00155 * .. 00156 * .. Array Arguments .. 00157 LOGICAL DOTYPE( * ) 00158 INTEGER MVAL( * ), NSVAL( * ) 00159 REAL SWORK(*) 00160 DOUBLE PRECISION A( * ), AFAC( * ), B( * ), 00161 $ RWORK( * ), WORK( * ), X( * ) 00162 * .. 00163 * 00164 * ===================================================================== 00165 * 00166 * .. Parameters .. 00167 DOUBLE PRECISION ZERO 00168 PARAMETER ( ZERO = 0.0D+0 ) 00169 INTEGER NTYPES 00170 PARAMETER ( NTYPES = 9 ) 00171 INTEGER NTESTS 00172 PARAMETER ( NTESTS = 1 ) 00173 * .. 00174 * .. Local Scalars .. 00175 LOGICAL ZEROT 00176 CHARACTER DIST, TYPE, UPLO, XTYPE 00177 CHARACTER*3 PATH 00178 INTEGER I, IM, IMAT, INFO, IOFF, IRHS, IUPLO, 00179 $ IZERO, KL, KU, LDA, MODE, N, 00180 $ NERRS, NFAIL, NIMAT, NRHS, NRUN 00181 DOUBLE PRECISION ANORM, CNDNUM 00182 * .. 00183 * .. Local Arrays .. 00184 CHARACTER UPLOS( 2 ) 00185 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00186 DOUBLE PRECISION RESULT( NTESTS ) 00187 * .. 00188 * .. Local Variables .. 00189 INTEGER ITER, KASE 00190 * .. 00191 * .. External Functions .. 00192 LOGICAL LSAME 00193 EXTERNAL LSAME 00194 * .. 00195 * .. External Subroutines .. 00196 EXTERNAL ALAERH, DLACPY, 00197 $ DLARHS, DLASET, DLATB4, DLATMS, 00198 $ DPOT06, DSPOSV 00199 * .. 00200 * .. Intrinsic Functions .. 00201 INTRINSIC DBLE, MAX, SQRT 00202 * .. 00203 * .. Scalars in Common .. 00204 LOGICAL LERR, OK 00205 CHARACTER*32 SRNAMT 00206 INTEGER INFOT, NUNIT 00207 * .. 00208 * .. Common blocks .. 00209 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00210 COMMON / SRNAMC / SRNAMT 00211 * .. 00212 * .. Data statements .. 00213 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00214 DATA UPLOS / 'U', 'L' / 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 ) = 'PO' 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 N in MVAL 00233 * 00234 DO 120 IM = 1, NM 00235 N = MVAL( IM ) 00236 LDA = MAX( N, 1 ) 00237 NIMAT = NTYPES 00238 IF( N.LE.0 ) 00239 $ NIMAT = 1 00240 * 00241 DO 110 IMAT = 1, NIMAT 00242 * 00243 * Do the tests only if DOTYPE( IMAT ) is true. 00244 * 00245 IF( .NOT.DOTYPE( IMAT ) ) 00246 $ GO TO 110 00247 * 00248 * Skip types 3, 4, or 5 if the matrix size is too small. 00249 * 00250 ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 00251 IF( ZEROT .AND. N.LT.IMAT-2 ) 00252 $ GO TO 110 00253 * 00254 * Do first for UPLO = 'U', then for UPLO = 'L' 00255 * 00256 DO 100 IUPLO = 1, 2 00257 UPLO = UPLOS( IUPLO ) 00258 * 00259 * Set up parameters with DLATB4 and generate a test matrix 00260 * with DLATMS. 00261 * 00262 CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00263 $ CNDNUM, DIST ) 00264 * 00265 SRNAMT = 'DLATMS' 00266 CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 00267 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, 00268 $ INFO ) 00269 * 00270 * Check error code from DLATMS. 00271 * 00272 IF( INFO.NE.0 ) THEN 00273 CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, 00274 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00275 GO TO 100 00276 END IF 00277 * 00278 * For types 3-5, zero one row and column of the matrix to 00279 * test that INFO is returned correctly. 00280 * 00281 IF( ZEROT ) THEN 00282 IF( IMAT.EQ.3 ) THEN 00283 IZERO = 1 00284 ELSE IF( IMAT.EQ.4 ) THEN 00285 IZERO = N 00286 ELSE 00287 IZERO = N / 2 + 1 00288 END IF 00289 IOFF = ( IZERO-1 )*LDA 00290 * 00291 * Set row and column IZERO of A to 0. 00292 * 00293 IF( IUPLO.EQ.1 ) THEN 00294 DO 20 I = 1, IZERO - 1 00295 A( IOFF+I ) = ZERO 00296 20 CONTINUE 00297 IOFF = IOFF + IZERO 00298 DO 30 I = IZERO, N 00299 A( IOFF ) = ZERO 00300 IOFF = IOFF + LDA 00301 30 CONTINUE 00302 ELSE 00303 IOFF = IZERO 00304 DO 40 I = 1, IZERO - 1 00305 A( IOFF ) = ZERO 00306 IOFF = IOFF + LDA 00307 40 CONTINUE 00308 IOFF = IOFF - IZERO 00309 DO 50 I = IZERO, N 00310 A( IOFF+I ) = ZERO 00311 50 CONTINUE 00312 END IF 00313 ELSE 00314 IZERO = 0 00315 END IF 00316 * 00317 DO 60 IRHS = 1, NNS 00318 NRHS = NSVAL( IRHS ) 00319 XTYPE = 'N' 00320 * 00321 * Form an exact solution and set the right hand side. 00322 * 00323 SRNAMT = 'DLARHS' 00324 CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 00325 $ NRHS, A, LDA, X, LDA, B, LDA, 00326 $ ISEED, INFO ) 00327 * 00328 * Compute the L*L' or U'*U factorization of the 00329 * matrix and solve the system. 00330 * 00331 SRNAMT = 'DSPOSV ' 00332 KASE = KASE + 1 00333 * 00334 CALL DLACPY( 'All', N, N, A, LDA, AFAC, LDA) 00335 * 00336 CALL DSPOSV( UPLO, N, NRHS, AFAC, LDA, B, LDA, X, LDA, 00337 $ WORK, SWORK, ITER, INFO ) 00338 00339 IF (ITER.LT.0) THEN 00340 CALL DLACPY( 'All', N, N, A, LDA, AFAC, LDA ) 00341 ENDIF 00342 * 00343 * Check error code from DSPOSV . 00344 * 00345 IF( INFO.NE.IZERO ) THEN 00346 * 00347 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00348 $ CALL ALAHD( NOUT, PATH ) 00349 NERRS = NERRS + 1 00350 * 00351 IF( INFO.NE.IZERO .AND. IZERO.NE.0 ) THEN 00352 WRITE( NOUT, FMT = 9988 )'DSPOSV',INFO,IZERO,N, 00353 $ IMAT 00354 ELSE 00355 WRITE( NOUT, FMT = 9975 )'DSPOSV',INFO,N,IMAT 00356 END IF 00357 END IF 00358 * 00359 * Skip the remaining test if the matrix is singular. 00360 * 00361 IF( INFO.NE.0 ) 00362 $ GO TO 110 00363 * 00364 * Check the quality of the solution 00365 * 00366 CALL DLACPY( 'All', N, NRHS, B, LDA, WORK, LDA ) 00367 * 00368 CALL DPOT06( UPLO, N, NRHS, A, LDA, X, LDA, WORK, 00369 $ LDA, RWORK, RESULT( 1 ) ) 00370 * 00371 * Check if the test passes the tesing. 00372 * Print information about the tests that did not 00373 * pass the testing. 00374 * 00375 * If iterative refinement has been used and claimed to 00376 * be successful (ITER>0), we want 00377 * NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 00378 * 00379 * If double precision has been used (ITER<0), we want 00380 * NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES 00381 * (Cf. the linear solver testing routines) 00382 * 00383 IF ((THRESH.LE.0.0E+00) 00384 $ .OR.((ITER.GE.0).AND.(N.GT.0) 00385 $ .AND.(RESULT(1).GE.SQRT(DBLE(N)))) 00386 $ .OR.((ITER.LT.0).AND.(RESULT(1).GE.THRESH))) THEN 00387 * 00388 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN 00389 WRITE( NOUT, FMT = 8999 )'DPO' 00390 WRITE( NOUT, FMT = '( '' Matrix types:'' )' ) 00391 WRITE( NOUT, FMT = 8979 ) 00392 WRITE( NOUT, FMT = '( '' Test ratios:'' )' ) 00393 WRITE( NOUT, FMT = 8960 )1 00394 WRITE( NOUT, FMT = '( '' Messages:'' )' ) 00395 END IF 00396 * 00397 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT, 1, 00398 $ RESULT( 1 ) 00399 * 00400 NFAIL = NFAIL + 1 00401 * 00402 END IF 00403 * 00404 NRUN = NRUN + 1 00405 * 00406 60 CONTINUE 00407 100 CONTINUE 00408 110 CONTINUE 00409 120 CONTINUE 00410 * 00411 * Print a summary of the results. 00412 * 00413 IF( NFAIL.GT.0 ) THEN 00414 WRITE( NOUT, FMT = 9996 )'DSPOSV', NFAIL, NRUN 00415 ELSE 00416 WRITE( NOUT, FMT = 9995 )'DSPOSV', NRUN 00417 END IF 00418 IF( NERRS.GT.0 ) THEN 00419 WRITE( NOUT, FMT = 9994 )NERRS 00420 END IF 00421 * 00422 9998 FORMAT( ' UPLO=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 00423 $ I2, ', test(', I2, ') =', G12.5 ) 00424 9996 FORMAT( 1X, A6, ': ', I6, ' out of ', I6, 00425 $ ' tests failed to pass the threshold' ) 00426 9995 FORMAT( /1X, 'All tests for ', A6, 00427 $ ' routines passed the threshold ( ', I6, ' tests run)' ) 00428 9994 FORMAT( 6X, I6, ' error messages recorded' ) 00429 * 00430 * SUBNAM, INFO, INFOE, N, IMAT 00431 * 00432 9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', 00433 $ I5, / ' ==> N =', I5, ', type ', 00434 $ I2 ) 00435 * 00436 * SUBNAM, INFO, N, IMAT 00437 * 00438 9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5, 00439 $ ', type ', I2 ) 00440 8999 FORMAT( / 1X, A3, ': positive definite dense matrices' ) 00441 8979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X, 00442 $ '2. Upper triangular', 16X, 00443 $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, 00444 $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS', 00445 $ / 4X, '4. Random, CNDNUM = 2', 13X, 00446 $ '10. Scaled near underflow', / 4X, '5. First column zero', 00447 $ 14X, '11. Scaled near overflow', / 4X, 00448 $ '6. Last column zero' ) 00449 8960 FORMAT( 3X, I2, ': norm_1( B - A * X ) / ', 00450 $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', 00451 $ / 4x, 'or norm_1( B - A * X ) / ', 00452 $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if DPOTRF' ) 00453 00454 RETURN 00455 * 00456 * End of DDRVAC 00457 * 00458 END