|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE ZDRVPO( 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 * ZDRVPO tests the driver routines ZPOSV 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) 00058 * 00059 * AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) 00060 * 00061 * ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) 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, 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, NB, NBMIN, 00097 $ NERRS, NFACT, NFAIL, NIMAT, NRUN, NT 00098 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC, 00099 $ ROLDC, SCOND 00100 * .. 00101 * .. Local Arrays .. 00102 CHARACTER EQUEDS( 2 ), FACTS( 3 ), UPLOS( 2 ) 00103 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00104 DOUBLE PRECISION RESULT( NTESTS ) 00105 * .. 00106 * .. External Functions .. 00107 LOGICAL LSAME 00108 DOUBLE PRECISION DGET06, ZLANHE 00109 EXTERNAL LSAME, DGET06, ZLANHE 00110 * .. 00111 * .. External Subroutines .. 00112 EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04, 00113 $ ZLACPY, ZLAIPD, ZLAQHE, ZLARHS, ZLASET, ZLATB4, 00114 $ ZLATMS, ZPOEQU, ZPOSV, ZPOSVX, ZPOT01, ZPOT02, 00115 $ ZPOT05, ZPOTRF, ZPOTRI 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' / 00132 DATA FACTS / 'F', 'N', 'E' / 00133 DATA EQUEDS / 'N', 'Y' / 00134 * .. 00135 * .. Executable Statements .. 00136 * 00137 * Initialize constants and the random number seed. 00138 * 00139 PATH( 1: 1 ) = 'Zomplex precision' 00140 PATH( 2: 3 ) = 'PO' 00141 NRUN = 0 00142 NFAIL = 0 00143 NERRS = 0 00144 DO 10 I = 1, 4 00145 ISEED( I ) = ISEEDY( I ) 00146 10 CONTINUE 00147 * 00148 * Test the error exits 00149 * 00150 IF( TSTERR ) 00151 $ CALL ZERRVX( PATH, NOUT ) 00152 INFOT = 0 00153 * 00154 * Set the block size and minimum block size for testing. 00155 * 00156 NB = 1 00157 NBMIN = 2 00158 CALL XLAENV( 1, NB ) 00159 CALL XLAENV( 2, NBMIN ) 00160 * 00161 * Do for each value of N in NVAL 00162 * 00163 DO 130 IN = 1, NN 00164 N = NVAL( IN ) 00165 LDA = MAX( N, 1 ) 00166 XTYPE = 'N' 00167 NIMAT = NTYPES 00168 IF( N.LE.0 ) 00169 $ NIMAT = 1 00170 * 00171 DO 120 IMAT = 1, NIMAT 00172 * 00173 * Do the tests only if DOTYPE( IMAT ) is true. 00174 * 00175 IF( .NOT.DOTYPE( IMAT ) ) 00176 $ GO TO 120 00177 * 00178 * Skip types 3, 4, or 5 if the matrix size is too small. 00179 * 00180 ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 00181 IF( ZEROT .AND. N.LT.IMAT-2 ) 00182 $ GO TO 120 00183 * 00184 * Do first for UPLO = 'U', then for UPLO = 'L' 00185 * 00186 DO 110 IUPLO = 1, 2 00187 UPLO = UPLOS( IUPLO ) 00188 * 00189 * Set up parameters with ZLATB4 and generate a test matrix 00190 * with ZLATMS. 00191 * 00192 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00193 $ CNDNUM, DIST ) 00194 * 00195 SRNAMT = 'ZLATMS' 00196 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 00197 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, 00198 $ INFO ) 00199 * 00200 * Check error code from ZLATMS. 00201 * 00202 IF( INFO.NE.0 ) THEN 00203 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1, 00204 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00205 GO TO 110 00206 END IF 00207 * 00208 * For types 3-5, zero one row and column of the matrix to 00209 * test that INFO is returned correctly. 00210 * 00211 IF( ZEROT ) THEN 00212 IF( IMAT.EQ.3 ) THEN 00213 IZERO = 1 00214 ELSE IF( IMAT.EQ.4 ) THEN 00215 IZERO = N 00216 ELSE 00217 IZERO = N / 2 + 1 00218 END IF 00219 IOFF = ( IZERO-1 )*LDA 00220 * 00221 * Set row and column IZERO of A to 0. 00222 * 00223 IF( IUPLO.EQ.1 ) THEN 00224 DO 20 I = 1, IZERO - 1 00225 A( IOFF+I ) = ZERO 00226 20 CONTINUE 00227 IOFF = IOFF + IZERO 00228 DO 30 I = IZERO, N 00229 A( IOFF ) = ZERO 00230 IOFF = IOFF + LDA 00231 30 CONTINUE 00232 ELSE 00233 IOFF = IZERO 00234 DO 40 I = 1, IZERO - 1 00235 A( IOFF ) = ZERO 00236 IOFF = IOFF + LDA 00237 40 CONTINUE 00238 IOFF = IOFF - IZERO 00239 DO 50 I = IZERO, N 00240 A( IOFF+I ) = ZERO 00241 50 CONTINUE 00242 END IF 00243 ELSE 00244 IZERO = 0 00245 END IF 00246 * 00247 * Set the imaginary part of the diagonals. 00248 * 00249 CALL ZLAIPD( N, A, LDA+1, 0 ) 00250 * 00251 * Save a copy of the matrix A in ASAV. 00252 * 00253 CALL ZLACPY( UPLO, N, N, A, LDA, ASAV, LDA ) 00254 * 00255 DO 100 IEQUED = 1, 2 00256 EQUED = EQUEDS( IEQUED ) 00257 IF( IEQUED.EQ.1 ) THEN 00258 NFACT = 3 00259 ELSE 00260 NFACT = 1 00261 END IF 00262 * 00263 DO 90 IFACT = 1, NFACT 00264 FACT = FACTS( IFACT ) 00265 PREFAC = LSAME( FACT, 'F' ) 00266 NOFACT = LSAME( FACT, 'N' ) 00267 EQUIL = LSAME( FACT, 'E' ) 00268 * 00269 IF( ZEROT ) THEN 00270 IF( PREFAC ) 00271 $ GO TO 90 00272 RCONDC = ZERO 00273 * 00274 ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN 00275 * 00276 * Compute the condition number for comparison with 00277 * the value returned by ZPOSVX (FACT = 'N' reuses 00278 * the condition number from the previous iteration 00279 * with FACT = 'F'). 00280 * 00281 CALL ZLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA ) 00282 IF( EQUIL .OR. IEQUED.GT.1 ) THEN 00283 * 00284 * Compute row and column scale factors to 00285 * equilibrate the matrix A. 00286 * 00287 CALL ZPOEQU( N, AFAC, LDA, S, SCOND, AMAX, 00288 $ INFO ) 00289 IF( INFO.EQ.0 .AND. N.GT.0 ) THEN 00290 IF( IEQUED.GT.1 ) 00291 $ SCOND = ZERO 00292 * 00293 * Equilibrate the matrix. 00294 * 00295 CALL ZLAQHE( UPLO, N, AFAC, LDA, S, SCOND, 00296 $ AMAX, EQUED ) 00297 END IF 00298 END IF 00299 * 00300 * Save the condition number of the 00301 * non-equilibrated system for use in ZGET04. 00302 * 00303 IF( EQUIL ) 00304 $ ROLDC = RCONDC 00305 * 00306 * Compute the 1-norm of A. 00307 * 00308 ANORM = ZLANHE( '1', UPLO, N, AFAC, LDA, RWORK ) 00309 * 00310 * Factor the matrix A. 00311 * 00312 CALL ZPOTRF( UPLO, N, AFAC, LDA, INFO ) 00313 * 00314 * Form the inverse of A. 00315 * 00316 CALL ZLACPY( UPLO, N, N, AFAC, LDA, A, LDA ) 00317 CALL ZPOTRI( UPLO, N, A, LDA, INFO ) 00318 * 00319 * Compute the 1-norm condition number of A. 00320 * 00321 AINVNM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) 00322 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00323 RCONDC = ONE 00324 ELSE 00325 RCONDC = ( ONE / ANORM ) / AINVNM 00326 END IF 00327 END IF 00328 * 00329 * Restore the matrix A. 00330 * 00331 CALL ZLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) 00332 * 00333 * Form an exact solution and set the right hand side. 00334 * 00335 SRNAMT = 'ZLARHS' 00336 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 00337 $ NRHS, A, LDA, XACT, LDA, B, LDA, 00338 $ ISEED, INFO ) 00339 XTYPE = 'C' 00340 CALL ZLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) 00341 * 00342 IF( NOFACT ) THEN 00343 * 00344 * --- Test ZPOSV --- 00345 * 00346 * Compute the L*L' or U'*U factorization of the 00347 * matrix and solve the system. 00348 * 00349 CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) 00350 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 00351 * 00352 SRNAMT = 'ZPOSV ' 00353 CALL ZPOSV( UPLO, N, NRHS, AFAC, LDA, X, LDA, 00354 $ INFO ) 00355 * 00356 * Check error code from ZPOSV . 00357 * 00358 IF( INFO.NE.IZERO ) THEN 00359 CALL ALAERH( PATH, 'ZPOSV ', INFO, IZERO, 00360 $ UPLO, N, N, -1, -1, NRHS, IMAT, 00361 $ NFAIL, NERRS, NOUT ) 00362 GO TO 70 00363 ELSE IF( INFO.NE.0 ) THEN 00364 GO TO 70 00365 END IF 00366 * 00367 * Reconstruct matrix from factors and compute 00368 * residual. 00369 * 00370 CALL ZPOT01( UPLO, N, A, LDA, AFAC, LDA, RWORK, 00371 $ RESULT( 1 ) ) 00372 * 00373 * Compute residual of the computed solution. 00374 * 00375 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, 00376 $ LDA ) 00377 CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, 00378 $ WORK, LDA, RWORK, RESULT( 2 ) ) 00379 * 00380 * Check solution from generated exact solution. 00381 * 00382 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00383 $ RESULT( 3 ) ) 00384 NT = 3 00385 * 00386 * Print information about the tests that did not 00387 * pass the threshold. 00388 * 00389 DO 60 K = 1, NT 00390 IF( RESULT( K ).GE.THRESH ) THEN 00391 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00392 $ CALL ALADHD( NOUT, PATH ) 00393 WRITE( NOUT, FMT = 9999 )'ZPOSV ', UPLO, 00394 $ N, IMAT, K, RESULT( K ) 00395 NFAIL = NFAIL + 1 00396 END IF 00397 60 CONTINUE 00398 NRUN = NRUN + NT 00399 70 CONTINUE 00400 END IF 00401 * 00402 * --- Test ZPOSVX --- 00403 * 00404 IF( .NOT.PREFAC ) 00405 $ CALL ZLASET( UPLO, N, N, DCMPLX( ZERO ), 00406 $ DCMPLX( ZERO ), AFAC, LDA ) 00407 CALL ZLASET( 'Full', N, NRHS, DCMPLX( ZERO ), 00408 $ DCMPLX( ZERO ), X, LDA ) 00409 IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN 00410 * 00411 * Equilibrate the matrix if FACT='F' and 00412 * EQUED='Y'. 00413 * 00414 CALL ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, 00415 $ EQUED ) 00416 END IF 00417 * 00418 * Solve the system and compute the condition number 00419 * and error bounds using ZPOSVX. 00420 * 00421 SRNAMT = 'ZPOSVX' 00422 CALL ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AFAC, 00423 $ LDA, EQUED, S, B, LDA, X, LDA, RCOND, 00424 $ RWORK, RWORK( NRHS+1 ), WORK, 00425 $ RWORK( 2*NRHS+1 ), INFO ) 00426 * 00427 * Check the error code from ZPOSVX. 00428 * 00429 IF( INFO.NE.IZERO ) THEN 00430 CALL ALAERH( PATH, 'ZPOSVX', INFO, IZERO, 00431 $ FACT // UPLO, N, N, -1, -1, NRHS, 00432 $ IMAT, NFAIL, NERRS, NOUT ) 00433 GO TO 90 00434 END IF 00435 * 00436 IF( INFO.EQ.0 ) THEN 00437 IF( .NOT.PREFAC ) THEN 00438 * 00439 * Reconstruct matrix from factors and compute 00440 * residual. 00441 * 00442 CALL ZPOT01( UPLO, N, A, LDA, AFAC, LDA, 00443 $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) 00444 K1 = 1 00445 ELSE 00446 K1 = 2 00447 END IF 00448 * 00449 * Compute residual of the computed solution. 00450 * 00451 CALL ZLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, 00452 $ LDA ) 00453 CALL ZPOT02( UPLO, N, NRHS, ASAV, LDA, X, LDA, 00454 $ WORK, LDA, RWORK( 2*NRHS+1 ), 00455 $ RESULT( 2 ) ) 00456 * 00457 * Check solution from generated exact solution. 00458 * 00459 IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, 00460 $ 'N' ) ) ) THEN 00461 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, 00462 $ RCONDC, RESULT( 3 ) ) 00463 ELSE 00464 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, 00465 $ ROLDC, RESULT( 3 ) ) 00466 END IF 00467 * 00468 * Check the error bounds from iterative 00469 * refinement. 00470 * 00471 CALL ZPOT05( UPLO, N, NRHS, ASAV, LDA, B, LDA, 00472 $ X, LDA, XACT, LDA, RWORK, 00473 $ RWORK( NRHS+1 ), RESULT( 4 ) ) 00474 ELSE 00475 K1 = 6 00476 END IF 00477 * 00478 * Compare RCOND from ZPOSVX with the computed value 00479 * in RCONDC. 00480 * 00481 RESULT( 6 ) = DGET06( RCOND, RCONDC ) 00482 * 00483 * Print information about the tests that did not pass 00484 * the threshold. 00485 * 00486 DO 80 K = K1, 6 00487 IF( RESULT( K ).GE.THRESH ) THEN 00488 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00489 $ CALL ALADHD( NOUT, PATH ) 00490 IF( PREFAC ) THEN 00491 WRITE( NOUT, FMT = 9997 )'ZPOSVX', FACT, 00492 $ UPLO, N, EQUED, IMAT, K, RESULT( K ) 00493 ELSE 00494 WRITE( NOUT, FMT = 9998 )'ZPOSVX', FACT, 00495 $ UPLO, N, IMAT, K, RESULT( K ) 00496 END IF 00497 NFAIL = NFAIL + 1 00498 END IF 00499 80 CONTINUE 00500 NRUN = NRUN + 7 - K1 00501 90 CONTINUE 00502 100 CONTINUE 00503 110 CONTINUE 00504 120 CONTINUE 00505 130 CONTINUE 00506 * 00507 * Print a summary of the results. 00508 * 00509 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00510 * 00511 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I1, 00512 $ ', test(', I1, ')=', G12.5 ) 00513 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, 00514 $ ', type ', I1, ', test(', I1, ')=', G12.5 ) 00515 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, 00516 $ ', EQUED=''', A1, ''', type ', I1, ', test(', I1, ') =', 00517 $ G12.5 ) 00518 RETURN 00519 * 00520 * End of ZDRVPO 00521 * 00522 END
1.7.3 
