LAPACK: TESTING/LIN/zchktr.f Source File

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