LAPACK: TESTING/LIN/schkps.f Source File

Go to the documentation of this file.
00001       SUBROUTINE SCHKPS( 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.1) --
00006 *     Craig Lucas, University of Manchester / NAG Ltd.
00007 *     October, 2008
00008 *
00009 *     .. Scalar Arguments ..
00010       REAL               THRESH
00011       INTEGER            NMAX, NN, NNB, NOUT, NRANK
00012       LOGICAL            TSTERR
00013 *     ..
00014 *     .. Array Arguments ..
00015       REAL               A( * ), AFAC( * ), PERM( * ), RWORK( * ),
00016      $                   WORK( * )
00017       INTEGER            NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
00018       LOGICAL            DOTYPE( * )
00019 *     ..
00020 *
00021 *  Purpose
00022 *  =======
00023 *
00024 *  SCHKPS tests SPSTRF.
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) REAL
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) REAL array, dimension (NMAX*NMAX)
00065 *
00066 *  AFAC    (workspace) REAL array, dimension (NMAX*NMAX)
00067 *
00068 *  PERM    (workspace) REAL array, dimension (NMAX*NMAX)
00069 *
00070 *  PIV     (workspace) INTEGER array, dimension (NMAX)
00071 *
00072 *  WORK    (workspace) REAL array, dimension (NMAX*3)
00073 *
00074 *  RWORK   (workspace) REAL array, dimension (NMAX)
00075 *
00076 *  NOUT    (input) INTEGER
00077 *          The unit number for output.
00078 *
00079 *  =====================================================================
00080 *
00081 *     .. Parameters ..
00082       REAL               ONE
00083       PARAMETER          ( ONE = 1.0E+0 )
00084       INTEGER            NTYPES
00085       PARAMETER          ( NTYPES = 9 )
00086 *     ..
00087 *     .. Local Scalars ..
00088       REAL               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, SERRPS, SLACPY, SLATB5,
00101      $                   SLATMT, SPST01, SPSTRF, XLAENV
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          MAX, REAL, 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 ) = 'Single 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 SERRPS( PATH, NOUT )
00136       INFOT = 0
00137       CALL XLAENV( 2, 2 )
00138 *
00139 *     Do for each value of N in NVAL
00140 *
00141       DO 150 IN = 1, NN
00142          N = NVAL( IN )
00143          LDA = MAX( N, 1 )
00144          NIMAT = NTYPES
00145          IF( N.LE.0 )
00146      $      NIMAT = 1
00147 *
00148          IZERO = 0
00149          DO 140 IMAT = 1, NIMAT
00150 *
00151 *           Do the tests only if DOTYPE( IMAT ) is true.
00152 *
00153             IF( .NOT.DOTYPE( IMAT ) )
00154      $         GO TO 140
00155 *
00156 *              Do for each value of RANK in RANKVAL
00157 *
00158             DO 130 IRANK = 1, NRANK
00159 *
00160 *              Only repeat test 3 to 5 for different ranks
00161 *              Other tests use full rank
00162 *
00163                IF( ( IMAT.LT.3 .OR. IMAT.GT.5 ) .AND. IRANK.GT.1 )
00164      $            GO TO 130
00165 *
00166                RANK = CEILING( ( N * REAL( RANKVAL( IRANK ) ) )
00167      $              / 100.E+0 )
00168 *
00169 *
00170 *           Do first for UPLO = 'U', then for UPLO = 'L'
00171 *
00172                DO 120 IUPLO = 1, 2
00173                   UPLO = UPLOS( IUPLO )
00174 *
00175 *              Set up parameters with SLATB5 and generate a test matrix
00176 *              with SLATMT.
00177 *
00178                   CALL SLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM,
00179      $                         MODE, CNDNUM, DIST )
00180 *
00181                   SRNAMT = 'SLATMT'
00182                   CALL SLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE,
00183      $                         CNDNUM, ANORM, RANK, KL, KU, UPLO, A,
00184      $                         LDA, WORK, INFO )
00185 *
00186 *              Check error code from SLATMT.
00187 *
00188                   IF( INFO.NE.0 ) THEN
00189                     CALL ALAERH( PATH, 'SLATMT', INFO, 0, UPLO, N,
00190      $                           N, -1, -1, -1, IMAT, NFAIL, NERRS, 
00191      $                           NOUT )
00192                      GO TO 120
00193                   END IF
00194 *
00195 *              Do for each value of NB in NBVAL
00196 *
00197                   DO 110 INB = 1, NNB
00198                      NB = NBVAL( INB )
00199                      CALL XLAENV( 1, NB )
00200 *
00201 *                 Compute the pivoted L*L' or U'*U factorization
00202 *                 of the matrix.
00203 *
00204                      CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
00205                      SRNAMT = 'SPSTRF'
00206 *
00207 *                 Use default tolerance
00208 *
00209                      TOL = -ONE
00210                      CALL SPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK,
00211      $                            TOL, WORK, INFO )
00212 *
00213 *                 Check error code from SPSTRF.
00214 *
00215                      IF( (INFO.LT.IZERO)
00216      $                    .OR.(INFO.NE.IZERO.AND.RANK.EQ.N)
00217      $                    .OR.(INFO.LE.IZERO.AND.RANK.LT.N) ) THEN
00218                         CALL ALAERH( PATH, 'SPSTRF', INFO, IZERO,
00219      $                               UPLO, N, N, -1, -1, NB, IMAT,
00220      $                               NFAIL, NERRS, NOUT )
00221                         GO TO 110
00222                      END IF
00223 *
00224 *                 Skip the test if INFO is not 0.
00225 *
00226                      IF( INFO.NE.0 )
00227      $                  GO TO 110
00228 *
00229 *                 Reconstruct matrix from factors and compute residual.
00230 *
00231 *                 PERM holds permuted L*L^T or U^T*U
00232 *
00233                      CALL SPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA,
00234      $                            PIV, RWORK, RESULT, COMPRANK )
00235 *
00236 *                 Print information about the tests that did not pass
00237 *                 the threshold or where computed rank was not RANK.
00238 *
00239                      IF( N.EQ.0 )
00240      $                  COMPRANK = 0
00241                      RANKDIFF = RANK - COMPRANK
00242                      IF( RESULT.GE.THRESH ) THEN
00243                         IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
00244      $                     CALL ALAHD( NOUT, PATH )
00245                         WRITE( NOUT, FMT = 9999 )UPLO, N, RANK,
00246      $                     RANKDIFF, NB, IMAT, RESULT
00247                         NFAIL = NFAIL + 1
00248                      END IF
00249                      NRUN = NRUN + 1
00250   110             CONTINUE
00251 *
00252   120          CONTINUE
00253   130       CONTINUE
00254   140    CONTINUE
00255   150 CONTINUE
00256 *
00257 *     Print a summary of the results.
00258 *
00259       CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
00260 *
00261  9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', RANK =', I3,
00262      $      ', Diff =', I5, ', NB =', I4, ', type ', I2, ', Ratio =',
00263      $      G12.5 )
00264       RETURN
00265 *
00266 *     End of SCHKPS
00267 *
00268       END