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