LAPACK 3.3.0

zchkgt.f

Go to the documentation of this file.
00001       SUBROUTINE ZCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
00002      $                   A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT )
00003 *
00004 *  -- LAPACK test routine (version 3.1) --
00005 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00006 *     November 2006
00007 *
00008 *     .. Scalar Arguments ..
00009       LOGICAL            TSTERR
00010       INTEGER            NN, NNS, NOUT
00011       DOUBLE PRECISION   THRESH
00012 *     ..
00013 *     .. Array Arguments ..
00014       LOGICAL            DOTYPE( * )
00015       INTEGER            IWORK( * ), NSVAL( * ), NVAL( * )
00016       DOUBLE PRECISION   RWORK( * )
00017       COMPLEX*16         A( * ), AF( * ), B( * ), WORK( * ), X( * ),
00018      $                   XACT( * )
00019 *     ..
00020 *
00021 *  Purpose
00022 *  =======
00023 *
00024 *  ZCHKGT tests ZGTTRF, -TRS, -RFS, and -CON
00025 *
00026 *  Arguments
00027 *  =========
00028 *
00029 *  DOTYPE  (input) LOGICAL array, dimension (NTYPES)
00030 *          The matrix types to be used for testing.  Matrices of type j
00031 *          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
00032 *          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
00033 *
00034 *  NN      (input) INTEGER
00035 *          The number of values of N contained in the vector NVAL.
00036 *
00037 *  NVAL    (input) INTEGER array, dimension (NN)
00038 *          The values of the matrix dimension N.
00039 *
00040 *  NNS     (input) INTEGER
00041 *          The number of values of NRHS contained in the vector NSVAL.
00042 *
00043 *  NSVAL   (input) INTEGER array, dimension (NNS)
00044 *          The values of the number of right hand sides NRHS.
00045 *
00046 *  THRESH  (input) DOUBLE PRECISION
00047 *          The threshold value for the test ratios.  A result is
00048 *          included in the output file if RESULT >= THRESH.  To have
00049 *          every test ratio printed, use THRESH = 0.
00050 *
00051 *  TSTERR  (input) LOGICAL
00052 *          Flag that indicates whether error exits are to be tested.
00053 *
00054 *  A       (workspace) COMPLEX*16 array, dimension (NMAX*4)
00055 *
00056 *  AF      (workspace) COMPLEX*16 array, dimension (NMAX*4)
00057 *
00058 *  B       (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
00059 *          where NSMAX is the largest entry in NSVAL.
00060 *
00061 *  X       (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
00062 *
00063 *  XACT    (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
00064 *
00065 *  WORK    (workspace) COMPLEX*16 array, dimension
00066 *                      (NMAX*max(3,NSMAX))
00067 *
00068 *  RWORK   (workspace) DOUBLE PRECISION array, dimension
00069 *                      (max(NMAX)+2*NSMAX)
00070 *
00071 *  IWORK   (workspace) INTEGER array, dimension (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 = 12 )
00083       INTEGER            NTESTS
00084       PARAMETER          ( NTESTS = 7 )
00085 *     ..
00086 *     .. Local Scalars ..
00087       LOGICAL            TRFCON, ZEROT
00088       CHARACTER          DIST, NORM, TRANS, TYPE
00089       CHARACTER*3        PATH
00090       INTEGER            I, IMAT, IN, INFO, IRHS, ITRAN, IX, IZERO, J,
00091      $                   K, KL, KOFF, KU, LDA, M, MODE, N, NERRS, NFAIL,
00092      $                   NIMAT, NRHS, NRUN
00093       DOUBLE PRECISION   AINVNM, ANORM, COND, RCOND, RCONDC, RCONDI,
00094      $                   RCONDO
00095 *     ..
00096 *     .. Local Arrays ..
00097       CHARACTER          TRANSS( 3 )
00098       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00099       DOUBLE PRECISION   RESULT( NTESTS )
00100       COMPLEX*16         Z( 3 )
00101 *     ..
00102 *     .. External Functions ..
00103       DOUBLE PRECISION   DGET06, DZASUM, ZLANGT
00104       EXTERNAL           DGET06, DZASUM, ZLANGT
00105 *     ..
00106 *     .. External Subroutines ..
00107       EXTERNAL           ALAERH, ALAHD, ALASUM, ZCOPY, ZDSCAL, ZERRGE,
00108      $                   ZGET04, ZGTCON, ZGTRFS, ZGTT01, ZGTT02, ZGTT05,
00109      $                   ZGTTRF, ZGTTRS, ZLACPY, ZLAGTM, ZLARNV, ZLATB4,
00110      $                   ZLATMS
00111 *     ..
00112 *     .. Intrinsic Functions ..
00113       INTRINSIC          MAX
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 / 0, 0, 0, 1 / , TRANSS / 'N', 'T',
00126      $                   'C' /
00127 *     ..
00128 *     .. Executable Statements ..
00129 *
00130       PATH( 1: 1 ) = 'Zomplex precision'
00131       PATH( 2: 3 ) = 'GT'
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 *     Test the error exits
00140 *
00141       IF( TSTERR )
00142      $   CALL ZERRGE( PATH, NOUT )
00143       INFOT = 0
00144 *
00145       DO 110 IN = 1, NN
00146 *
00147 *        Do for each value of N in NVAL.
00148 *
00149          N = NVAL( IN )
00150          M = MAX( N-1, 0 )
00151          LDA = MAX( 1, N )
00152          NIMAT = NTYPES
00153          IF( N.LE.0 )
00154      $      NIMAT = 1
00155 *
00156          DO 100 IMAT = 1, NIMAT
00157 *
00158 *           Do the tests only if DOTYPE( IMAT ) is true.
00159 *
00160             IF( .NOT.DOTYPE( IMAT ) )
00161      $         GO TO 100
00162 *
00163 *           Set up parameters with ZLATB4.
00164 *
00165             CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
00166      $                   COND, DIST )
00167 *
00168             ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
00169             IF( IMAT.LE.6 ) THEN
00170 *
00171 *              Types 1-6:  generate matrices of known condition number.
00172 *
00173                KOFF = MAX( 2-KU, 3-MAX( 1, N ) )
00174                SRNAMT = 'ZLATMS'
00175                CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
00176      $                      ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
00177      $                      INFO )
00178 *
00179 *              Check the error code from ZLATMS.
00180 *
00181                IF( INFO.NE.0 ) THEN
00182                   CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', N, N, KL,
00183      $                         KU, -1, IMAT, NFAIL, NERRS, NOUT )
00184                   GO TO 100
00185                END IF
00186                IZERO = 0
00187 *
00188                IF( N.GT.1 ) THEN
00189                   CALL ZCOPY( N-1, AF( 4 ), 3, A, 1 )
00190                   CALL ZCOPY( N-1, AF( 3 ), 3, A( N+M+1 ), 1 )
00191                END IF
00192                CALL ZCOPY( N, AF( 2 ), 3, A( M+1 ), 1 )
00193             ELSE
00194 *
00195 *              Types 7-12:  generate tridiagonal matrices with
00196 *              unknown condition numbers.
00197 *
00198                IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
00199 *
00200 *                 Generate a matrix with elements whose real and
00201 *                 imaginary parts are from [-1,1].
00202 *
00203                   CALL ZLARNV( 2, ISEED, N+2*M, A )
00204                   IF( ANORM.NE.ONE )
00205      $               CALL ZDSCAL( N+2*M, ANORM, A, 1 )
00206                ELSE IF( IZERO.GT.0 ) THEN
00207 *
00208 *                 Reuse the last matrix by copying back the zeroed out
00209 *                 elements.
00210 *
00211                   IF( IZERO.EQ.1 ) THEN
00212                      A( N ) = Z( 2 )
00213                      IF( N.GT.1 )
00214      $                  A( 1 ) = Z( 3 )
00215                   ELSE IF( IZERO.EQ.N ) THEN
00216                      A( 3*N-2 ) = Z( 1 )
00217                      A( 2*N-1 ) = Z( 2 )
00218                   ELSE
00219                      A( 2*N-2+IZERO ) = Z( 1 )
00220                      A( N-1+IZERO ) = Z( 2 )
00221                      A( IZERO ) = Z( 3 )
00222                   END IF
00223                END IF
00224 *
00225 *              If IMAT > 7, set one column of the matrix to 0.
00226 *
00227                IF( .NOT.ZEROT ) THEN
00228                   IZERO = 0
00229                ELSE IF( IMAT.EQ.8 ) THEN
00230                   IZERO = 1
00231                   Z( 2 ) = A( N )
00232                   A( N ) = ZERO
00233                   IF( N.GT.1 ) THEN
00234                      Z( 3 ) = A( 1 )
00235                      A( 1 ) = ZERO
00236                   END IF
00237                ELSE IF( IMAT.EQ.9 ) THEN
00238                   IZERO = N
00239                   Z( 1 ) = A( 3*N-2 )
00240                   Z( 2 ) = A( 2*N-1 )
00241                   A( 3*N-2 ) = ZERO
00242                   A( 2*N-1 ) = ZERO
00243                ELSE
00244                   IZERO = ( N+1 ) / 2
00245                   DO 20 I = IZERO, N - 1
00246                      A( 2*N-2+I ) = ZERO
00247                      A( N-1+I ) = ZERO
00248                      A( I ) = ZERO
00249    20             CONTINUE
00250                   A( 3*N-2 ) = ZERO
00251                   A( 2*N-1 ) = ZERO
00252                END IF
00253             END IF
00254 *
00255 *+    TEST 1
00256 *           Factor A as L*U and compute the ratio
00257 *              norm(L*U - A) / (n * norm(A) * EPS )
00258 *
00259             CALL ZCOPY( N+2*M, A, 1, AF, 1 )
00260             SRNAMT = 'ZGTTRF'
00261             CALL ZGTTRF( N, AF, AF( M+1 ), AF( N+M+1 ), AF( N+2*M+1 ),
00262      $                   IWORK, INFO )
00263 *
00264 *           Check error code from ZGTTRF.
00265 *
00266             IF( INFO.NE.IZERO )
00267      $         CALL ALAERH( PATH, 'ZGTTRF', INFO, IZERO, ' ', N, N, 1,
00268      $                      1, -1, IMAT, NFAIL, NERRS, NOUT )
00269             TRFCON = INFO.NE.0
00270 *
00271             CALL ZGTT01( N, A, A( M+1 ), A( N+M+1 ), AF, AF( M+1 ),
00272      $                   AF( N+M+1 ), AF( N+2*M+1 ), IWORK, WORK, LDA,
00273      $                   RWORK, RESULT( 1 ) )
00274 *
00275 *           Print the test ratio if it is .GE. THRESH.
00276 *
00277             IF( RESULT( 1 ).GE.THRESH ) THEN
00278                IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00279      $            CALL ALAHD( NOUT, PATH )
00280                WRITE( NOUT, FMT = 9999 )N, IMAT, 1, RESULT( 1 )
00281                NFAIL = NFAIL + 1
00282             END IF
00283             NRUN = NRUN + 1
00284 *
00285             DO 50 ITRAN = 1, 2
00286                TRANS = TRANSS( ITRAN )
00287                IF( ITRAN.EQ.1 ) THEN
00288                   NORM = 'O'
00289                ELSE
00290                   NORM = 'I'
00291                END IF
00292                ANORM = ZLANGT( NORM, N, A, A( M+1 ), A( N+M+1 ) )
00293 *
00294                IF( .NOT.TRFCON ) THEN
00295 *
00296 *                 Use ZGTTRS to solve for one column at a time of
00297 *                 inv(A), computing the maximum column sum as we go.
00298 *
00299                   AINVNM = ZERO
00300                   DO 40 I = 1, N
00301                      DO 30 J = 1, N
00302                         X( J ) = ZERO
00303    30                CONTINUE
00304                      X( I ) = ONE
00305                      CALL ZGTTRS( TRANS, N, 1, AF, AF( M+1 ),
00306      $                            AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
00307      $                            LDA, INFO )
00308                      AINVNM = MAX( AINVNM, DZASUM( N, X, 1 ) )
00309    40             CONTINUE
00310 *
00311 *                 Compute RCONDC = 1 / (norm(A) * norm(inv(A))
00312 *
00313                   IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
00314                      RCONDC = ONE
00315                   ELSE
00316                      RCONDC = ( ONE / ANORM ) / AINVNM
00317                   END IF
00318                   IF( ITRAN.EQ.1 ) THEN
00319                      RCONDO = RCONDC
00320                   ELSE
00321                      RCONDI = RCONDC
00322                   END IF
00323                ELSE
00324                   RCONDC = ZERO
00325                END IF
00326 *
00327 *+    TEST 7
00328 *              Estimate the reciprocal of the condition number of the
00329 *              matrix.
00330 *
00331                SRNAMT = 'ZGTCON'
00332                CALL ZGTCON( NORM, N, AF, AF( M+1 ), AF( N+M+1 ),
00333      $                      AF( N+2*M+1 ), IWORK, ANORM, RCOND, WORK,
00334      $                      INFO )
00335 *
00336 *              Check error code from ZGTCON.
00337 *
00338                IF( INFO.NE.0 )
00339      $            CALL ALAERH( PATH, 'ZGTCON', INFO, 0, NORM, N, N, -1,
00340      $                         -1, -1, IMAT, NFAIL, NERRS, NOUT )
00341 *
00342                RESULT( 7 ) = DGET06( RCOND, RCONDC )
00343 *
00344 *              Print the test ratio if it is .GE. THRESH.
00345 *
00346                IF( RESULT( 7 ).GE.THRESH ) THEN
00347                   IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00348      $               CALL ALAHD( NOUT, PATH )
00349                   WRITE( NOUT, FMT = 9997 )NORM, N, IMAT, 7,
00350      $               RESULT( 7 )
00351                   NFAIL = NFAIL + 1
00352                END IF
00353                NRUN = NRUN + 1
00354    50       CONTINUE
00355 *
00356 *           Skip the remaining tests if the matrix is singular.
00357 *
00358             IF( TRFCON )
00359      $         GO TO 100
00360 *
00361             DO 90 IRHS = 1, NNS
00362                NRHS = NSVAL( IRHS )
00363 *
00364 *              Generate NRHS random solution vectors.
00365 *
00366                IX = 1
00367                DO 60 J = 1, NRHS
00368                   CALL ZLARNV( 2, ISEED, N, XACT( IX ) )
00369                   IX = IX + LDA
00370    60          CONTINUE
00371 *
00372                DO 80 ITRAN = 1, 3
00373                   TRANS = TRANSS( ITRAN )
00374                   IF( ITRAN.EQ.1 ) THEN
00375                      RCONDC = RCONDO
00376                   ELSE
00377                      RCONDC = RCONDI
00378                   END IF
00379 *
00380 *                 Set the right hand side.
00381 *
00382                   CALL ZLAGTM( TRANS, N, NRHS, ONE, A, A( M+1 ),
00383      $                         A( N+M+1 ), XACT, LDA, ZERO, B, LDA )
00384 *
00385 *+    TEST 2
00386 *              Solve op(A) * X = B and compute the residual.
00387 *
00388                   CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
00389                   SRNAMT = 'ZGTTRS'
00390                   CALL ZGTTRS( TRANS, N, NRHS, AF, AF( M+1 ),
00391      $                         AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
00392      $                         LDA, INFO )
00393 *
00394 *              Check error code from ZGTTRS.
00395 *
00396                   IF( INFO.NE.0 )
00397      $               CALL ALAERH( PATH, 'ZGTTRS', INFO, 0, TRANS, N, N,
00398      $                            -1, -1, NRHS, IMAT, NFAIL, NERRS,
00399      $                            NOUT )
00400 *
00401                   CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
00402                   CALL ZGTT02( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
00403      $                         X, LDA, WORK, LDA, RWORK, RESULT( 2 ) )
00404 *
00405 *+    TEST 3
00406 *              Check solution from generated exact solution.
00407 *
00408                   CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
00409      $                         RESULT( 3 ) )
00410 *
00411 *+    TESTS 4, 5, and 6
00412 *              Use iterative refinement to improve the solution.
00413 *
00414                   SRNAMT = 'ZGTRFS'
00415                   CALL ZGTRFS( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
00416      $                         AF, AF( M+1 ), AF( N+M+1 ),
00417      $                         AF( N+2*M+1 ), IWORK, B, LDA, X, LDA,
00418      $                         RWORK, RWORK( NRHS+1 ), WORK,
00419      $                         RWORK( 2*NRHS+1 ), INFO )
00420 *
00421 *              Check error code from ZGTRFS.
00422 *
00423                   IF( INFO.NE.0 )
00424      $               CALL ALAERH( PATH, 'ZGTRFS', INFO, 0, TRANS, N, N,
00425      $                            -1, -1, NRHS, IMAT, NFAIL, NERRS,
00426      $                            NOUT )
00427 *
00428                   CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
00429      $                         RESULT( 4 ) )
00430                   CALL ZGTT05( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
00431      $                         B, LDA, X, LDA, XACT, LDA, RWORK,
00432      $                         RWORK( NRHS+1 ), RESULT( 5 ) )
00433 *
00434 *              Print information about the tests that did not pass the
00435 *              threshold.
00436 *
00437                   DO 70 K = 2, 6
00438                      IF( RESULT( K ).GE.THRESH ) THEN
00439                         IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00440      $                     CALL ALAHD( NOUT, PATH )
00441                         WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS, IMAT,
00442      $                     K, RESULT( K )
00443                         NFAIL = NFAIL + 1
00444                      END IF
00445    70             CONTINUE
00446                   NRUN = NRUN + 5
00447    80          CONTINUE
00448    90       CONTINUE
00449   100    CONTINUE
00450   110 CONTINUE
00451 *
00452 *     Print a summary of the results.
00453 *
00454       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00455 *
00456  9999 FORMAT( 12X, 'N =', I5, ',', 10X, ' type ', I2, ', test(', I2,
00457      $      ') = ', G12.5 )
00458  9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
00459      $      I2, ', test(', I2, ') = ', G12.5 )
00460  9997 FORMAT( ' NORM =''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
00461      $      ', test(', I2, ') = ', G12.5 )
00462       RETURN
00463 *
00464 *     End of ZCHKGT
00465 *
00466       END
 All Files Functions