LAPACK: TESTING/LIN/ddrvab.f Source File

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