LAPACK: TESTING/LIN/zdrvac.f Source File

Go to the documentation of this file.
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