 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
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
1.7.3 
