LAPACK 3.3.1 Linear Algebra PACKage

# dchktp.f

Go to the documentation of this file.
```00001       SUBROUTINE DCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
00002      \$                   NMAX, AP, AINVP, B, X, XACT, WORK, RWORK,
00003      \$                   IWORK, NOUT )
00004 *
00005 *  -- LAPACK test routine (version 3.1) --
00006 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00007 *     November 2006
00008 *
00009 *     .. Scalar Arguments ..
00010       LOGICAL            TSTERR
00011       INTEGER            NMAX, NN, NNS, NOUT
00012       DOUBLE PRECISION   THRESH
00013 *     ..
00014 *     .. Array Arguments ..
00015       LOGICAL            DOTYPE( * )
00016       INTEGER            IWORK( * ), NSVAL( * ), NVAL( * )
00017       DOUBLE PRECISION   AINVP( * ), AP( * ), B( * ), RWORK( * ),
00018      \$                   WORK( * ), X( * ), XACT( * )
00019 *     ..
00020 *
00021 *  Purpose
00022 *  =======
00023 *
00024 *  DCHKTP tests DTPTRI, -TRS, -RFS, and -CON, and DLATPS
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 column 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 *  NMAX    (input) INTEGER
00055 *          The leading dimension of the work arrays.  NMAX >= the
00056 *          maximumm value of N in NVAL.
00057 *
00058 *  AP      (workspace) DOUBLE PRECISION array, dimension
00059 *                      (NMAX*(NMAX+1)/2)
00060 *
00061 *  AINVP   (workspace) DOUBLE PRECISION array, dimension
00062 *                      (NMAX*(NMAX+1)/2)
00063 *
00064 *  B       (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
00065 *          where NSMAX is the largest entry in NSVAL.
00066 *
00067 *  X       (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
00068 *
00069 *  XACT    (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
00070 *
00071 *  WORK    (workspace) DOUBLE PRECISION array, dimension
00072 *                      (NMAX*max(3,NSMAX))
00073 *
00074 *  IWORK   (workspace) INTEGER array, dimension (NMAX)
00075 *
00076 *  RWORK   (workspace) DOUBLE PRECISION array, dimension
00077 *                      (max(NMAX,2*NSMAX))
00078 *
00079 *  NOUT    (input) INTEGER
00080 *          The unit number for output.
00081 *
00082 *  =====================================================================
00083 *
00084 *     .. Parameters ..
00085       INTEGER            NTYPE1, NTYPES
00086       PARAMETER          ( NTYPE1 = 10, NTYPES = 18 )
00087       INTEGER            NTESTS
00088       PARAMETER          ( NTESTS = 9 )
00089       INTEGER            NTRAN
00090       PARAMETER          ( NTRAN = 3 )
00091       DOUBLE PRECISION   ONE, ZERO
00092       PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
00093 *     ..
00094 *     .. Local Scalars ..
00095       CHARACTER          DIAG, NORM, TRANS, UPLO, XTYPE
00096       CHARACTER*3        PATH
00097       INTEGER            I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO,
00098      \$                   K, LAP, LDA, N, NERRS, NFAIL, NRHS, NRUN
00099       DOUBLE PRECISION   AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
00100      \$                   SCALE
00101 *     ..
00102 *     .. Local Arrays ..
00103       CHARACTER          TRANSS( NTRAN ), UPLOS( 2 )
00104       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00105       DOUBLE PRECISION   RESULT( NTESTS )
00106 *     ..
00107 *     .. External Functions ..
00108       LOGICAL            LSAME
00109       DOUBLE PRECISION   DLANTP
00110       EXTERNAL           LSAME, DLANTP
00111 *     ..
00112 *     .. External Subroutines ..
00113       EXTERNAL           ALAERH, ALAHD, ALASUM, DCOPY, DERRTR, DGET04,
00114      \$                   DLACPY, DLARHS, DLATPS, DLATTP, DTPCON, DTPRFS,
00115      \$                   DTPT01, DTPT02, DTPT03, DTPT05, DTPT06, DTPTRI,
00116      \$                   DTPTRS
00117 *     ..
00118 *     .. Scalars in Common ..
00119       LOGICAL            LERR, OK
00120       CHARACTER*32       SRNAMT
00121       INTEGER            INFOT, IOUNIT
00122 *     ..
00123 *     .. Common blocks ..
00124       COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
00125       COMMON             / SRNAMC / SRNAMT
00126 *     ..
00127 *     .. Intrinsic Functions ..
00128       INTRINSIC          MAX
00129 *     ..
00130 *     .. Data statements ..
00131       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00132       DATA               UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
00133 *     ..
00134 *     .. Executable Statements ..
00135 *
00136 *     Initialize constants and the random number seed.
00137 *
00138       PATH( 1: 1 ) = 'Double precision'
00139       PATH( 2: 3 ) = 'TP'
00140       NRUN = 0
00141       NFAIL = 0
00142       NERRS = 0
00143       DO 10 I = 1, 4
00144          ISEED( I ) = ISEEDY( I )
00145    10 CONTINUE
00146 *
00147 *     Test the error exits
00148 *
00149       IF( TSTERR )
00150      \$   CALL DERRTR( PATH, NOUT )
00151       INFOT = 0
00152 *
00153       DO 110 IN = 1, NN
00154 *
00155 *        Do for each value of N in NVAL
00156 *
00157          N = NVAL( IN )
00158          LDA = MAX( 1, N )
00159          LAP = LDA*( LDA+1 ) / 2
00160          XTYPE = 'N'
00161 *
00162          DO 70 IMAT = 1, NTYPE1
00163 *
00164 *           Do the tests only if DOTYPE( IMAT ) is true.
00165 *
00166             IF( .NOT.DOTYPE( IMAT ) )
00167      \$         GO TO 70
00168 *
00169             DO 60 IUPLO = 1, 2
00170 *
00171 *              Do first for UPLO = 'U', then for UPLO = 'L'
00172 *
00173                UPLO = UPLOS( IUPLO )
00174 *
00175 *              Call DLATTP to generate a triangular test matrix.
00176 *
00177                SRNAMT = 'DLATTP'
00178                CALL DLATTP( IMAT, UPLO, 'No transpose', DIAG, ISEED, N,
00179      \$                      AP, X, WORK, INFO )
00180 *
00181 *              Set IDIAG = 1 for non-unit matrices, 2 for unit.
00182 *
00183                IF( LSAME( DIAG, 'N' ) ) THEN
00184                   IDIAG = 1
00185                ELSE
00186                   IDIAG = 2
00187                END IF
00188 *
00189 *+    TEST 1
00190 *              Form the inverse of A.
00191 *
00192                IF( N.GT.0 )
00193      \$            CALL DCOPY( LAP, AP, 1, AINVP, 1 )
00194                SRNAMT = 'DTPTRI'
00195                CALL DTPTRI( UPLO, DIAG, N, AINVP, INFO )
00196 *
00197 *              Check error code from DTPTRI.
00198 *
00199                IF( INFO.NE.0 )
00200      \$            CALL ALAERH( PATH, 'DTPTRI', INFO, 0, UPLO // DIAG, N,
00201      \$                         N, -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
00202 *
00203 *              Compute the infinity-norm condition number of A.
00204 *
00205                ANORM = DLANTP( 'I', UPLO, DIAG, N, AP, RWORK )
00206                AINVNM = DLANTP( 'I', UPLO, DIAG, N, AINVP, RWORK )
00207                IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
00208                   RCONDI = ONE
00209                ELSE
00210                   RCONDI = ( ONE / ANORM ) / AINVNM
00211                END IF
00212 *
00213 *              Compute the residual for the triangular matrix times its
00214 *              inverse.  Also compute the 1-norm condition number of A.
00215 *
00216                CALL DTPT01( UPLO, DIAG, N, AP, AINVP, RCONDO, RWORK,
00217      \$                      RESULT( 1 ) )
00218 *
00219 *              Print the test ratio if it is .GE. THRESH.
00220 *
00221                IF( RESULT( 1 ).GE.THRESH ) THEN
00222                   IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00223      \$               CALL ALAHD( NOUT, PATH )
00224                   WRITE( NOUT, FMT = 9999 )UPLO, DIAG, N, IMAT, 1,
00225      \$               RESULT( 1 )
00226                   NFAIL = NFAIL + 1
00227                END IF
00228                NRUN = NRUN + 1
00229 *
00230                DO 40 IRHS = 1, NNS
00231                   NRHS = NSVAL( IRHS )
00232                   XTYPE = 'N'
00233 *
00234                   DO 30 ITRAN = 1, NTRAN
00235 *
00236 *                 Do for op(A) = A, A**T, or A**H.
00237 *
00238                      TRANS = TRANSS( ITRAN )
00239                      IF( ITRAN.EQ.1 ) THEN
00240                         NORM = 'O'
00241                         RCONDC = RCONDO
00242                      ELSE
00243                         NORM = 'I'
00244                         RCONDC = RCONDI
00245                      END IF
00246 *
00247 *+    TEST 2
00248 *                 Solve and compute residual for op(A)*x = b.
00249 *
00250                      SRNAMT = 'DLARHS'
00251                      CALL DLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0,
00252      \$                            IDIAG, NRHS, AP, LAP, XACT, LDA, B,
00253      \$                            LDA, ISEED, INFO )
00254                      XTYPE = 'C'
00255                      CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
00256 *
00257                      SRNAMT = 'DTPTRS'
00258                      CALL DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, X,
00259      \$                            LDA, INFO )
00260 *
00261 *                 Check error code from DTPTRS.
00262 *
00263                      IF( INFO.NE.0 )
00264      \$                  CALL ALAERH( PATH, 'DTPTRS', INFO, 0,
00265      \$                               UPLO // TRANS // DIAG, N, N, -1,
00266      \$                               -1, -1, IMAT, NFAIL, NERRS, NOUT )
00267 *
00268                      CALL DTPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X,
00269      \$                            LDA, B, LDA, WORK, RESULT( 2 ) )
00270 *
00271 *+    TEST 3
00272 *                 Check solution from generated exact solution.
00273 *
00274                      CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
00275      \$                            RESULT( 3 ) )
00276 *
00277 *+    TESTS 4, 5, and 6
00278 *                 Use iterative refinement to improve the solution and
00279 *                 compute error bounds.
00280 *
00281                      SRNAMT = 'DTPRFS'
00282                      CALL DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B,
00283      \$                            LDA, X, LDA, RWORK, RWORK( NRHS+1 ),
00284      \$                            WORK, IWORK, INFO )
00285 *
00286 *                 Check error code from DTPRFS.
00287 *
00288                      IF( INFO.NE.0 )
00289      \$                  CALL ALAERH( PATH, 'DTPRFS', INFO, 0,
00290      \$                               UPLO // TRANS // DIAG, N, N, -1,
00291      \$                               -1, NRHS, IMAT, NFAIL, NERRS,
00292      \$                               NOUT )
00293 *
00294                      CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
00295      \$                            RESULT( 4 ) )
00296                      CALL DTPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B,
00297      \$                            LDA, X, LDA, XACT, LDA, RWORK,
00298      \$                            RWORK( NRHS+1 ), RESULT( 5 ) )
00299 *
00300 *                    Print information about the tests that did not pass
00301 *                    the threshold.
00302 *
00303                      DO 20 K = 2, 6
00304                         IF( RESULT( K ).GE.THRESH ) THEN
00305                            IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00306      \$                        CALL ALAHD( NOUT, PATH )
00307                            WRITE( NOUT, FMT = 9998 )UPLO, TRANS, DIAG,
00308      \$                        N, NRHS, IMAT, K, RESULT( K )
00309                            NFAIL = NFAIL + 1
00310                         END IF
00311    20                CONTINUE
00312                      NRUN = NRUN + 5
00313    30             CONTINUE
00314    40          CONTINUE
00315 *
00316 *+    TEST 7
00317 *                 Get an estimate of RCOND = 1/CNDNUM.
00318 *
00319                DO 50 ITRAN = 1, 2
00320                   IF( ITRAN.EQ.1 ) THEN
00321                      NORM = 'O'
00322                      RCONDC = RCONDO
00323                   ELSE
00324                      NORM = 'I'
00325                      RCONDC = RCONDI
00326                   END IF
00327 *
00328                   SRNAMT = 'DTPCON'
00329                   CALL DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK,
00330      \$                         IWORK, INFO )
00331 *
00332 *                 Check error code from DTPCON.
00333 *
00334                   IF( INFO.NE.0 )
00335      \$               CALL ALAERH( PATH, 'DTPCON', INFO, 0,
00336      \$                            NORM // UPLO // DIAG, N, N, -1, -1,
00337      \$                            -1, IMAT, NFAIL, NERRS, NOUT )
00338 *
00339                   CALL DTPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK,
00340      \$                         RESULT( 7 ) )
00341 *
00342 *                 Print the test ratio if it is .GE. THRESH.
00343 *
00344                   IF( RESULT( 7 ).GE.THRESH ) THEN
00345                      IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00346      \$                  CALL ALAHD( NOUT, PATH )
00347                      WRITE( NOUT, FMT = 9997 ) 'DTPCON', NORM, UPLO,
00348      \$                  DIAG, N, IMAT, 7, RESULT( 7 )
00349                      NFAIL = NFAIL + 1
00350                   END IF
00351                   NRUN = NRUN + 1
00352    50          CONTINUE
00353    60       CONTINUE
00354    70    CONTINUE
00355 *
00356 *        Use pathological test matrices to test DLATPS.
00357 *
00358          DO 100 IMAT = NTYPE1 + 1, NTYPES
00359 *
00360 *           Do the tests only if DOTYPE( IMAT ) is true.
00361 *
00362             IF( .NOT.DOTYPE( IMAT ) )
00363      \$         GO TO 100
00364 *
00365             DO 90 IUPLO = 1, 2
00366 *
00367 *              Do first for UPLO = 'U', then for UPLO = 'L'
00368 *
00369                UPLO = UPLOS( IUPLO )
00370                DO 80 ITRAN = 1, NTRAN
00371 *
00372 *                 Do for op(A) = A, A**T, or A**H.
00373 *
00374                   TRANS = TRANSS( ITRAN )
00375 *
00376 *                 Call DLATTP to generate a triangular test matrix.
00377 *
00378                   SRNAMT = 'DLATTP'
00379                   CALL DLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, X,
00380      \$                         WORK, INFO )
00381 *
00382 *+    TEST 8
00383 *                 Solve the system op(A)*x = b.
00384 *
00385                   SRNAMT = 'DLATPS'
00386                   CALL DCOPY( N, X, 1, B, 1 )
00387                   CALL DLATPS( UPLO, TRANS, DIAG, 'N', N, AP, B, SCALE,
00388      \$                         RWORK, INFO )
00389 *
00390 *                 Check error code from DLATPS.
00391 *
00392                   IF( INFO.NE.0 )
00393      \$               CALL ALAERH( PATH, 'DLATPS', INFO, 0,
00394      \$                            UPLO // TRANS // DIAG // 'N', N, N,
00395      \$                            -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
00396 *
00397                   CALL DTPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
00398      \$                         RWORK, ONE, B, LDA, X, LDA, WORK,
00399      \$                         RESULT( 8 ) )
00400 *
00401 *+    TEST 9
00402 *                 Solve op(A)*x = b again with NORMIN = 'Y'.
00403 *
00404                   CALL DCOPY( N, X, 1, B( N+1 ), 1 )
00405                   CALL DLATPS( UPLO, TRANS, DIAG, 'Y', N, AP, B( N+1 ),
00406      \$                         SCALE, RWORK, INFO )
00407 *
00408 *                 Check error code from DLATPS.
00409 *
00410                   IF( INFO.NE.0 )
00411      \$               CALL ALAERH( PATH, 'DLATPS', INFO, 0,
00412      \$                            UPLO // TRANS // DIAG // 'Y', N, N,
00413      \$                            -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
00414 *
00415                   CALL DTPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
00416      \$                         RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
00417      \$                         RESULT( 9 ) )
00418 *
00419 *                 Print information about the tests that did not pass
00420 *                 the threshold.
00421 *
00422                   IF( RESULT( 8 ).GE.THRESH ) THEN
00423                      IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00424      \$                  CALL ALAHD( NOUT, PATH )
00425                      WRITE( NOUT, FMT = 9996 )'DLATPS', UPLO, TRANS,
00426      \$                  DIAG, 'N', N, IMAT, 8, RESULT( 8 )
00427                      NFAIL = NFAIL + 1
00428                   END IF
00429                   IF( RESULT( 9 ).GE.THRESH ) THEN
00430                      IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00431      \$                  CALL ALAHD( NOUT, PATH )
00432                      WRITE( NOUT, FMT = 9996 )'DLATPS', UPLO, TRANS,
00433      \$                  DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
00434                      NFAIL = NFAIL + 1
00435                   END IF
00436                   NRUN = NRUN + 2
00437    80          CONTINUE
00438    90       CONTINUE
00439   100    CONTINUE
00440   110 CONTINUE
00441 *
00442 *     Print a summary of the results.
00443 *
00444       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00445 *
00446  9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5,
00447      \$      ', type ', I2, ', test(', I2, ')= ', G12.5 )
00448  9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1,
00449      \$      ''', N=', I5, ''', NRHS=', I5, ', type ', I2, ', test(',
00450      \$      I2, ')= ', G12.5 )
00451  9997 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',',
00452      \$      I5, ', ... ), type ', I2, ', test(', I2, ')=', G12.5 )
00453  9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',
00454      \$      A1, ''',', I5, ', ... ), type ', I2, ', test(', I2, ')=',
00455      \$      G12.5 )
00456       RETURN
00457 *
00458 *     End of DCHKTP
00459 *
00460       END
```