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