 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 SUBROUTINE CCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, 00002 $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, 00003 $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, 00004 $ LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT, 00005 $ INFO ) 00006 IMPLICIT NONE 00007 * 00008 * -- LAPACK test routine (version 3.1) -- 00009 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00010 * November 2006 00011 * 00012 * .. Scalar Arguments .. 00013 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT, 00014 $ NSIZES, NTYPES 00015 REAL THRESH 00016 * .. 00017 * .. Array Arguments .. 00018 LOGICAL DOTYPE( * ) 00019 INTEGER ISEED( 4 ), IWORK( * ), NN( * ) 00020 REAL D1( * ), D2( * ), D3( * ), D4( * ), D5( * ), 00021 $ RESULT( * ), RWORK( * ), SD( * ), SE( * ), 00022 $ WA1( * ), WA2( * ), WA3( * ), WR( * ) 00023 COMPLEX A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ), 00024 $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * ) 00025 * .. 00026 * 00027 * Purpose 00028 * ======= 00029 * 00030 * CCHKST checks the Hermitian eigenvalue problem routines. 00031 * 00032 * CHETRD factors A as U S U* , where * means conjugate transpose, 00033 * S is real symmetric tridiagonal, and U is unitary. 00034 * CHETRD can use either just the lower or just the upper triangle 00035 * of A; CCHKST checks both cases. 00036 * U is represented as a product of Householder 00037 * transformations, whose vectors are stored in the first 00038 * n-1 columns of V, and whose scale factors are in TAU. 00039 * 00040 * CHPTRD does the same as CHETRD, except that A and V are stored 00041 * in "packed" format. 00042 * 00043 * CUNGTR constructs the matrix U from the contents of V and TAU. 00044 * 00045 * CUPGTR constructs the matrix U from the contents of VP and TAU. 00046 * 00047 * CSTEQR factors S as Z D1 Z* , where Z is the unitary 00048 * matrix of eigenvectors and D1 is a diagonal matrix with 00049 * the eigenvalues on the diagonal. D2 is the matrix of 00050 * eigenvalues computed when Z is not computed. 00051 * 00052 * SSTERF computes D3, the matrix of eigenvalues, by the 00053 * PWK method, which does not yield eigenvectors. 00054 * 00055 * CPTEQR factors S as Z4 D4 Z4* , for a 00056 * Hermitian positive definite tridiagonal matrix. 00057 * D5 is the matrix of eigenvalues computed when Z is not 00058 * computed. 00059 * 00060 * SSTEBZ computes selected eigenvalues. WA1, WA2, and 00061 * WA3 will denote eigenvalues computed to high 00062 * absolute accuracy, with different range options. 00063 * WR will denote eigenvalues computed to high relative 00064 * accuracy. 00065 * 00066 * CSTEIN computes Y, the eigenvectors of S, given the 00067 * eigenvalues. 00068 * 00069 * CSTEDC factors S as Z D1 Z* , where Z is the unitary 00070 * matrix of eigenvectors and D1 is a diagonal matrix with 00071 * the eigenvalues on the diagonal ('I' option). It may also 00072 * update an input unitary matrix, usually the output 00073 * from CHETRD/CUNGTR or CHPTRD/CUPGTR ('V' option). It may 00074 * also just compute eigenvalues ('N' option). 00075 * 00076 * CSTEMR factors S as Z D1 Z* , where Z is the unitary 00077 * matrix of eigenvectors and D1 is a diagonal matrix with 00078 * the eigenvalues on the diagonal ('I' option). CSTEMR 00079 * uses the Relatively Robust Representation whenever possible. 00080 * 00081 * When CCHKST is called, a number of matrix "sizes" ("n's") and a 00082 * number of matrix "types" are specified. For each size ("n") 00083 * and each type of matrix, one matrix will be generated and used 00084 * to test the Hermitian eigenroutines. For each matrix, a number 00085 * of tests will be performed: 00086 * 00087 * (1) | A - V S V* | / ( |A| n ulp ) CHETRD( UPLO='U', ... ) 00088 * 00089 * (2) | I - UV* | / ( n ulp ) CUNGTR( UPLO='U', ... ) 00090 * 00091 * (3) | A - V S V* | / ( |A| n ulp ) CHETRD( UPLO='L', ... ) 00092 * 00093 * (4) | I - UV* | / ( n ulp ) CUNGTR( UPLO='L', ... ) 00094 * 00095 * (5-8) Same as 1-4, but for CHPTRD and CUPGTR. 00096 * 00097 * (9) | S - Z D Z* | / ( |S| n ulp ) CSTEQR('V',...) 00098 * 00099 * (10) | I - ZZ* | / ( n ulp ) CSTEQR('V',...) 00100 * 00101 * (11) | D1 - D2 | / ( |D1| ulp ) CSTEQR('N',...) 00102 * 00103 * (12) | D1 - D3 | / ( |D1| ulp ) SSTERF 00104 * 00105 * (13) 0 if the true eigenvalues (computed by sturm count) 00106 * of S are within THRESH of 00107 * those in D1. 2*THRESH if they are not. (Tested using 00108 * SSTECH) 00109 * 00110 * For S positive definite, 00111 * 00112 * (14) | S - Z4 D4 Z4* | / ( |S| n ulp ) CPTEQR('V',...) 00113 * 00114 * (15) | I - Z4 Z4* | / ( n ulp ) CPTEQR('V',...) 00115 * 00116 * (16) | D4 - D5 | / ( 100 |D4| ulp ) CPTEQR('N',...) 00117 * 00118 * When S is also diagonally dominant by the factor gamma < 1, 00119 * 00120 * (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) , 00121 * i 00122 * omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 00123 * SSTEBZ( 'A', 'E', ...) 00124 * 00125 * (18) | WA1 - D3 | / ( |D3| ulp ) SSTEBZ( 'A', 'E', ...) 00126 * 00127 * (19) ( max { min | WA2(i)-WA3(j) | } + 00128 * i j 00129 * max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) 00130 * i j 00131 * SSTEBZ( 'I', 'E', ...) 00132 * 00133 * (20) | S - Y WA1 Y* | / ( |S| n ulp ) SSTEBZ, CSTEIN 00134 * 00135 * (21) | I - Y Y* | / ( n ulp ) SSTEBZ, CSTEIN 00136 * 00137 * (22) | S - Z D Z* | / ( |S| n ulp ) CSTEDC('I') 00138 * 00139 * (23) | I - ZZ* | / ( n ulp ) CSTEDC('I') 00140 * 00141 * (24) | S - Z D Z* | / ( |S| n ulp ) CSTEDC('V') 00142 * 00143 * (25) | I - ZZ* | / ( n ulp ) CSTEDC('V') 00144 * 00145 * (26) | D1 - D2 | / ( |D1| ulp ) CSTEDC('V') and 00146 * CSTEDC('N') 00147 * 00148 * Test 27 is disabled at the moment because CSTEMR does not 00149 * guarantee high relatvie accuracy. 00150 * 00151 * (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , 00152 * i 00153 * omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 00154 * CSTEMR('V', 'A') 00155 * 00156 * (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) , 00157 * i 00158 * omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4 00159 * CSTEMR('V', 'I') 00160 * 00161 * Tests 29 through 34 are disable at present because CSTEMR 00162 * does not handle partial specturm requests. 00163 * 00164 * (29) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'I') 00165 * 00166 * (30) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'I') 00167 * 00168 * (31) ( max { min | WA2(i)-WA3(j) | } + 00169 * i j 00170 * max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) 00171 * i j 00172 * CSTEMR('N', 'I') vs. CSTEMR('V', 'I') 00173 * 00174 * (32) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'V') 00175 * 00176 * (33) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'V') 00177 * 00178 * (34) ( max { min | WA2(i)-WA3(j) | } + 00179 * i j 00180 * max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) 00181 * i j 00182 * CSTEMR('N', 'V') vs. CSTEMR('V', 'V') 00183 * 00184 * (35) | S - Z D Z* | / ( |S| n ulp ) CSTEMR('V', 'A') 00185 * 00186 * (36) | I - ZZ* | / ( n ulp ) CSTEMR('V', 'A') 00187 * 00188 * (37) ( max { min | WA2(i)-WA3(j) | } + 00189 * i j 00190 * max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp ) 00191 * i j 00192 * CSTEMR('N', 'A') vs. CSTEMR('V', 'A') 00193 * 00194 * The "sizes" are specified by an array NN(1:NSIZES); the value of 00195 * each element NN(j) specifies one size. 00196 * The "types" are specified by a logical array DOTYPE( 1:NTYPES ); 00197 * if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. 00198 * Currently, the list of possible types is: 00199 * 00200 * (1) The zero matrix. 00201 * (2) The identity matrix. 00202 * 00203 * (3) A diagonal matrix with evenly spaced entries 00204 * 1, ..., ULP and random signs. 00205 * (ULP = (first number larger than 1) - 1 ) 00206 * (4) A diagonal matrix with geometrically spaced entries 00207 * 1, ..., ULP and random signs. 00208 * (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP 00209 * and random signs. 00210 * 00211 * (6) Same as (4), but multiplied by SQRT( overflow threshold ) 00212 * (7) Same as (4), but multiplied by SQRT( underflow threshold ) 00213 * 00214 * (8) A matrix of the form U* D U, where U is unitary and 00215 * D has evenly spaced entries 1, ..., ULP with random signs 00216 * on the diagonal. 00217 * 00218 * (9) A matrix of the form U* D U, where U is unitary and 00219 * D has geometrically spaced entries 1, ..., ULP with random 00220 * signs on the diagonal. 00221 * 00222 * (10) A matrix of the form U* D U, where U is unitary and 00223 * D has "clustered" entries 1, ULP,..., ULP with random 00224 * signs on the diagonal. 00225 * 00226 * (11) Same as (8), but multiplied by SQRT( overflow threshold ) 00227 * (12) Same as (8), but multiplied by SQRT( underflow threshold ) 00228 * 00229 * (13) Hermitian matrix with random entries chosen from (-1,1). 00230 * (14) Same as (13), but multiplied by SQRT( overflow threshold ) 00231 * (15) Same as (13), but multiplied by SQRT( underflow threshold ) 00232 * (16) Same as (8), but diagonal elements are all positive. 00233 * (17) Same as (9), but diagonal elements are all positive. 00234 * (18) Same as (10), but diagonal elements are all positive. 00235 * (19) Same as (16), but multiplied by SQRT( overflow threshold ) 00236 * (20) Same as (16), but multiplied by SQRT( underflow threshold ) 00237 * (21) A diagonally dominant tridiagonal matrix with geometrically 00238 * spaced diagonal entries 1, ..., ULP. 00239 * 00240 * Arguments 00241 * ========= 00242 * 00243 * NSIZES (input) INTEGER 00244 * The number of sizes of matrices to use. If it is zero, 00245 * CCHKST does nothing. It must be at least zero. 00246 * 00247 * NN (input) INTEGER array, dimension (NSIZES) 00248 * An array containing the sizes to be used for the matrices. 00249 * Zero values will be skipped. The values must be at least 00250 * zero. 00251 * 00252 * NTYPES (input) INTEGER 00253 * The number of elements in DOTYPE. If it is zero, CCHKST 00254 * does nothing. It must be at least zero. If it is MAXTYP+1 00255 * and NSIZES is 1, then an additional type, MAXTYP+1 is 00256 * defined, which is to use whatever matrix is in A. This 00257 * is only useful if DOTYPE(1:MAXTYP) is .FALSE. and 00258 * DOTYPE(MAXTYP+1) is .TRUE. . 00259 * 00260 * DOTYPE (input) LOGICAL array, dimension (NTYPES) 00261 * If DOTYPE(j) is .TRUE., then for each size in NN a 00262 * matrix of that size and of type j will be generated. 00263 * If NTYPES is smaller than the maximum number of types 00264 * defined (PARAMETER MAXTYP), then types NTYPES+1 through 00265 * MAXTYP will not be generated. If NTYPES is larger 00266 * than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) 00267 * will be ignored. 00268 * 00269 * ISEED (input/output) INTEGER array, dimension (4) 00270 * On entry ISEED specifies the seed of the random number 00271 * generator. The array elements should be between 0 and 4095; 00272 * if not they will be reduced mod 4096. Also, ISEED(4) must 00273 * be odd. The random number generator uses a linear 00274 * congruential sequence limited to small integers, and so 00275 * should produce machine independent random numbers. The 00276 * values of ISEED are changed on exit, and can be used in the 00277 * next call to CCHKST to continue the same random number 00278 * sequence. 00279 * 00280 * THRESH (input) REAL 00281 * A test will count as "failed" if the "error", computed as 00282 * described above, exceeds THRESH. Note that the error 00283 * is scaled to be O(1), so THRESH should be a reasonably 00284 * small multiple of 1, e.g., 10 or 100. In particular, 00285 * it should not depend on the precision (single vs. double) 00286 * or the size of the matrix. It must be at least zero. 00287 * 00288 * NOUNIT (input) INTEGER 00289 * The FORTRAN unit number for printing out error messages 00290 * (e.g., if a routine returns IINFO not equal to 0.) 00291 * 00292 * A (input/workspace/output) COMPLEX array of 00293 * dimension ( LDA , max(NN) ) 00294 * Used to hold the matrix whose eigenvalues are to be 00295 * computed. On exit, A contains the last matrix actually 00296 * used. 00297 * 00298 * LDA (input) INTEGER 00299 * The leading dimension of A. It must be at 00300 * least 1 and at least max( NN ). 00301 * 00302 * AP (workspace) COMPLEX array of 00303 * dimension( max(NN)*max(NN+1)/2 ) 00304 * The matrix A stored in packed format. 00305 * 00306 * SD (workspace/output) REAL array of 00307 * dimension( max(NN) ) 00308 * The diagonal of the tridiagonal matrix computed by CHETRD. 00309 * On exit, SD and SE contain the tridiagonal form of the 00310 * matrix in A. 00311 * 00312 * SE (workspace/output) REAL array of 00313 * dimension( max(NN) ) 00314 * The off-diagonal of the tridiagonal matrix computed by 00315 * CHETRD. On exit, SD and SE contain the tridiagonal form of 00316 * the matrix in A. 00317 * 00318 * D1 (workspace/output) REAL array of 00319 * dimension( max(NN) ) 00320 * The eigenvalues of A, as computed by CSTEQR simlutaneously 00321 * with Z. On exit, the eigenvalues in D1 correspond with the 00322 * matrix in A. 00323 * 00324 * D2 (workspace/output) REAL array of 00325 * dimension( max(NN) ) 00326 * The eigenvalues of A, as computed by CSTEQR if Z is not 00327 * computed. On exit, the eigenvalues in D2 correspond with 00328 * the matrix in A. 00329 * 00330 * D3 (workspace/output) REAL array of 00331 * dimension( max(NN) ) 00332 * The eigenvalues of A, as computed by SSTERF. On exit, the 00333 * eigenvalues in D3 correspond with the matrix in A. 00334 * 00335 * U (workspace/output) COMPLEX array of 00336 * dimension( LDU, max(NN) ). 00337 * The unitary matrix computed by CHETRD + CUNGTR. 00338 * 00339 * LDU (input) INTEGER 00340 * The leading dimension of U, Z, and V. It must be at least 1 00341 * and at least max( NN ). 00342 * 00343 * V (workspace/output) COMPLEX array of 00344 * dimension( LDU, max(NN) ). 00345 * The Housholder vectors computed by CHETRD in reducing A to 00346 * tridiagonal form. The vectors computed with UPLO='U' are 00347 * in the upper triangle, and the vectors computed with UPLO='L' 00348 * are in the lower triangle. (As described in CHETRD, the 00349 * sub- and superdiagonal are not set to 1, although the 00350 * true Householder vector has a 1 in that position. The 00351 * routines that use V, such as CUNGTR, set those entries to 00352 * 1 before using them, and then restore them later.) 00353 * 00354 * VP (workspace) COMPLEX array of 00355 * dimension( max(NN)*max(NN+1)/2 ) 00356 * The matrix V stored in packed format. 00357 * 00358 * TAU (workspace/output) COMPLEX array of 00359 * dimension( max(NN) ) 00360 * The Householder factors computed by CHETRD in reducing A 00361 * to tridiagonal form. 00362 * 00363 * Z (workspace/output) COMPLEX array of 00364 * dimension( LDU, max(NN) ). 00365 * The unitary matrix of eigenvectors computed by CSTEQR, 00366 * CPTEQR, and CSTEIN. 00367 * 00368 * WORK (workspace/output) COMPLEX array of 00369 * dimension( LWORK ) 00370 * 00371 * LWORK (input) INTEGER 00372 * The number of entries in WORK. This must be at least 00373 * 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2 00374 * where Nmax = max( NN(j), 2 ) and lg = log base 2. 00375 * 00376 * IWORK (workspace/output) INTEGER array, 00377 * dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax ) 00378 * where Nmax = max( NN(j), 2 ) and lg = log base 2. 00379 * Workspace. 00380 * 00381 * RWORK (workspace/output) REAL array of 00382 * dimension( ??? ) 00383 * 00384 * RESULT (output) REAL array, dimension (26) 00385 * The values computed by the tests described above. 00386 * The values are currently limited to 1/ulp, to avoid 00387 * overflow. 00388 * 00389 * INFO (output) INTEGER 00390 * If 0, then everything ran OK. 00391 * -1: NSIZES < 0 00392 * -2: Some NN(j) < 0 00393 * -3: NTYPES < 0 00394 * -5: THRESH < 0 00395 * -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). 00396 * -23: LDU < 1 or LDU < NMAX. 00397 * -29: LWORK too small. 00398 * If CLATMR, CLATMS, CHETRD, CUNGTR, CSTEQR, SSTERF, 00399 * or CUNMC2 returns an error code, the 00400 * absolute value of it is returned. 00401 * 00402 *----------------------------------------------------------------------- 00403 * 00404 * Some Local Variables and Parameters: 00405 * ---- ----- --------- --- ---------- 00406 * ZERO, ONE Real 0 and 1. 00407 * MAXTYP The number of types defined. 00408 * NTEST The number of tests performed, or which can 00409 * be performed so far, for the current matrix. 00410 * NTESTT The total number of tests performed so far. 00411 * NBLOCK Blocksize as returned by ENVIR. 00412 * NMAX Largest value in NN. 00413 * NMATS The number of matrices generated so far. 00414 * NERRS The number of tests which have exceeded THRESH 00415 * so far. 00416 * COND, IMODE Values to be passed to the matrix generators. 00417 * ANORM Norm of A; passed to matrix generators. 00418 * 00419 * OVFL, UNFL Overflow and underflow thresholds. 00420 * ULP, ULPINV Finest relative precision and its inverse. 00421 * RTOVFL, RTUNFL Square roots of the previous 2 values. 00422 * The following four arrays decode JTYPE: 00423 * KTYPE(j) The general type (1-10) for type "j". 00424 * KMODE(j) The MODE value to be passed to the matrix 00425 * generator for type "j". 00426 * KMAGN(j) The order of magnitude ( O(1), 00427 * O(overflow^(1/2) ), O(underflow^(1/2) ) 00428 * 00429 * ===================================================================== 00430 * 00431 * .. Parameters .. 00432 REAL ZERO, ONE, TWO, EIGHT, TEN, HUN 00433 PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, 00434 $ EIGHT = 8.0E0, TEN = 10.0E0, HUN = 100.0E0 ) 00435 COMPLEX CZERO, CONE 00436 PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), 00437 $ CONE = ( 1.0E+0, 0.0E+0 ) ) 00438 REAL HALF 00439 PARAMETER ( HALF = ONE / TWO ) 00440 INTEGER MAXTYP 00441 PARAMETER ( MAXTYP = 21 ) 00442 LOGICAL CRANGE 00443 PARAMETER ( CRANGE = .FALSE. ) 00444 LOGICAL CREL 00445 PARAMETER ( CREL = .FALSE. ) 00446 * .. 00447 * .. Local Scalars .. 00448 LOGICAL BADNN, TRYRAC 00449 INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP, 00450 $ ITYPE, IU, J, JC, JR, JSIZE, JTYPE, LGN, 00451 $ LIWEDC, LOG2UI, LRWEDC, LWEDC, M, M2, M3, 00452 $ MTYPES, N, NAP, NBLOCK, NERRS, NMATS, NMAX, 00453 $ NSPLIT, NTEST, NTESTT 00454 REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, 00455 $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, 00456 $ ULPINV, UNFL, VL, VU 00457 * .. 00458 * .. Local Arrays .. 00459 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), 00460 $ KMAGN( MAXTYP ), KMODE( MAXTYP ), 00461 $ KTYPE( MAXTYP ) 00462 REAL DUMMA( 1 ) 00463 * .. 00464 * .. External Functions .. 00465 INTEGER ILAENV 00466 REAL SLAMCH, SLARND, SSXT1 00467 EXTERNAL ILAENV, SLAMCH, SLARND, SSXT1 00468 * .. 00469 * .. External Subroutines .. 00470 EXTERNAL CCOPY, CHET21, CHETRD, CHPT21, CHPTRD, CLACPY, 00471 $ CLASET, CLATMR, CLATMS, CPTEQR, CSTEDC, CSTEMR, 00472 $ CSTEIN, CSTEQR, CSTT21, CSTT22, CUNGTR, CUPGTR, 00473 $ SCOPY, SLABAD, SLASUM, SSTEBZ, SSTECH, SSTERF, 00474 $ XERBLA 00475 * .. 00476 * .. Intrinsic Functions .. 00477 INTRINSIC ABS, CONJG, INT, LOG, MAX, MIN, REAL, SQRT 00478 * .. 00479 * .. Data statements .. 00480 DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, 00481 $ 8, 8, 9, 9, 9, 9, 9, 10 / 00482 DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, 00483 $ 2, 3, 1, 1, 1, 2, 3, 1 / 00484 DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0, 00485 $ 0, 0, 4, 3, 1, 4, 4, 3 / 00486 * .. 00487 * .. Executable Statements .. 00488 * 00489 * Keep ftnchek happy 00490 IDUMMA( 1 ) = 1 00491 * 00492 * Check for errors 00493 * 00494 NTESTT = 0 00495 INFO = 0 00496 * 00497 * Important constants 00498 * 00499 BADNN = .FALSE. 00500 TRYRAC = .TRUE. 00501 NMAX = 1 00502 DO 10 J = 1, NSIZES 00503 NMAX = MAX( NMAX, NN( J ) ) 00504 IF( NN( J ).LT.0 ) 00505 $ BADNN = .TRUE. 00506 10 CONTINUE 00507 * 00508 NBLOCK = ILAENV( 1, 'CHETRD', 'L', NMAX, -1, -1, -1 ) 00509 NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) ) 00510 * 00511 * Check for errors 00512 * 00513 IF( NSIZES.LT.0 ) THEN 00514 INFO = -1 00515 ELSE IF( BADNN ) THEN 00516 INFO = -2 00517 ELSE IF( NTYPES.LT.0 ) THEN 00518 INFO = -3 00519 ELSE IF( LDA.LT.NMAX ) THEN 00520 INFO = -9 00521 ELSE IF( LDU.LT.NMAX ) THEN 00522 INFO = -23 00523 ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN 00524 INFO = -29 00525 END IF 00526 * 00527 IF( INFO.NE.0 ) THEN 00528 CALL XERBLA( 'CCHKST', -INFO ) 00529 RETURN 00530 END IF 00531 * 00532 * Quick return if possible 00533 * 00534 IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) 00535 $ RETURN 00536 * 00537 * More Important constants 00538 * 00539 UNFL = SLAMCH( 'Safe minimum' ) 00540 OVFL = ONE / UNFL 00541 CALL SLABAD( UNFL, OVFL ) 00542 ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) 00543 ULPINV = ONE / ULP 00544 LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) ) 00545 RTUNFL = SQRT( UNFL ) 00546 RTOVFL = SQRT( OVFL ) 00547 * 00548 * Loop over sizes, types 00549 * 00550 DO 20 I = 1, 4 00551 ISEED2( I ) = ISEED( I ) 00552 20 CONTINUE 00553 NERRS = 0 00554 NMATS = 0 00555 * 00556 DO 310 JSIZE = 1, NSIZES 00557 N = NN( JSIZE ) 00558 IF( N.GT.0 ) THEN 00559 LGN = INT( LOG( REAL( N ) ) / LOG( TWO ) ) 00560 IF( 2**LGN.LT.N ) 00561 $ LGN = LGN + 1 00562 IF( 2**LGN.LT.N ) 00563 $ LGN = LGN + 1 00564 LWEDC = 1 + 4*N + 2*N*LGN + 3*N**2 00565 LRWEDC = 1 + 3*N + 2*N*LGN + 3*N**2 00566 LIWEDC = 6 + 6*N + 5*N*LGN 00567 ELSE 00568 LWEDC = 8 00569 LRWEDC = 7 00570 LIWEDC = 12 00571 END IF 00572 NAP = ( N*( N+1 ) ) / 2 00573 ANINV = ONE / REAL( MAX( 1, N ) ) 00574 * 00575 IF( NSIZES.NE.1 ) THEN 00576 MTYPES = MIN( MAXTYP, NTYPES ) 00577 ELSE 00578 MTYPES = MIN( MAXTYP+1, NTYPES ) 00579 END IF 00580 * 00581 DO 300 JTYPE = 1, MTYPES 00582 IF( .NOT.DOTYPE( JTYPE ) ) 00583 $ GO TO 300 00584 NMATS = NMATS + 1 00585 NTEST = 0 00586 * 00587 DO 30 J = 1, 4 00588 IOLDSD( J ) = ISEED( J ) 00589 30 CONTINUE 00590 * 00591 * Compute "A" 00592 * 00593 * Control parameters: 00594 * 00595 * KMAGN KMODE KTYPE 00596 * =1 O(1) clustered 1 zero 00597 * =2 large clustered 2 identity 00598 * =3 small exponential (none) 00599 * =4 arithmetic diagonal, (w/ eigenvalues) 00600 * =5 random log Hermitian, w/ eigenvalues 00601 * =6 random (none) 00602 * =7 random diagonal 00603 * =8 random Hermitian 00604 * =9 positive definite 00605 * =10 diagonally dominant tridiagonal 00606 * 00607 IF( MTYPES.GT.MAXTYP ) 00608 $ GO TO 100 00609 * 00610 ITYPE = KTYPE( JTYPE ) 00611 IMODE = KMODE( JTYPE ) 00612 * 00613 * Compute norm 00614 * 00615 GO TO ( 40, 50, 60 )KMAGN( JTYPE ) 00616 * 00617 40 CONTINUE 00618 ANORM = ONE 00619 GO TO 70 00620 * 00621 50 CONTINUE 00622 ANORM = ( RTOVFL*ULP )*ANINV 00623 GO TO 70 00624 * 00625 60 CONTINUE 00626 ANORM = RTUNFL*N*ULPINV 00627 GO TO 70 00628 * 00629 70 CONTINUE 00630 * 00631 CALL CLASET( 'Full', LDA, N, CZERO, CZERO, A, LDA ) 00632 IINFO = 0 00633 IF( JTYPE.LE.15 ) THEN 00634 COND = ULPINV 00635 ELSE 00636 COND = ULPINV*ANINV / TEN 00637 END IF 00638 * 00639 * Special Matrices -- Identity & Jordan block 00640 * 00641 * Zero 00642 * 00643 IF( ITYPE.EQ.1 ) THEN 00644 IINFO = 0 00645 * 00646 ELSE IF( ITYPE.EQ.2 ) THEN 00647 * 00648 * Identity 00649 * 00650 DO 80 JC = 1, N 00651 A( JC, JC ) = ANORM 00652 80 CONTINUE 00653 * 00654 ELSE IF( ITYPE.EQ.4 ) THEN 00655 * 00656 * Diagonal Matrix, [Eigen]values Specified 00657 * 00658 CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, 00659 $ ANORM, 0, 0, 'N', A, LDA, WORK, IINFO ) 00660 * 00661 * 00662 ELSE IF( ITYPE.EQ.5 ) THEN 00663 * 00664 * Hermitian, eigenvalues specified 00665 * 00666 CALL CLATMS( N, N, 'S', ISEED, 'H', RWORK, IMODE, COND, 00667 $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) 00668 * 00669 ELSE IF( ITYPE.EQ.7 ) THEN 00670 * 00671 * Diagonal, random eigenvalues 00672 * 00673 CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, 00674 $ 'T', 'N', WORK( N+1 ), 1, ONE, 00675 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, 00676 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) 00677 * 00678 ELSE IF( ITYPE.EQ.8 ) THEN 00679 * 00680 * Hermitian, random eigenvalues 00681 * 00682 CALL CLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, CONE, 00683 $ 'T', 'N', WORK( N+1 ), 1, ONE, 00684 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, 00685 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) 00686 * 00687 ELSE IF( ITYPE.EQ.9 ) THEN 00688 * 00689 * Positive definite, eigenvalues specified. 00690 * 00691 CALL CLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, COND, 00692 $ ANORM, N, N, 'N', A, LDA, WORK, IINFO ) 00693 * 00694 ELSE IF( ITYPE.EQ.10 ) THEN 00695 * 00696 * Positive definite tridiagonal, eigenvalues specified. 00697 * 00698 CALL CLATMS( N, N, 'S', ISEED, 'P', RWORK, IMODE, COND, 00699 $ ANORM, 1, 1, 'N', A, LDA, WORK, IINFO ) 00700 DO 90 I = 2, N 00701 TEMP1 = ABS( A( I-1, I ) ) 00702 TEMP2 = SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) ) 00703 IF( TEMP1.GT.HALF*TEMP2 ) THEN 00704 A( I-1, I ) = A( I-1, I )* 00705 $ ( HALF*TEMP2 / ( UNFL+TEMP1 ) ) 00706 A( I, I-1 ) = CONJG( A( I-1, I ) ) 00707 END IF 00708 90 CONTINUE 00709 * 00710 ELSE 00711 * 00712 IINFO = 1 00713 END IF 00714 * 00715 IF( IINFO.NE.0 ) THEN 00716 WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, 00717 $ IOLDSD 00718 INFO = ABS( IINFO ) 00719 RETURN 00720 END IF 00721 * 00722 100 CONTINUE 00723 * 00724 * Call CHETRD and CUNGTR to compute S and U from 00725 * upper triangle. 00726 * 00727 CALL CLACPY( 'U', N, N, A, LDA, V, LDU ) 00728 * 00729 NTEST = 1 00730 CALL CHETRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK, 00731 $ IINFO ) 00732 * 00733 IF( IINFO.NE.0 ) THEN 00734 WRITE( NOUNIT, FMT = 9999 )'CHETRD(U)', IINFO, N, JTYPE, 00735 $ IOLDSD 00736 INFO = ABS( IINFO ) 00737 IF( IINFO.LT.0 ) THEN 00738 RETURN 00739 ELSE 00740 RESULT( 1 ) = ULPINV 00741 GO TO 280 00742 END IF 00743 END IF 00744 * 00745 CALL CLACPY( 'U', N, N, V, LDU, U, LDU ) 00746 * 00747 NTEST = 2 00748 CALL CUNGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO ) 00749 IF( IINFO.NE.0 ) THEN 00750 WRITE( NOUNIT, FMT = 9999 )'CUNGTR(U)', IINFO, N, JTYPE, 00751 $ IOLDSD 00752 INFO = ABS( IINFO ) 00753 IF( IINFO.LT.0 ) THEN 00754 RETURN 00755 ELSE 00756 RESULT( 2 ) = ULPINV 00757 GO TO 280 00758 END IF 00759 END IF 00760 * 00761 * Do tests 1 and 2 00762 * 00763 CALL CHET21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, 00764 $ LDU, TAU, WORK, RWORK, RESULT( 1 ) ) 00765 CALL CHET21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V, 00766 $ LDU, TAU, WORK, RWORK, RESULT( 2 ) ) 00767 * 00768 * Call CHETRD and CUNGTR to compute S and U from 00769 * lower triangle, do tests. 00770 * 00771 CALL CLACPY( 'L', N, N, A, LDA, V, LDU ) 00772 * 00773 NTEST = 3 00774 CALL CHETRD( 'L', N, V, LDU, SD, SE, TAU, WORK, LWORK, 00775 $ IINFO ) 00776 * 00777 IF( IINFO.NE.0 ) THEN 00778 WRITE( NOUNIT, FMT = 9999 )'CHETRD(L)', IINFO, N, JTYPE, 00779 $ IOLDSD 00780 INFO = ABS( IINFO ) 00781 IF( IINFO.LT.0 ) THEN 00782 RETURN 00783 ELSE 00784 RESULT( 3 ) = ULPINV 00785 GO TO 280 00786 END IF 00787 END IF 00788 * 00789 CALL CLACPY( 'L', N, N, V, LDU, U, LDU ) 00790 * 00791 NTEST = 4 00792 CALL CUNGTR( 'L', N, U, LDU, TAU, WORK, LWORK, IINFO ) 00793 IF( IINFO.NE.0 ) THEN 00794 WRITE( NOUNIT, FMT = 9999 )'CUNGTR(L)', IINFO, N, JTYPE, 00795 $ IOLDSD 00796 INFO = ABS( IINFO ) 00797 IF( IINFO.LT.0 ) THEN 00798 RETURN 00799 ELSE 00800 RESULT( 4 ) = ULPINV 00801 GO TO 280 00802 END IF 00803 END IF 00804 * 00805 CALL CHET21( 2, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, 00806 $ LDU, TAU, WORK, RWORK, RESULT( 3 ) ) 00807 CALL CHET21( 3, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V, 00808 $ LDU, TAU, WORK, RWORK, RESULT( 4 ) ) 00809 * 00810 * Store the upper triangle of A in AP 00811 * 00812 I = 0 00813 DO 120 JC = 1, N 00814 DO 110 JR = 1, JC 00815 I = I + 1 00816 AP( I ) = A( JR, JC ) 00817 110 CONTINUE 00818 120 CONTINUE 00819 * 00820 * Call CHPTRD and CUPGTR to compute S and U from AP 00821 * 00822 CALL CCOPY( NAP, AP, 1, VP, 1 ) 00823 * 00824 NTEST = 5 00825 CALL CHPTRD( 'U', N, VP, SD, SE, TAU, IINFO ) 00826 * 00827 IF( IINFO.NE.0 ) THEN 00828 WRITE( NOUNIT, FMT = 9999 )'CHPTRD(U)', IINFO, N, JTYPE, 00829 $ IOLDSD 00830 INFO = ABS( IINFO ) 00831 IF( IINFO.LT.0 ) THEN 00832 RETURN 00833 ELSE 00834 RESULT( 5 ) = ULPINV 00835 GO TO 280 00836 END IF 00837 END IF 00838 * 00839 NTEST = 6 00840 CALL CUPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO ) 00841 IF( IINFO.NE.0 ) THEN 00842 WRITE( NOUNIT, FMT = 9999 )'CUPGTR(U)', IINFO, N, JTYPE, 00843 $ IOLDSD 00844 INFO = ABS( IINFO ) 00845 IF( IINFO.LT.0 ) THEN 00846 RETURN 00847 ELSE 00848 RESULT( 6 ) = ULPINV 00849 GO TO 280 00850 END IF 00851 END IF 00852 * 00853 * Do tests 5 and 6 00854 * 00855 CALL CHPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, 00856 $ WORK, RWORK, RESULT( 5 ) ) 00857 CALL CHPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU, 00858 $ WORK, RWORK, RESULT( 6 ) ) 00859 * 00860 * Store the lower triangle of A in AP 00861 * 00862 I = 0 00863 DO 140 JC = 1, N 00864 DO 130 JR = JC, N 00865 I = I + 1 00866 AP( I ) = A( JR, JC ) 00867 130 CONTINUE 00868 140 CONTINUE 00869 * 00870 * Call CHPTRD and CUPGTR to compute S and U from AP 00871 * 00872 CALL CCOPY( NAP, AP, 1, VP, 1 ) 00873 * 00874 NTEST = 7 00875 CALL CHPTRD( 'L', N, VP, SD, SE, TAU, IINFO ) 00876 * 00877 IF( IINFO.NE.0 ) THEN 00878 WRITE( NOUNIT, FMT = 9999 )'CHPTRD(L)', IINFO, N, JTYPE, 00879 $ IOLDSD 00880 INFO = ABS( IINFO ) 00881 IF( IINFO.LT.0 ) THEN 00882 RETURN 00883 ELSE 00884 RESULT( 7 ) = ULPINV 00885 GO TO 280 00886 END IF 00887 END IF 00888 * 00889 NTEST = 8 00890 CALL CUPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO ) 00891 IF( IINFO.NE.0 ) THEN 00892 WRITE( NOUNIT, FMT = 9999 )'CUPGTR(L)', IINFO, N, JTYPE, 00893 $ IOLDSD 00894 INFO = ABS( IINFO ) 00895 IF( IINFO.LT.0 ) THEN 00896 RETURN 00897 ELSE 00898 RESULT( 8 ) = ULPINV 00899 GO TO 280 00900 END IF 00901 END IF 00902 * 00903 CALL CHPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, 00904 $ WORK, RWORK, RESULT( 7 ) ) 00905 CALL CHPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU, 00906 $ WORK, RWORK, RESULT( 8 ) ) 00907 * 00908 * Call CSTEQR to compute D1, D2, and Z, do tests. 00909 * 00910 * Compute D1 and Z 00911 * 00912 CALL SCOPY( N, SD, 1, D1, 1 ) 00913 IF( N.GT.0 ) 00914 $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) 00915 CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) 00916 * 00917 NTEST = 9 00918 CALL CSTEQR( 'V', N, D1, RWORK, Z, LDU, RWORK( N+1 ), 00919 $ IINFO ) 00920 IF( IINFO.NE.0 ) THEN 00921 WRITE( NOUNIT, FMT = 9999 )'CSTEQR(V)', IINFO, N, JTYPE, 00922 $ IOLDSD 00923 INFO = ABS( IINFO ) 00924 IF( IINFO.LT.0 ) THEN 00925 RETURN 00926 ELSE 00927 RESULT( 9 ) = ULPINV 00928 GO TO 280 00929 END IF 00930 END IF 00931 * 00932 * Compute D2 00933 * 00934 CALL SCOPY( N, SD, 1, D2, 1 ) 00935 IF( N.GT.0 ) 00936 $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) 00937 * 00938 NTEST = 11 00939 CALL CSTEQR( 'N', N, D2, RWORK, WORK, LDU, RWORK( N+1 ), 00940 $ IINFO ) 00941 IF( IINFO.NE.0 ) THEN 00942 WRITE( NOUNIT, FMT = 9999 )'CSTEQR(N)', IINFO, N, JTYPE, 00943 $ IOLDSD 00944 INFO = ABS( IINFO ) 00945 IF( IINFO.LT.0 ) THEN 00946 RETURN 00947 ELSE 00948 RESULT( 11 ) = ULPINV 00949 GO TO 280 00950 END IF 00951 END IF 00952 * 00953 * Compute D3 (using PWK method) 00954 * 00955 CALL SCOPY( N, SD, 1, D3, 1 ) 00956 IF( N.GT.0 ) 00957 $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) 00958 * 00959 NTEST = 12 00960 CALL SSTERF( N, D3, RWORK, IINFO ) 00961 IF( IINFO.NE.0 ) THEN 00962 WRITE( NOUNIT, FMT = 9999 )'SSTERF', IINFO, N, JTYPE, 00963 $ IOLDSD 00964 INFO = ABS( IINFO ) 00965 IF( IINFO.LT.0 ) THEN 00966 RETURN 00967 ELSE 00968 RESULT( 12 ) = ULPINV 00969 GO TO 280 00970 END IF 00971 END IF 00972 * 00973 * Do Tests 9 and 10 00974 * 00975 CALL CSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, 00976 $ RESULT( 9 ) ) 00977 * 00978 * Do Tests 11 and 12 00979 * 00980 TEMP1 = ZERO 00981 TEMP2 = ZERO 00982 TEMP3 = ZERO 00983 TEMP4 = ZERO 00984 * 00985 DO 150 J = 1, N 00986 TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) 00987 TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) 00988 TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) ) 00989 TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) ) 00990 150 CONTINUE 00991 * 00992 RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) 00993 RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) ) 00994 * 00995 * Do Test 13 -- Sturm Sequence Test of Eigenvalues 00996 * Go up by factors of two until it succeeds 00997 * 00998 NTEST = 13 00999 TEMP1 = THRESH*( HALF-ULP ) 01000 * 01001 DO 160 J = 0, LOG2UI 01002 CALL SSTECH( N, SD, SE, D1, TEMP1, RWORK, IINFO ) 01003 IF( IINFO.EQ.0 ) 01004 $ GO TO 170 01005 TEMP1 = TEMP1*TWO 01006 160 CONTINUE 01007 * 01008 170 CONTINUE 01009 RESULT( 13 ) = TEMP1 01010 * 01011 * For positive definite matrices ( JTYPE.GT.15 ) call CPTEQR 01012 * and do tests 14, 15, and 16 . 01013 * 01014 IF( JTYPE.GT.15 ) THEN 01015 * 01016 * Compute D4 and Z4 01017 * 01018 CALL SCOPY( N, SD, 1, D4, 1 ) 01019 IF( N.GT.0 ) 01020 $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) 01021 CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) 01022 * 01023 NTEST = 14 01024 CALL CPTEQR( 'V', N, D4, RWORK, Z, LDU, RWORK( N+1 ), 01025 $ IINFO ) 01026 IF( IINFO.NE.0 ) THEN 01027 WRITE( NOUNIT, FMT = 9999 )'CPTEQR(V)', IINFO, N, 01028 $ JTYPE, IOLDSD 01029 INFO = ABS( IINFO ) 01030 IF( IINFO.LT.0 ) THEN 01031 RETURN 01032 ELSE 01033 RESULT( 14 ) = ULPINV 01034 GO TO 280 01035 END IF 01036 END IF 01037 * 01038 * Do Tests 14 and 15 01039 * 01040 CALL CSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK, 01041 $ RWORK, RESULT( 14 ) ) 01042 * 01043 * Compute D5 01044 * 01045 CALL SCOPY( N, SD, 1, D5, 1 ) 01046 IF( N.GT.0 ) 01047 $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) 01048 * 01049 NTEST = 16 01050 CALL CPTEQR( 'N', N, D5, RWORK, Z, LDU, RWORK( N+1 ), 01051 $ IINFO ) 01052 IF( IINFO.NE.0 ) THEN 01053 WRITE( NOUNIT, FMT = 9999 )'CPTEQR(N)', IINFO, N, 01054 $ JTYPE, IOLDSD 01055 INFO = ABS( IINFO ) 01056 IF( IINFO.LT.0 ) THEN 01057 RETURN 01058 ELSE 01059 RESULT( 16 ) = ULPINV 01060 GO TO 280 01061 END IF 01062 END IF 01063 * 01064 * Do Test 16 01065 * 01066 TEMP1 = ZERO 01067 TEMP2 = ZERO 01068 DO 180 J = 1, N 01069 TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) ) 01070 TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) ) 01071 180 CONTINUE 01072 * 01073 RESULT( 16 ) = TEMP2 / MAX( UNFL, 01074 $ HUN*ULP*MAX( TEMP1, TEMP2 ) ) 01075 ELSE 01076 RESULT( 14 ) = ZERO 01077 RESULT( 15 ) = ZERO 01078 RESULT( 16 ) = ZERO 01079 END IF 01080 * 01081 * Call SSTEBZ with different options and do tests 17-18. 01082 * 01083 * If S is positive definite and diagonally dominant, 01084 * ask for all eigenvalues with high relative accuracy. 01085 * 01086 VL = ZERO 01087 VU = ZERO 01088 IL = 0 01089 IU = 0 01090 IF( JTYPE.EQ.21 ) THEN 01091 NTEST = 17 01092 ABSTOL = UNFL + UNFL 01093 CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, 01094 $ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ), 01095 $ RWORK, IWORK( 2*N+1 ), IINFO ) 01096 IF( IINFO.NE.0 ) THEN 01097 WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,rel)', IINFO, N, 01098 $ JTYPE, IOLDSD 01099 INFO = ABS( IINFO ) 01100 IF( IINFO.LT.0 ) THEN 01101 RETURN 01102 ELSE 01103 RESULT( 17 ) = ULPINV 01104 GO TO 280 01105 END IF 01106 END IF 01107 * 01108 * Do test 17 01109 * 01110 TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / 01111 $ ( ONE-HALF )**4 01112 * 01113 TEMP1 = ZERO 01114 DO 190 J = 1, N 01115 TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / 01116 $ ( ABSTOL+ABS( D4( J ) ) ) ) 01117 190 CONTINUE 01118 * 01119 RESULT( 17 ) = TEMP1 / TEMP2 01120 ELSE 01121 RESULT( 17 ) = ZERO 01122 END IF 01123 * 01124 * Now ask for all eigenvalues with high absolute accuracy. 01125 * 01126 NTEST = 18 01127 ABSTOL = UNFL + UNFL 01128 CALL SSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, 01129 $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK, 01130 $ IWORK( 2*N+1 ), IINFO ) 01131 IF( IINFO.NE.0 ) THEN 01132 WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A)', IINFO, N, JTYPE, 01133 $ IOLDSD 01134 INFO = ABS( IINFO ) 01135 IF( IINFO.LT.0 ) THEN 01136 RETURN 01137 ELSE 01138 RESULT( 18 ) = ULPINV 01139 GO TO 280 01140 END IF 01141 END IF 01142 * 01143 * Do test 18 01144 * 01145 TEMP1 = ZERO 01146 TEMP2 = ZERO 01147 DO 200 J = 1, N 01148 TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) ) 01149 TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) ) 01150 200 CONTINUE 01151 * 01152 RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) 01153 * 01154 * Choose random values for IL and IU, and ask for the 01155 * IL-th through IU-th eigenvalues. 01156 * 01157 NTEST = 19 01158 IF( N.LE.1 ) THEN 01159 IL = 1 01160 IU = N 01161 ELSE 01162 IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) 01163 IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) 01164 IF( IU.LT.IL ) THEN 01165 ITEMP = IU 01166 IU = IL 01167 IL = ITEMP 01168 END IF 01169 END IF 01170 * 01171 CALL SSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, 01172 $ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ), 01173 $ RWORK, IWORK( 2*N+1 ), IINFO ) 01174 IF( IINFO.NE.0 ) THEN 01175 WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(I)', IINFO, N, JTYPE, 01176 $ IOLDSD 01177 INFO = ABS( IINFO ) 01178 IF( IINFO.LT.0 ) THEN 01179 RETURN 01180 ELSE 01181 RESULT( 19 ) = ULPINV 01182 GO TO 280 01183 END IF 01184 END IF 01185 * 01186 * Determine the values VL and VU of the IL-th and IU-th 01187 * eigenvalues and ask for all eigenvalues in this range. 01188 * 01189 IF( N.GT.0 ) THEN 01190 IF( IL.NE.1 ) THEN 01191 VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ), 01192 $ ULP*ANORM, TWO*RTUNFL ) 01193 ELSE 01194 VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ), 01195 $ ULP*ANORM, TWO*RTUNFL ) 01196 END IF 01197 IF( IU.NE.N ) THEN 01198 VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ), 01199 $ ULP*ANORM, TWO*RTUNFL ) 01200 ELSE 01201 VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ), 01202 $ ULP*ANORM, TWO*RTUNFL ) 01203 END IF 01204 ELSE 01205 VL = ZERO 01206 VU = ONE 01207 END IF 01208 * 01209 CALL SSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, 01210 $ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ), 01211 $ RWORK, IWORK( 2*N+1 ), IINFO ) 01212 IF( IINFO.NE.0 ) THEN 01213 WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(V)', IINFO, N, JTYPE, 01214 $ IOLDSD 01215 INFO = ABS( IINFO ) 01216 IF( IINFO.LT.0 ) THEN 01217 RETURN 01218 ELSE 01219 RESULT( 19 ) = ULPINV 01220 GO TO 280 01221 END IF 01222 END IF 01223 * 01224 IF( M3.EQ.0 .AND. N.NE.0 ) THEN 01225 RESULT( 19 ) = ULPINV 01226 GO TO 280 01227 END IF 01228 * 01229 * Do test 19 01230 * 01231 TEMP1 = SSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL ) 01232 TEMP2 = SSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL ) 01233 IF( N.GT.0 ) THEN 01234 TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) ) 01235 ELSE 01236 TEMP3 = ZERO 01237 END IF 01238 * 01239 RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP ) 01240 * 01241 * Call CSTEIN to compute eigenvectors corresponding to 01242 * eigenvalues in WA1. (First call SSTEBZ again, to make sure 01243 * it returns these eigenvalues in the correct order.) 01244 * 01245 NTEST = 21 01246 CALL SSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M, 01247 $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK, 01248 $ IWORK( 2*N+1 ), IINFO ) 01249 IF( IINFO.NE.0 ) THEN 01250 WRITE( NOUNIT, FMT = 9999 )'SSTEBZ(A,B)', IINFO, N, 01251 $ JTYPE, IOLDSD 01252 INFO = ABS( IINFO ) 01253 IF( IINFO.LT.0 ) THEN 01254 RETURN 01255 ELSE 01256 RESULT( 20 ) = ULPINV 01257 RESULT( 21 ) = ULPINV 01258 GO TO 280 01259 END IF 01260 END IF 01261 * 01262 CALL CSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z, 01263 $ LDU, RWORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ), 01264 $ IINFO ) 01265 IF( IINFO.NE.0 ) THEN 01266 WRITE( NOUNIT, FMT = 9999 )'CSTEIN', IINFO, N, JTYPE, 01267 $ IOLDSD 01268 INFO = ABS( IINFO ) 01269 IF( IINFO.LT.0 ) THEN 01270 RETURN 01271 ELSE 01272 RESULT( 20 ) = ULPINV 01273 RESULT( 21 ) = ULPINV 01274 GO TO 280 01275 END IF 01276 END IF 01277 * 01278 * Do tests 20 and 21 01279 * 01280 CALL CSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK, RWORK, 01281 $ RESULT( 20 ) ) 01282 * 01283 * Call CSTEDC(I) to compute D1 and Z, do tests. 01284 * 01285 * Compute D1 and Z 01286 * 01287 INDE = 1 01288 INDRWK = INDE + N 01289 CALL SCOPY( N, SD, 1, D1, 1 ) 01290 IF( N.GT.0 ) 01291 $ CALL SCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) 01292 CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) 01293 * 01294 NTEST = 22 01295 CALL CSTEDC( 'I', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC, 01296 $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) 01297 IF( IINFO.NE.0 ) THEN 01298 WRITE( NOUNIT, FMT = 9999 )'CSTEDC(I)', IINFO, N, JTYPE, 01299 $ IOLDSD 01300 INFO = ABS( IINFO ) 01301 IF( IINFO.LT.0 ) THEN 01302 RETURN 01303 ELSE 01304 RESULT( 22 ) = ULPINV 01305 GO TO 280 01306 END IF 01307 END IF 01308 * 01309 * Do Tests 22 and 23 01310 * 01311 CALL CSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, 01312 $ RESULT( 22 ) ) 01313 * 01314 * Call CSTEDC(V) to compute D1 and Z, do tests. 01315 * 01316 * Compute D1 and Z 01317 * 01318 CALL SCOPY( N, SD, 1, D1, 1 ) 01319 IF( N.GT.0 ) 01320 $ CALL SCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) 01321 CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) 01322 * 01323 NTEST = 24 01324 CALL CSTEDC( 'V', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC, 01325 $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) 01326 IF( IINFO.NE.0 ) THEN 01327 WRITE( NOUNIT, FMT = 9999 )'CSTEDC(V)', IINFO, N, JTYPE, 01328 $ IOLDSD 01329 INFO = ABS( IINFO ) 01330 IF( IINFO.LT.0 ) THEN 01331 RETURN 01332 ELSE 01333 RESULT( 24 ) = ULPINV 01334 GO TO 280 01335 END IF 01336 END IF 01337 * 01338 * Do Tests 24 and 25 01339 * 01340 CALL CSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK, 01341 $ RESULT( 24 ) ) 01342 * 01343 * Call CSTEDC(N) to compute D2, do tests. 01344 * 01345 * Compute D2 01346 * 01347 CALL SCOPY( N, SD, 1, D2, 1 ) 01348 IF( N.GT.0 ) 01349 $ CALL SCOPY( N-1, SE, 1, RWORK( INDE ), 1 ) 01350 CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) 01351 * 01352 NTEST = 26 01353 CALL CSTEDC( 'N', N, D2, RWORK( INDE ), Z, LDU, WORK, LWEDC, 01354 $ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO ) 01355 IF( IINFO.NE.0 ) THEN 01356 WRITE( NOUNIT, FMT = 9999 )'CSTEDC(N)', IINFO, N, JTYPE, 01357 $ IOLDSD 01358 INFO = ABS( IINFO ) 01359 IF( IINFO.LT.0 ) THEN 01360 RETURN 01361 ELSE 01362 RESULT( 26 ) = ULPINV 01363 GO TO 280 01364 END IF 01365 END IF 01366 * 01367 * Do Test 26 01368 * 01369 TEMP1 = ZERO 01370 TEMP2 = ZERO 01371 * 01372 DO 210 J = 1, N 01373 TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) 01374 TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) 01375 210 CONTINUE 01376 * 01377 RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) 01378 * 01379 * Only test CSTEMR if IEEE compliant 01380 * 01381 IF( ILAENV( 10, 'CSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND. 01382 $ ILAENV( 11, 'CSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN 01383 * 01384 * Call CSTEMR, do test 27 (relative eigenvalue accuracy) 01385 * 01386 * If S is positive definite and diagonally dominant, 01387 * ask for all eigenvalues with high relative accuracy. 01388 * 01389 VL = ZERO 01390 VU = ZERO 01391 IL = 0 01392 IU = 0 01393 IF( JTYPE.EQ.21 .AND. CREL ) THEN 01394 NTEST = 27 01395 ABSTOL = UNFL + UNFL 01396 CALL CSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU, 01397 $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, 01398 $ RWORK, LRWORK, IWORK( 2*N+1 ), LWORK-2*N, 01399 $ IINFO ) 01400 IF( IINFO.NE.0 ) THEN 01401 WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,A,rel)', 01402 $ IINFO, N, JTYPE, IOLDSD 01403 INFO = ABS( IINFO ) 01404 IF( IINFO.LT.0 ) THEN 01405 RETURN 01406 ELSE 01407 RESULT( 27 ) = ULPINV 01408 GO TO 270 01409 END IF 01410 END IF 01411 * 01412 * Do test 27 01413 * 01414 TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / 01415 $ ( ONE-HALF )**4 01416 * 01417 TEMP1 = ZERO 01418 DO 220 J = 1, N 01419 TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) / 01420 $ ( ABSTOL+ABS( D4( J ) ) ) ) 01421 220 CONTINUE 01422 * 01423 RESULT( 27 ) = TEMP1 / TEMP2 01424 * 01425 IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) 01426 IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) 01427 IF( IU.LT.IL ) THEN 01428 ITEMP = IU 01429 IU = IL 01430 IL = ITEMP 01431 END IF 01432 * 01433 IF( CRANGE ) THEN 01434 NTEST = 28 01435 ABSTOL = UNFL + UNFL 01436 CALL CSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU, 01437 $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC, 01438 $ RWORK, LRWORK, IWORK( 2*N+1 ), 01439 $ LWORK-2*N, IINFO ) 01440 * 01441 IF( IINFO.NE.0 ) THEN 01442 WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,I,rel)', 01443 $ IINFO, N, JTYPE, IOLDSD 01444 INFO = ABS( IINFO ) 01445 IF( IINFO.LT.0 ) THEN 01446 RETURN 01447 ELSE 01448 RESULT( 28 ) = ULPINV 01449 GO TO 270 01450 END IF 01451 END IF 01452 * 01453 * 01454 * Do test 28 01455 * 01456 TEMP2 = TWO*( TWO*N-ONE )*ULP* 01457 $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 01458 * 01459 TEMP1 = ZERO 01460 DO 230 J = IL, IU 01461 TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+ 01462 $ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) ) 01463 230 CONTINUE 01464 * 01465 RESULT( 28 ) = TEMP1 / TEMP2 01466 ELSE 01467 RESULT( 28 ) = ZERO 01468 END IF 01469 ELSE 01470 RESULT( 27 ) = ZERO 01471 RESULT( 28 ) = ZERO 01472 END IF 01473 * 01474 * Call CSTEMR(V,I) to compute D1 and Z, do tests. 01475 * 01476 * Compute D1 and Z 01477 * 01478 CALL SCOPY( N, SD, 1, D5, 1 ) 01479 IF( N.GT.0 ) 01480 $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) 01481 CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) 01482 * 01483 IF( CRANGE ) THEN 01484 NTEST = 29 01485 IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) 01486 IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) 01487 IF( IU.LT.IL ) THEN 01488 ITEMP = IU 01489 IU = IL 01490 IL = ITEMP 01491 END IF 01492 CALL CSTEMR( 'V', 'I', N, D5, RWORK, VL, VU, IL, IU, 01493 $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, 01494 $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), 01495 $ LIWORK-2*N, IINFO ) 01496 IF( IINFO.NE.0 ) THEN 01497 WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,I)', IINFO, 01498 $ N, JTYPE, IOLDSD 01499 INFO = ABS( IINFO ) 01500 IF( IINFO.LT.0 ) THEN 01501 RETURN 01502 ELSE 01503 RESULT( 29 ) = ULPINV 01504 GO TO 280 01505 END IF 01506 END IF 01507 * 01508 * Do Tests 29 and 30 01509 * 01510 * 01511 * Call CSTEMR to compute D2, do tests. 01512 * 01513 * Compute D2 01514 * 01515 CALL SCOPY( N, SD, 1, D5, 1 ) 01516 IF( N.GT.0 ) 01517 $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) 01518 * 01519 NTEST = 31 01520 CALL CSTEMR( 'N', 'I', N, D5, RWORK, VL, VU, IL, IU, 01521 $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, 01522 $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), 01523 $ LIWORK-2*N, IINFO ) 01524 IF( IINFO.NE.0 ) THEN 01525 WRITE( NOUNIT, FMT = 9999 )'CSTEMR(N,I)', IINFO, 01526 $ N, JTYPE, IOLDSD 01527 INFO = ABS( IINFO ) 01528 IF( IINFO.LT.0 ) THEN 01529 RETURN 01530 ELSE 01531 RESULT( 31 ) = ULPINV 01532 GO TO 280 01533 END IF 01534 END IF 01535 * 01536 * Do Test 31 01537 * 01538 TEMP1 = ZERO 01539 TEMP2 = ZERO 01540 * 01541 DO 240 J = 1, IU - IL + 1 01542 TEMP1 = MAX( TEMP1, ABS( D1( J ) ), 01543 $ ABS( D2( J ) ) ) 01544 TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) 01545 240 CONTINUE 01546 * 01547 RESULT( 31 ) = TEMP2 / MAX( UNFL, 01548 $ ULP*MAX( TEMP1, TEMP2 ) ) 01549 * 01550 * 01551 * Call CSTEMR(V,V) to compute D1 and Z, do tests. 01552 * 01553 * Compute D1 and Z 01554 * 01555 CALL SCOPY( N, SD, 1, D5, 1 ) 01556 IF( N.GT.0 ) 01557 $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) 01558 CALL CLASET( 'Full', N, N, CZERO, CONE, Z, LDU ) 01559 * 01560 NTEST = 32 01561 * 01562 IF( N.GT.0 ) THEN 01563 IF( IL.NE.1 ) THEN 01564 VL = D2( IL ) - MAX( HALF* 01565 $ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM, 01566 $ TWO*RTUNFL ) 01567 ELSE 01568 VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ), 01569 $ ULP*ANORM, TWO*RTUNFL ) 01570 END IF 01571 IF( IU.NE.N ) THEN 01572 VU = D2( IU ) + MAX( HALF* 01573 $ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM, 01574 $ TWO*RTUNFL ) 01575 ELSE 01576 VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ), 01577 $ ULP*ANORM, TWO*RTUNFL ) 01578 END IF 01579 ELSE 01580 VL = ZERO 01581 VU = ONE 01582 END IF 01583 * 01584 CALL CSTEMR( 'V', 'V', N, D5, RWORK, VL, VU, IL, IU, 01585 $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, 01586 $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), 01587 $ LIWORK-2*N, IINFO ) 01588 IF( IINFO.NE.0 ) THEN 01589 WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,V)', IINFO, 01590 $ N, JTYPE, IOLDSD 01591 INFO = ABS( IINFO ) 01592 IF( IINFO.LT.0 ) THEN 01593 RETURN 01594 ELSE 01595 RESULT( 32 ) = ULPINV 01596 GO TO 280 01597 END IF 01598 END IF 01599 * 01600 * Do Tests 32 and 33 01601 * 01602 CALL CSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, 01603 $ M, RWORK, RESULT( 32 ) ) 01604 * 01605 * Call CSTEMR to compute D2, do tests. 01606 * 01607 * Compute D2 01608 * 01609 CALL SCOPY( N, SD, 1, D5, 1 ) 01610 IF( N.GT.0 ) 01611 $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) 01612 * 01613 NTEST = 34 01614 CALL CSTEMR( 'N', 'V', N, D5, RWORK, VL, VU, IL, IU, 01615 $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, 01616 $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), 01617 $ LIWORK-2*N, IINFO ) 01618 IF( IINFO.NE.0 ) THEN 01619 WRITE( NOUNIT, FMT = 9999 )'CSTEMR(N,V)', IINFO, 01620 $ N, JTYPE, IOLDSD 01621 INFO = ABS( IINFO ) 01622 IF( IINFO.LT.0 ) THEN 01623 RETURN 01624 ELSE 01625 RESULT( 34 ) = ULPINV 01626 GO TO 280 01627 END IF 01628 END IF 01629 * 01630 * Do Test 34 01631 * 01632 TEMP1 = ZERO 01633 TEMP2 = ZERO 01634 * 01635 DO 250 J = 1, IU - IL + 1 01636 TEMP1 = MAX( TEMP1, ABS( D1( J ) ), 01637 $ ABS( D2( J ) ) ) 01638 TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) 01639 250 CONTINUE 01640 * 01641 RESULT( 34 ) = TEMP2 / MAX( UNFL, 01642 $ ULP*MAX( TEMP1, TEMP2 ) ) 01643 ELSE 01644 RESULT( 29 ) = ZERO 01645 RESULT( 30 ) = ZERO 01646 RESULT( 31 ) = ZERO 01647 RESULT( 32 ) = ZERO 01648 RESULT( 33 ) = ZERO 01649 RESULT( 34 ) = ZERO 01650 END IF 01651 * 01652 * 01653 * Call CSTEMR(V,A) to compute D1 and Z, do tests. 01654 * 01655 * Compute D1 and Z 01656 * 01657 CALL SCOPY( N, SD, 1, D5, 1 ) 01658 IF( N.GT.0 ) 01659 $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) 01660 * 01661 NTEST = 35 01662 * 01663 CALL CSTEMR( 'V', 'A', N, D5, RWORK, VL, VU, IL, IU, 01664 $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC, 01665 $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), 01666 $ LIWORK-2*N, IINFO ) 01667 IF( IINFO.NE.0 ) THEN 01668 WRITE( NOUNIT, FMT = 9999 )'CSTEMR(V,A)', IINFO, N, 01669 $ JTYPE, IOLDSD 01670 INFO = ABS( IINFO ) 01671 IF( IINFO.LT.0 ) THEN 01672 RETURN 01673 ELSE 01674 RESULT( 35 ) = ULPINV 01675 GO TO 280 01676 END IF 01677 END IF 01678 * 01679 * Do Tests 35 and 36 01680 * 01681 CALL CSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M, 01682 $ RWORK, RESULT( 35 ) ) 01683 * 01684 * Call CSTEMR to compute D2, do tests. 01685 * 01686 * Compute D2 01687 * 01688 CALL SCOPY( N, SD, 1, D5, 1 ) 01689 IF( N.GT.0 ) 01690 $ CALL SCOPY( N-1, SE, 1, RWORK, 1 ) 01691 * 01692 NTEST = 37 01693 CALL CSTEMR( 'N', 'A', N, D5, RWORK, VL, VU, IL, IU, 01694 $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC, 01695 $ RWORK( N+1 ), LRWORK-N, IWORK( 2*N+1 ), 01696 $ LIWORK-2*N, IINFO ) 01697 IF( IINFO.NE.0 ) THEN 01698 WRITE( NOUNIT, FMT = 9999 )'CSTEMR(N,A)', IINFO, N, 01699 $ JTYPE, IOLDSD 01700 INFO = ABS( IINFO ) 01701 IF( IINFO.LT.0 ) THEN 01702 RETURN 01703 ELSE 01704 RESULT( 37 ) = ULPINV 01705 GO TO 280 01706 END IF 01707 END IF 01708 * 01709 * Do Test 34 01710 * 01711 TEMP1 = ZERO 01712 TEMP2 = ZERO 01713 * 01714 DO 260 J = 1, N 01715 TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) ) 01716 TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) ) 01717 260 CONTINUE 01718 * 01719 RESULT( 37 ) = TEMP2 / MAX( UNFL, 01720 $ ULP*MAX( TEMP1, TEMP2 ) ) 01721 END IF 01722 270 CONTINUE 01723 280 CONTINUE 01724 NTESTT = NTESTT + NTEST 01725 * 01726 * End of Loop -- Check for RESULT(j) > THRESH 01727 * 01728 * 01729 * Print out tests which fail. 01730 * 01731 DO 290 JR = 1, NTEST 01732 IF( RESULT( JR ).GE.THRESH ) THEN 01733 * 01734 * If this is the first test to fail, 01735 * print a header to the data file. 01736 * 01737 IF( NERRS.EQ.0 ) THEN 01738 WRITE( NOUNIT, FMT = 9998 )'CST' 01739 WRITE( NOUNIT, FMT = 9997 ) 01740 WRITE( NOUNIT, FMT = 9996 ) 01741 WRITE( NOUNIT, FMT = 9995 )'Hermitian' 01742 WRITE( NOUNIT, FMT = 9994 ) 01743 * 01744 * Tests performed 01745 * 01746 WRITE( NOUNIT, FMT = 9987 ) 01747 END IF 01748 NERRS = NERRS + 1 01749 IF( RESULT( JR ).LT.10000.0E0 ) THEN 01750 WRITE( NOUNIT, FMT = 9989 )N, JTYPE, IOLDSD, JR, 01751 $ RESULT( JR ) 01752 ELSE 01753 WRITE( NOUNIT, FMT = 9988 )N, JTYPE, IOLDSD, JR, 01754 $ RESULT( JR ) 01755 END IF 01756 END IF 01757 290 CONTINUE 01758 300 CONTINUE 01759 310 CONTINUE 01760 * 01761 * Summary 01762 * 01763 CALL SLASUM( 'CST', NOUNIT, NERRS, NTESTT ) 01764 RETURN 01765 * 01766 9999 FORMAT( ' CCHKST: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', 01767 $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) 01768 * 01769 9998 FORMAT( / 1X, A3, ' -- Complex Hermitian eigenvalue problem' ) 01770 9997 FORMAT( ' Matrix types (see CCHKST for details): ' ) 01771 * 01772 9996 FORMAT( / ' Special Matrices:', 01773 $ / ' 1=Zero matrix. ', 01774 $ ' 5=Diagonal: clustered entries.', 01775 $ / ' 2=Identity matrix. ', 01776 $ ' 6=Diagonal: large, evenly spaced.', 01777 $ / ' 3=Diagonal: evenly spaced entries. ', 01778 $ ' 7=Diagonal: small, evenly spaced.', 01779 $ / ' 4=Diagonal: geometr. spaced entries.' ) 01780 9995 FORMAT( ' Dense ', A, ' Matrices:', 01781 $ / ' 8=Evenly spaced eigenvals. ', 01782 $ ' 12=Small, evenly spaced eigenvals.', 01783 $ / ' 9=Geometrically spaced eigenvals. ', 01784 $ ' 13=Matrix with random O(1) entries.', 01785 $ / ' 10=Clustered eigenvalues. ', 01786 $ ' 14=Matrix with large random entries.', 01787 $ / ' 11=Large, evenly spaced eigenvals. ', 01788 $ ' 15=Matrix with small random entries.' ) 01789 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues', 01790 $ / ' 17=Positive definite, geometrically spaced eigenvlaues', 01791 $ / ' 18=Positive definite, clustered eigenvalues', 01792 $ / ' 19=Positive definite, small evenly spaced eigenvalues', 01793 $ / ' 20=Positive definite, large evenly spaced eigenvalues', 01794 $ / ' 21=Diagonally dominant tridiagonal, geometrically', 01795 $ ' spaced eigenvalues' ) 01796 * 01797 9993 FORMAT( / ' Tests performed: ', 01798 $ '(S is Tridiag, D is diagonal, U and Z are ', A, ',', / 20X, 01799 $ A, ', W is a diagonal matrix of eigenvalues,', / 20X, 01800 $ ' V is U represented by Householder vectors, and', / 20X, 01801 $ ' Y is a matrix of eigenvectors of S.)', 01802 $ / ' CHETRD, UPLO=''U'':', / ' 1= | A - V S V', A1, 01803 $ ' | / ( |A| n ulp ) ', ' 2= | I - U V', A1, 01804 $ ' | / ( n ulp )', / ' CHETRD, UPLO=''L'':', 01805 $ / ' 3= | A - V S V', A1, ' | / ( |A| n ulp ) ', 01806 $ ' 4= | I - U V', A1, ' | / ( n ulp )' ) 01807 9992 FORMAT( ' CHPTRD, UPLO=''U'':', / ' 5= | A - V S V', A1, 01808 $ ' | / ( |A| n ulp ) ', ' 6= | I - U V', A1, 01809 $ ' | / ( n ulp )', / ' CHPTRD, UPLO=''L'':', 01810 $ / ' 7= | A - V S V', A1, ' | / ( |A| n ulp ) ', 01811 $ ' 8= | I - U V', A1, ' | / ( n ulp )', 01812 $ / ' 9= | S - Z D Z', A1, ' | / ( |S| n ulp ) ', 01813 $ ' 10= | I - Z Z', A1, ' | / ( n ulp )', 01814 $ / ' 11= |D(with Z) - D(w/o Z)| / (|D| ulp) ', 01815 $ ' 12= | D(PWK) - D(QR) | / (|D| ulp)', 01816 $ / ' 13= Sturm sequence test on W ' ) 01817 9991 FORMAT( ' 14= | S - Z4 D4 Z4', A1, ' | / (|S| n ulp)', 01818 $ / ' 15= | I - Z4 Z4', A1, ' | / (n ulp ) ', 01819 $ ' 16= | D4 - D5 | / ( 100 |D4| ulp ) ', 01820 $ / ' 17= max | D4(i) - WR(i) | / ( |D4(i)| (2n-1) ulp )', 01821 $ / ' 18= | WA1 - D3 | / ( |D3| ulp )', 01822 $ / ' 19= max | WA2(i) - WA3(ii) | / ( |D3| ulp )', 01823 $ / ' 20= | S - Y WA1 Y', A1, ' | / ( |S| n ulp )', 01824 $ / ' 21= | I - Y Y', A1, ' | / ( n ulp )' ) 01825 9990 FORMAT( ' 22= | S - Z D Z', A1, 01826 $ ' | / ( |S| n ulp ) for CSTEDC(I)', / ' 23= | I - Z Z', A1, 01827 $ ' | / ( n ulp ) for CSTEDC(I)', / ' 24= | S - Z D Z', 01828 $ A1, ' | / ( |S| n ulp ) for CSTEDC(V)', / ' 25= | I - Z Z', 01829 $ A1, ' | / ( n ulp ) for CSTEDC(V)', 01830 $ / ' 26= | D1(CSTEDC(V)) - D2(CSTEDC(N)) | / ( |D1| ulp )' ) 01831 9989 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', 01832 $ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 ) 01833 9988 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=', 01834 $ 4( I4, ',' ), ' result ', I3, ' is', 1P, E10.3 ) 01835 * 01836 9987 FORMAT( / 'Test performed: see CCHKST for details.', / ) 01837 * End of CCHKST 01838 * 01839 END
1.7.3 
