LAPACK: TESTING/EIG/dchkhs.f Source File

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