![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SDRVSY 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 SDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, 00012 * A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, 00013 * NOUT ) 00014 * 00015 * .. Scalar Arguments .. 00016 * LOGICAL TSTERR 00017 * INTEGER NMAX, NN, NOUT, NRHS 00018 * REAL THRESH 00019 * .. 00020 * .. Array Arguments .. 00021 * LOGICAL DOTYPE( * ) 00022 * INTEGER IWORK( * ), NVAL( * ) 00023 * REAL A( * ), AFAC( * ), AINV( * ), B( * ), 00024 * $ RWORK( * ), WORK( * ), X( * ), XACT( * ) 00025 * .. 00026 * 00027 * 00028 *> \par Purpose: 00029 * ============= 00030 *> 00031 *> \verbatim 00032 *> 00033 *> SDRVSY tests the driver routines SSYSV and -SVX. 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] NRHS 00060 *> \verbatim 00061 *> NRHS is INTEGER 00062 *> The number of right hand side vectors to be generated for 00063 *> each linear system. 00064 *> \endverbatim 00065 *> 00066 *> \param[in] THRESH 00067 *> \verbatim 00068 *> THRESH is REAL 00069 *> The threshold value for the test ratios. A result is 00070 *> included in the output file if RESULT >= THRESH. To have 00071 *> every test ratio printed, use THRESH = 0. 00072 *> \endverbatim 00073 *> 00074 *> \param[in] TSTERR 00075 *> \verbatim 00076 *> TSTERR is LOGICAL 00077 *> Flag that indicates whether error exits are to be tested. 00078 *> \endverbatim 00079 *> 00080 *> \param[in] NMAX 00081 *> \verbatim 00082 *> NMAX is INTEGER 00083 *> The maximum value permitted for N, used in dimensioning the 00084 *> work arrays. 00085 *> \endverbatim 00086 *> 00087 *> \param[out] A 00088 *> \verbatim 00089 *> A is REAL array, dimension (NMAX*NMAX) 00090 *> \endverbatim 00091 *> 00092 *> \param[out] AFAC 00093 *> \verbatim 00094 *> AFAC is REAL array, dimension (NMAX*NMAX) 00095 *> \endverbatim 00096 *> 00097 *> \param[out] AINV 00098 *> \verbatim 00099 *> AINV is REAL array, dimension (NMAX*NMAX) 00100 *> \endverbatim 00101 *> 00102 *> \param[out] B 00103 *> \verbatim 00104 *> B is REAL array, dimension (NMAX*NRHS) 00105 *> \endverbatim 00106 *> 00107 *> \param[out] X 00108 *> \verbatim 00109 *> X is REAL array, dimension (NMAX*NRHS) 00110 *> \endverbatim 00111 *> 00112 *> \param[out] XACT 00113 *> \verbatim 00114 *> XACT is REAL array, dimension (NMAX*NRHS) 00115 *> \endverbatim 00116 *> 00117 *> \param[out] WORK 00118 *> \verbatim 00119 *> WORK is REAL array, dimension 00120 *> (NMAX*max(2,NRHS)) 00121 *> \endverbatim 00122 *> 00123 *> \param[out] RWORK 00124 *> \verbatim 00125 *> RWORK is REAL array, dimension (NMAX+2*NRHS) 00126 *> \endverbatim 00127 *> 00128 *> \param[out] IWORK 00129 *> \verbatim 00130 *> IWORK is INTEGER array, dimension (2*NMAX) 00131 *> \endverbatim 00132 *> 00133 *> \param[in] NOUT 00134 *> \verbatim 00135 *> NOUT is INTEGER 00136 *> The unit number for output. 00137 *> \endverbatim 00138 * 00139 * Authors: 00140 * ======== 00141 * 00142 *> \author Univ. of Tennessee 00143 *> \author Univ. of California Berkeley 00144 *> \author Univ. of Colorado Denver 00145 *> \author NAG Ltd. 00146 * 00147 *> \date November 2011 00148 * 00149 *> \ingroup single_lin 00150 * 00151 * ===================================================================== 00152 SUBROUTINE SDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, 00153 $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK, 00154 $ NOUT ) 00155 * 00156 * -- LAPACK test routine (version 3.4.0) -- 00157 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00158 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00159 * November 2011 00160 * 00161 * .. Scalar Arguments .. 00162 LOGICAL TSTERR 00163 INTEGER NMAX, NN, NOUT, NRHS 00164 REAL THRESH 00165 * .. 00166 * .. Array Arguments .. 00167 LOGICAL DOTYPE( * ) 00168 INTEGER IWORK( * ), NVAL( * ) 00169 REAL A( * ), AFAC( * ), AINV( * ), B( * ), 00170 $ RWORK( * ), WORK( * ), X( * ), XACT( * ) 00171 * .. 00172 * 00173 * ===================================================================== 00174 * 00175 * .. Parameters .. 00176 REAL ONE, ZERO 00177 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) 00178 INTEGER NTYPES, NTESTS 00179 PARAMETER ( NTYPES = 10, NTESTS = 6 ) 00180 INTEGER NFACT 00181 PARAMETER ( NFACT = 2 ) 00182 * .. 00183 * .. Local Scalars .. 00184 LOGICAL ZEROT 00185 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE 00186 CHARACTER*3 PATH 00187 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, 00188 $ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N, 00189 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT 00190 REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC 00191 * .. 00192 * .. Local Arrays .. 00193 CHARACTER FACTS( NFACT ), UPLOS( 2 ) 00194 INTEGER ISEED( 4 ), ISEEDY( 4 ) 00195 REAL RESULT( NTESTS ) 00196 * .. 00197 * .. External Functions .. 00198 REAL SGET06, SLANSY 00199 EXTERNAL SGET06, SLANSY 00200 * .. 00201 * .. External Subroutines .. 00202 EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY, 00203 $ SLARHS, SLASET, SLATB4, SLATMS, SPOT02, SPOT05, 00204 $ SSYSV, SSYSVX, SSYT01, SSYTRF, SSYTRI2, XLAENV 00205 * .. 00206 * .. Scalars in Common .. 00207 LOGICAL LERR, OK 00208 CHARACTER*32 SRNAMT 00209 INTEGER INFOT, NUNIT 00210 * .. 00211 * .. Common blocks .. 00212 COMMON / INFOC / INFOT, NUNIT, OK, LERR 00213 COMMON / SRNAMC / SRNAMT 00214 * .. 00215 * .. Intrinsic Functions .. 00216 INTRINSIC MAX, MIN 00217 * .. 00218 * .. Data statements .. 00219 DATA ISEEDY / 1988, 1989, 1990, 1991 / 00220 DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / 00221 * .. 00222 * .. Executable Statements .. 00223 * 00224 * Initialize constants and the random number seed. 00225 * 00226 PATH( 1: 1 ) = 'Single precision' 00227 PATH( 2: 3 ) = 'SY' 00228 NRUN = 0 00229 NFAIL = 0 00230 NERRS = 0 00231 DO 10 I = 1, 4 00232 ISEED( I ) = ISEEDY( I ) 00233 10 CONTINUE 00234 LWORK = MAX( 2*NMAX, NMAX*NRHS ) 00235 * 00236 * Test the error exits 00237 * 00238 IF( TSTERR ) 00239 $ CALL SERRVX( PATH, NOUT ) 00240 INFOT = 0 00241 * 00242 * Set the block size and minimum block size for testing. 00243 * 00244 NB = 1 00245 NBMIN = 2 00246 CALL XLAENV( 1, NB ) 00247 CALL XLAENV( 2, NBMIN ) 00248 * 00249 * Do for each value of N in NVAL 00250 * 00251 DO 180 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 170 IMAT = 1, NIMAT 00260 * 00261 * Do the tests only if DOTYPE( IMAT ) is true. 00262 * 00263 IF( .NOT.DOTYPE( IMAT ) ) 00264 $ GO TO 170 00265 * 00266 * Skip types 3, 4, 5, or 6 if the matrix size is too small. 00267 * 00268 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 00269 IF( ZEROT .AND. N.LT.IMAT-2 ) 00270 $ GO TO 170 00271 * 00272 * Do first for UPLO = 'U', then for UPLO = 'L' 00273 * 00274 DO 160 IUPLO = 1, 2 00275 UPLO = UPLOS( IUPLO ) 00276 * 00277 * Set up parameters with SLATB4 and generate a test matrix 00278 * with SLATMS. 00279 * 00280 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, 00281 $ CNDNUM, DIST ) 00282 * 00283 SRNAMT = 'SLATMS' 00284 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, 00285 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, 00286 $ INFO ) 00287 * 00288 * Check error code from SLATMS. 00289 * 00290 IF( INFO.NE.0 ) THEN 00291 CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, 00292 $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) 00293 GO TO 160 00294 END IF 00295 * 00296 * For types 3-6, zero one or more rows and columns of the 00297 * matrix to test that INFO is returned correctly. 00298 * 00299 IF( ZEROT ) THEN 00300 IF( IMAT.EQ.3 ) THEN 00301 IZERO = 1 00302 ELSE IF( IMAT.EQ.4 ) THEN 00303 IZERO = N 00304 ELSE 00305 IZERO = N / 2 + 1 00306 END IF 00307 * 00308 IF( IMAT.LT.6 ) THEN 00309 * 00310 * Set row and column IZERO to zero. 00311 * 00312 IF( IUPLO.EQ.1 ) THEN 00313 IOFF = ( IZERO-1 )*LDA 00314 DO 20 I = 1, IZERO - 1 00315 A( IOFF+I ) = ZERO 00316 20 CONTINUE 00317 IOFF = IOFF + IZERO 00318 DO 30 I = IZERO, N 00319 A( IOFF ) = ZERO 00320 IOFF = IOFF + LDA 00321 30 CONTINUE 00322 ELSE 00323 IOFF = IZERO 00324 DO 40 I = 1, IZERO - 1 00325 A( IOFF ) = ZERO 00326 IOFF = IOFF + LDA 00327 40 CONTINUE 00328 IOFF = IOFF - IZERO 00329 DO 50 I = IZERO, N 00330 A( IOFF+I ) = ZERO 00331 50 CONTINUE 00332 END IF 00333 ELSE 00334 IOFF = 0 00335 IF( IUPLO.EQ.1 ) THEN 00336 * 00337 * Set the first IZERO rows and columns to zero. 00338 * 00339 DO 70 J = 1, N 00340 I2 = MIN( J, IZERO ) 00341 DO 60 I = 1, I2 00342 A( IOFF+I ) = ZERO 00343 60 CONTINUE 00344 IOFF = IOFF + LDA 00345 70 CONTINUE 00346 ELSE 00347 * 00348 * Set the last IZERO rows and columns to zero. 00349 * 00350 DO 90 J = 1, N 00351 I1 = MAX( J, IZERO ) 00352 DO 80 I = I1, N 00353 A( IOFF+I ) = ZERO 00354 80 CONTINUE 00355 IOFF = IOFF + LDA 00356 90 CONTINUE 00357 END IF 00358 END IF 00359 ELSE 00360 IZERO = 0 00361 END IF 00362 * 00363 DO 150 IFACT = 1, NFACT 00364 * 00365 * Do first for FACT = 'F', then for other values. 00366 * 00367 FACT = FACTS( IFACT ) 00368 * 00369 * Compute the condition number for comparison with 00370 * the value returned by SSYSVX. 00371 * 00372 IF( ZEROT ) THEN 00373 IF( IFACT.EQ.1 ) 00374 $ GO TO 150 00375 RCONDC = ZERO 00376 * 00377 ELSE IF( IFACT.EQ.1 ) THEN 00378 * 00379 * Compute the 1-norm of A. 00380 * 00381 ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) 00382 * 00383 * Factor the matrix A. 00384 * 00385 CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) 00386 CALL SSYTRF( UPLO, N, AFAC, LDA, IWORK, WORK, 00387 $ LWORK, INFO ) 00388 * 00389 * Compute inv(A) and take its norm. 00390 * 00391 CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) 00392 LWORK = (N+NB+1)*(NB+3) 00393 CALL SSYTRI2( UPLO, N, AINV, LDA, IWORK, WORK, 00394 $ LWORK, INFO ) 00395 AINVNM = SLANSY( '1', UPLO, N, AINV, LDA, RWORK ) 00396 * 00397 * Compute the 1-norm condition number of A. 00398 * 00399 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN 00400 RCONDC = ONE 00401 ELSE 00402 RCONDC = ( ONE / ANORM ) / AINVNM 00403 END IF 00404 END IF 00405 * 00406 * Form an exact solution and set the right hand side. 00407 * 00408 SRNAMT = 'SLARHS' 00409 CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, 00410 $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, 00411 $ INFO ) 00412 XTYPE = 'C' 00413 * 00414 * --- Test SSYSV --- 00415 * 00416 IF( IFACT.EQ.2 ) THEN 00417 CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) 00418 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) 00419 * 00420 * Factor the matrix and solve the system using SSYSV. 00421 * 00422 SRNAMT = 'SSYSV ' 00423 CALL SSYSV( UPLO, N, NRHS, AFAC, LDA, IWORK, X, 00424 $ LDA, WORK, LWORK, INFO ) 00425 * 00426 * Adjust the expected value of INFO to account for 00427 * pivoting. 00428 * 00429 K = IZERO 00430 IF( K.GT.0 ) THEN 00431 100 CONTINUE 00432 IF( IWORK( K ).LT.0 ) THEN 00433 IF( IWORK( K ).NE.-K ) THEN 00434 K = -IWORK( K ) 00435 GO TO 100 00436 END IF 00437 ELSE IF( IWORK( K ).NE.K ) THEN 00438 K = IWORK( K ) 00439 GO TO 100 00440 END IF 00441 END IF 00442 * 00443 * Check error code from SSYSV . 00444 * 00445 IF( INFO.NE.K ) THEN 00446 CALL ALAERH( PATH, 'SSYSV ', INFO, K, UPLO, N, 00447 $ N, -1, -1, NRHS, IMAT, NFAIL, 00448 $ NERRS, NOUT ) 00449 GO TO 120 00450 ELSE IF( INFO.NE.0 ) THEN 00451 GO TO 120 00452 END IF 00453 * 00454 * Reconstruct matrix from factors and compute 00455 * residual. 00456 * 00457 CALL SSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, 00458 $ AINV, LDA, RWORK, RESULT( 1 ) ) 00459 * 00460 * Compute residual of the computed solution. 00461 * 00462 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 00463 CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, 00464 $ LDA, RWORK, RESULT( 2 ) ) 00465 * 00466 * Check solution from generated exact solution. 00467 * 00468 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00469 $ RESULT( 3 ) ) 00470 NT = 3 00471 * 00472 * Print information about the tests that did not pass 00473 * the threshold. 00474 * 00475 DO 110 K = 1, NT 00476 IF( RESULT( K ).GE.THRESH ) THEN 00477 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00478 $ CALL ALADHD( NOUT, PATH ) 00479 WRITE( NOUT, FMT = 9999 )'SSYSV ', UPLO, N, 00480 $ IMAT, K, RESULT( K ) 00481 NFAIL = NFAIL + 1 00482 END IF 00483 110 CONTINUE 00484 NRUN = NRUN + NT 00485 120 CONTINUE 00486 END IF 00487 * 00488 * --- Test SSYSVX --- 00489 * 00490 IF( IFACT.EQ.2 ) 00491 $ CALL SLASET( UPLO, N, N, ZERO, ZERO, AFAC, LDA ) 00492 CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) 00493 * 00494 * Solve the system and compute the condition number and 00495 * error bounds using SSYSVX. 00496 * 00497 SRNAMT = 'SSYSVX' 00498 CALL SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AFAC, LDA, 00499 $ IWORK, B, LDA, X, LDA, RCOND, RWORK, 00500 $ RWORK( NRHS+1 ), WORK, LWORK, 00501 $ IWORK( N+1 ), INFO ) 00502 * 00503 * Adjust the expected value of INFO to account for 00504 * pivoting. 00505 * 00506 K = IZERO 00507 IF( K.GT.0 ) THEN 00508 130 CONTINUE 00509 IF( IWORK( K ).LT.0 ) THEN 00510 IF( IWORK( K ).NE.-K ) THEN 00511 K = -IWORK( K ) 00512 GO TO 130 00513 END IF 00514 ELSE IF( IWORK( K ).NE.K ) THEN 00515 K = IWORK( K ) 00516 GO TO 130 00517 END IF 00518 END IF 00519 * 00520 * Check the error code from SSYSVX. 00521 * 00522 IF( INFO.NE.K ) THEN 00523 CALL ALAERH( PATH, 'SSYSVX', INFO, K, FACT // UPLO, 00524 $ N, N, -1, -1, NRHS, IMAT, NFAIL, 00525 $ NERRS, NOUT ) 00526 GO TO 150 00527 END IF 00528 * 00529 IF( INFO.EQ.0 ) THEN 00530 IF( IFACT.GE.2 ) THEN 00531 * 00532 * Reconstruct matrix from factors and compute 00533 * residual. 00534 * 00535 CALL SSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, 00536 $ AINV, LDA, RWORK( 2*NRHS+1 ), 00537 $ RESULT( 1 ) ) 00538 K1 = 1 00539 ELSE 00540 K1 = 2 00541 END IF 00542 * 00543 * Compute residual of the computed solution. 00544 * 00545 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) 00546 CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, 00547 $ LDA, RWORK( 2*NRHS+1 ), RESULT( 2 ) ) 00548 * 00549 * Check solution from generated exact solution. 00550 * 00551 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, 00552 $ RESULT( 3 ) ) 00553 * 00554 * Check the error bounds from iterative refinement. 00555 * 00556 CALL SPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA, 00557 $ XACT, LDA, RWORK, RWORK( NRHS+1 ), 00558 $ RESULT( 4 ) ) 00559 ELSE 00560 K1 = 6 00561 END IF 00562 * 00563 * Compare RCOND from SSYSVX with the computed value 00564 * in RCONDC. 00565 * 00566 RESULT( 6 ) = SGET06( RCOND, RCONDC ) 00567 * 00568 * Print information about the tests that did not pass 00569 * the threshold. 00570 * 00571 DO 140 K = K1, 6 00572 IF( RESULT( K ).GE.THRESH ) THEN 00573 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) 00574 $ CALL ALADHD( NOUT, PATH ) 00575 WRITE( NOUT, FMT = 9998 )'SSYSVX', FACT, UPLO, 00576 $ N, IMAT, K, RESULT( K ) 00577 NFAIL = NFAIL + 1 00578 END IF 00579 140 CONTINUE 00580 NRUN = NRUN + 7 - K1 00581 * 00582 150 CONTINUE 00583 * 00584 160 CONTINUE 00585 170 CONTINUE 00586 180 CONTINUE 00587 * 00588 * Print a summary of the results. 00589 * 00590 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) 00591 * 00592 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, 00593 $ ', test ', I2, ', ratio =', G12.5 ) 00594 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5, 00595 $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) 00596 RETURN 00597 * 00598 * End of SDRVSY 00599 * 00600 END