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