LAPACK: TESTING/LIN/zchkps.f Source File

Go to the documentation of this file.
00001       SUBROUTINE ZCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL,
00002      $                   THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK,
00003      $                   RWORK, NOUT )
00004 *
00005 *  -- LAPACK test routine (version 3.2.1) --
00006 *     Craig Lucas, University of Manchester / NAG Ltd.
00007 *     -- April 2009
00008 *
00009 *     .. Scalar Arguments ..
00010       DOUBLE PRECISION   THRESH
00011       INTEGER            NMAX, NN, NNB, NOUT, NRANK
00012       LOGICAL            TSTERR
00013 *     ..
00014 *     .. Array Arguments ..
00015       COMPLEX*16         A( * ), AFAC( * ), PERM( * ), WORK( * )
00016       DOUBLE PRECISION   RWORK( * )
00017       INTEGER            NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
00018       LOGICAL            DOTYPE( * )
00019 *     ..
00020 *
00021 *  Purpose
00022 *  =======
00023 *
00024 *  ZCHKPS tests ZPSTRF.
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 *  NNB     (input) INTEGER
00041 *          The number of values of NB contained in the vector NBVAL.
00042 *
00043 *  NBVAL   (input) INTEGER array, dimension (NBVAL)
00044 *          The values of the block size NB.
00045 *
00046 *  NRANK   (input) INTEGER
00047 *          The number of values of RANK contained in the vector RANKVAL.
00048 *
00049 *  RANKVAL (input) INTEGER array, dimension (NBVAL)
00050 *          The values of the block size NB.
00051 *
00052 *  THRESH  (input) DOUBLE PRECISION
00053 *          The threshold value for the test ratios.  A result is
00054 *          included in the output file if RESULT >= THRESH.  To have
00055 *          every test ratio printed, use THRESH = 0.
00056 *
00057 *  TSTERR  (input) LOGICAL
00058 *          Flag that indicates whether error exits are to be tested.
00059 *
00060 *  NMAX    (input) INTEGER
00061 *          The maximum value permitted for N, used in dimensioning the
00062 *          work arrays.
00063 *
00064 *  A       (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
00065 *
00066 *  AFAC    (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
00067 *
00068 *  PERM    (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
00069 *
00070 *  PIV     (workspace) INTEGER array, dimension (NMAX)
00071 *
00072 *  WORK    (workspace) COMPLEX*16 array, dimension (NMAX*3)
00073 *
00074 *  RWORK   (workspace) DOUBLE PRECISION array, dimension (NMAX)
00075 *
00076 *  NOUT    (input) INTEGER
00077 *          The unit number for output.
00078 *
00079 *  =====================================================================
00080 *
00081 *     .. Parameters ..
00082       DOUBLE PRECISION   ONE
00083       PARAMETER          ( ONE = 1.0E+0 )
00084       INTEGER            NTYPES
00085       PARAMETER          ( NTYPES = 9 )
00086 *     ..
00087 *     .. Local Scalars ..
00088       DOUBLE PRECISION   ANORM, CNDNUM, RESULT, TOL
00089       INTEGER            COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO,
00090      $                   IZERO, KL, KU, LDA, MODE, N, NB, NERRS, NFAIL,
00091      $                   NIMAT, NRUN, RANK, RANKDIFF
00092       CHARACTER          DIST, TYPE, UPLO
00093       CHARACTER*3        PATH
00094 *     ..
00095 *     .. Local Arrays ..
00096       INTEGER            ISEED( 4 ), ISEEDY( 4 )
00097       CHARACTER          UPLOS( 2 )
00098 *     ..
00099 *     .. External Subroutines ..
00100       EXTERNAL           ALAERH, ALAHD, ALASUM, XLAENV, ZERRPS, ZLACPY,
00101      $                   ZLATB5, ZLATMT, ZPST01, ZPSTRF
00102 *     ..
00103 *     .. Scalars in Common ..
00104       INTEGER            INFOT, NUNIT
00105       LOGICAL            LERR, OK
00106       CHARACTER*32       SRNAMT
00107 *     ..
00108 *     .. Common blocks ..
00109       COMMON             / INFOC / INFOT, NUNIT, OK, LERR
00110       COMMON             / SRNAMC / SRNAMT
00111 *     ..
00112 *     .. Intrinsic Functions ..
00113       INTRINSIC          DBLE, MAX, CEILING
00114 *     ..
00115 *     .. Data statements ..
00116       DATA               ISEEDY / 1988, 1989, 1990, 1991 /
00117       DATA               UPLOS / 'U', 'L' /
00118 *     ..
00119 *     .. Executable Statements ..
00120 *
00121 *     Initialize constants and the random number seed.
00122 *
00123       PATH( 1: 1 ) = 'Zomplex Precision'
00124       PATH( 2: 3 ) = 'PS'
00125       NRUN = 0
00126       NFAIL = 0
00127       NERRS = 0
00128       DO 100 I = 1, 4
00129          ISEED( I ) = ISEEDY( I )
00130   100 CONTINUE
00131 *
00132 *     Test the error exits
00133 *
00134       IF( TSTERR )
00135      $   CALL ZERRPS( PATH, NOUT )
00136       INFOT = 0
00137 *
00138 *     Do for each value of N in NVAL
00139 *
00140       DO 150 IN = 1, NN
00141          N = NVAL( IN )
00142          LDA = MAX( N, 1 )
00143          NIMAT = NTYPES
00144          IF( N.LE.0 )
00145      $      NIMAT = 1
00146 *
00147          IZERO = 0
00148          DO 140 IMAT = 1, NIMAT
00149 *
00150 *           Do the tests only if DOTYPE( IMAT ) is true.
00151 *
00152             IF( .NOT.DOTYPE( IMAT ) )
00153      $         GO TO 140
00154 *
00155 *              Do for each value of RANK in RANKVAL
00156 *
00157             DO 130 IRANK = 1, NRANK
00158 *
00159 *              Only repeat test 3 to 5 for different ranks
00160 *              Other tests use full rank
00161 *
00162                IF( ( IMAT.LT.3 .OR. IMAT.GT.5 ) .AND. IRANK.GT.1 )
00163      $            GO TO 130
00164 *
00165                RANK = CEILING( ( N * DBLE( RANKVAL( IRANK ) ) )
00166      $              / 100.E+0 )
00167 *
00168 *
00169 *           Do first for UPLO = 'U', then for UPLO = 'L'
00170 *
00171                DO 120 IUPLO = 1, 2
00172                   UPLO = UPLOS( IUPLO )
00173 *
00174 *              Set up parameters with ZLATB5 and generate a test matrix
00175 *              with ZLATMT.
00176 *
00177                   CALL ZLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM,
00178      $                         MODE, CNDNUM, DIST )
00179 *
00180                   SRNAMT = 'ZLATMT'
00181                   CALL ZLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE,
00182      $                         CNDNUM, ANORM, RANK, KL, KU, UPLO, A,
00183      $                         LDA, WORK, INFO )
00184 *
00185 *              Check error code from ZLATMT.
00186 *
00187                   IF( INFO.NE.0 ) THEN
00188                     CALL ALAERH( PATH, 'ZLATMT', INFO, 0, UPLO, N,
00189      $                           N, -1, -1, -1, IMAT, NFAIL, NERRS,
00190      $                           NOUT )
00191                      GO TO 120
00192                   END IF
00193 *
00194 *              Do for each value of NB in NBVAL
00195 *
00196                   DO 110 INB = 1, NNB
00197                      NB = NBVAL( INB )
00198                      CALL XLAENV( 1, NB )
00199 *
00200 *                 Compute the pivoted L*L' or U'*U factorization
00201 *                 of the matrix.
00202 *
00203                      CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
00204                      SRNAMT = 'ZPSTRF'
00205 *
00206 *                 Use default tolerance
00207 *
00208                      TOL = -ONE
00209                      CALL ZPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK,
00210      $                            TOL, RWORK, INFO )
00211 *
00212 *                 Check error code from ZPSTRF.
00213 *
00214                      IF( (INFO.LT.IZERO)
00215      $                    .OR.(INFO.NE.IZERO.AND.RANK.EQ.N)
00216      $                    .OR.(INFO.LE.IZERO.AND.RANK.LT.N) ) THEN
00217                         CALL ALAERH( PATH, 'ZPSTRF', INFO, IZERO,
00218      $                               UPLO, N, N, -1, -1, NB, IMAT,
00219      $                               NFAIL, NERRS, NOUT )
00220                         GO TO 110
00221                      END IF
00222 *
00223 *                 Skip the test if INFO is not 0.
00224 *
00225                      IF( INFO.NE.0 )
00226      $                  GO TO 110
00227 *
00228 *                 Reconstruct matrix from factors and compute residual.
00229 *
00230 *                 PERM holds permuted L*L^T or U^T*U
00231 *
00232                      CALL ZPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA,
00233      $                            PIV, RWORK, RESULT, COMPRANK )
00234 *
00235 *                 Print information about the tests that did not pass
00236 *                 the threshold or where computed rank was not RANK.
00237 *
00238                      IF( N.EQ.0 )
00239      $                  COMPRANK = 0
00240                      RANKDIFF = RANK - COMPRANK
00241                      IF( RESULT.GE.THRESH ) THEN
00242                         IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00243      $                     CALL ALAHD( NOUT, PATH )
00244                         WRITE( NOUT, FMT = 9999 )UPLO, N, RANK,
00245      $                     RANKDIFF, NB, IMAT, RESULT
00246                         NFAIL = NFAIL + 1
00247                      END IF
00248                      NRUN = NRUN + 1
00249   110             CONTINUE
00250 *
00251   120          CONTINUE
00252   130       CONTINUE
00253   140    CONTINUE
00254   150 CONTINUE
00255 *
00256 *     Print a summary of the results.
00257 *
00258       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00259 *
00260  9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', RANK =', I3,
00261      $      ', Diff =', I5, ', NB =', I4, ', type ', I2, ', Ratio =',
00262      $      G12.5 )
00263       RETURN
00264 *
00265 *     End of ZCHKPS
00266 *
00267       END