LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
dchkhs.f
Go to the documentation of this file.
00001 *> \brief \b DCHKHS
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 DCHKHS( 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 *       DOUBLE PRECISION   THRESH
00020 *       ..
00021 *       .. Array Arguments ..
00022 *       LOGICAL            DOTYPE( * ), SELECT( * )
00023 *       INTEGER            ISEED( 4 ), IWORK( * ), NN( * )
00024 *       DOUBLE PRECISION   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 *>    DCHKHS  checks the nonsymmetric eigenvalue problem routines.
00040 *>
00041 *>            DGEHRD factors A as  U H U' , where ' means transpose,
00042 *>            H is hessenberg, and U is an orthogonal matrix.
00043 *>
00044 *>            DORGHR generates the orthogonal matrix U.
00045 *>
00046 *>            DORMHR multiplies a matrix by the orthogonal matrix U.
00047 *>
00048 *>            DHSEQR factors H as  Z T Z' , where Z is orthogonal and
00049 *>            T is "quasi-triangular", and the eigenvalue vector W.
00050 *>
00051 *>            DTREVC computes the left and right eigenvector matrices
00052 *>            L and R for T.
00053 *>
00054 *>            DHSEIN computes the left and right eigenvector matrices
00055 *>            Y and X for H, using inverse iteration.
00056 *>
00057 *>    When DCHKHS 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 *>           DCHKHS 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, DCHKHS
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 DCHKHS to continue the same random number
00203 *>           sequence.
00204 *>           Modified.
00205 *>
00206 *>  THRESH - DOUBLE PRECISION
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      - DOUBLE PRECISION 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      - DOUBLE PRECISION array, dimension (LDA,max(NN))
00232 *>           The upper hessenberg matrix computed by DGEHRD.  On exit,
00233 *>           H contains the Hessenberg form of the matrix in A.
00234 *>           Modified.
00235 *>
00236 *>  T1     - DOUBLE PRECISION array, dimension (LDA,max(NN))
00237 *>           The Schur (="quasi-triangular") matrix computed by DHSEQR
00238 *>           if Z is computed.  On exit, T1 contains the Schur form of
00239 *>           the matrix in A.
00240 *>           Modified.
00241 *>
00242 *>  T2     - DOUBLE PRECISION array, dimension (LDA,max(NN))
00243 *>           The Schur matrix computed by DHSEQR 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      - DOUBLE PRECISION array, dimension (LDU,max(NN))
00253 *>           The orthogonal matrix computed by DGEHRD.
00254 *>           Modified.
00255 *>
00256 *>  Z      - DOUBLE PRECISION array, dimension (LDU,max(NN))
00257 *>           The orthogonal matrix computed by DHSEQR.
00258 *>           Modified.
00259 *>
00260 *>  UZ     - DOUBLE PRECISION array, dimension (LDU,max(NN))
00261 *>           The product of U times Z.
00262 *>           Modified.
00263 *>
00264 *>  WR1    - DOUBLE PRECISION array, dimension (max(NN))
00265 *>  WI1    - DOUBLE PRECISION 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    - DOUBLE PRECISION array, dimension (max(NN))
00272 *>  WI3    - DOUBLE PRECISION array, dimension (max(NN))
00273 *>           Like WR1, WI1, these arrays contain the eigenvalues of A,
00274 *>           but those computed when DHSEQR 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 - DOUBLE PRECISION 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 *>  EVEZTR - DOUBLE PRECISION 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 - DOUBLE PRECISION 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 - DOUBLE PRECISION 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     - DOUBLE PRECISION array, dimension (LDU,max(NN))
00305 *>           Details of the orthogonal matrix computed by DGEHRD.
00306 *>           Modified.
00307 *>
00308 *>  TAU    - DOUBLE PRECISION array, dimension(max(NN))
00309 *>           Further details of the orthogonal matrix computed by DGEHRD.
00310 *>           Modified.
00311 *>
00312 *>  WORK   - DOUBLE PRECISION 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 - DOUBLE PRECISION 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  DLATMR, SLATMS, or SLATME returns an error code, the
00343 *>               absolute value of it is returned.
00344 *>           If 1, then DHSEQR 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 DLAFTS).
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 double_eig
00400 *
00401 *  =====================================================================
00402       SUBROUTINE DCHKHS( 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       DOUBLE PRECISION   THRESH
00416 *     ..
00417 *     .. Array Arguments ..
00418       LOGICAL            DOTYPE( * ), SELECT( * )
00419       INTEGER            ISEED( 4 ), IWORK( * ), NN( * )
00420       DOUBLE PRECISION   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       DOUBLE PRECISION   ZERO, ONE
00433       PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
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       DOUBLE PRECISION   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       DOUBLE PRECISION   DUMMA( 6 )
00451 *     ..
00452 *     .. External Functions ..
00453       DOUBLE PRECISION   DLAMCH
00454       EXTERNAL           DLAMCH
00455 *     ..
00456 *     .. External Subroutines ..
00457       EXTERNAL           DCOPY, DGEHRD, DGEMM, DGET10, DGET22, DHSEIN,
00458      $                   DHSEQR, DHST01, DLABAD, DLACPY, DLAFTS, DLASET,
00459      $                   DLASUM, DLATME, DLATMR, DLATMS, DORGHR, DORMHR,
00460      $                   DTREVC, XERBLA
00461 *     ..
00462 *     .. Intrinsic Functions ..
00463       INTRINSIC          ABS, DBLE, MAX, MIN, 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( 'DCHKHS', -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 = DLAMCH( 'Safe minimum' )
00519       OVFL = DLAMCH( 'Overflow' )
00520       CALL DLABAD( UNFL, OVFL )
00521       ULP = DLAMCH( 'Epsilon' )*DLAMCH( '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 / DBLE( 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 DLASET( '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 DLATMS( 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 DLATMS( 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 DLATME( 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 DLATMR( 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 DLATMR( 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 DLATMR( 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 DLATMR( 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 DGEHRD to compute H and U, do tests.
00719 *
00720             CALL DLACPY( ' ', N, N, A, LDA, H, LDA )
00721 *
00722             NTEST = 1
00723 *
00724             ILO = 1
00725             IHI = N
00726 *
00727             CALL DGEHRD( 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 )'DGEHRD', 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 DCOPY( N-1, WORK, 1, TAU, 1 )
00747             CALL DORGHR( N, ILO, IHI, U, LDU, WORK, WORK( N+1 ),
00748      $                   NWORK-N, IINFO )
00749             NTEST = 2
00750 *
00751             CALL DHST01( N, ILO, IHI, A, LDA, H, LDA, U, LDU, WORK,
00752      $                   NWORK, RESULT( 1 ) )
00753 *
00754 *           Call DHSEQR to compute T1, T2 and Z, do tests.
00755 *
00756 *           Eigenvalues only (WR3,WI3)
00757 *
00758             CALL DLACPY( ' ', N, N, H, LDA, T2, LDA )
00759             NTEST = 3
00760             RESULT( 3 ) = ULPINV
00761 *
00762             CALL DHSEQR( '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 )'DHSEQR(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 DLACPY( ' ', N, N, H, LDA, T2, LDA )
00776 *
00777             CALL DHSEQR( '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 )'DHSEQR(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 DLACPY( ' ', N, N, H, LDA, T1, LDA )
00790             CALL DLACPY( ' ', N, N, U, LDU, UZ, LDA )
00791 *
00792             CALL DHSEQR( '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 )'DHSEQR(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 DGEMM( '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 DHST01( 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 DHST01( 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 DGET10( 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 DTREVC( '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 )'DTREVC(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 DGET22( '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', 'DTREVC',
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 DTREVC( '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 )'DTREVC(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', 'DTREVC', N, JTYPE,
00927      $         IOLDSD
00928 *
00929 *           Compute the Left eigenvector Matrix:
00930 *
00931             NTEST = 10
00932             RESULT( 10 ) = ULPINV
00933             CALL DTREVC( '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 )'DTREVC(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 DGET22( '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', 'DTREVC', 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 DTREVC( '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 )'DTREVC(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', 'DTREVC', N, JTYPE,
00989      $         IOLDSD
00990 *
00991 *           Call DHSEIN 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 DHSEIN( '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 )'DHSEIN(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 DGET22( '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', 'DHSEIN',
01020      $               DUMMA( 2 ), N, JTYPE, IOLDSD
01021                END IF
01022             END IF
01023 *
01024 *           Call DHSEIN 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 DHSEIN( '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 )'DHSEIN(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 DGET22( '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', 'DHSEIN',
01053      $               DUMMA( 4 ), N, JTYPE, IOLDSD
01054                END IF
01055             END IF
01056 *
01057 *           Call DORMHR for Right eigenvectors of A, do test 13
01058 *
01059             NTEST = 13
01060             RESULT( 13 ) = ULPINV
01061 *
01062             CALL DORMHR( '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 )'DORMHR(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 DGET22( '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 DORMHR for Left eigenvectors of A, do test 14
01083 *
01084             NTEST = 14
01085             RESULT( 14 ) = ULPINV
01086 *
01087             CALL DORMHR( '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 )'DORMHR(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 DGET22( '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 DLAFTS( 'DHS', N, N, JTYPE, NTEST, RESULT, IOLDSD,
01113      $                   THRESH, NOUNIT, NERRS )
01114 *
01115   260    CONTINUE
01116   270 CONTINUE
01117 *
01118 *     Summary
01119 *
01120       CALL DLASUM( 'DHS', NOUNIT, NERRS, NTESTT )
01121 *
01122       RETURN
01123 *
01124  9999 FORMAT( ' DCHKHS: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
01125      $      I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
01126  9998 FORMAT( ' DCHKHS: ', 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( ' DCHKHS: 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 DCHKHS
01135 *
01136       END
 All Files Functions