LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
ddrvac.f
Go to the documentation of this file.
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
 All Files Functions