![]() |
LAPACK
3.4.1
LAPACK: Linear Algebra PACKage
|
00001 *> \brief \b SCHKHS 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 SCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, 00012 * NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1, 00013 * WI1, WR3, WI3, EVECTL, EVECTR, EVECTY, EVECTX, 00014 * UU, TAU, WORK, NWORK, IWORK, SELECT, RESULT, 00015 * INFO ) 00016 * 00017 * .. Scalar Arguments .. 00018 * INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK 00019 * REAL THRESH 00020 * .. 00021 * .. Array Arguments .. 00022 * LOGICAL DOTYPE( * ), SELECT( * ) 00023 * INTEGER ISEED( 4 ), IWORK( * ), NN( * ) 00024 * REAL A( LDA, * ), EVECTL( LDU, * ), 00025 * $ EVECTR( LDU, * ), EVECTX( LDU, * ), 00026 * $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ), 00027 * $ T1( LDA, * ), T2( LDA, * ), TAU( * ), 00028 * $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ), 00029 * $ WI1( * ), WI3( * ), WORK( * ), WR1( * ), 00030 * $ WR3( * ), Z( LDU, * ) 00031 * .. 00032 * 00033 * 00034 *> \par Purpose: 00035 * ============= 00036 *> 00037 *> \verbatim 00038 *> 00039 *> SCHKHS checks the nonsymmetric eigenvalue problem routines. 00040 *> 00041 *> SGEHRD factors A as U H U' , where ' means transpose, 00042 *> H is hessenberg, and U is an orthogonal matrix. 00043 *> 00044 *> SORGHR generates the orthogonal matrix U. 00045 *> 00046 *> SORMHR multiplies a matrix by the orthogonal matrix U. 00047 *> 00048 *> SHSEQR factors H as Z T Z' , where Z is orthogonal and 00049 *> T is "quasi-triangular", and the eigenvalue vector W. 00050 *> 00051 *> STREVC computes the left and right eigenvector matrices 00052 *> L and R for T. 00053 *> 00054 *> SHSEIN computes the left and right eigenvector matrices 00055 *> Y and X for H, using inverse iteration. 00056 *> 00057 *> When SCHKHS is called, a number of matrix "sizes" ("n's") and a 00058 *> number of matrix "types" are specified. For each size ("n") 00059 *> and each type of matrix, one matrix will be generated and used 00060 *> to test the nonsymmetric eigenroutines. For each matrix, 14 00061 *> tests will be performed: 00062 *> 00063 *> (1) | A - U H U**T | / ( |A| n ulp ) 00064 *> 00065 *> (2) | I - UU**T | / ( n ulp ) 00066 *> 00067 *> (3) | H - Z T Z**T | / ( |H| n ulp ) 00068 *> 00069 *> (4) | I - ZZ**T | / ( n ulp ) 00070 *> 00071 *> (5) | A - UZ H (UZ)**T | / ( |A| n ulp ) 00072 *> 00073 *> (6) | I - UZ (UZ)**T | / ( n ulp ) 00074 *> 00075 *> (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) 00076 *> 00077 *> (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) 00078 *> 00079 *> (9) | TR - RW | / ( |T| |R| ulp ) 00080 *> 00081 *> (10) | L**H T - W**H L | / ( |T| |L| ulp ) 00082 *> 00083 *> (11) | HX - XW | / ( |H| |X| ulp ) 00084 *> 00085 *> (12) | Y**H H - W**H Y | / ( |H| |Y| ulp ) 00086 *> 00087 *> (13) | AX - XW | / ( |A| |X| ulp ) 00088 *> 00089 *> (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) 00090 *> 00091 *> The "sizes" are specified by an array NN(1:NSIZES); the value of 00092 *> each element NN(j) specifies one size. 00093 *> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); 00094 *> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. 00095 *> Currently, the list of possible types is: 00096 *> 00097 *> (1) The zero matrix. 00098 *> (2) The identity matrix. 00099 *> (3) A (transposed) Jordan block, with 1's on the diagonal. 00100 *> 00101 *> (4) A diagonal matrix with evenly spaced entries 00102 *> 1, ..., ULP and random signs. 00103 *> (ULP = (first number larger than 1) - 1 ) 00104 *> (5) A diagonal matrix with geometrically spaced entries 00105 *> 1, ..., ULP and random signs. 00106 *> (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP 00107 *> and random signs. 00108 *> 00109 *> (7) Same as (4), but multiplied by SQRT( overflow threshold ) 00110 *> (8) Same as (4), but multiplied by SQRT( underflow threshold ) 00111 *> 00112 *> (9) A matrix of the form U' T U, where U is orthogonal and 00113 *> T has evenly spaced entries 1, ..., ULP with random signs 00114 *> on the diagonal and random O(1) entries in the upper 00115 *> triangle. 00116 *> 00117 *> (10) A matrix of the form U' T U, where U is orthogonal and 00118 *> T has geometrically spaced entries 1, ..., ULP with random 00119 *> signs on the diagonal and random O(1) entries in the upper 00120 *> triangle. 00121 *> 00122 *> (11) A matrix of the form U' T U, where U is orthogonal and 00123 *> T has "clustered" entries 1, ULP,..., ULP with random 00124 *> signs on the diagonal and random O(1) entries in the upper 00125 *> triangle. 00126 *> 00127 *> (12) A matrix of the form U' T U, where U is orthogonal and 00128 *> T has real or complex conjugate paired eigenvalues randomly 00129 *> chosen from ( ULP, 1 ) and random O(1) entries in the upper 00130 *> triangle. 00131 *> 00132 *> (13) A matrix of the form X' T X, where X has condition 00133 *> SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP 00134 *> with random signs on the diagonal and random O(1) entries 00135 *> in the upper triangle. 00136 *> 00137 *> (14) A matrix of the form X' T X, where X has condition 00138 *> SQRT( ULP ) and T has geometrically spaced entries 00139 *> 1, ..., ULP with random signs on the diagonal and random 00140 *> O(1) entries in the upper triangle. 00141 *> 00142 *> (15) A matrix of the form X' T X, where X has condition 00143 *> SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP 00144 *> with random signs on the diagonal and random O(1) entries 00145 *> in the upper triangle. 00146 *> 00147 *> (16) A matrix of the form X' T X, where X has condition 00148 *> SQRT( ULP ) and T has real or complex conjugate paired 00149 *> eigenvalues randomly chosen from ( ULP, 1 ) and random 00150 *> O(1) entries in the upper triangle. 00151 *> 00152 *> (17) Same as (16), but multiplied by SQRT( overflow threshold ) 00153 *> (18) Same as (16), but multiplied by SQRT( underflow threshold ) 00154 *> 00155 *> (19) Nonsymmetric matrix with random entries chosen from (-1,1). 00156 *> (20) Same as (19), but multiplied by SQRT( overflow threshold ) 00157 *> (21) Same as (19), but multiplied by SQRT( underflow threshold ) 00158 *> \endverbatim 00159 * 00160 * Arguments: 00161 * ========== 00162 * 00163 *> \verbatim 00164 *> NSIZES - INTEGER 00165 *> The number of sizes of matrices to use. If it is zero, 00166 *> SCHKHS does nothing. It must be at least zero. 00167 *> Not modified. 00168 *> 00169 *> NN - INTEGER array, dimension (NSIZES) 00170 *> An array containing the sizes to be used for the matrices. 00171 *> Zero values will be skipped. The values must be at least 00172 *> zero. 00173 *> Not modified. 00174 *> 00175 *> NTYPES - INTEGER 00176 *> The number of elements in DOTYPE. If it is zero, SCHKHS 00177 *> does nothing. It must be at least zero. If it is MAXTYP+1 00178 *> and NSIZES is 1, then an additional type, MAXTYP+1 is 00179 *> defined, which is to use whatever matrix is in A. This 00180 *> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and 00181 *> DOTYPE(MAXTYP+1) is .TRUE. . 00182 *> Not modified. 00183 *> 00184 *> DOTYPE - LOGICAL array, dimension (NTYPES) 00185 *> If DOTYPE(j) is .TRUE., then for each size in NN a 00186 *> matrix of that size and of type j will be generated. 00187 *> If NTYPES is smaller than the maximum number of types 00188 *> defined (PARAMETER MAXTYP), then types NTYPES+1 through 00189 *> MAXTYP will not be generated. If NTYPES is larger 00190 *> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) 00191 *> will be ignored. 00192 *> Not modified. 00193 *> 00194 *> ISEED - INTEGER array, dimension (4) 00195 *> On entry ISEED specifies the seed of the random number 00196 *> generator. The array elements should be between 0 and 4095; 00197 *> if not they will be reduced mod 4096. Also, ISEED(4) must 00198 *> be odd. The random number generator uses a linear 00199 *> congruential sequence limited to small integers, and so 00200 *> should produce machine independent random numbers. The 00201 *> values of ISEED are changed on exit, and can be used in the 00202 *> next call to SCHKHS to continue the same random number 00203 *> sequence. 00204 *> Modified. 00205 *> 00206 *> THRESH - REAL 00207 *> A test will count as "failed" if the "error", computed as 00208 *> described above, exceeds THRESH. Note that the error 00209 *> is scaled to be O(1), so THRESH should be a reasonably 00210 *> small multiple of 1, e.g., 10 or 100. In particular, 00211 *> it should not depend on the precision (single vs. double) 00212 *> or the size of the matrix. It must be at least zero. 00213 *> Not modified. 00214 *> 00215 *> NOUNIT - INTEGER 00216 *> The FORTRAN unit number for printing out error messages 00217 *> (e.g., if a routine returns IINFO not equal to 0.) 00218 *> Not modified. 00219 *> 00220 *> A - REAL array, dimension (LDA,max(NN)) 00221 *> Used to hold the matrix whose eigenvalues are to be 00222 *> computed. On exit, A contains the last matrix actually 00223 *> used. 00224 *> Modified. 00225 *> 00226 *> LDA - INTEGER 00227 *> The leading dimension of A, H, T1 and T2. It must be at 00228 *> least 1 and at least max( NN ). 00229 *> Not modified. 00230 *> 00231 *> H - REAL array, dimension (LDA,max(NN)) 00232 *> The upper hessenberg matrix computed by SGEHRD. On exit, 00233 *> H contains the Hessenberg form of the matrix in A. 00234 *> Modified. 00235 *> 00236 *> T1 - REAL array, dimension (LDA,max(NN)) 00237 *> The Schur (="quasi-triangular") matrix computed by SHSEQR 00238 *> if Z is computed. On exit, T1 contains the Schur form of 00239 *> the matrix in A. 00240 *> Modified. 00241 *> 00242 *> T2 - REAL array, dimension (LDA,max(NN)) 00243 *> The Schur matrix computed by SHSEQR when Z is not computed. 00244 *> This should be identical to T1. 00245 *> Modified. 00246 *> 00247 *> LDU - INTEGER 00248 *> The leading dimension of U, Z, UZ and UU. It must be at 00249 *> least 1 and at least max( NN ). 00250 *> Not modified. 00251 *> 00252 *> U - REAL array, dimension (LDU,max(NN)) 00253 *> The orthogonal matrix computed by SGEHRD. 00254 *> Modified. 00255 *> 00256 *> Z - REAL array, dimension (LDU,max(NN)) 00257 *> The orthogonal matrix computed by SHSEQR. 00258 *> Modified. 00259 *> 00260 *> UZ - REAL array, dimension (LDU,max(NN)) 00261 *> The product of U times Z. 00262 *> Modified. 00263 *> 00264 *> WR1 - REAL array, dimension (max(NN)) 00265 *> WI1 - REAL array, dimension (max(NN)) 00266 *> The real and imaginary parts of the eigenvalues of A, 00267 *> as computed when Z is computed. 00268 *> On exit, WR1 + WI1*i are the eigenvalues of the matrix in A. 00269 *> Modified. 00270 *> 00271 *> WR3 - REAL array, dimension (max(NN)) 00272 *> WI3 - REAL array, dimension (max(NN)) 00273 *> Like WR1, WI1, these arrays contain the eigenvalues of A, 00274 *> but those computed when SHSEQR only computes the 00275 *> eigenvalues, i.e., not the Schur vectors and no more of the 00276 *> Schur form than is necessary for computing the 00277 *> eigenvalues. 00278 *> Modified. 00279 *> 00280 *> EVECTL - REAL array, dimension (LDU,max(NN)) 00281 *> The (upper triangular) left eigenvector matrix for the 00282 *> matrix in T1. For complex conjugate pairs, the real part 00283 *> is stored in one row and the imaginary part in the next. 00284 *> Modified. 00285 *> 00286 *> EVECTR - REAL array, dimension (LDU,max(NN)) 00287 *> The (upper triangular) right eigenvector matrix for the 00288 *> matrix in T1. For complex conjugate pairs, the real part 00289 *> is stored in one column and the imaginary part in the next. 00290 *> Modified. 00291 *> 00292 *> EVECTY - REAL array, dimension (LDU,max(NN)) 00293 *> The left eigenvector matrix for the 00294 *> matrix in H. For complex conjugate pairs, the real part 00295 *> is stored in one row and the imaginary part in the next. 00296 *> Modified. 00297 *> 00298 *> EVECTX - REAL array, dimension (LDU,max(NN)) 00299 *> The right eigenvector matrix for the 00300 *> matrix in H. For complex conjugate pairs, the real part 00301 *> is stored in one column and the imaginary part in the next. 00302 *> Modified. 00303 *> 00304 *> UU - REAL array, dimension (LDU,max(NN)) 00305 *> Details of the orthogonal matrix computed by SGEHRD. 00306 *> Modified. 00307 *> 00308 *> TAU - REAL array, dimension(max(NN)) 00309 *> Further details of the orthogonal matrix computed by SGEHRD. 00310 *> Modified. 00311 *> 00312 *> WORK - REAL array, dimension (NWORK) 00313 *> Workspace. 00314 *> Modified. 00315 *> 00316 *> NWORK - INTEGER 00317 *> The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2. 00318 *> 00319 *> IWORK - INTEGER array, dimension (max(NN)) 00320 *> Workspace. 00321 *> Modified. 00322 *> 00323 *> SELECT - LOGICAL array, dimension (max(NN)) 00324 *> Workspace. 00325 *> Modified. 00326 *> 00327 *> RESULT - REAL array, dimension (14) 00328 *> The values computed by the fourteen tests described above. 00329 *> The values are currently limited to 1/ulp, to avoid 00330 *> overflow. 00331 *> Modified. 00332 *> 00333 *> INFO - INTEGER 00334 *> If 0, then everything ran OK. 00335 *> -1: NSIZES < 0 00336 *> -2: Some NN(j) < 0 00337 *> -3: NTYPES < 0 00338 *> -6: THRESH < 0 00339 *> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). 00340 *> -14: LDU < 1 or LDU < NMAX. 00341 *> -28: NWORK too small. 00342 *> If SLATMR, SLATMS, or SLATME returns an error code, the 00343 *> absolute value of it is returned. 00344 *> If 1, then SHSEQR could not find all the shifts. 00345 *> If 2, then the EISPACK code (for small blocks) failed. 00346 *> If >2, then 30*N iterations were not enough to find an 00347 *> eigenvalue or to decompose the problem. 00348 *> Modified. 00349 *> 00350 *>----------------------------------------------------------------------- 00351 *> 00352 *> Some Local Variables and Parameters: 00353 *> ---- ----- --------- --- ---------- 00354 *> 00355 *> ZERO, ONE Real 0 and 1. 00356 *> MAXTYP The number of types defined. 00357 *> MTEST The number of tests defined: care must be taken 00358 *> that (1) the size of RESULT, (2) the number of 00359 *> tests actually performed, and (3) MTEST agree. 00360 *> NTEST The number of tests performed on this matrix 00361 *> so far. This should be less than MTEST, and 00362 *> equal to it by the last test. It will be less 00363 *> if any of the routines being tested indicates 00364 *> that it could not compute the matrices that 00365 *> would be tested. 00366 *> NMAX Largest value in NN. 00367 *> NMATS The number of matrices generated so far. 00368 *> NERRS The number of tests which have exceeded THRESH 00369 *> so far (computed by SLAFTS). 00370 *> COND, CONDS, 00371 *> IMODE Values to be passed to the matrix generators. 00372 *> ANORM Norm of A; passed to matrix generators. 00373 *> 00374 *> OVFL, UNFL Overflow and underflow thresholds. 00375 *> ULP, ULPINV Finest relative precision and its inverse. 00376 *> RTOVFL, RTUNFL, 00377 *> RTULP, RTULPI Square roots of the previous 4 values. 00378 *> 00379 *> The following four arrays decode JTYPE: 00380 *> KTYPE(j) The general type (1-10) for type "j". 00381 *> KMODE(j) The MODE value to be passed to the matrix 00382 *> generator for type "j". 00383 *> KMAGN(j) The order of magnitude ( O(1), 00384 *> O(overflow^(1/2) ), O(underflow^(1/2) ) 00385 *> KCONDS(j) Selects whether CONDS is to be 1 or 00386 *> 1/sqrt(ulp). (0 means irrelevant.) 00387 *> \endverbatim 00388 * 00389 * Authors: 00390 * ======== 00391 * 00392 *> \author Univ. of Tennessee 00393 *> \author Univ. of California Berkeley 00394 *> \author Univ. of Colorado Denver 00395 *> \author NAG Ltd. 00396 * 00397 *> \date November 2011 00398 * 00399 *> \ingroup single_eig 00400 * 00401 * ===================================================================== 00402 SUBROUTINE SCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, 00403 $ NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1, 00404 $ WI1, WR3, WI3, EVECTL, EVECTR, EVECTY, EVECTX, 00405 $ UU, TAU, WORK, NWORK, IWORK, SELECT, RESULT, 00406 $ INFO ) 00407 * 00408 * -- LAPACK test routine (version 3.4.0) -- 00409 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00410 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00411 * November 2011 00412 * 00413 * .. Scalar Arguments .. 00414 INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK 00415 REAL THRESH 00416 * .. 00417 * .. Array Arguments .. 00418 LOGICAL DOTYPE( * ), SELECT( * ) 00419 INTEGER ISEED( 4 ), IWORK( * ), NN( * ) 00420 REAL A( LDA, * ), EVECTL( LDU, * ), 00421 $ EVECTR( LDU, * ), EVECTX( LDU, * ), 00422 $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ), 00423 $ T1( LDA, * ), T2( LDA, * ), TAU( * ), 00424 $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ), 00425 $ WI1( * ), WI3( * ), WORK( * ), WR1( * ), 00426 $ WR3( * ), Z( LDU, * ) 00427 * .. 00428 * 00429 * ===================================================================== 00430 * 00431 * .. Parameters .. 00432 REAL ZERO, ONE 00433 PARAMETER ( ZERO = 0.0, ONE = 1.0 ) 00434 INTEGER MAXTYP 00435 PARAMETER ( MAXTYP = 21 ) 00436 * .. 00437 * .. Local Scalars .. 00438 LOGICAL BADNN, MATCH 00439 INTEGER I, IHI, IINFO, ILO, IMODE, IN, ITYPE, J, JCOL, 00440 $ JJ, JSIZE, JTYPE, K, MTYPES, N, N1, NERRS, 00441 $ NMATS, NMAX, NSELC, NSELR, NTEST, NTESTT 00442 REAL ANINV, ANORM, COND, CONDS, OVFL, RTOVFL, RTULP, 00443 $ RTULPI, RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL 00444 * .. 00445 * .. Local Arrays .. 00446 CHARACTER ADUMMA( 1 ) 00447 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ), 00448 $ KMAGN( MAXTYP ), KMODE( MAXTYP ), 00449 $ KTYPE( MAXTYP ) 00450 REAL DUMMA( 6 ) 00451 * .. 00452 * .. External Functions .. 00453 REAL SLAMCH 00454 EXTERNAL SLAMCH 00455 * .. 00456 * .. External Subroutines .. 00457 EXTERNAL SCOPY, SGEHRD, SGEMM, SGET10, SGET22, SHSEIN, 00458 $ SHSEQR, SHST01, SLABAD, SLACPY, SLAFTS, SLASET, 00459 $ SLASUM, SLATME, SLATMR, SLATMS, SORGHR, SORMHR, 00460 $ STREVC, XERBLA 00461 * .. 00462 * .. Intrinsic Functions .. 00463 INTRINSIC ABS, MAX, MIN, REAL, SQRT 00464 * .. 00465 * .. Data statements .. 00466 DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 / 00467 DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2, 00468 $ 3, 1, 2, 3 / 00469 DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3, 00470 $ 1, 5, 5, 5, 4, 3, 1 / 00471 DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 / 00472 * .. 00473 * .. Executable Statements .. 00474 * 00475 * Check for errors 00476 * 00477 NTESTT = 0 00478 INFO = 0 00479 * 00480 BADNN = .FALSE. 00481 NMAX = 0 00482 DO 10 J = 1, NSIZES 00483 NMAX = MAX( NMAX, NN( J ) ) 00484 IF( NN( J ).LT.0 ) 00485 $ BADNN = .TRUE. 00486 10 CONTINUE 00487 * 00488 * Check for errors 00489 * 00490 IF( NSIZES.LT.0 ) THEN 00491 INFO = -1 00492 ELSE IF( BADNN ) THEN 00493 INFO = -2 00494 ELSE IF( NTYPES.LT.0 ) THEN 00495 INFO = -3 00496 ELSE IF( THRESH.LT.ZERO ) THEN 00497 INFO = -6 00498 ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN 00499 INFO = -9 00500 ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN 00501 INFO = -14 00502 ELSE IF( 4*NMAX*NMAX+2.GT.NWORK ) THEN 00503 INFO = -28 00504 END IF 00505 * 00506 IF( INFO.NE.0 ) THEN 00507 CALL XERBLA( 'SCHKHS', -INFO ) 00508 RETURN 00509 END IF 00510 * 00511 * Quick return if possible 00512 * 00513 IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) 00514 $ RETURN 00515 * 00516 * More important constants 00517 * 00518 UNFL = SLAMCH( 'Safe minimum' ) 00519 OVFL = SLAMCH( 'Overflow' ) 00520 CALL SLABAD( UNFL, OVFL ) 00521 ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' ) 00522 ULPINV = ONE / ULP 00523 RTUNFL = SQRT( UNFL ) 00524 RTOVFL = SQRT( OVFL ) 00525 RTULP = SQRT( ULP ) 00526 RTULPI = ONE / RTULP 00527 * 00528 * Loop over sizes, types 00529 * 00530 NERRS = 0 00531 NMATS = 0 00532 * 00533 DO 270 JSIZE = 1, NSIZES 00534 N = NN( JSIZE ) 00535 IF( N.EQ.0 ) 00536 $ GO TO 270 00537 N1 = MAX( 1, N ) 00538 ANINV = ONE / REAL( N1 ) 00539 * 00540 IF( NSIZES.NE.1 ) THEN 00541 MTYPES = MIN( MAXTYP, NTYPES ) 00542 ELSE 00543 MTYPES = MIN( MAXTYP+1, NTYPES ) 00544 END IF 00545 * 00546 DO 260 JTYPE = 1, MTYPES 00547 IF( .NOT.DOTYPE( JTYPE ) ) 00548 $ GO TO 260 00549 NMATS = NMATS + 1 00550 NTEST = 0 00551 * 00552 * Save ISEED in case of an error. 00553 * 00554 DO 20 J = 1, 4 00555 IOLDSD( J ) = ISEED( J ) 00556 20 CONTINUE 00557 * 00558 * Initialize RESULT 00559 * 00560 DO 30 J = 1, 14 00561 RESULT( J ) = ZERO 00562 30 CONTINUE 00563 * 00564 * Compute "A" 00565 * 00566 * Control parameters: 00567 * 00568 * KMAGN KCONDS KMODE KTYPE 00569 * =1 O(1) 1 clustered 1 zero 00570 * =2 large large clustered 2 identity 00571 * =3 small exponential Jordan 00572 * =4 arithmetic diagonal, (w/ eigenvalues) 00573 * =5 random log symmetric, w/ eigenvalues 00574 * =6 random general, w/ eigenvalues 00575 * =7 random diagonal 00576 * =8 random symmetric 00577 * =9 random general 00578 * =10 random triangular 00579 * 00580 IF( MTYPES.GT.MAXTYP ) 00581 $ GO TO 100 00582 * 00583 ITYPE = KTYPE( JTYPE ) 00584 IMODE = KMODE( JTYPE ) 00585 * 00586 * Compute norm 00587 * 00588 GO TO ( 40, 50, 60 )KMAGN( JTYPE ) 00589 * 00590 40 CONTINUE 00591 ANORM = ONE 00592 GO TO 70 00593 * 00594 50 CONTINUE 00595 ANORM = ( RTOVFL*ULP )*ANINV 00596 GO TO 70 00597 * 00598 60 CONTINUE 00599 ANORM = RTUNFL*N*ULPINV 00600 GO TO 70 00601 * 00602 70 CONTINUE 00603 * 00604 CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA ) 00605 IINFO = 0 00606 COND = ULPINV 00607 * 00608 * Special Matrices 00609 * 00610 IF( ITYPE.EQ.1 ) THEN 00611 * 00612 * Zero 00613 * 00614 IINFO = 0 00615 * 00616 ELSE IF( ITYPE.EQ.2 ) THEN 00617 * 00618 * Identity 00619 * 00620 DO 80 JCOL = 1, N 00621 A( JCOL, JCOL ) = ANORM 00622 80 CONTINUE 00623 * 00624 ELSE IF( ITYPE.EQ.3 ) THEN 00625 * 00626 * Jordan Block 00627 * 00628 DO 90 JCOL = 1, N 00629 A( JCOL, JCOL ) = ANORM 00630 IF( JCOL.GT.1 ) 00631 $ A( JCOL, JCOL-1 ) = ONE 00632 90 CONTINUE 00633 * 00634 ELSE IF( ITYPE.EQ.4 ) THEN 00635 * 00636 * Diagonal Matrix, [Eigen]values Specified 00637 * 00638 CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, 00639 $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), 00640 $ IINFO ) 00641 * 00642 ELSE IF( ITYPE.EQ.5 ) THEN 00643 * 00644 * Symmetric, eigenvalues specified 00645 * 00646 CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, 00647 $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), 00648 $ IINFO ) 00649 * 00650 ELSE IF( ITYPE.EQ.6 ) THEN 00651 * 00652 * General, eigenvalues specified 00653 * 00654 IF( KCONDS( JTYPE ).EQ.1 ) THEN 00655 CONDS = ONE 00656 ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN 00657 CONDS = RTULPI 00658 ELSE 00659 CONDS = ZERO 00660 END IF 00661 * 00662 ADUMMA( 1 ) = ' ' 00663 CALL SLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE, 00664 $ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4, 00665 $ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ), 00666 $ IINFO ) 00667 * 00668 ELSE IF( ITYPE.EQ.7 ) THEN 00669 * 00670 * Diagonal, random eigenvalues 00671 * 00672 CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, 00673 $ 'T', 'N', WORK( N+1 ), 1, ONE, 00674 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, 00675 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) 00676 * 00677 ELSE IF( ITYPE.EQ.8 ) THEN 00678 * 00679 * Symmetric, random eigenvalues 00680 * 00681 CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, 00682 $ 'T', 'N', WORK( N+1 ), 1, ONE, 00683 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, 00684 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) 00685 * 00686 ELSE IF( ITYPE.EQ.9 ) THEN 00687 * 00688 * General, random eigenvalues 00689 * 00690 CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE, 00691 $ 'T', 'N', WORK( N+1 ), 1, ONE, 00692 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, 00693 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) 00694 * 00695 ELSE IF( ITYPE.EQ.10 ) THEN 00696 * 00697 * Triangular, random eigenvalues 00698 * 00699 CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE, 00700 $ 'T', 'N', WORK( N+1 ), 1, ONE, 00701 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0, 00702 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) 00703 * 00704 ELSE 00705 * 00706 IINFO = 1 00707 END IF 00708 * 00709 IF( IINFO.NE.0 ) THEN 00710 WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, 00711 $ IOLDSD 00712 INFO = ABS( IINFO ) 00713 RETURN 00714 END IF 00715 * 00716 100 CONTINUE 00717 * 00718 * Call SGEHRD to compute H and U, do tests. 00719 * 00720 CALL SLACPY( ' ', N, N, A, LDA, H, LDA ) 00721 * 00722 NTEST = 1 00723 * 00724 ILO = 1 00725 IHI = N 00726 * 00727 CALL SGEHRD( N, ILO, IHI, H, LDA, WORK, WORK( N+1 ), 00728 $ NWORK-N, IINFO ) 00729 * 00730 IF( IINFO.NE.0 ) THEN 00731 RESULT( 1 ) = ULPINV 00732 WRITE( NOUNIT, FMT = 9999 )'SGEHRD', IINFO, N, JTYPE, 00733 $ IOLDSD 00734 INFO = ABS( IINFO ) 00735 GO TO 250 00736 END IF 00737 * 00738 DO 120 J = 1, N - 1 00739 UU( J+1, J ) = ZERO 00740 DO 110 I = J + 2, N 00741 U( I, J ) = H( I, J ) 00742 UU( I, J ) = H( I, J ) 00743 H( I, J ) = ZERO 00744 110 CONTINUE 00745 120 CONTINUE 00746 CALL SCOPY( N-1, WORK, 1, TAU, 1 ) 00747 CALL SORGHR( N, ILO, IHI, U, LDU, WORK, WORK( N+1 ), 00748 $ NWORK-N, IINFO ) 00749 NTEST = 2 00750 * 00751 CALL SHST01( N, ILO, IHI, A, LDA, H, LDA, U, LDU, WORK, 00752 $ NWORK, RESULT( 1 ) ) 00753 * 00754 * Call SHSEQR to compute T1, T2 and Z, do tests. 00755 * 00756 * Eigenvalues only (WR3,WI3) 00757 * 00758 CALL SLACPY( ' ', N, N, H, LDA, T2, LDA ) 00759 NTEST = 3 00760 RESULT( 3 ) = ULPINV 00761 * 00762 CALL SHSEQR( 'E', 'N', N, ILO, IHI, T2, LDA, WR3, WI3, UZ, 00763 $ LDU, WORK, NWORK, IINFO ) 00764 IF( IINFO.NE.0 ) THEN 00765 WRITE( NOUNIT, FMT = 9999 )'SHSEQR(E)', IINFO, N, JTYPE, 00766 $ IOLDSD 00767 IF( IINFO.LE.N+2 ) THEN 00768 INFO = ABS( IINFO ) 00769 GO TO 250 00770 END IF 00771 END IF 00772 * 00773 * Eigenvalues (WR1,WI1) and Full Schur Form (T2) 00774 * 00775 CALL SLACPY( ' ', N, N, H, LDA, T2, LDA ) 00776 * 00777 CALL SHSEQR( 'S', 'N', N, ILO, IHI, T2, LDA, WR1, WI1, UZ, 00778 $ LDU, WORK, NWORK, IINFO ) 00779 IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN 00780 WRITE( NOUNIT, FMT = 9999 )'SHSEQR(S)', IINFO, N, JTYPE, 00781 $ IOLDSD 00782 INFO = ABS( IINFO ) 00783 GO TO 250 00784 END IF 00785 * 00786 * Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors 00787 * (UZ) 00788 * 00789 CALL SLACPY( ' ', N, N, H, LDA, T1, LDA ) 00790 CALL SLACPY( ' ', N, N, U, LDU, UZ, LDA ) 00791 * 00792 CALL SHSEQR( 'S', 'V', N, ILO, IHI, T1, LDA, WR1, WI1, UZ, 00793 $ LDU, WORK, NWORK, IINFO ) 00794 IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN 00795 WRITE( NOUNIT, FMT = 9999 )'SHSEQR(V)', IINFO, N, JTYPE, 00796 $ IOLDSD 00797 INFO = ABS( IINFO ) 00798 GO TO 250 00799 END IF 00800 * 00801 * Compute Z = U' UZ 00802 * 00803 CALL SGEMM( 'T', 'N', N, N, N, ONE, U, LDU, UZ, LDU, ZERO, 00804 $ Z, LDU ) 00805 NTEST = 8 00806 * 00807 * Do Tests 3: | H - Z T Z' | / ( |H| n ulp ) 00808 * and 4: | I - Z Z' | / ( n ulp ) 00809 * 00810 CALL SHST01( N, ILO, IHI, H, LDA, T1, LDA, Z, LDU, WORK, 00811 $ NWORK, RESULT( 3 ) ) 00812 * 00813 * Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp ) 00814 * and 6: | I - UZ (UZ)' | / ( n ulp ) 00815 * 00816 CALL SHST01( N, ILO, IHI, A, LDA, T1, LDA, UZ, LDU, WORK, 00817 $ NWORK, RESULT( 5 ) ) 00818 * 00819 * Do Test 7: | T2 - T1 | / ( |T| n ulp ) 00820 * 00821 CALL SGET10( N, N, T2, LDA, T1, LDA, WORK, RESULT( 7 ) ) 00822 * 00823 * Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp ) 00824 * 00825 TEMP1 = ZERO 00826 TEMP2 = ZERO 00827 DO 130 J = 1, N 00828 TEMP1 = MAX( TEMP1, ABS( WR1( J ) )+ABS( WI1( J ) ), 00829 $ ABS( WR3( J ) )+ABS( WI3( J ) ) ) 00830 TEMP2 = MAX( TEMP2, ABS( WR1( J )-WR3( J ) )+ 00831 $ ABS( WR1( J )-WR3( J ) ) ) 00832 130 CONTINUE 00833 * 00834 RESULT( 8 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) 00835 * 00836 * Compute the Left and Right Eigenvectors of T 00837 * 00838 * Compute the Right eigenvector Matrix: 00839 * 00840 NTEST = 9 00841 RESULT( 9 ) = ULPINV 00842 * 00843 * Select last max(N/4,1) real, max(N/4,1) complex eigenvectors 00844 * 00845 NSELC = 0 00846 NSELR = 0 00847 J = N 00848 140 CONTINUE 00849 IF( WI1( J ).EQ.ZERO ) THEN 00850 IF( NSELR.LT.MAX( N / 4, 1 ) ) THEN 00851 NSELR = NSELR + 1 00852 SELECT( J ) = .TRUE. 00853 ELSE 00854 SELECT( J ) = .FALSE. 00855 END IF 00856 J = J - 1 00857 ELSE 00858 IF( NSELC.LT.MAX( N / 4, 1 ) ) THEN 00859 NSELC = NSELC + 1 00860 SELECT( J ) = .TRUE. 00861 SELECT( J-1 ) = .FALSE. 00862 ELSE 00863 SELECT( J ) = .FALSE. 00864 SELECT( J-1 ) = .FALSE. 00865 END IF 00866 J = J - 2 00867 END IF 00868 IF( J.GT.0 ) 00869 $ GO TO 140 00870 * 00871 CALL STREVC( 'Right', 'All', SELECT, N, T1, LDA, DUMMA, LDU, 00872 $ EVECTR, LDU, N, IN, WORK, IINFO ) 00873 IF( IINFO.NE.0 ) THEN 00874 WRITE( NOUNIT, FMT = 9999 )'STREVC(R,A)', IINFO, N, 00875 $ JTYPE, IOLDSD 00876 INFO = ABS( IINFO ) 00877 GO TO 250 00878 END IF 00879 * 00880 * Test 9: | TR - RW | / ( |T| |R| ulp ) 00881 * 00882 CALL SGET22( 'N', 'N', 'N', N, T1, LDA, EVECTR, LDU, WR1, 00883 $ WI1, WORK, DUMMA( 1 ) ) 00884 RESULT( 9 ) = DUMMA( 1 ) 00885 IF( DUMMA( 2 ).GT.THRESH ) THEN 00886 WRITE( NOUNIT, FMT = 9998 )'Right', 'STREVC', 00887 $ DUMMA( 2 ), N, JTYPE, IOLDSD 00888 END IF 00889 * 00890 * Compute selected right eigenvectors and confirm that 00891 * they agree with previous right eigenvectors 00892 * 00893 CALL STREVC( 'Right', 'Some', SELECT, N, T1, LDA, DUMMA, 00894 $ LDU, EVECTL, LDU, N, IN, WORK, IINFO ) 00895 IF( IINFO.NE.0 ) THEN 00896 WRITE( NOUNIT, FMT = 9999 )'STREVC(R,S)', IINFO, N, 00897 $ JTYPE, IOLDSD 00898 INFO = ABS( IINFO ) 00899 GO TO 250 00900 END IF 00901 * 00902 K = 1 00903 MATCH = .TRUE. 00904 DO 170 J = 1, N 00905 IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN 00906 DO 150 JJ = 1, N 00907 IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) ) THEN 00908 MATCH = .FALSE. 00909 GO TO 180 00910 END IF 00911 150 CONTINUE 00912 K = K + 1 00913 ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN 00914 DO 160 JJ = 1, N 00915 IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) .OR. 00916 $ EVECTR( JJ, J+1 ).NE.EVECTL( JJ, K+1 ) ) THEN 00917 MATCH = .FALSE. 00918 GO TO 180 00919 END IF 00920 160 CONTINUE 00921 K = K + 2 00922 END IF 00923 170 CONTINUE 00924 180 CONTINUE 00925 IF( .NOT.MATCH ) 00926 $ WRITE( NOUNIT, FMT = 9997 )'Right', 'STREVC', N, JTYPE, 00927 $ IOLDSD 00928 * 00929 * Compute the Left eigenvector Matrix: 00930 * 00931 NTEST = 10 00932 RESULT( 10 ) = ULPINV 00933 CALL STREVC( 'Left', 'All', SELECT, N, T1, LDA, EVECTL, LDU, 00934 $ DUMMA, LDU, N, IN, WORK, IINFO ) 00935 IF( IINFO.NE.0 ) THEN 00936 WRITE( NOUNIT, FMT = 9999 )'STREVC(L,A)', IINFO, N, 00937 $ JTYPE, IOLDSD 00938 INFO = ABS( IINFO ) 00939 GO TO 250 00940 END IF 00941 * 00942 * Test 10: | LT - WL | / ( |T| |L| ulp ) 00943 * 00944 CALL SGET22( 'Trans', 'N', 'Conj', N, T1, LDA, EVECTL, LDU, 00945 $ WR1, WI1, WORK, DUMMA( 3 ) ) 00946 RESULT( 10 ) = DUMMA( 3 ) 00947 IF( DUMMA( 4 ).GT.THRESH ) THEN 00948 WRITE( NOUNIT, FMT = 9998 )'Left', 'STREVC', DUMMA( 4 ), 00949 $ N, JTYPE, IOLDSD 00950 END IF 00951 * 00952 * Compute selected left eigenvectors and confirm that 00953 * they agree with previous left eigenvectors 00954 * 00955 CALL STREVC( 'Left', 'Some', SELECT, N, T1, LDA, EVECTR, 00956 $ LDU, DUMMA, LDU, N, IN, WORK, IINFO ) 00957 IF( IINFO.NE.0 ) THEN 00958 WRITE( NOUNIT, FMT = 9999 )'STREVC(L,S)', IINFO, N, 00959 $ JTYPE, IOLDSD 00960 INFO = ABS( IINFO ) 00961 GO TO 250 00962 END IF 00963 * 00964 K = 1 00965 MATCH = .TRUE. 00966 DO 210 J = 1, N 00967 IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN 00968 DO 190 JJ = 1, N 00969 IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) ) THEN 00970 MATCH = .FALSE. 00971 GO TO 220 00972 END IF 00973 190 CONTINUE 00974 K = K + 1 00975 ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN 00976 DO 200 JJ = 1, N 00977 IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) .OR. 00978 $ EVECTL( JJ, J+1 ).NE.EVECTR( JJ, K+1 ) ) THEN 00979 MATCH = .FALSE. 00980 GO TO 220 00981 END IF 00982 200 CONTINUE 00983 K = K + 2 00984 END IF 00985 210 CONTINUE 00986 220 CONTINUE 00987 IF( .NOT.MATCH ) 00988 $ WRITE( NOUNIT, FMT = 9997 )'Left', 'STREVC', N, JTYPE, 00989 $ IOLDSD 00990 * 00991 * Call SHSEIN for Right eigenvectors of H, do test 11 00992 * 00993 NTEST = 11 00994 RESULT( 11 ) = ULPINV 00995 DO 230 J = 1, N 00996 SELECT( J ) = .TRUE. 00997 230 CONTINUE 00998 * 00999 CALL SHSEIN( 'Right', 'Qr', 'Ninitv', SELECT, N, H, LDA, 01000 $ WR3, WI3, DUMMA, LDU, EVECTX, LDU, N1, IN, 01001 $ WORK, IWORK, IWORK, IINFO ) 01002 IF( IINFO.NE.0 ) THEN 01003 WRITE( NOUNIT, FMT = 9999 )'SHSEIN(R)', IINFO, N, JTYPE, 01004 $ IOLDSD 01005 INFO = ABS( IINFO ) 01006 IF( IINFO.LT.0 ) 01007 $ GO TO 250 01008 ELSE 01009 * 01010 * Test 11: | HX - XW | / ( |H| |X| ulp ) 01011 * 01012 * (from inverse iteration) 01013 * 01014 CALL SGET22( 'N', 'N', 'N', N, H, LDA, EVECTX, LDU, WR3, 01015 $ WI3, WORK, DUMMA( 1 ) ) 01016 IF( DUMMA( 1 ).LT.ULPINV ) 01017 $ RESULT( 11 ) = DUMMA( 1 )*ANINV 01018 IF( DUMMA( 2 ).GT.THRESH ) THEN 01019 WRITE( NOUNIT, FMT = 9998 )'Right', 'SHSEIN', 01020 $ DUMMA( 2 ), N, JTYPE, IOLDSD 01021 END IF 01022 END IF 01023 * 01024 * Call SHSEIN for Left eigenvectors of H, do test 12 01025 * 01026 NTEST = 12 01027 RESULT( 12 ) = ULPINV 01028 DO 240 J = 1, N 01029 SELECT( J ) = .TRUE. 01030 240 CONTINUE 01031 * 01032 CALL SHSEIN( 'Left', 'Qr', 'Ninitv', SELECT, N, H, LDA, WR3, 01033 $ WI3, EVECTY, LDU, DUMMA, LDU, N1, IN, WORK, 01034 $ IWORK, IWORK, IINFO ) 01035 IF( IINFO.NE.0 ) THEN 01036 WRITE( NOUNIT, FMT = 9999 )'SHSEIN(L)', IINFO, N, JTYPE, 01037 $ IOLDSD 01038 INFO = ABS( IINFO ) 01039 IF( IINFO.LT.0 ) 01040 $ GO TO 250 01041 ELSE 01042 * 01043 * Test 12: | YH - WY | / ( |H| |Y| ulp ) 01044 * 01045 * (from inverse iteration) 01046 * 01047 CALL SGET22( 'C', 'N', 'C', N, H, LDA, EVECTY, LDU, WR3, 01048 $ WI3, WORK, DUMMA( 3 ) ) 01049 IF( DUMMA( 3 ).LT.ULPINV ) 01050 $ RESULT( 12 ) = DUMMA( 3 )*ANINV 01051 IF( DUMMA( 4 ).GT.THRESH ) THEN 01052 WRITE( NOUNIT, FMT = 9998 )'Left', 'SHSEIN', 01053 $ DUMMA( 4 ), N, JTYPE, IOLDSD 01054 END IF 01055 END IF 01056 * 01057 * Call SORMHR for Right eigenvectors of A, do test 13 01058 * 01059 NTEST = 13 01060 RESULT( 13 ) = ULPINV 01061 * 01062 CALL SORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU, 01063 $ LDU, TAU, EVECTX, LDU, WORK, NWORK, IINFO ) 01064 IF( IINFO.NE.0 ) THEN 01065 WRITE( NOUNIT, FMT = 9999 )'SORMHR(R)', IINFO, N, JTYPE, 01066 $ IOLDSD 01067 INFO = ABS( IINFO ) 01068 IF( IINFO.LT.0 ) 01069 $ GO TO 250 01070 ELSE 01071 * 01072 * Test 13: | AX - XW | / ( |A| |X| ulp ) 01073 * 01074 * (from inverse iteration) 01075 * 01076 CALL SGET22( 'N', 'N', 'N', N, A, LDA, EVECTX, LDU, WR3, 01077 $ WI3, WORK, DUMMA( 1 ) ) 01078 IF( DUMMA( 1 ).LT.ULPINV ) 01079 $ RESULT( 13 ) = DUMMA( 1 )*ANINV 01080 END IF 01081 * 01082 * Call SORMHR for Left eigenvectors of A, do test 14 01083 * 01084 NTEST = 14 01085 RESULT( 14 ) = ULPINV 01086 * 01087 CALL SORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU, 01088 $ LDU, TAU, EVECTY, LDU, WORK, NWORK, IINFO ) 01089 IF( IINFO.NE.0 ) THEN 01090 WRITE( NOUNIT, FMT = 9999 )'SORMHR(L)', IINFO, N, JTYPE, 01091 $ IOLDSD 01092 INFO = ABS( IINFO ) 01093 IF( IINFO.LT.0 ) 01094 $ GO TO 250 01095 ELSE 01096 * 01097 * Test 14: | YA - WY | / ( |A| |Y| ulp ) 01098 * 01099 * (from inverse iteration) 01100 * 01101 CALL SGET22( 'C', 'N', 'C', N, A, LDA, EVECTY, LDU, WR3, 01102 $ WI3, WORK, DUMMA( 3 ) ) 01103 IF( DUMMA( 3 ).LT.ULPINV ) 01104 $ RESULT( 14 ) = DUMMA( 3 )*ANINV 01105 END IF 01106 * 01107 * End of Loop -- Check for RESULT(j) > THRESH 01108 * 01109 250 CONTINUE 01110 * 01111 NTESTT = NTESTT + NTEST 01112 CALL SLAFTS( 'SHS', N, N, JTYPE, NTEST, RESULT, IOLDSD, 01113 $ THRESH, NOUNIT, NERRS ) 01114 * 01115 260 CONTINUE 01116 270 CONTINUE 01117 * 01118 * Summary 01119 * 01120 CALL SLASUM( 'SHS', NOUNIT, NERRS, NTESTT ) 01121 * 01122 RETURN 01123 * 01124 9999 FORMAT( ' SCHKHS: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', 01125 $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) 01126 9998 FORMAT( ' SCHKHS: ', A, ' Eigenvectors from ', A, ' incorrectly ', 01127 $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X, 01128 $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, 01129 $ ')' ) 01130 9997 FORMAT( ' SCHKHS: Selected ', A, ' Eigenvectors from ', A, 01131 $ ' do not match other eigenvectors ', 9X, 'N=', I6, 01132 $ ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) 01133 * 01134 * End of SCHKHS 01135 * 01136 END