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