![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SCHKPS 00002 * 00003 * =========== DOCUMENTATION =========== 00004 * 00005 * Online html documentation available at 00006 * http://www.netlib.org/lapack/explore-html/ 00007 * 00008 * Definition: 00009 * =========== 00010 * 00011 * SUBROUTINE SCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, 00012 * THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, 00013 * RWORK, NOUT ) 00014 * 00015 * .. Scalar Arguments .. 00016 * REAL THRESH 00017 * INTEGER NMAX, NN, NNB, NOUT, NRANK 00018 * LOGICAL TSTERR 00019 * .. 00020 * .. Array Arguments .. 00021 * REAL A( * ), AFAC( * ), PERM( * ), RWORK( * ), 00022 * $ WORK( * ) 00023 * INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * ) 00024 * LOGICAL DOTYPE( * ) 00025 * .. 00026 * 00027 * 00028 *> \par Purpose: 00029 * ============= 00030 *> 00031 *> \verbatim 00032 *> 00033 *> SCHKPS tests SPSTRF. 00034 *> \endverbatim 00035 * 00036 * Arguments: 00037 * ========== 00038 * 00039 *> \param[in] DOTYPE 00040 *> \verbatim 00041 *> DOTYPE is LOGICAL array, dimension (NTYPES) 00042 *> The matrix types to be used for testing. Matrices of type j 00043 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00044 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00045 *> \endverbatim 00046 *> 00047 *> \param[in] NN 00048 *> \verbatim 00049 *> NN is INTEGER 00050 *> The number of values of N contained in the vector NVAL. 00051 *> \endverbatim 00052 *> 00053 *> \param[in] NVAL 00054 *> \verbatim 00055 *> NVAL is INTEGER array, dimension (NN) 00056 *> The values of the matrix dimension N. 00057 *> \endverbatim 00058 *> 00059 *> \param[in] NNB 00060 *> \verbatim 00061 *> NNB is INTEGER 00062 *> The number of values of NB contained in the vector NBVAL. 00063 *> \endverbatim 00064 *> 00065 *> \param[in] NBVAL 00066 *> \verbatim 00067 *> NBVAL is INTEGER array, dimension (NBVAL) 00068 *> The values of the block size NB. 00069 *> \endverbatim 00070 *> 00071 *> \param[in] NRANK 00072 *> \verbatim 00073 *> NRANK is INTEGER 00074 *> The number of values of RANK contained in the vector RANKVAL. 00075 *> \endverbatim 00076 *> 00077 *> \param[in] RANKVAL 00078 *> \verbatim 00079 *> RANKVAL is INTEGER array, dimension (NBVAL) 00080 *> The values of the block size NB. 00081 *> \endverbatim 00082 *> 00083 *> \param[in] THRESH 00084 *> \verbatim 00085 *> THRESH is REAL 00086 *> The threshold value for the test ratios. A result is 00087 *> included in the output file if RESULT >= THRESH. To have 00088 *> every test ratio printed, use THRESH = 0. 00089 *> \endverbatim 00090 *> 00091 *> \param[in] TSTERR 00092 *> \verbatim 00093 *> TSTERR is LOGICAL 00094 *> Flag that indicates whether error exits are to be tested. 00095 *> \endverbatim 00096 *> 00097 *> \param[in] NMAX 00098 *> \verbatim 00099 *> NMAX is INTEGER 00100 *> The maximum value permitted for N, used in dimensioning the 00101 *> work arrays. 00102 *> \endverbatim 00103 *> 00104 *> \param[out] A 00105 *> \verbatim 00106 *> A is REAL array, dimension (NMAX*NMAX) 00107 *> \endverbatim 00108 *> 00109 *> \param[out] AFAC 00110 *> \verbatim 00111 *> AFAC is REAL array, dimension (NMAX*NMAX) 00112 *> \endverbatim 00113 *> 00114 *> \param[out] PERM 00115 *> \verbatim 00116 *> PERM is REAL array, dimension (NMAX*NMAX) 00117 *> \endverbatim 00118 *> 00119 *> \param[out] PIV 00120 *> \verbatim 00121 *> PIV is INTEGER array, dimension (NMAX) 00122 *> \endverbatim 00123 *> 00124 *> \param[out] WORK 00125 *> \verbatim 00126 *> WORK is REAL array, dimension (NMAX*3) 00127 *> \endverbatim 00128 *> 00129 *> \param[out] RWORK 00130 *> \verbatim 00131 *> RWORK is REAL array, dimension (NMAX) 00132 *> \endverbatim 00133 *> 00134 *> \param[in] NOUT 00135 *> \verbatim 00136 *> NOUT is INTEGER 00137 *> The unit number for output. 00138 *> \endverbatim 00139 * 00140 * Authors: 00141 * ======== 00142 * 00143 *> \author Univ. of Tennessee 00144 *> \author Univ. of California Berkeley 00145 *> \author Univ. of Colorado Denver 00146 *> \author NAG Ltd. 00147 * 00148 *> \date November 2011 00149 * 00150 *> \ingroup single_lin 00151 * 00152 * ===================================================================== 00153 SUBROUTINE SCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, 00154 $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, 00155 $ RWORK, NOUT ) 00156 * 00157 * -- LAPACK test routine (version 3.4.0) -- 00158 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00159 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00160 * November 2011 00161 * 00162 * .. Scalar Arguments .. 00163 REAL THRESH 00164 INTEGER NMAX, NN, NNB, NOUT, NRANK 00165 LOGICAL TSTERR 00166 * .. 00167 * .. Array Arguments .. 00168 REAL A( * ), AFAC( * ), PERM( * ), RWORK( * ), 00169 $ WORK( * ) 00170 INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * ) 00171 LOGICAL DOTYPE( * ) 00172 * .. 00173 * 00174 * ===================================================================== 00175 * 00176 * .. Parameters .. 00177 REAL ONE 00178 PARAMETER ( ONE = 1.0E+0 ) 00179 INTEGER NTYPES 00180 PARAMETER ( NTYPES = 9 ) 00181 * .. 00182 * .. Local Scalars .. 00183 REAL ANORM, CNDNUM, RESULT, TOL 00184 INTEGER COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO, 00185 $ IZERO, KL, KU, LDA, MODE, N, NB, NERRS, NFAIL, 00186 $ NIMAT, NRUN, RANK, RANKDIFF 00187 CHARACTER DIST, TYPE, UPLO 00188 CHARACTER*3 PATH 00189 * .. 00190 * .. Local Arrays .. 00191 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00192 CHARACTER UPLOS( 2 ) 00193 * .. 00194 * .. External Subroutines .. 00195 EXTERNAL ALAERH, ALAHD, ALASUM, SERRPS, SLACPY, SLATB5, 00196 $ SLATMT, SPST01, SPSTRF, XLAENV 00197 * .. 00198 * .. Scalars in Common .. 00199 INTEGER INFOT, NUNIT 00200 LOGICAL LERR, OK 00201 CHARACTER*32 SRNAMT 00202 * .. 00203 * .. Common blocks .. 00204 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00205 COMMON / SRNAMC / SRNAMT 00206 * .. 00207 * .. Intrinsic Functions .. 00208 INTRINSIC MAX, REAL, CEILING 00209 * .. 00210 * .. Data statements .. 00211 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00212 DATA UPLOS / 'U', 'L' / 00213 * .. 00214 * .. Executable Statements .. 00215 * 00216 * Initialize constants and the random number seed. 00217 * 00218 PATH( 1: 1 ) = 'Single Precision' 00219 PATH( 2: 3 ) = 'PS' 00220 NRUN = 0 00221 NFAIL = 0 00222 NERRS = 0 00223 DO 100 I = 1, 4 00224 ISEED( I ) = ISEEDY( I ) 00225 100 CONTINUE 00226 * 00227 * Test the error exits 00228 * 00229 IF( TSTERR ) 00230 $ CALL SERRPS( PATH, NOUT ) 00231 INFOT = 0 00232 CALL XLAENV( 2, 2 ) 00233 * 00234 * Do for each value of N in NVAL 00235 * 00236 DO 150 IN = 1, NN 00237 N = NVAL( IN ) 00238 LDA = MAX( N, 1 ) 00239 NIMAT = NTYPES 00240 IF( N.LE.0 ) 00241 $ NIMAT = 1 00242 * 00243 IZERO = 0 00244 DO 140 IMAT = 1, NIMAT 00245 * 00246 * Do the tests only if DOTYPE( IMAT ) is true. 00247 * 00248 IF( .NOT.DOTYPE( IMAT ) ) 00249 $ GO TO 140 00250 * 00251 * Do for each value of RANK in RANKVAL 00252 * 00253 DO 130 IRANK = 1, NRANK 00254 * 00255 * Only repeat test 3 to 5 for different ranks 00256 * Other tests use full rank 00257 * 00258 IF( ( IMAT.LT.3 .OR. IMAT.GT.5 ) .AND. IRANK.GT.1 ) 00259 $ GO TO 130 00260 * 00261 RANK = CEILING( ( N * REAL( RANKVAL( IRANK ) ) ) 00262 $ / 100.E+0 ) 00263 * 00264 * 00265 * Do first for UPLO = 'U', then for UPLO = 'L' 00266 * 00267 DO 120 IUPLO = 1, 2 00268 UPLO = UPLOS( IUPLO ) 00269 * 00270 * Set up parameters with SLATB5 and generate a test matrix 00271 * with SLATMT. 00272 * 00273 CALL SLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, 00274 $ MODE, CNDNUM, DIST ) 00275 * 00276 SRNAMT = 'SLATMT' 00277 CALL SLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE, 00278 $ CNDNUM, ANORM, RANK, KL, KU, UPLO, A, 00279 $ LDA, WORK, INFO ) 00280 * 00281 * Check error code from SLATMT. 00282 * 00283 IF( INFO.NE.0 ) THEN 00284 CALL ALAERH( PATH, 'SLATMT', INFO, 0, UPLO, N, 00285 $ N, -1, -1, -1, IMAT, NFAIL, NERRS, 00286 $ NOUT ) 00287 GO TO 120 00288 END IF 00289 * 00290 * Do for each value of NB in NBVAL 00291 * 00292 DO 110 INB = 1, NNB 00293 NB = NBVAL( INB ) 00294 CALL XLAENV( 1, NB ) 00295 * 00296 * Compute the pivoted L*L' or U'*U factorization 00297 * of the matrix. 00298 * 00299 CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) 00300 SRNAMT = 'SPSTRF' 00301 * 00302 * Use default tolerance 00303 * 00304 TOL = -ONE 00305 CALL SPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK, 00306 $ TOL, WORK, INFO ) 00307 * 00308 * Check error code from SPSTRF. 00309 * 00310 IF( (INFO.LT.IZERO) 00311 $ .OR.(INFO.NE.IZERO.AND.RANK.EQ.N) 00312 $ .OR.(INFO.LE.IZERO.AND.RANK.LT.N) ) THEN 00313 CALL ALAERH( PATH, 'SPSTRF', INFO, IZERO, 00314 $ UPLO, N, N, -1, -1, NB, IMAT, 00315 $ NFAIL, NERRS, NOUT ) 00316 GO TO 110 00317 END IF 00318 * 00319 * Skip the test if INFO is not 0. 00320 * 00321 IF( INFO.NE.0 ) 00322 $ GO TO 110 00323 * 00324 * Reconstruct matrix from factors and compute residual. 00325 * 00326 * PERM holds permuted L*L^T or U^T*U 00327 * 00328 CALL SPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA, 00329 $ PIV, RWORK, RESULT, COMPRANK ) 00330 * 00331 * Print information about the tests that did not pass 00332 * the threshold or where computed rank was not RANK. 00333 * 00334 IF( N.EQ.0 ) 00335 $ COMPRANK = 0 00336 RANKDIFF = RANK - COMPRANK 00337 IF( RESULT.GE.THRESH ) THEN 00338 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00339 $ CALL ALAHD( NOUT, PATH ) 00340 WRITE( NOUT, FMT = 9999 )UPLO, N, RANK, 00341 $ RANKDIFF, NB, IMAT, RESULT 00342 NFAIL = NFAIL + 1 00343 END IF 00344 NRUN = NRUN + 1 00345 110 CONTINUE 00346 * 00347 120 CONTINUE 00348 130 CONTINUE 00349 140 CONTINUE 00350 150 CONTINUE 00351 * 00352 * Print a summary of the results. 00353 * 00354 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00355 * 00356 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', RANK =', I3, 00357 $ ', Diff =', I5, ', NB =', I4, ', type ', I2, ', Ratio =', 00358 $ G12.5 ) 00359 RETURN 00360 * 00361 * End of SCHKPS 00362 * 00363 END