![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b ZCHKPP 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 ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 00012 * NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, 00013 * NOUT ) 00014 * 00015 * .. Scalar Arguments .. 00016 * LOGICAL TSTERR 00017 * INTEGER NMAX, NN, NNS, NOUT 00018 * DOUBLE PRECISION THRESH 00019 * .. 00020 * .. Array Arguments .. 00021 * LOGICAL DOTYPE( * ) 00022 * INTEGER NSVAL( * ), NVAL( * ) 00023 * DOUBLE PRECISION RWORK( * ) 00024 * COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), 00025 * $ WORK( * ), X( * ), XACT( * ) 00026 * .. 00027 * 00028 * 00029 *> \par Purpose: 00030 * ============= 00031 *> 00032 *> \verbatim 00033 *> 00034 *> ZCHKPP tests ZPPTRF, -TRI, -TRS, -RFS, and -CON 00035 *> \endverbatim 00036 * 00037 * Arguments: 00038 * ========== 00039 * 00040 *> \param[in] DOTYPE 00041 *> \verbatim 00042 *> DOTYPE is LOGICAL array, dimension (NTYPES) 00043 *> The matrix types to be used for testing. Matrices of type j 00044 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = 00045 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. 00046 *> \endverbatim 00047 *> 00048 *> \param[in] NN 00049 *> \verbatim 00050 *> NN is INTEGER 00051 *> The number of values of N contained in the vector NVAL. 00052 *> \endverbatim 00053 *> 00054 *> \param[in] NVAL 00055 *> \verbatim 00056 *> NVAL is INTEGER array, dimension (NN) 00057 *> The values of the matrix dimension N. 00058 *> \endverbatim 00059 *> 00060 *> \param[in] NNS 00061 *> \verbatim 00062 *> NNS is INTEGER 00063 *> The number of values of NRHS contained in the vector NSVAL. 00064 *> \endverbatim 00065 *> 00066 *> \param[in] NSVAL 00067 *> \verbatim 00068 *> NSVAL is INTEGER array, dimension (NNS) 00069 *> The values of the number of right hand sides NRHS. 00070 *> \endverbatim 00071 *> 00072 *> \param[in] THRESH 00073 *> \verbatim 00074 *> THRESH is DOUBLE PRECISION 00075 *> The threshold value for the test ratios. A result is 00076 *> included in the output file if RESULT >= THRESH. To have 00077 *> every test ratio printed, use THRESH = 0. 00078 *> \endverbatim 00079 *> 00080 *> \param[in] TSTERR 00081 *> \verbatim 00082 *> TSTERR is LOGICAL 00083 *> Flag that indicates whether error exits are to be tested. 00084 *> \endverbatim 00085 *> 00086 *> \param[in] NMAX 00087 *> \verbatim 00088 *> NMAX is INTEGER 00089 *> The maximum value permitted for N, used in dimensioning the 00090 *> work arrays. 00091 *> \endverbatim 00092 *> 00093 *> \param[out] A 00094 *> \verbatim 00095 *> A is COMPLEX*16 array, dimension 00096 *> (NMAX*(NMAX+1)/2) 00097 *> \endverbatim 00098 *> 00099 *> \param[out] AFAC 00100 *> \verbatim 00101 *> AFAC is COMPLEX*16 array, dimension 00102 *> (NMAX*(NMAX+1)/2) 00103 *> \endverbatim 00104 *> 00105 *> \param[out] AINV 00106 *> \verbatim 00107 *> AINV is COMPLEX*16 array, dimension 00108 *> (NMAX*(NMAX+1)/2) 00109 *> \endverbatim 00110 *> 00111 *> \param[out] B 00112 *> \verbatim 00113 *> B is COMPLEX*16 array, dimension (NMAX*NSMAX) 00114 *> where NSMAX is the largest entry in NSVAL. 00115 *> \endverbatim 00116 *> 00117 *> \param[out] X 00118 *> \verbatim 00119 *> X is COMPLEX*16 array, dimension (NMAX*NSMAX) 00120 *> \endverbatim 00121 *> 00122 *> \param[out] XACT 00123 *> \verbatim 00124 *> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX) 00125 *> \endverbatim 00126 *> 00127 *> \param[out] WORK 00128 *> \verbatim 00129 *> WORK is COMPLEX*16 array, dimension 00130 *> (NMAX*max(3,NSMAX)) 00131 *> \endverbatim 00132 *> 00133 *> \param[out] RWORK 00134 *> \verbatim 00135 *> RWORK is DOUBLE PRECISION array, dimension 00136 *> (max(NMAX,2*NSMAX)) 00137 *> \endverbatim 00138 *> 00139 *> \param[in] NOUT 00140 *> \verbatim 00141 *> NOUT is INTEGER 00142 *> The unit number for output. 00143 *> \endverbatim 00144 * 00145 * Authors: 00146 * ======== 00147 * 00148 *> \author Univ. of Tennessee 00149 *> \author Univ. of California Berkeley 00150 *> \author Univ. of Colorado Denver 00151 *> \author NAG Ltd. 00152 * 00153 *> \date November 2011 00154 * 00155 *> \ingroup complex16_lin 00156 * 00157 * ===================================================================== 00158 SUBROUTINE ZCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR, 00159 $ NMAX, A, AFAC, AINV, B, X, XACT, WORK, RWORK, 00160 $ NOUT ) 00161 * 00162 * -- LAPACK test routine (version 3.4.0) -- 00163 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00164 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00165 * November 2011 00166 * 00167 * .. Scalar Arguments .. 00168 LOGICAL TSTERR 00169 INTEGER NMAX, NN, NNS, NOUT 00170 DOUBLE PRECISION THRESH 00171 * .. 00172 * .. Array Arguments .. 00173 LOGICAL DOTYPE( * ) 00174 INTEGER NSVAL( * ), NVAL( * ) 00175 DOUBLE PRECISION RWORK( * ) 00176 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), 00177 $ WORK( * ), X( * ), XACT( * ) 00178 * .. 00179 * 00180 * ===================================================================== 00181 * 00182 * .. Parameters .. 00183 DOUBLE PRECISION ZERO 00184 PARAMETER ( ZERO = 0.0D+0 ) 00185 INTEGER NTYPES 00186 PARAMETER ( NTYPES = 9 ) 00187 INTEGER NTESTS 00188 PARAMETER ( NTESTS = 8 ) 00189 * .. 00190 * .. Local Scalars .. 00191 LOGICAL ZEROT 00192 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE 00193 CHARACTER*3 PATH 00194 INTEGER I, IMAT, IN, INFO, IOFF, IRHS, IUPLO, IZERO, K, 00195 $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, NPP, 00196 $ NRHS, NRUN 00197 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC 00198 * .. 00199 * .. Local Arrays .. 00200 CHARACTER PACKS( 2 ), UPLOS( 2 ) 00201 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00202 DOUBLE PRECISION RESULT( NTESTS ) 00203 * .. 00204 * .. External Functions .. 00205 DOUBLE PRECISION DGET06, ZLANHP 00206 EXTERNAL DGET06, ZLANHP 00207 * .. 00208 * .. External Subroutines .. 00209 EXTERNAL ALAERH, ALAHD, ALASUM, ZCOPY, ZERRPO, ZGET04, 00210 $ ZLACPY, ZLAIPD, ZLARHS, ZLATB4, ZLATMS, ZPPCON, 00211 $ ZPPRFS, ZPPT01, ZPPT02, ZPPT03, ZPPT05, ZPPTRF, 00212 $ ZPPTRI, ZPPTRS 00213 * .. 00214 * .. Scalars in Common .. 00215 LOGICAL LERR, OK 00216 CHARACTER*32 SRNAMT 00217 INTEGER INFOT, NUNIT 00218 * .. 00219 * .. Common blocks .. 00220 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00221 COMMON / SRNAMC / SRNAMT 00222 * .. 00223 * .. Intrinsic Functions .. 00224 INTRINSIC MAX 00225 * .. 00226 * .. Data statements .. 00227 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00228 DATA UPLOS / 'U', 'L' / , PACKS / 'C', 'R' / 00229 * .. 00230 * .. Executable Statements .. 00231 * 00232 * Initialize constants and the random number seed. 00233 * 00234 PATH( 1: 1 ) = 'Zomplex precision' 00235 PATH( 2: 3 ) = 'PP' 00236 NRUN = 0 00237 NFAIL = 0 00238 NERRS = 0 00239 DO 10 I = 1, 4 00240 ISEED( I ) = ISEEDY( I ) 00241 10 CONTINUE 00242 * 00243 * Test the error exits 00244 * 00245 IF( TSTERR ) 00246 $ CALL ZERRPO( PATH, NOUT ) 00247 INFOT = 0 00248 * 00249 * Do for each value of N in NVAL 00250 * 00251 DO 110 IN = 1, NN 00252 N = NVAL( IN ) 00253 LDA = MAX( N, 1 ) 00254 XTYPE = 'N' 00255 NIMAT = NTYPES 00256 IF( N.LE.0 ) 00257 $ NIMAT = 1 00258 * 00259 DO 100 IMAT = 1, NIMAT 00260 * 00261 * Do the tests only if DOTYPE( IMAT ) is true. 00262 * 00263 IF( .NOT.DOTYPE( IMAT ) ) 00264 $ GO TO 100 00265 * 00266 * Skip types 3, 4, or 5 if the matrix size is too small. 00267 * 00268 ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 00269 IF( ZEROT .AND. N.LT.IMAT-2 ) 00270 $ GO TO 100 00271 * 00272 * Do first for UPLO = 'U', then for UPLO = 'L' 00273 * 00274 DO 90 IUPLO = 1, 2 00275 UPLO = UPLOS( IUPLO ) 00276 PACKIT = PACKS( IUPLO ) 00277 * 00278 * Set up parameters with ZLATB4 and generate a test matrix 00279 * with ZLATMS. 00280 * 00281 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00282 $ CNDNUM, DIST ) 00283 * 00284 SRNAMT = 'ZLATMS' 00285 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 00286 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK, 00287 $ INFO ) 00288 * 00289 * Check error code from ZLATMS. 00290 * 00291 IF( INFO.NE.0 ) THEN 00292 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1, 00293 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00294 GO TO 90 00295 END IF 00296 * 00297 * For types 3-5, zero one row and column of the matrix to 00298 * test that INFO is returned correctly. 00299 * 00300 IF( ZEROT ) THEN 00301 IF( IMAT.EQ.3 ) THEN 00302 IZERO = 1 00303 ELSE IF( IMAT.EQ.4 ) THEN 00304 IZERO = N 00305 ELSE 00306 IZERO = N / 2 + 1 00307 END IF 00308 * 00309 * Set row and column IZERO of A to 0. 00310 * 00311 IF( IUPLO.EQ.1 ) THEN 00312 IOFF = ( IZERO-1 )*IZERO / 2 00313 DO 20 I = 1, IZERO - 1 00314 A( IOFF+I ) = ZERO 00315 20 CONTINUE 00316 IOFF = IOFF + IZERO 00317 DO 30 I = IZERO, N 00318 A( IOFF ) = ZERO 00319 IOFF = IOFF + I 00320 30 CONTINUE 00321 ELSE 00322 IOFF = IZERO 00323 DO 40 I = 1, IZERO - 1 00324 A( IOFF ) = ZERO 00325 IOFF = IOFF + N - I 00326 40 CONTINUE 00327 IOFF = IOFF - IZERO 00328 DO 50 I = IZERO, N 00329 A( IOFF+I ) = ZERO 00330 50 CONTINUE 00331 END IF 00332 ELSE 00333 IZERO = 0 00334 END IF 00335 * 00336 * Set the imaginary part of the diagonals. 00337 * 00338 IF( IUPLO.EQ.1 ) THEN 00339 CALL ZLAIPD( N, A, 2, 1 ) 00340 ELSE 00341 CALL ZLAIPD( N, A, N, -1 ) 00342 END IF 00343 * 00344 * Compute the L*L' or U'*U factorization of the matrix. 00345 * 00346 NPP = N*( N+1 ) / 2 00347 CALL ZCOPY( NPP, A, 1, AFAC, 1 ) 00348 SRNAMT = 'ZPPTRF' 00349 CALL ZPPTRF( UPLO, N, AFAC, INFO ) 00350 * 00351 * Check error code from ZPPTRF. 00352 * 00353 IF( INFO.NE.IZERO ) THEN 00354 CALL ALAERH( PATH, 'ZPPTRF', INFO, IZERO, UPLO, N, N, 00355 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00356 GO TO 90 00357 END IF 00358 * 00359 * Skip the tests if INFO is not 0. 00360 * 00361 IF( INFO.NE.0 ) 00362 $ GO TO 90 00363 * 00364 *+ TEST 1 00365 * Reconstruct matrix from factors and compute residual. 00366 * 00367 CALL ZCOPY( NPP, AFAC, 1, AINV, 1 ) 00368 CALL ZPPT01( UPLO, N, A, AINV, RWORK, RESULT( 1 ) ) 00369 * 00370 *+ TEST 2 00371 * Form the inverse and compute the residual. 00372 * 00373 CALL ZCOPY( NPP, AFAC, 1, AINV, 1 ) 00374 SRNAMT = 'ZPPTRI' 00375 CALL ZPPTRI( UPLO, N, AINV, INFO ) 00376 * 00377 * Check error code from ZPPTRI. 00378 * 00379 IF( INFO.NE.0 ) 00380 $ CALL ALAERH( PATH, 'ZPPTRI', INFO, 0, UPLO, N, N, -1, 00381 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00382 * 00383 CALL ZPPT03( UPLO, N, A, AINV, WORK, LDA, RWORK, RCONDC, 00384 $ RESULT( 2 ) ) 00385 * 00386 * Print information about the tests that did not pass 00387 * the threshold. 00388 * 00389 DO 60 K = 1, 2 00390 IF( RESULT( K ).GE.THRESH ) THEN 00391 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00392 $ CALL ALAHD( NOUT, PATH ) 00393 WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, K, 00394 $ RESULT( K ) 00395 NFAIL = NFAIL + 1 00396 END IF 00397 60 CONTINUE 00398 NRUN = NRUN + 2 00399 * 00400 DO 80 IRHS = 1, NNS 00401 NRHS = NSVAL( IRHS ) 00402 * 00403 *+ TEST 3 00404 * Solve and compute residual for A * X = B. 00405 * 00406 SRNAMT = 'ZLARHS' 00407 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 00408 $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, 00409 $ INFO ) 00410 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 00411 * 00412 SRNAMT = 'ZPPTRS' 00413 CALL ZPPTRS( UPLO, N, NRHS, AFAC, X, LDA, INFO ) 00414 * 00415 * Check error code from ZPPTRS. 00416 * 00417 IF( INFO.NE.0 ) 00418 $ CALL ALAERH( PATH, 'ZPPTRS', INFO, 0, UPLO, N, N, 00419 $ -1, -1, NRHS, IMAT, NFAIL, NERRS, 00420 $ NOUT ) 00421 * 00422 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 00423 CALL ZPPT02( UPLO, N, NRHS, A, X, LDA, WORK, LDA, 00424 $ RWORK, RESULT( 3 ) ) 00425 * 00426 *+ TEST 4 00427 * Check solution from generated exact solution. 00428 * 00429 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00430 $ RESULT( 4 ) ) 00431 * 00432 *+ TESTS 5, 6, and 7 00433 * Use iterative refinement to improve the solution. 00434 * 00435 SRNAMT = 'ZPPRFS' 00436 CALL ZPPRFS( UPLO, N, NRHS, A, AFAC, B, LDA, X, LDA, 00437 $ RWORK, RWORK( NRHS+1 ), WORK, 00438 $ RWORK( 2*NRHS+1 ), INFO ) 00439 * 00440 * Check error code from ZPPRFS. 00441 * 00442 IF( INFO.NE.0 ) 00443 $ CALL ALAERH( PATH, 'ZPPRFS', INFO, 0, UPLO, N, N, 00444 $ -1, -1, NRHS, IMAT, NFAIL, NERRS, 00445 $ NOUT ) 00446 * 00447 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00448 $ RESULT( 5 ) ) 00449 CALL ZPPT05( UPLO, N, NRHS, A, B, LDA, X, LDA, XACT, 00450 $ LDA, RWORK, RWORK( NRHS+1 ), 00451 $ RESULT( 6 ) ) 00452 * 00453 * Print information about the tests that did not pass 00454 * the threshold. 00455 * 00456 DO 70 K = 3, 7 00457 IF( RESULT( K ).GE.THRESH ) THEN 00458 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00459 $ CALL ALAHD( NOUT, PATH ) 00460 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT, 00461 $ K, RESULT( K ) 00462 NFAIL = NFAIL + 1 00463 END IF 00464 70 CONTINUE 00465 NRUN = NRUN + 5 00466 80 CONTINUE 00467 * 00468 *+ TEST 8 00469 * Get an estimate of RCOND = 1/CNDNUM. 00470 * 00471 ANORM = ZLANHP( '1', UPLO, N, A, RWORK ) 00472 SRNAMT = 'ZPPCON' 00473 CALL ZPPCON( UPLO, N, AFAC, ANORM, RCOND, WORK, RWORK, 00474 $ INFO ) 00475 * 00476 * Check error code from ZPPCON. 00477 * 00478 IF( INFO.NE.0 ) 00479 $ CALL ALAERH( PATH, 'ZPPCON', INFO, 0, UPLO, N, N, -1, 00480 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00481 * 00482 RESULT( 8 ) = DGET06( RCOND, RCONDC ) 00483 * 00484 * Print the test ratio if greater than or equal to THRESH. 00485 * 00486 IF( RESULT( 8 ).GE.THRESH ) THEN 00487 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00488 $ CALL ALAHD( NOUT, PATH ) 00489 WRITE( NOUT, FMT = 9999 )UPLO, N, IMAT, 8, 00490 $ RESULT( 8 ) 00491 NFAIL = NFAIL + 1 00492 END IF 00493 NRUN = NRUN + 1 00494 * 00495 90 CONTINUE 00496 100 CONTINUE 00497 110 CONTINUE 00498 * 00499 * Print a summary of the results. 00500 * 00501 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00502 * 00503 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', type ', I2, ', test ', 00504 $ I2, ', ratio =', G12.5 ) 00505 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', 00506 $ I2, ', test(', I2, ') =', G12.5 ) 00507 RETURN 00508 * 00509 * End of ZCHKPP 00510 * 00511 END