1 SUBROUTINE SCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
2 $ NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1,
3 $ WI1, WR3, WI3, EVECTL, EVECTR, EVECTY, EVECTX,
4 $ UU, TAU, WORK, NWORK, IWORK, SELECT, RESULT,
5 $ INFO )
6 *
7 * -- LAPACK test routine (version 3.1.1) --
8 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
9 * February 2007
10 *
11 * .. Scalar Arguments ..
12 INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK
13 REAL THRESH
14 * ..
15 * .. Array Arguments ..
16 LOGICAL DOTYPE( * ), SELECT( * )
17 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
18 REAL A( LDA, * ), EVECTL( LDU, * ),
19 $ EVECTR( LDU, * ), EVECTX( LDU, * ),
20 $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ),
21 $ T1( LDA, * ), T2( LDA, * ), TAU( * ),
22 $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ),
23 $ WI1( * ), WI3( * ), WORK( * ), WR1( * ),
24 $ WR3( * ), Z( LDU, * )
25 * ..
26 *
27 * Purpose
28 * =======
29 *
30 * SCHKHS checks the nonsymmetric eigenvalue problem routines.
31 *
32 * SGEHRD factors A as U H U' , where ' means transpose,
33 * H is hessenberg, and U is an orthogonal matrix.
34 *
35 * SORGHR generates the orthogonal matrix U.
36 *
37 * SORMHR multiplies a matrix by the orthogonal matrix U.
38 *
39 * SHSEQR factors H as Z T Z' , where Z is orthogonal and
40 * T is "quasi-triangular", and the eigenvalue vector W.
41 *
42 * STREVC computes the left and right eigenvector matrices
43 * L and R for T.
44 *
45 * SHSEIN computes the left and right eigenvector matrices
46 * Y and X for H, using inverse iteration.
47 *
48 * When SCHKHS is called, a number of matrix "sizes" ("n's") and a
49 * number of matrix "types" are specified. For each size ("n")
50 * and each type of matrix, one matrix will be generated and used
51 * to test the nonsymmetric eigenroutines. For each matrix, 14
52 * tests will be performed:
53 *
54 * (1) | A - U H U**T | / ( |A| n ulp )
55 *
56 * (2) | I - UU**T | / ( n ulp )
57 *
58 * (3) | H - Z T Z**T | / ( |H| n ulp )
59 *
60 * (4) | I - ZZ**T | / ( n ulp )
61 *
62 * (5) | A - UZ H (UZ)**T | / ( |A| n ulp )
63 *
64 * (6) | I - UZ (UZ)**T | / ( n ulp )
65 *
66 * (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp )
67 *
68 * (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp )
69 *
70 * (9) | TR - RW | / ( |T| |R| ulp )
71 *
72 * (10) | L**H T - W**H L | / ( |T| |L| ulp )
73 *
74 * (11) | HX - XW | / ( |H| |X| ulp )
75 *
76 * (12) | Y**H H - W**H Y | / ( |H| |Y| ulp )
77 *
78 * (13) | AX - XW | / ( |A| |X| ulp )
79 *
80 * (14) | Y**H A - W**H Y | / ( |A| |Y| ulp )
81 *
82 * The "sizes" are specified by an array NN(1:NSIZES); the value of
83 * each element NN(j) specifies one size.
84 * The "types" are specified by a logical array DOTYPE( 1:NTYPES );
85 * if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
86 * Currently, the list of possible types is:
87 *
88 * (1) The zero matrix.
89 * (2) The identity matrix.
90 * (3) A (transposed) Jordan block, with 1's on the diagonal.
91 *
92 * (4) A diagonal matrix with evenly spaced entries
93 * 1, ..., ULP and random signs.
94 * (ULP = (first number larger than 1) - 1 )
95 * (5) A diagonal matrix with geometrically spaced entries
96 * 1, ..., ULP and random signs.
97 * (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
98 * and random signs.
99 *
100 * (7) Same as (4), but multiplied by SQRT( overflow threshold )
101 * (8) Same as (4), but multiplied by SQRT( underflow threshold )
102 *
103 * (9) A matrix of the form U' T U, where U is orthogonal and
104 * T has evenly spaced entries 1, ..., ULP with random signs
105 * on the diagonal and random O(1) entries in the upper
106 * triangle.
107 *
108 * (10) A matrix of the form U' T U, where U is orthogonal and
109 * T has geometrically spaced entries 1, ..., ULP with random
110 * signs on the diagonal and random O(1) entries in the upper
111 * triangle.
112 *
113 * (11) A matrix of the form U' T U, where U is orthogonal and
114 * T has "clustered" entries 1, ULP,..., ULP with random
115 * signs on the diagonal and random O(1) entries in the upper
116 * triangle.
117 *
118 * (12) A matrix of the form U' T U, where U is orthogonal and
119 * T has real or complex conjugate paired eigenvalues randomly
120 * chosen from ( ULP, 1 ) and random O(1) entries in the upper
121 * triangle.
122 *
123 * (13) A matrix of the form X' T X, where X has condition
124 * SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
125 * with random signs on the diagonal and random O(1) entries
126 * in the upper triangle.
127 *
128 * (14) A matrix of the form X' T X, where X has condition
129 * SQRT( ULP ) and T has geometrically spaced entries
130 * 1, ..., ULP with random signs on the diagonal and random
131 * O(1) entries in the upper triangle.
132 *
133 * (15) A matrix of the form X' T X, where X has condition
134 * SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
135 * with random signs on the diagonal and random O(1) entries
136 * in the upper triangle.
137 *
138 * (16) A matrix of the form X' T X, where X has condition
139 * SQRT( ULP ) and T has real or complex conjugate paired
140 * eigenvalues randomly chosen from ( ULP, 1 ) and random
141 * O(1) entries in the upper triangle.
142 *
143 * (17) Same as (16), but multiplied by SQRT( overflow threshold )
144 * (18) Same as (16), but multiplied by SQRT( underflow threshold )
145 *
146 * (19) Nonsymmetric matrix with random entries chosen from (-1,1).
147 * (20) Same as (19), but multiplied by SQRT( overflow threshold )
148 * (21) Same as (19), but multiplied by SQRT( underflow threshold )
149 *
150 * Arguments
151 * ==========
152 *
153 * NSIZES - INTEGER
154 * The number of sizes of matrices to use. If it is zero,
155 * SCHKHS does nothing. It must be at least zero.
156 * Not modified.
157 *
158 * NN - INTEGER array, dimension (NSIZES)
159 * An array containing the sizes to be used for the matrices.
160 * Zero values will be skipped. The values must be at least
161 * zero.
162 * Not modified.
163 *
164 * NTYPES - INTEGER
165 * The number of elements in DOTYPE. If it is zero, SCHKHS
166 * does nothing. It must be at least zero. If it is MAXTYP+1
167 * and NSIZES is 1, then an additional type, MAXTYP+1 is
168 * defined, which is to use whatever matrix is in A. This
169 * is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
170 * DOTYPE(MAXTYP+1) is .TRUE. .
171 * Not modified.
172 *
173 * DOTYPE - LOGICAL array, dimension (NTYPES)
174 * If DOTYPE(j) is .TRUE., then for each size in NN a
175 * matrix of that size and of type j will be generated.
176 * If NTYPES is smaller than the maximum number of types
177 * defined (PARAMETER MAXTYP), then types NTYPES+1 through
178 * MAXTYP will not be generated. If NTYPES is larger
179 * than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
180 * will be ignored.
181 * Not modified.
182 *
183 * ISEED - INTEGER array, dimension (4)
184 * On entry ISEED specifies the seed of the random number
185 * generator. The array elements should be between 0 and 4095;
186 * if not they will be reduced mod 4096. Also, ISEED(4) must
187 * be odd. The random number generator uses a linear
188 * congruential sequence limited to small integers, and so
189 * should produce machine independent random numbers. The
190 * values of ISEED are changed on exit, and can be used in the
191 * next call to SCHKHS to continue the same random number
192 * sequence.
193 * Modified.
194 *
195 * THRESH - REAL
196 * A test will count as "failed" if the "error", computed as
197 * described above, exceeds THRESH. Note that the error
198 * is scaled to be O(1), so THRESH should be a reasonably
199 * small multiple of 1, e.g., 10 or 100. In particular,
200 * it should not depend on the precision (single vs. double)
201 * or the size of the matrix. It must be at least zero.
202 * Not modified.
203 *
204 * NOUNIT - INTEGER
205 * The FORTRAN unit number for printing out error messages
206 * (e.g., if a routine returns IINFO not equal to 0.)
207 * Not modified.
208 *
209 * A - REAL array, dimension (LDA,max(NN))
210 * Used to hold the matrix whose eigenvalues are to be
211 * computed. On exit, A contains the last matrix actually
212 * used.
213 * Modified.
214 *
215 * LDA - INTEGER
216 * The leading dimension of A, H, T1 and T2. It must be at
217 * least 1 and at least max( NN ).
218 * Not modified.
219 *
220 * H - REAL array, dimension (LDA,max(NN))
221 * The upper hessenberg matrix computed by SGEHRD. On exit,
222 * H contains the Hessenberg form of the matrix in A.
223 * Modified.
224 *
225 * T1 - REAL array, dimension (LDA,max(NN))
226 * The Schur (="quasi-triangular") matrix computed by SHSEQR
227 * if Z is computed. On exit, T1 contains the Schur form of
228 * the matrix in A.
229 * Modified.
230 *
231 * T2 - REAL array, dimension (LDA,max(NN))
232 * The Schur matrix computed by SHSEQR when Z is not computed.
233 * This should be identical to T1.
234 * Modified.
235 *
236 * LDU - INTEGER
237 * The leading dimension of U, Z, UZ and UU. It must be at
238 * least 1 and at least max( NN ).
239 * Not modified.
240 *
241 * U - REAL array, dimension (LDU,max(NN))
242 * The orthogonal matrix computed by SGEHRD.
243 * Modified.
244 *
245 * Z - REAL array, dimension (LDU,max(NN))
246 * The orthogonal matrix computed by SHSEQR.
247 * Modified.
248 *
249 * UZ - REAL array, dimension (LDU,max(NN))
250 * The product of U times Z.
251 * Modified.
252 *
253 * WR1 - REAL array, dimension (max(NN))
254 * WI1 - REAL array, dimension (max(NN))
255 * The real and imaginary parts of the eigenvalues of A,
256 * as computed when Z is computed.
257 * On exit, WR1 + WI1*i are the eigenvalues of the matrix in A.
258 * Modified.
259 *
260 * WR3 - REAL array, dimension (max(NN))
261 * WI3 - REAL array, dimension (max(NN))
262 * Like WR1, WI1, these arrays contain the eigenvalues of A,
263 * but those computed when SHSEQR only computes the
264 * eigenvalues, i.e., not the Schur vectors and no more of the
265 * Schur form than is necessary for computing the
266 * eigenvalues.
267 * Modified.
268 *
269 * EVECTL - REAL array, dimension (LDU,max(NN))
270 * The (upper triangular) left eigenvector matrix for the
271 * matrix in T1. For complex conjugate pairs, the real part
272 * is stored in one row and the imaginary part in the next.
273 * Modified.
274 *
275 * EVECTR - REAL array, dimension (LDU,max(NN))
276 * The (upper triangular) right eigenvector matrix for the
277 * matrix in T1. For complex conjugate pairs, the real part
278 * is stored in one column and the imaginary part in the next.
279 * Modified.
280 *
281 * EVECTY - REAL array, dimension (LDU,max(NN))
282 * The left eigenvector matrix for the
283 * matrix in H. For complex conjugate pairs, the real part
284 * is stored in one row and the imaginary part in the next.
285 * Modified.
286 *
287 * EVECTX - REAL array, dimension (LDU,max(NN))
288 * The right eigenvector matrix for the
289 * matrix in H. For complex conjugate pairs, the real part
290 * is stored in one column and the imaginary part in the next.
291 * Modified.
292 *
293 * UU - REAL array, dimension (LDU,max(NN))
294 * Details of the orthogonal matrix computed by SGEHRD.
295 * Modified.
296 *
297 * TAU - REAL array, dimension(max(NN))
298 * Further details of the orthogonal matrix computed by SGEHRD.
299 * Modified.
300 *
301 * WORK - REAL array, dimension (NWORK)
302 * Workspace.
303 * Modified.
304 *
305 * NWORK - INTEGER
306 * The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2.
307 *
308 * IWORK - INTEGER array, dimension (max(NN))
309 * Workspace.
310 * Modified.
311 *
312 * SELECT - LOGICAL array, dimension (max(NN))
313 * Workspace.
314 * Modified.
315 *
316 * RESULT - REAL array, dimension (14)
317 * The values computed by the fourteen tests described above.
318 * The values are currently limited to 1/ulp, to avoid
319 * overflow.
320 * Modified.
321 *
322 * INFO - INTEGER
323 * If 0, then everything ran OK.
324 * -1: NSIZES < 0
325 * -2: Some NN(j) < 0
326 * -3: NTYPES < 0
327 * -6: THRESH < 0
328 * -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
329 * -14: LDU < 1 or LDU < NMAX.
330 * -28: NWORK too small.
331 * If SLATMR, SLATMS, or SLATME returns an error code, the
332 * absolute value of it is returned.
333 * If 1, then SHSEQR could not find all the shifts.
334 * If 2, then the EISPACK code (for small blocks) failed.
335 * If >2, then 30*N iterations were not enough to find an
336 * eigenvalue or to decompose the problem.
337 * Modified.
338 *
339 *-----------------------------------------------------------------------
340 *
341 * Some Local Variables and Parameters:
342 * ---- ----- --------- --- ----------
343 *
344 * ZERO, ONE Real 0 and 1.
345 * MAXTYP The number of types defined.
346 * MTEST The number of tests defined: care must be taken
347 * that (1) the size of RESULT, (2) the number of
348 * tests actually performed, and (3) MTEST agree.
349 * NTEST The number of tests performed on this matrix
350 * so far. This should be less than MTEST, and
351 * equal to it by the last test. It will be less
352 * if any of the routines being tested indicates
353 * that it could not compute the matrices that
354 * would be tested.
355 * NMAX Largest value in NN.
356 * NMATS The number of matrices generated so far.
357 * NERRS The number of tests which have exceeded THRESH
358 * so far (computed by SLAFTS).
359 * COND, CONDS,
360 * IMODE Values to be passed to the matrix generators.
361 * ANORM Norm of A; passed to matrix generators.
362 *
363 * OVFL, UNFL Overflow and underflow thresholds.
364 * ULP, ULPINV Finest relative precision and its inverse.
365 * RTOVFL, RTUNFL,
366 * RTULP, RTULPI Square roots of the previous 4 values.
367 *
368 * The following four arrays decode JTYPE:
369 * KTYPE(j) The general type (1-10) for type "j".
370 * KMODE(j) The MODE value to be passed to the matrix
371 * generator for type "j".
372 * KMAGN(j) The order of magnitude ( O(1),
373 * O(overflow^(1/2) ), O(underflow^(1/2) )
374 * KCONDS(j) Selects whether CONDS is to be 1 or
375 * 1/sqrt(ulp). (0 means irrelevant.)
376 *
377 * =====================================================================
378 *
379 * .. Parameters ..
380 REAL ZERO, ONE
381 PARAMETER ( ZERO = 0.0, ONE = 1.0 )
382 INTEGER MAXTYP
383 PARAMETER ( MAXTYP = 21 )
384 * ..
385 * .. Local Scalars ..
386 LOGICAL BADNN, MATCH
387 INTEGER I, IHI, IINFO, ILO, IMODE, IN, ITYPE, J, JCOL,
388 $ JJ, JSIZE, JTYPE, K, MTYPES, N, N1, NERRS,
389 $ NMATS, NMAX, NSELC, NSELR, NTEST, NTESTT
390 REAL ANINV, ANORM, COND, CONDS, OVFL, RTOVFL, RTULP,
391 $ RTULPI, RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL
392 * ..
393 * .. Local Arrays ..
394 CHARACTER ADUMMA( 1 )
395 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
396 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
397 $ KTYPE( MAXTYP )
398 REAL DUMMA( 6 )
399 * ..
400 * .. External Functions ..
401 REAL SLAMCH
402 EXTERNAL SLAMCH
403 * ..
404 * .. External Subroutines ..
405 EXTERNAL SCOPY, SGEHRD, SGEMM, SGET10, SGET22, SHSEIN,
406 $ SHSEQR, SHST01, SLABAD, SLACPY, SLAFTS, SLASET,
407 $ SLASUM, SLATME, SLATMR, SLATMS, SORGHR, SORMHR,
408 $ STREVC, XERBLA
409 * ..
410 * .. Intrinsic Functions ..
411 INTRINSIC ABS, MAX, MIN, REAL, SQRT
412 * ..
413 * .. Data statements ..
414 DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
415 DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
416 $ 3, 1, 2, 3 /
417 DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
418 $ 1, 5, 5, 5, 4, 3, 1 /
419 DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
420 * ..
421 * .. Executable Statements ..
422 *
423 * Check for errors
424 *
425 NTESTT = 0
426 INFO = 0
427 *
428 BADNN = .FALSE.
429 NMAX = 0
430 DO 10 J = 1, NSIZES
431 NMAX = MAX( NMAX, NN( J ) )
432 IF( NN( J ).LT.0 )
433 $ BADNN = .TRUE.
434 10 CONTINUE
435 *
436 * Check for errors
437 *
438 IF( NSIZES.LT.0 ) THEN
439 INFO = -1
440 ELSE IF( BADNN ) THEN
441 INFO = -2
442 ELSE IF( NTYPES.LT.0 ) THEN
443 INFO = -3
444 ELSE IF( THRESH.LT.ZERO ) THEN
445 INFO = -6
446 ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
447 INFO = -9
448 ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN
449 INFO = -14
450 ELSE IF( 4*NMAX*NMAX+2.GT.NWORK ) THEN
451 INFO = -28
452 END IF
453 *
454 IF( INFO.NE.0 ) THEN
455 CALL XERBLA( 'SCHKHS', -INFO )
456 RETURN
457 END IF
458 *
459 * Quick return if possible
460 *
461 IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
462 $ RETURN
463 *
464 * More important constants
465 *
466 UNFL = SLAMCH( 'Safe minimum' )
467 OVFL = SLAMCH( 'Overflow' )
468 CALL SLABAD( UNFL, OVFL )
469 ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
470 ULPINV = ONE / ULP
471 RTUNFL = SQRT( UNFL )
472 RTOVFL = SQRT( OVFL )
473 RTULP = SQRT( ULP )
474 RTULPI = ONE / RTULP
475 *
476 * Loop over sizes, types
477 *
478 NERRS = 0
479 NMATS = 0
480 *
481 DO 270 JSIZE = 1, NSIZES
482 N = NN( JSIZE )
483 IF( N.EQ.0 )
484 $ GO TO 270
485 N1 = MAX( 1, N )
486 ANINV = ONE / REAL( N1 )
487 *
488 IF( NSIZES.NE.1 ) THEN
489 MTYPES = MIN( MAXTYP, NTYPES )
490 ELSE
491 MTYPES = MIN( MAXTYP+1, NTYPES )
492 END IF
493 *
494 DO 260 JTYPE = 1, MTYPES
495 IF( .NOT.DOTYPE( JTYPE ) )
496 $ GO TO 260
497 NMATS = NMATS + 1
498 NTEST = 0
499 *
500 * Save ISEED in case of an error.
501 *
502 DO 20 J = 1, 4
503 IOLDSD( J ) = ISEED( J )
504 20 CONTINUE
505 *
506 * Initialize RESULT
507 *
508 DO 30 J = 1, 14
509 RESULT( J ) = ZERO
510 30 CONTINUE
511 *
512 * Compute "A"
513 *
514 * Control parameters:
515 *
516 * KMAGN KCONDS KMODE KTYPE
517 * =1 O(1) 1 clustered 1 zero
518 * =2 large large clustered 2 identity
519 * =3 small exponential Jordan
520 * =4 arithmetic diagonal, (w/ eigenvalues)
521 * =5 random log symmetric, w/ eigenvalues
522 * =6 random general, w/ eigenvalues
523 * =7 random diagonal
524 * =8 random symmetric
525 * =9 random general
526 * =10 random triangular
527 *
528 IF( MTYPES.GT.MAXTYP )
529 $ GO TO 100
530 *
531 ITYPE = KTYPE( JTYPE )
532 IMODE = KMODE( JTYPE )
533 *
534 * Compute norm
535 *
536 GO TO ( 40, 50, 60 )KMAGN( JTYPE )
537 *
538 40 CONTINUE
539 ANORM = ONE
540 GO TO 70
541 *
542 50 CONTINUE
543 ANORM = ( RTOVFL*ULP )*ANINV
544 GO TO 70
545 *
546 60 CONTINUE
547 ANORM = RTUNFL*N*ULPINV
548 GO TO 70
549 *
550 70 CONTINUE
551 *
552 CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
553 IINFO = 0
554 COND = ULPINV
555 *
556 * Special Matrices
557 *
558 IF( ITYPE.EQ.1 ) THEN
559 *
560 * Zero
561 *
562 IINFO = 0
563 *
564 ELSE IF( ITYPE.EQ.2 ) THEN
565 *
566 * Identity
567 *
568 DO 80 JCOL = 1, N
569 A( JCOL, JCOL ) = ANORM
570 80 CONTINUE
571 *
572 ELSE IF( ITYPE.EQ.3 ) THEN
573 *
574 * Jordan Block
575 *
576 DO 90 JCOL = 1, N
577 A( JCOL, JCOL ) = ANORM
578 IF( JCOL.GT.1 )
579 $ A( JCOL, JCOL-1 ) = ONE
580 90 CONTINUE
581 *
582 ELSE IF( ITYPE.EQ.4 ) THEN
583 *
584 * Diagonal Matrix, [Eigen]values Specified
585 *
586 CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
587 $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
588 $ IINFO )
589 *
590 ELSE IF( ITYPE.EQ.5 ) THEN
591 *
592 * Symmetric, eigenvalues specified
593 *
594 CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
595 $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
596 $ IINFO )
597 *
598 ELSE IF( ITYPE.EQ.6 ) THEN
599 *
600 * General, eigenvalues specified
601 *
602 IF( KCONDS( JTYPE ).EQ.1 ) THEN
603 CONDS = ONE
604 ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
605 CONDS = RTULPI
606 ELSE
607 CONDS = ZERO
608 END IF
609 *
610 ADUMMA( 1 ) = ' '
611 CALL SLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
612 $ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
613 $ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
614 $ IINFO )
615 *
616 ELSE IF( ITYPE.EQ.7 ) THEN
617 *
618 * Diagonal, random eigenvalues
619 *
620 CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
621 $ 'T', 'N', WORK( N+1 ), 1, ONE,
622 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
623 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
624 *
625 ELSE IF( ITYPE.EQ.8 ) THEN
626 *
627 * Symmetric, random eigenvalues
628 *
629 CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
630 $ 'T', 'N', WORK( N+1 ), 1, ONE,
631 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
632 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
633 *
634 ELSE IF( ITYPE.EQ.9 ) THEN
635 *
636 * General, random eigenvalues
637 *
638 CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
639 $ 'T', 'N', WORK( N+1 ), 1, ONE,
640 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
641 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
642 *
643 ELSE IF( ITYPE.EQ.10 ) THEN
644 *
645 * Triangular, random eigenvalues
646 *
647 CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
648 $ 'T', 'N', WORK( N+1 ), 1, ONE,
649 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
650 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
651 *
652 ELSE
653 *
654 IINFO = 1
655 END IF
656 *
657 IF( IINFO.NE.0 ) THEN
658 WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
659 $ IOLDSD
660 INFO = ABS( IINFO )
661 RETURN
662 END IF
663 *
664 100 CONTINUE
665 *
666 * Call SGEHRD to compute H and U, do tests.
667 *
668 CALL SLACPY( ' ', N, N, A, LDA, H, LDA )
669 *
670 NTEST = 1
671 *
672 ILO = 1
673 IHI = N
674 *
675 CALL SGEHRD( N, ILO, IHI, H, LDA, WORK, WORK( N+1 ),
676 $ NWORK-N, IINFO )
677 *
678 IF( IINFO.NE.0 ) THEN
679 RESULT( 1 ) = ULPINV
680 WRITE( NOUNIT, FMT = 9999 )'SGEHRD', IINFO, N, JTYPE,
681 $ IOLDSD
682 INFO = ABS( IINFO )
683 GO TO 250
684 END IF
685 *
686 DO 120 J = 1, N - 1
687 UU( J+1, J ) = ZERO
688 DO 110 I = J + 2, N
689 U( I, J ) = H( I, J )
690 UU( I, J ) = H( I, J )
691 H( I, J ) = ZERO
692 110 CONTINUE
693 120 CONTINUE
694 CALL SCOPY( N-1, WORK, 1, TAU, 1 )
695 CALL SORGHR( N, ILO, IHI, U, LDU, WORK, WORK( N+1 ),
696 $ NWORK-N, IINFO )
697 NTEST = 2
698 *
699 CALL SHST01( N, ILO, IHI, A, LDA, H, LDA, U, LDU, WORK,
700 $ NWORK, RESULT( 1 ) )
701 *
702 * Call SHSEQR to compute T1, T2 and Z, do tests.
703 *
704 * Eigenvalues only (WR3,WI3)
705 *
706 CALL SLACPY( ' ', N, N, H, LDA, T2, LDA )
707 NTEST = 3
708 RESULT( 3 ) = ULPINV
709 *
710 CALL SHSEQR( 'E', 'N', N, ILO, IHI, T2, LDA, WR3, WI3, UZ,
711 $ LDU, WORK, NWORK, IINFO )
712 IF( IINFO.NE.0 ) THEN
713 WRITE( NOUNIT, FMT = 9999 )'SHSEQR(E)', IINFO, N, JTYPE,
714 $ IOLDSD
715 IF( IINFO.LE.N+2 ) THEN
716 INFO = ABS( IINFO )
717 GO TO 250
718 END IF
719 END IF
720 *
721 * Eigenvalues (WR1,WI1) and Full Schur Form (T2)
722 *
723 CALL SLACPY( ' ', N, N, H, LDA, T2, LDA )
724 *
725 CALL SHSEQR( 'S', 'N', N, ILO, IHI, T2, LDA, WR1, WI1, UZ,
726 $ LDU, WORK, NWORK, IINFO )
727 IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
728 WRITE( NOUNIT, FMT = 9999 )'SHSEQR(S)', IINFO, N, JTYPE,
729 $ IOLDSD
730 INFO = ABS( IINFO )
731 GO TO 250
732 END IF
733 *
734 * Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors
735 * (UZ)
736 *
737 CALL SLACPY( ' ', N, N, H, LDA, T1, LDA )
738 CALL SLACPY( ' ', N, N, U, LDU, UZ, LDA )
739 *
740 CALL SHSEQR( 'S', 'V', N, ILO, IHI, T1, LDA, WR1, WI1, UZ,
741 $ LDU, WORK, NWORK, IINFO )
742 IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
743 WRITE( NOUNIT, FMT = 9999 )'SHSEQR(V)', IINFO, N, JTYPE,
744 $ IOLDSD
745 INFO = ABS( IINFO )
746 GO TO 250
747 END IF
748 *
749 * Compute Z = U' UZ
750 *
751 CALL SGEMM( 'T', 'N', N, N, N, ONE, U, LDU, UZ, LDU, ZERO,
752 $ Z, LDU )
753 NTEST = 8
754 *
755 * Do Tests 3: | H - Z T Z' | / ( |H| n ulp )
756 * and 4: | I - Z Z' | / ( n ulp )
757 *
758 CALL SHST01( N, ILO, IHI, H, LDA, T1, LDA, Z, LDU, WORK,
759 $ NWORK, RESULT( 3 ) )
760 *
761 * Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp )
762 * and 6: | I - UZ (UZ)' | / ( n ulp )
763 *
764 CALL SHST01( N, ILO, IHI, A, LDA, T1, LDA, UZ, LDU, WORK,
765 $ NWORK, RESULT( 5 ) )
766 *
767 * Do Test 7: | T2 - T1 | / ( |T| n ulp )
768 *
769 CALL SGET10( N, N, T2, LDA, T1, LDA, WORK, RESULT( 7 ) )
770 *
771 * Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp )
772 *
773 TEMP1 = ZERO
774 TEMP2 = ZERO
775 DO 130 J = 1, N
776 TEMP1 = MAX( TEMP1, ABS( WR1( J ) )+ABS( WI1( J ) ),
777 $ ABS( WR3( J ) )+ABS( WI3( J ) ) )
778 TEMP2 = MAX( TEMP2, ABS( WR1( J )-WR3( J ) )+
779 $ ABS( WR1( J )-WR3( J ) ) )
780 130 CONTINUE
781 *
782 RESULT( 8 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
783 *
784 * Compute the Left and Right Eigenvectors of T
785 *
786 * Compute the Right eigenvector Matrix:
787 *
788 NTEST = 9
789 RESULT( 9 ) = ULPINV
790 *
791 * Select last max(N/4,1) real, max(N/4,1) complex eigenvectors
792 *
793 NSELC = 0
794 NSELR = 0
795 J = N
796 140 CONTINUE
797 IF( WI1( J ).EQ.ZERO ) THEN
798 IF( NSELR.LT.MAX( N / 4, 1 ) ) THEN
799 NSELR = NSELR + 1
800 SELECT( J ) = .TRUE.
801 ELSE
802 SELECT( J ) = .FALSE.
803 END IF
804 J = J - 1
805 ELSE
806 IF( NSELC.LT.MAX( N / 4, 1 ) ) THEN
807 NSELC = NSELC + 1
808 SELECT( J ) = .TRUE.
809 SELECT( J-1 ) = .FALSE.
810 ELSE
811 SELECT( J ) = .FALSE.
812 SELECT( J-1 ) = .FALSE.
813 END IF
814 J = J - 2
815 END IF
816 IF( J.GT.0 )
817 $ GO TO 140
818 *
819 CALL STREVC( 'Right', 'All', SELECT, N, T1, LDA, DUMMA, LDU,
820 $ EVECTR, LDU, N, IN, WORK, IINFO )
821 IF( IINFO.NE.0 ) THEN
822 WRITE( NOUNIT, FMT = 9999 )'STREVC(R,A)', IINFO, N,
823 $ JTYPE, IOLDSD
824 INFO = ABS( IINFO )
825 GO TO 250
826 END IF
827 *
828 * Test 9: | TR - RW | / ( |T| |R| ulp )
829 *
830 CALL SGET22( 'N', 'N', 'N', N, T1, LDA, EVECTR, LDU, WR1,
831 $ WI1, WORK, DUMMA( 1 ) )
832 RESULT( 9 ) = DUMMA( 1 )
833 IF( DUMMA( 2 ).GT.THRESH ) THEN
834 WRITE( NOUNIT, FMT = 9998 )'Right', 'STREVC',
835 $ DUMMA( 2 ), N, JTYPE, IOLDSD
836 END IF
837 *
838 * Compute selected right eigenvectors and confirm that
839 * they agree with previous right eigenvectors
840 *
841 CALL STREVC( 'Right', 'Some', SELECT, N, T1, LDA, DUMMA,
842 $ LDU, EVECTL, LDU, N, IN, WORK, IINFO )
843 IF( IINFO.NE.0 ) THEN
844 WRITE( NOUNIT, FMT = 9999 )'STREVC(R,S)', IINFO, N,
845 $ JTYPE, IOLDSD
846 INFO = ABS( IINFO )
847 GO TO 250
848 END IF
849 *
850 K = 1
851 MATCH = .TRUE.
852 DO 170 J = 1, N
853 IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
854 DO 150 JJ = 1, N
855 IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) ) THEN
856 MATCH = .FALSE.
857 GO TO 180
858 END IF
859 150 CONTINUE
860 K = K + 1
861 ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
862 DO 160 JJ = 1, N
863 IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) .OR.
864 $ EVECTR( JJ, J+1 ).NE.EVECTL( JJ, K+1 ) ) THEN
865 MATCH = .FALSE.
866 GO TO 180
867 END IF
868 160 CONTINUE
869 K = K + 2
870 END IF
871 170 CONTINUE
872 180 CONTINUE
873 IF( .NOT.MATCH )
874 $ WRITE( NOUNIT, FMT = 9997 )'Right', 'STREVC', N, JTYPE,
875 $ IOLDSD
876 *
877 * Compute the Left eigenvector Matrix:
878 *
879 NTEST = 10
880 RESULT( 10 ) = ULPINV
881 CALL STREVC( 'Left', 'All', SELECT, N, T1, LDA, EVECTL, LDU,
882 $ DUMMA, LDU, N, IN, WORK, IINFO )
883 IF( IINFO.NE.0 ) THEN
884 WRITE( NOUNIT, FMT = 9999 )'STREVC(L,A)', IINFO, N,
885 $ JTYPE, IOLDSD
886 INFO = ABS( IINFO )
887 GO TO 250
888 END IF
889 *
890 * Test 10: | LT - WL | / ( |T| |L| ulp )
891 *
892 CALL SGET22( 'Trans', 'N', 'Conj', N, T1, LDA, EVECTL, LDU,
893 $ WR1, WI1, WORK, DUMMA( 3 ) )
894 RESULT( 10 ) = DUMMA( 3 )
895 IF( DUMMA( 4 ).GT.THRESH ) THEN
896 WRITE( NOUNIT, FMT = 9998 )'Left', 'STREVC', DUMMA( 4 ),
897 $ N, JTYPE, IOLDSD
898 END IF
899 *
900 * Compute selected left eigenvectors and confirm that
901 * they agree with previous left eigenvectors
902 *
903 CALL STREVC( 'Left', 'Some', SELECT, N, T1, LDA, EVECTR,
904 $ LDU, DUMMA, LDU, N, IN, WORK, IINFO )
905 IF( IINFO.NE.0 ) THEN
906 WRITE( NOUNIT, FMT = 9999 )'STREVC(L,S)', IINFO, N,
907 $ JTYPE, IOLDSD
908 INFO = ABS( IINFO )
909 GO TO 250
910 END IF
911 *
912 K = 1
913 MATCH = .TRUE.
914 DO 210 J = 1, N
915 IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
916 DO 190 JJ = 1, N
917 IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) ) THEN
918 MATCH = .FALSE.
919 GO TO 220
920 END IF
921 190 CONTINUE
922 K = K + 1
923 ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
924 DO 200 JJ = 1, N
925 IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) .OR.
926 $ EVECTL( JJ, J+1 ).NE.EVECTR( JJ, K+1 ) ) THEN
927 MATCH = .FALSE.
928 GO TO 220
929 END IF
930 200 CONTINUE
931 K = K + 2
932 END IF
933 210 CONTINUE
934 220 CONTINUE
935 IF( .NOT.MATCH )
936 $ WRITE( NOUNIT, FMT = 9997 )'Left', 'STREVC', N, JTYPE,
937 $ IOLDSD
938 *
939 * Call SHSEIN for Right eigenvectors of H, do test 11
940 *
941 NTEST = 11
942 RESULT( 11 ) = ULPINV
943 DO 230 J = 1, N
944 SELECT( J ) = .TRUE.
945 230 CONTINUE
946 *
947 CALL SHSEIN( 'Right', 'Qr', 'Ninitv', SELECT, N, H, LDA,
948 $ WR3, WI3, DUMMA, LDU, EVECTX, LDU, N1, IN,
949 $ WORK, IWORK, IWORK, IINFO )
950 IF( IINFO.NE.0 ) THEN
951 WRITE( NOUNIT, FMT = 9999 )'SHSEIN(R)', IINFO, N, JTYPE,
952 $ IOLDSD
953 INFO = ABS( IINFO )
954 IF( IINFO.LT.0 )
955 $ GO TO 250
956 ELSE
957 *
958 * Test 11: | HX - XW | / ( |H| |X| ulp )
959 *
960 * (from inverse iteration)
961 *
962 CALL SGET22( 'N', 'N', 'N', N, H, LDA, EVECTX, LDU, WR3,
963 $ WI3, WORK, DUMMA( 1 ) )
964 IF( DUMMA( 1 ).LT.ULPINV )
965 $ RESULT( 11 ) = DUMMA( 1 )*ANINV
966 IF( DUMMA( 2 ).GT.THRESH ) THEN
967 WRITE( NOUNIT, FMT = 9998 )'Right', 'SHSEIN',
968 $ DUMMA( 2 ), N, JTYPE, IOLDSD
969 END IF
970 END IF
971 *
972 * Call SHSEIN for Left eigenvectors of H, do test 12
973 *
974 NTEST = 12
975 RESULT( 12 ) = ULPINV
976 DO 240 J = 1, N
977 SELECT( J ) = .TRUE.
978 240 CONTINUE
979 *
980 CALL SHSEIN( 'Left', 'Qr', 'Ninitv', SELECT, N, H, LDA, WR3,
981 $ WI3, EVECTY, LDU, DUMMA, LDU, N1, IN, WORK,
982 $ IWORK, IWORK, IINFO )
983 IF( IINFO.NE.0 ) THEN
984 WRITE( NOUNIT, FMT = 9999 )'SHSEIN(L)', IINFO, N, JTYPE,
985 $ IOLDSD
986 INFO = ABS( IINFO )
987 IF( IINFO.LT.0 )
988 $ GO TO 250
989 ELSE
990 *
991 * Test 12: | YH - WY | / ( |H| |Y| ulp )
992 *
993 * (from inverse iteration)
994 *
995 CALL SGET22( 'C', 'N', 'C', N, H, LDA, EVECTY, LDU, WR3,
996 $ WI3, WORK, DUMMA( 3 ) )
997 IF( DUMMA( 3 ).LT.ULPINV )
998 $ RESULT( 12 ) = DUMMA( 3 )*ANINV
999 IF( DUMMA( 4 ).GT.THRESH ) THEN
1000 WRITE( NOUNIT, FMT = 9998 )'Left', 'SHSEIN',
1001 $ DUMMA( 4 ), N, JTYPE, IOLDSD
1002 END IF
1003 END IF
1004 *
1005 * Call SORMHR for Right eigenvectors of A, do test 13
1006 *
1007 NTEST = 13
1008 RESULT( 13 ) = ULPINV
1009 *
1010 CALL SORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
1011 $ LDU, TAU, EVECTX, LDU, WORK, NWORK, IINFO )
1012 IF( IINFO.NE.0 ) THEN
1013 WRITE( NOUNIT, FMT = 9999 )'SORMHR(R)', IINFO, N, JTYPE,
1014 $ IOLDSD
1015 INFO = ABS( IINFO )
1016 IF( IINFO.LT.0 )
1017 $ GO TO 250
1018 ELSE
1019 *
1020 * Test 13: | AX - XW | / ( |A| |X| ulp )
1021 *
1022 * (from inverse iteration)
1023 *
1024 CALL SGET22( 'N', 'N', 'N', N, A, LDA, EVECTX, LDU, WR3,
1025 $ WI3, WORK, DUMMA( 1 ) )
1026 IF( DUMMA( 1 ).LT.ULPINV )
1027 $ RESULT( 13 ) = DUMMA( 1 )*ANINV
1028 END IF
1029 *
1030 * Call SORMHR for Left eigenvectors of A, do test 14
1031 *
1032 NTEST = 14
1033 RESULT( 14 ) = ULPINV
1034 *
1035 CALL SORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
1036 $ LDU, TAU, EVECTY, LDU, WORK, NWORK, IINFO )
1037 IF( IINFO.NE.0 ) THEN
1038 WRITE( NOUNIT, FMT = 9999 )'SORMHR(L)', IINFO, N, JTYPE,
1039 $ IOLDSD
1040 INFO = ABS( IINFO )
1041 IF( IINFO.LT.0 )
1042 $ GO TO 250
1043 ELSE
1044 *
1045 * Test 14: | YA - WY | / ( |A| |Y| ulp )
1046 *
1047 * (from inverse iteration)
1048 *
1049 CALL SGET22( 'C', 'N', 'C', N, A, LDA, EVECTY, LDU, WR3,
1050 $ WI3, WORK, DUMMA( 3 ) )
1051 IF( DUMMA( 3 ).LT.ULPINV )
1052 $ RESULT( 14 ) = DUMMA( 3 )*ANINV
1053 END IF
1054 *
1055 * End of Loop -- Check for RESULT(j) > THRESH
1056 *
1057 250 CONTINUE
1058 *
1059 NTESTT = NTESTT + NTEST
1060 CALL SLAFTS( 'SHS', N, N, JTYPE, NTEST, RESULT, IOLDSD,
1061 $ THRESH, NOUNIT, NERRS )
1062 *
1063 260 CONTINUE
1064 270 CONTINUE
1065 *
1066 * Summary
1067 *
1068 CALL SLASUM( 'SHS', NOUNIT, NERRS, NTESTT )
1069 *
1070 RETURN
1071 *
1072 9999 FORMAT( ' SCHKHS: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
1073 $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
1074 9998 FORMAT( ' SCHKHS: ', A, ' Eigenvectors from ', A, ' incorrectly ',
1075 $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
1076 $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
1077 $ ')' )
1078 9997 FORMAT( ' SCHKHS: Selected ', A, ' Eigenvectors from ', A,
1079 $ ' do not match other eigenvectors ', 9X, 'N=', I6,
1080 $ ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
1081 *
1082 * End of SCHKHS
1083 *
1084 END
2 $ NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1,
3 $ WI1, WR3, WI3, EVECTL, EVECTR, EVECTY, EVECTX,
4 $ UU, TAU, WORK, NWORK, IWORK, SELECT, RESULT,
5 $ INFO )
6 *
7 * -- LAPACK test routine (version 3.1.1) --
8 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
9 * February 2007
10 *
11 * .. Scalar Arguments ..
12 INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK
13 REAL THRESH
14 * ..
15 * .. Array Arguments ..
16 LOGICAL DOTYPE( * ), SELECT( * )
17 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
18 REAL A( LDA, * ), EVECTL( LDU, * ),
19 $ EVECTR( LDU, * ), EVECTX( LDU, * ),
20 $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ),
21 $ T1( LDA, * ), T2( LDA, * ), TAU( * ),
22 $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ),
23 $ WI1( * ), WI3( * ), WORK( * ), WR1( * ),
24 $ WR3( * ), Z( LDU, * )
25 * ..
26 *
27 * Purpose
28 * =======
29 *
30 * SCHKHS checks the nonsymmetric eigenvalue problem routines.
31 *
32 * SGEHRD factors A as U H U' , where ' means transpose,
33 * H is hessenberg, and U is an orthogonal matrix.
34 *
35 * SORGHR generates the orthogonal matrix U.
36 *
37 * SORMHR multiplies a matrix by the orthogonal matrix U.
38 *
39 * SHSEQR factors H as Z T Z' , where Z is orthogonal and
40 * T is "quasi-triangular", and the eigenvalue vector W.
41 *
42 * STREVC computes the left and right eigenvector matrices
43 * L and R for T.
44 *
45 * SHSEIN computes the left and right eigenvector matrices
46 * Y and X for H, using inverse iteration.
47 *
48 * When SCHKHS is called, a number of matrix "sizes" ("n's") and a
49 * number of matrix "types" are specified. For each size ("n")
50 * and each type of matrix, one matrix will be generated and used
51 * to test the nonsymmetric eigenroutines. For each matrix, 14
52 * tests will be performed:
53 *
54 * (1) | A - U H U**T | / ( |A| n ulp )
55 *
56 * (2) | I - UU**T | / ( n ulp )
57 *
58 * (3) | H - Z T Z**T | / ( |H| n ulp )
59 *
60 * (4) | I - ZZ**T | / ( n ulp )
61 *
62 * (5) | A - UZ H (UZ)**T | / ( |A| n ulp )
63 *
64 * (6) | I - UZ (UZ)**T | / ( n ulp )
65 *
66 * (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp )
67 *
68 * (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp )
69 *
70 * (9) | TR - RW | / ( |T| |R| ulp )
71 *
72 * (10) | L**H T - W**H L | / ( |T| |L| ulp )
73 *
74 * (11) | HX - XW | / ( |H| |X| ulp )
75 *
76 * (12) | Y**H H - W**H Y | / ( |H| |Y| ulp )
77 *
78 * (13) | AX - XW | / ( |A| |X| ulp )
79 *
80 * (14) | Y**H A - W**H Y | / ( |A| |Y| ulp )
81 *
82 * The "sizes" are specified by an array NN(1:NSIZES); the value of
83 * each element NN(j) specifies one size.
84 * The "types" are specified by a logical array DOTYPE( 1:NTYPES );
85 * if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
86 * Currently, the list of possible types is:
87 *
88 * (1) The zero matrix.
89 * (2) The identity matrix.
90 * (3) A (transposed) Jordan block, with 1's on the diagonal.
91 *
92 * (4) A diagonal matrix with evenly spaced entries
93 * 1, ..., ULP and random signs.
94 * (ULP = (first number larger than 1) - 1 )
95 * (5) A diagonal matrix with geometrically spaced entries
96 * 1, ..., ULP and random signs.
97 * (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
98 * and random signs.
99 *
100 * (7) Same as (4), but multiplied by SQRT( overflow threshold )
101 * (8) Same as (4), but multiplied by SQRT( underflow threshold )
102 *
103 * (9) A matrix of the form U' T U, where U is orthogonal and
104 * T has evenly spaced entries 1, ..., ULP with random signs
105 * on the diagonal and random O(1) entries in the upper
106 * triangle.
107 *
108 * (10) A matrix of the form U' T U, where U is orthogonal and
109 * T has geometrically spaced entries 1, ..., ULP with random
110 * signs on the diagonal and random O(1) entries in the upper
111 * triangle.
112 *
113 * (11) A matrix of the form U' T U, where U is orthogonal and
114 * T has "clustered" entries 1, ULP,..., ULP with random
115 * signs on the diagonal and random O(1) entries in the upper
116 * triangle.
117 *
118 * (12) A matrix of the form U' T U, where U is orthogonal and
119 * T has real or complex conjugate paired eigenvalues randomly
120 * chosen from ( ULP, 1 ) and random O(1) entries in the upper
121 * triangle.
122 *
123 * (13) A matrix of the form X' T X, where X has condition
124 * SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
125 * with random signs on the diagonal and random O(1) entries
126 * in the upper triangle.
127 *
128 * (14) A matrix of the form X' T X, where X has condition
129 * SQRT( ULP ) and T has geometrically spaced entries
130 * 1, ..., ULP with random signs on the diagonal and random
131 * O(1) entries in the upper triangle.
132 *
133 * (15) A matrix of the form X' T X, where X has condition
134 * SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
135 * with random signs on the diagonal and random O(1) entries
136 * in the upper triangle.
137 *
138 * (16) A matrix of the form X' T X, where X has condition
139 * SQRT( ULP ) and T has real or complex conjugate paired
140 * eigenvalues randomly chosen from ( ULP, 1 ) and random
141 * O(1) entries in the upper triangle.
142 *
143 * (17) Same as (16), but multiplied by SQRT( overflow threshold )
144 * (18) Same as (16), but multiplied by SQRT( underflow threshold )
145 *
146 * (19) Nonsymmetric matrix with random entries chosen from (-1,1).
147 * (20) Same as (19), but multiplied by SQRT( overflow threshold )
148 * (21) Same as (19), but multiplied by SQRT( underflow threshold )
149 *
150 * Arguments
151 * ==========
152 *
153 * NSIZES - INTEGER
154 * The number of sizes of matrices to use. If it is zero,
155 * SCHKHS does nothing. It must be at least zero.
156 * Not modified.
157 *
158 * NN - INTEGER array, dimension (NSIZES)
159 * An array containing the sizes to be used for the matrices.
160 * Zero values will be skipped. The values must be at least
161 * zero.
162 * Not modified.
163 *
164 * NTYPES - INTEGER
165 * The number of elements in DOTYPE. If it is zero, SCHKHS
166 * does nothing. It must be at least zero. If it is MAXTYP+1
167 * and NSIZES is 1, then an additional type, MAXTYP+1 is
168 * defined, which is to use whatever matrix is in A. This
169 * is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
170 * DOTYPE(MAXTYP+1) is .TRUE. .
171 * Not modified.
172 *
173 * DOTYPE - LOGICAL array, dimension (NTYPES)
174 * If DOTYPE(j) is .TRUE., then for each size in NN a
175 * matrix of that size and of type j will be generated.
176 * If NTYPES is smaller than the maximum number of types
177 * defined (PARAMETER MAXTYP), then types NTYPES+1 through
178 * MAXTYP will not be generated. If NTYPES is larger
179 * than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
180 * will be ignored.
181 * Not modified.
182 *
183 * ISEED - INTEGER array, dimension (4)
184 * On entry ISEED specifies the seed of the random number
185 * generator. The array elements should be between 0 and 4095;
186 * if not they will be reduced mod 4096. Also, ISEED(4) must
187 * be odd. The random number generator uses a linear
188 * congruential sequence limited to small integers, and so
189 * should produce machine independent random numbers. The
190 * values of ISEED are changed on exit, and can be used in the
191 * next call to SCHKHS to continue the same random number
192 * sequence.
193 * Modified.
194 *
195 * THRESH - REAL
196 * A test will count as "failed" if the "error", computed as
197 * described above, exceeds THRESH. Note that the error
198 * is scaled to be O(1), so THRESH should be a reasonably
199 * small multiple of 1, e.g., 10 or 100. In particular,
200 * it should not depend on the precision (single vs. double)
201 * or the size of the matrix. It must be at least zero.
202 * Not modified.
203 *
204 * NOUNIT - INTEGER
205 * The FORTRAN unit number for printing out error messages
206 * (e.g., if a routine returns IINFO not equal to 0.)
207 * Not modified.
208 *
209 * A - REAL array, dimension (LDA,max(NN))
210 * Used to hold the matrix whose eigenvalues are to be
211 * computed. On exit, A contains the last matrix actually
212 * used.
213 * Modified.
214 *
215 * LDA - INTEGER
216 * The leading dimension of A, H, T1 and T2. It must be at
217 * least 1 and at least max( NN ).
218 * Not modified.
219 *
220 * H - REAL array, dimension (LDA,max(NN))
221 * The upper hessenberg matrix computed by SGEHRD. On exit,
222 * H contains the Hessenberg form of the matrix in A.
223 * Modified.
224 *
225 * T1 - REAL array, dimension (LDA,max(NN))
226 * The Schur (="quasi-triangular") matrix computed by SHSEQR
227 * if Z is computed. On exit, T1 contains the Schur form of
228 * the matrix in A.
229 * Modified.
230 *
231 * T2 - REAL array, dimension (LDA,max(NN))
232 * The Schur matrix computed by SHSEQR when Z is not computed.
233 * This should be identical to T1.
234 * Modified.
235 *
236 * LDU - INTEGER
237 * The leading dimension of U, Z, UZ and UU. It must be at
238 * least 1 and at least max( NN ).
239 * Not modified.
240 *
241 * U - REAL array, dimension (LDU,max(NN))
242 * The orthogonal matrix computed by SGEHRD.
243 * Modified.
244 *
245 * Z - REAL array, dimension (LDU,max(NN))
246 * The orthogonal matrix computed by SHSEQR.
247 * Modified.
248 *
249 * UZ - REAL array, dimension (LDU,max(NN))
250 * The product of U times Z.
251 * Modified.
252 *
253 * WR1 - REAL array, dimension (max(NN))
254 * WI1 - REAL array, dimension (max(NN))
255 * The real and imaginary parts of the eigenvalues of A,
256 * as computed when Z is computed.
257 * On exit, WR1 + WI1*i are the eigenvalues of the matrix in A.
258 * Modified.
259 *
260 * WR3 - REAL array, dimension (max(NN))
261 * WI3 - REAL array, dimension (max(NN))
262 * Like WR1, WI1, these arrays contain the eigenvalues of A,
263 * but those computed when SHSEQR only computes the
264 * eigenvalues, i.e., not the Schur vectors and no more of the
265 * Schur form than is necessary for computing the
266 * eigenvalues.
267 * Modified.
268 *
269 * EVECTL - REAL array, dimension (LDU,max(NN))
270 * The (upper triangular) left eigenvector matrix for the
271 * matrix in T1. For complex conjugate pairs, the real part
272 * is stored in one row and the imaginary part in the next.
273 * Modified.
274 *
275 * EVECTR - REAL array, dimension (LDU,max(NN))
276 * The (upper triangular) right eigenvector matrix for the
277 * matrix in T1. For complex conjugate pairs, the real part
278 * is stored in one column and the imaginary part in the next.
279 * Modified.
280 *
281 * EVECTY - REAL array, dimension (LDU,max(NN))
282 * The left eigenvector matrix for the
283 * matrix in H. For complex conjugate pairs, the real part
284 * is stored in one row and the imaginary part in the next.
285 * Modified.
286 *
287 * EVECTX - REAL array, dimension (LDU,max(NN))
288 * The right eigenvector matrix for the
289 * matrix in H. For complex conjugate pairs, the real part
290 * is stored in one column and the imaginary part in the next.
291 * Modified.
292 *
293 * UU - REAL array, dimension (LDU,max(NN))
294 * Details of the orthogonal matrix computed by SGEHRD.
295 * Modified.
296 *
297 * TAU - REAL array, dimension(max(NN))
298 * Further details of the orthogonal matrix computed by SGEHRD.
299 * Modified.
300 *
301 * WORK - REAL array, dimension (NWORK)
302 * Workspace.
303 * Modified.
304 *
305 * NWORK - INTEGER
306 * The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2.
307 *
308 * IWORK - INTEGER array, dimension (max(NN))
309 * Workspace.
310 * Modified.
311 *
312 * SELECT - LOGICAL array, dimension (max(NN))
313 * Workspace.
314 * Modified.
315 *
316 * RESULT - REAL array, dimension (14)
317 * The values computed by the fourteen tests described above.
318 * The values are currently limited to 1/ulp, to avoid
319 * overflow.
320 * Modified.
321 *
322 * INFO - INTEGER
323 * If 0, then everything ran OK.
324 * -1: NSIZES < 0
325 * -2: Some NN(j) < 0
326 * -3: NTYPES < 0
327 * -6: THRESH < 0
328 * -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
329 * -14: LDU < 1 or LDU < NMAX.
330 * -28: NWORK too small.
331 * If SLATMR, SLATMS, or SLATME returns an error code, the
332 * absolute value of it is returned.
333 * If 1, then SHSEQR could not find all the shifts.
334 * If 2, then the EISPACK code (for small blocks) failed.
335 * If >2, then 30*N iterations were not enough to find an
336 * eigenvalue or to decompose the problem.
337 * Modified.
338 *
339 *-----------------------------------------------------------------------
340 *
341 * Some Local Variables and Parameters:
342 * ---- ----- --------- --- ----------
343 *
344 * ZERO, ONE Real 0 and 1.
345 * MAXTYP The number of types defined.
346 * MTEST The number of tests defined: care must be taken
347 * that (1) the size of RESULT, (2) the number of
348 * tests actually performed, and (3) MTEST agree.
349 * NTEST The number of tests performed on this matrix
350 * so far. This should be less than MTEST, and
351 * equal to it by the last test. It will be less
352 * if any of the routines being tested indicates
353 * that it could not compute the matrices that
354 * would be tested.
355 * NMAX Largest value in NN.
356 * NMATS The number of matrices generated so far.
357 * NERRS The number of tests which have exceeded THRESH
358 * so far (computed by SLAFTS).
359 * COND, CONDS,
360 * IMODE Values to be passed to the matrix generators.
361 * ANORM Norm of A; passed to matrix generators.
362 *
363 * OVFL, UNFL Overflow and underflow thresholds.
364 * ULP, ULPINV Finest relative precision and its inverse.
365 * RTOVFL, RTUNFL,
366 * RTULP, RTULPI Square roots of the previous 4 values.
367 *
368 * The following four arrays decode JTYPE:
369 * KTYPE(j) The general type (1-10) for type "j".
370 * KMODE(j) The MODE value to be passed to the matrix
371 * generator for type "j".
372 * KMAGN(j) The order of magnitude ( O(1),
373 * O(overflow^(1/2) ), O(underflow^(1/2) )
374 * KCONDS(j) Selects whether CONDS is to be 1 or
375 * 1/sqrt(ulp). (0 means irrelevant.)
376 *
377 * =====================================================================
378 *
379 * .. Parameters ..
380 REAL ZERO, ONE
381 PARAMETER ( ZERO = 0.0, ONE = 1.0 )
382 INTEGER MAXTYP
383 PARAMETER ( MAXTYP = 21 )
384 * ..
385 * .. Local Scalars ..
386 LOGICAL BADNN, MATCH
387 INTEGER I, IHI, IINFO, ILO, IMODE, IN, ITYPE, J, JCOL,
388 $ JJ, JSIZE, JTYPE, K, MTYPES, N, N1, NERRS,
389 $ NMATS, NMAX, NSELC, NSELR, NTEST, NTESTT
390 REAL ANINV, ANORM, COND, CONDS, OVFL, RTOVFL, RTULP,
391 $ RTULPI, RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL
392 * ..
393 * .. Local Arrays ..
394 CHARACTER ADUMMA( 1 )
395 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
396 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
397 $ KTYPE( MAXTYP )
398 REAL DUMMA( 6 )
399 * ..
400 * .. External Functions ..
401 REAL SLAMCH
402 EXTERNAL SLAMCH
403 * ..
404 * .. External Subroutines ..
405 EXTERNAL SCOPY, SGEHRD, SGEMM, SGET10, SGET22, SHSEIN,
406 $ SHSEQR, SHST01, SLABAD, SLACPY, SLAFTS, SLASET,
407 $ SLASUM, SLATME, SLATMR, SLATMS, SORGHR, SORMHR,
408 $ STREVC, XERBLA
409 * ..
410 * .. Intrinsic Functions ..
411 INTRINSIC ABS, MAX, MIN, REAL, SQRT
412 * ..
413 * .. Data statements ..
414 DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
415 DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
416 $ 3, 1, 2, 3 /
417 DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
418 $ 1, 5, 5, 5, 4, 3, 1 /
419 DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
420 * ..
421 * .. Executable Statements ..
422 *
423 * Check for errors
424 *
425 NTESTT = 0
426 INFO = 0
427 *
428 BADNN = .FALSE.
429 NMAX = 0
430 DO 10 J = 1, NSIZES
431 NMAX = MAX( NMAX, NN( J ) )
432 IF( NN( J ).LT.0 )
433 $ BADNN = .TRUE.
434 10 CONTINUE
435 *
436 * Check for errors
437 *
438 IF( NSIZES.LT.0 ) THEN
439 INFO = -1
440 ELSE IF( BADNN ) THEN
441 INFO = -2
442 ELSE IF( NTYPES.LT.0 ) THEN
443 INFO = -3
444 ELSE IF( THRESH.LT.ZERO ) THEN
445 INFO = -6
446 ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
447 INFO = -9
448 ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN
449 INFO = -14
450 ELSE IF( 4*NMAX*NMAX+2.GT.NWORK ) THEN
451 INFO = -28
452 END IF
453 *
454 IF( INFO.NE.0 ) THEN
455 CALL XERBLA( 'SCHKHS', -INFO )
456 RETURN
457 END IF
458 *
459 * Quick return if possible
460 *
461 IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
462 $ RETURN
463 *
464 * More important constants
465 *
466 UNFL = SLAMCH( 'Safe minimum' )
467 OVFL = SLAMCH( 'Overflow' )
468 CALL SLABAD( UNFL, OVFL )
469 ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
470 ULPINV = ONE / ULP
471 RTUNFL = SQRT( UNFL )
472 RTOVFL = SQRT( OVFL )
473 RTULP = SQRT( ULP )
474 RTULPI = ONE / RTULP
475 *
476 * Loop over sizes, types
477 *
478 NERRS = 0
479 NMATS = 0
480 *
481 DO 270 JSIZE = 1, NSIZES
482 N = NN( JSIZE )
483 IF( N.EQ.0 )
484 $ GO TO 270
485 N1 = MAX( 1, N )
486 ANINV = ONE / REAL( N1 )
487 *
488 IF( NSIZES.NE.1 ) THEN
489 MTYPES = MIN( MAXTYP, NTYPES )
490 ELSE
491 MTYPES = MIN( MAXTYP+1, NTYPES )
492 END IF
493 *
494 DO 260 JTYPE = 1, MTYPES
495 IF( .NOT.DOTYPE( JTYPE ) )
496 $ GO TO 260
497 NMATS = NMATS + 1
498 NTEST = 0
499 *
500 * Save ISEED in case of an error.
501 *
502 DO 20 J = 1, 4
503 IOLDSD( J ) = ISEED( J )
504 20 CONTINUE
505 *
506 * Initialize RESULT
507 *
508 DO 30 J = 1, 14
509 RESULT( J ) = ZERO
510 30 CONTINUE
511 *
512 * Compute "A"
513 *
514 * Control parameters:
515 *
516 * KMAGN KCONDS KMODE KTYPE
517 * =1 O(1) 1 clustered 1 zero
518 * =2 large large clustered 2 identity
519 * =3 small exponential Jordan
520 * =4 arithmetic diagonal, (w/ eigenvalues)
521 * =5 random log symmetric, w/ eigenvalues
522 * =6 random general, w/ eigenvalues
523 * =7 random diagonal
524 * =8 random symmetric
525 * =9 random general
526 * =10 random triangular
527 *
528 IF( MTYPES.GT.MAXTYP )
529 $ GO TO 100
530 *
531 ITYPE = KTYPE( JTYPE )
532 IMODE = KMODE( JTYPE )
533 *
534 * Compute norm
535 *
536 GO TO ( 40, 50, 60 )KMAGN( JTYPE )
537 *
538 40 CONTINUE
539 ANORM = ONE
540 GO TO 70
541 *
542 50 CONTINUE
543 ANORM = ( RTOVFL*ULP )*ANINV
544 GO TO 70
545 *
546 60 CONTINUE
547 ANORM = RTUNFL*N*ULPINV
548 GO TO 70
549 *
550 70 CONTINUE
551 *
552 CALL SLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
553 IINFO = 0
554 COND = ULPINV
555 *
556 * Special Matrices
557 *
558 IF( ITYPE.EQ.1 ) THEN
559 *
560 * Zero
561 *
562 IINFO = 0
563 *
564 ELSE IF( ITYPE.EQ.2 ) THEN
565 *
566 * Identity
567 *
568 DO 80 JCOL = 1, N
569 A( JCOL, JCOL ) = ANORM
570 80 CONTINUE
571 *
572 ELSE IF( ITYPE.EQ.3 ) THEN
573 *
574 * Jordan Block
575 *
576 DO 90 JCOL = 1, N
577 A( JCOL, JCOL ) = ANORM
578 IF( JCOL.GT.1 )
579 $ A( JCOL, JCOL-1 ) = ONE
580 90 CONTINUE
581 *
582 ELSE IF( ITYPE.EQ.4 ) THEN
583 *
584 * Diagonal Matrix, [Eigen]values Specified
585 *
586 CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
587 $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
588 $ IINFO )
589 *
590 ELSE IF( ITYPE.EQ.5 ) THEN
591 *
592 * Symmetric, eigenvalues specified
593 *
594 CALL SLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
595 $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
596 $ IINFO )
597 *
598 ELSE IF( ITYPE.EQ.6 ) THEN
599 *
600 * General, eigenvalues specified
601 *
602 IF( KCONDS( JTYPE ).EQ.1 ) THEN
603 CONDS = ONE
604 ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
605 CONDS = RTULPI
606 ELSE
607 CONDS = ZERO
608 END IF
609 *
610 ADUMMA( 1 ) = ' '
611 CALL SLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
612 $ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
613 $ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
614 $ IINFO )
615 *
616 ELSE IF( ITYPE.EQ.7 ) THEN
617 *
618 * Diagonal, random eigenvalues
619 *
620 CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
621 $ 'T', 'N', WORK( N+1 ), 1, ONE,
622 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
623 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
624 *
625 ELSE IF( ITYPE.EQ.8 ) THEN
626 *
627 * Symmetric, random eigenvalues
628 *
629 CALL SLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
630 $ 'T', 'N', WORK( N+1 ), 1, ONE,
631 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
632 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
633 *
634 ELSE IF( ITYPE.EQ.9 ) THEN
635 *
636 * General, random eigenvalues
637 *
638 CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
639 $ 'T', 'N', WORK( N+1 ), 1, ONE,
640 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
641 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
642 *
643 ELSE IF( ITYPE.EQ.10 ) THEN
644 *
645 * Triangular, random eigenvalues
646 *
647 CALL SLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
648 $ 'T', 'N', WORK( N+1 ), 1, ONE,
649 $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
650 $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
651 *
652 ELSE
653 *
654 IINFO = 1
655 END IF
656 *
657 IF( IINFO.NE.0 ) THEN
658 WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
659 $ IOLDSD
660 INFO = ABS( IINFO )
661 RETURN
662 END IF
663 *
664 100 CONTINUE
665 *
666 * Call SGEHRD to compute H and U, do tests.
667 *
668 CALL SLACPY( ' ', N, N, A, LDA, H, LDA )
669 *
670 NTEST = 1
671 *
672 ILO = 1
673 IHI = N
674 *
675 CALL SGEHRD( N, ILO, IHI, H, LDA, WORK, WORK( N+1 ),
676 $ NWORK-N, IINFO )
677 *
678 IF( IINFO.NE.0 ) THEN
679 RESULT( 1 ) = ULPINV
680 WRITE( NOUNIT, FMT = 9999 )'SGEHRD', IINFO, N, JTYPE,
681 $ IOLDSD
682 INFO = ABS( IINFO )
683 GO TO 250
684 END IF
685 *
686 DO 120 J = 1, N - 1
687 UU( J+1, J ) = ZERO
688 DO 110 I = J + 2, N
689 U( I, J ) = H( I, J )
690 UU( I, J ) = H( I, J )
691 H( I, J ) = ZERO
692 110 CONTINUE
693 120 CONTINUE
694 CALL SCOPY( N-1, WORK, 1, TAU, 1 )
695 CALL SORGHR( N, ILO, IHI, U, LDU, WORK, WORK( N+1 ),
696 $ NWORK-N, IINFO )
697 NTEST = 2
698 *
699 CALL SHST01( N, ILO, IHI, A, LDA, H, LDA, U, LDU, WORK,
700 $ NWORK, RESULT( 1 ) )
701 *
702 * Call SHSEQR to compute T1, T2 and Z, do tests.
703 *
704 * Eigenvalues only (WR3,WI3)
705 *
706 CALL SLACPY( ' ', N, N, H, LDA, T2, LDA )
707 NTEST = 3
708 RESULT( 3 ) = ULPINV
709 *
710 CALL SHSEQR( 'E', 'N', N, ILO, IHI, T2, LDA, WR3, WI3, UZ,
711 $ LDU, WORK, NWORK, IINFO )
712 IF( IINFO.NE.0 ) THEN
713 WRITE( NOUNIT, FMT = 9999 )'SHSEQR(E)', IINFO, N, JTYPE,
714 $ IOLDSD
715 IF( IINFO.LE.N+2 ) THEN
716 INFO = ABS( IINFO )
717 GO TO 250
718 END IF
719 END IF
720 *
721 * Eigenvalues (WR1,WI1) and Full Schur Form (T2)
722 *
723 CALL SLACPY( ' ', N, N, H, LDA, T2, LDA )
724 *
725 CALL SHSEQR( 'S', 'N', N, ILO, IHI, T2, LDA, WR1, WI1, UZ,
726 $ LDU, WORK, NWORK, IINFO )
727 IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
728 WRITE( NOUNIT, FMT = 9999 )'SHSEQR(S)', IINFO, N, JTYPE,
729 $ IOLDSD
730 INFO = ABS( IINFO )
731 GO TO 250
732 END IF
733 *
734 * Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors
735 * (UZ)
736 *
737 CALL SLACPY( ' ', N, N, H, LDA, T1, LDA )
738 CALL SLACPY( ' ', N, N, U, LDU, UZ, LDA )
739 *
740 CALL SHSEQR( 'S', 'V', N, ILO, IHI, T1, LDA, WR1, WI1, UZ,
741 $ LDU, WORK, NWORK, IINFO )
742 IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
743 WRITE( NOUNIT, FMT = 9999 )'SHSEQR(V)', IINFO, N, JTYPE,
744 $ IOLDSD
745 INFO = ABS( IINFO )
746 GO TO 250
747 END IF
748 *
749 * Compute Z = U' UZ
750 *
751 CALL SGEMM( 'T', 'N', N, N, N, ONE, U, LDU, UZ, LDU, ZERO,
752 $ Z, LDU )
753 NTEST = 8
754 *
755 * Do Tests 3: | H - Z T Z' | / ( |H| n ulp )
756 * and 4: | I - Z Z' | / ( n ulp )
757 *
758 CALL SHST01( N, ILO, IHI, H, LDA, T1, LDA, Z, LDU, WORK,
759 $ NWORK, RESULT( 3 ) )
760 *
761 * Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp )
762 * and 6: | I - UZ (UZ)' | / ( n ulp )
763 *
764 CALL SHST01( N, ILO, IHI, A, LDA, T1, LDA, UZ, LDU, WORK,
765 $ NWORK, RESULT( 5 ) )
766 *
767 * Do Test 7: | T2 - T1 | / ( |T| n ulp )
768 *
769 CALL SGET10( N, N, T2, LDA, T1, LDA, WORK, RESULT( 7 ) )
770 *
771 * Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp )
772 *
773 TEMP1 = ZERO
774 TEMP2 = ZERO
775 DO 130 J = 1, N
776 TEMP1 = MAX( TEMP1, ABS( WR1( J ) )+ABS( WI1( J ) ),
777 $ ABS( WR3( J ) )+ABS( WI3( J ) ) )
778 TEMP2 = MAX( TEMP2, ABS( WR1( J )-WR3( J ) )+
779 $ ABS( WR1( J )-WR3( J ) ) )
780 130 CONTINUE
781 *
782 RESULT( 8 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
783 *
784 * Compute the Left and Right Eigenvectors of T
785 *
786 * Compute the Right eigenvector Matrix:
787 *
788 NTEST = 9
789 RESULT( 9 ) = ULPINV
790 *
791 * Select last max(N/4,1) real, max(N/4,1) complex eigenvectors
792 *
793 NSELC = 0
794 NSELR = 0
795 J = N
796 140 CONTINUE
797 IF( WI1( J ).EQ.ZERO ) THEN
798 IF( NSELR.LT.MAX( N / 4, 1 ) ) THEN
799 NSELR = NSELR + 1
800 SELECT( J ) = .TRUE.
801 ELSE
802 SELECT( J ) = .FALSE.
803 END IF
804 J = J - 1
805 ELSE
806 IF( NSELC.LT.MAX( N / 4, 1 ) ) THEN
807 NSELC = NSELC + 1
808 SELECT( J ) = .TRUE.
809 SELECT( J-1 ) = .FALSE.
810 ELSE
811 SELECT( J ) = .FALSE.
812 SELECT( J-1 ) = .FALSE.
813 END IF
814 J = J - 2
815 END IF
816 IF( J.GT.0 )
817 $ GO TO 140
818 *
819 CALL STREVC( 'Right', 'All', SELECT, N, T1, LDA, DUMMA, LDU,
820 $ EVECTR, LDU, N, IN, WORK, IINFO )
821 IF( IINFO.NE.0 ) THEN
822 WRITE( NOUNIT, FMT = 9999 )'STREVC(R,A)', IINFO, N,
823 $ JTYPE, IOLDSD
824 INFO = ABS( IINFO )
825 GO TO 250
826 END IF
827 *
828 * Test 9: | TR - RW | / ( |T| |R| ulp )
829 *
830 CALL SGET22( 'N', 'N', 'N', N, T1, LDA, EVECTR, LDU, WR1,
831 $ WI1, WORK, DUMMA( 1 ) )
832 RESULT( 9 ) = DUMMA( 1 )
833 IF( DUMMA( 2 ).GT.THRESH ) THEN
834 WRITE( NOUNIT, FMT = 9998 )'Right', 'STREVC',
835 $ DUMMA( 2 ), N, JTYPE, IOLDSD
836 END IF
837 *
838 * Compute selected right eigenvectors and confirm that
839 * they agree with previous right eigenvectors
840 *
841 CALL STREVC( 'Right', 'Some', SELECT, N, T1, LDA, DUMMA,
842 $ LDU, EVECTL, LDU, N, IN, WORK, IINFO )
843 IF( IINFO.NE.0 ) THEN
844 WRITE( NOUNIT, FMT = 9999 )'STREVC(R,S)', IINFO, N,
845 $ JTYPE, IOLDSD
846 INFO = ABS( IINFO )
847 GO TO 250
848 END IF
849 *
850 K = 1
851 MATCH = .TRUE.
852 DO 170 J = 1, N
853 IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
854 DO 150 JJ = 1, N
855 IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) ) THEN
856 MATCH = .FALSE.
857 GO TO 180
858 END IF
859 150 CONTINUE
860 K = K + 1
861 ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
862 DO 160 JJ = 1, N
863 IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) .OR.
864 $ EVECTR( JJ, J+1 ).NE.EVECTL( JJ, K+1 ) ) THEN
865 MATCH = .FALSE.
866 GO TO 180
867 END IF
868 160 CONTINUE
869 K = K + 2
870 END IF
871 170 CONTINUE
872 180 CONTINUE
873 IF( .NOT.MATCH )
874 $ WRITE( NOUNIT, FMT = 9997 )'Right', 'STREVC', N, JTYPE,
875 $ IOLDSD
876 *
877 * Compute the Left eigenvector Matrix:
878 *
879 NTEST = 10
880 RESULT( 10 ) = ULPINV
881 CALL STREVC( 'Left', 'All', SELECT, N, T1, LDA, EVECTL, LDU,
882 $ DUMMA, LDU, N, IN, WORK, IINFO )
883 IF( IINFO.NE.0 ) THEN
884 WRITE( NOUNIT, FMT = 9999 )'STREVC(L,A)', IINFO, N,
885 $ JTYPE, IOLDSD
886 INFO = ABS( IINFO )
887 GO TO 250
888 END IF
889 *
890 * Test 10: | LT - WL | / ( |T| |L| ulp )
891 *
892 CALL SGET22( 'Trans', 'N', 'Conj', N, T1, LDA, EVECTL, LDU,
893 $ WR1, WI1, WORK, DUMMA( 3 ) )
894 RESULT( 10 ) = DUMMA( 3 )
895 IF( DUMMA( 4 ).GT.THRESH ) THEN
896 WRITE( NOUNIT, FMT = 9998 )'Left', 'STREVC', DUMMA( 4 ),
897 $ N, JTYPE, IOLDSD
898 END IF
899 *
900 * Compute selected left eigenvectors and confirm that
901 * they agree with previous left eigenvectors
902 *
903 CALL STREVC( 'Left', 'Some', SELECT, N, T1, LDA, EVECTR,
904 $ LDU, DUMMA, LDU, N, IN, WORK, IINFO )
905 IF( IINFO.NE.0 ) THEN
906 WRITE( NOUNIT, FMT = 9999 )'STREVC(L,S)', IINFO, N,
907 $ JTYPE, IOLDSD
908 INFO = ABS( IINFO )
909 GO TO 250
910 END IF
911 *
912 K = 1
913 MATCH = .TRUE.
914 DO 210 J = 1, N
915 IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
916 DO 190 JJ = 1, N
917 IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) ) THEN
918 MATCH = .FALSE.
919 GO TO 220
920 END IF
921 190 CONTINUE
922 K = K + 1
923 ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
924 DO 200 JJ = 1, N
925 IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) .OR.
926 $ EVECTL( JJ, J+1 ).NE.EVECTR( JJ, K+1 ) ) THEN
927 MATCH = .FALSE.
928 GO TO 220
929 END IF
930 200 CONTINUE
931 K = K + 2
932 END IF
933 210 CONTINUE
934 220 CONTINUE
935 IF( .NOT.MATCH )
936 $ WRITE( NOUNIT, FMT = 9997 )'Left', 'STREVC', N, JTYPE,
937 $ IOLDSD
938 *
939 * Call SHSEIN for Right eigenvectors of H, do test 11
940 *
941 NTEST = 11
942 RESULT( 11 ) = ULPINV
943 DO 230 J = 1, N
944 SELECT( J ) = .TRUE.
945 230 CONTINUE
946 *
947 CALL SHSEIN( 'Right', 'Qr', 'Ninitv', SELECT, N, H, LDA,
948 $ WR3, WI3, DUMMA, LDU, EVECTX, LDU, N1, IN,
949 $ WORK, IWORK, IWORK, IINFO )
950 IF( IINFO.NE.0 ) THEN
951 WRITE( NOUNIT, FMT = 9999 )'SHSEIN(R)', IINFO, N, JTYPE,
952 $ IOLDSD
953 INFO = ABS( IINFO )
954 IF( IINFO.LT.0 )
955 $ GO TO 250
956 ELSE
957 *
958 * Test 11: | HX - XW | / ( |H| |X| ulp )
959 *
960 * (from inverse iteration)
961 *
962 CALL SGET22( 'N', 'N', 'N', N, H, LDA, EVECTX, LDU, WR3,
963 $ WI3, WORK, DUMMA( 1 ) )
964 IF( DUMMA( 1 ).LT.ULPINV )
965 $ RESULT( 11 ) = DUMMA( 1 )*ANINV
966 IF( DUMMA( 2 ).GT.THRESH ) THEN
967 WRITE( NOUNIT, FMT = 9998 )'Right', 'SHSEIN',
968 $ DUMMA( 2 ), N, JTYPE, IOLDSD
969 END IF
970 END IF
971 *
972 * Call SHSEIN for Left eigenvectors of H, do test 12
973 *
974 NTEST = 12
975 RESULT( 12 ) = ULPINV
976 DO 240 J = 1, N
977 SELECT( J ) = .TRUE.
978 240 CONTINUE
979 *
980 CALL SHSEIN( 'Left', 'Qr', 'Ninitv', SELECT, N, H, LDA, WR3,
981 $ WI3, EVECTY, LDU, DUMMA, LDU, N1, IN, WORK,
982 $ IWORK, IWORK, IINFO )
983 IF( IINFO.NE.0 ) THEN
984 WRITE( NOUNIT, FMT = 9999 )'SHSEIN(L)', IINFO, N, JTYPE,
985 $ IOLDSD
986 INFO = ABS( IINFO )
987 IF( IINFO.LT.0 )
988 $ GO TO 250
989 ELSE
990 *
991 * Test 12: | YH - WY | / ( |H| |Y| ulp )
992 *
993 * (from inverse iteration)
994 *
995 CALL SGET22( 'C', 'N', 'C', N, H, LDA, EVECTY, LDU, WR3,
996 $ WI3, WORK, DUMMA( 3 ) )
997 IF( DUMMA( 3 ).LT.ULPINV )
998 $ RESULT( 12 ) = DUMMA( 3 )*ANINV
999 IF( DUMMA( 4 ).GT.THRESH ) THEN
1000 WRITE( NOUNIT, FMT = 9998 )'Left', 'SHSEIN',
1001 $ DUMMA( 4 ), N, JTYPE, IOLDSD
1002 END IF
1003 END IF
1004 *
1005 * Call SORMHR for Right eigenvectors of A, do test 13
1006 *
1007 NTEST = 13
1008 RESULT( 13 ) = ULPINV
1009 *
1010 CALL SORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
1011 $ LDU, TAU, EVECTX, LDU, WORK, NWORK, IINFO )
1012 IF( IINFO.NE.0 ) THEN
1013 WRITE( NOUNIT, FMT = 9999 )'SORMHR(R)', IINFO, N, JTYPE,
1014 $ IOLDSD
1015 INFO = ABS( IINFO )
1016 IF( IINFO.LT.0 )
1017 $ GO TO 250
1018 ELSE
1019 *
1020 * Test 13: | AX - XW | / ( |A| |X| ulp )
1021 *
1022 * (from inverse iteration)
1023 *
1024 CALL SGET22( 'N', 'N', 'N', N, A, LDA, EVECTX, LDU, WR3,
1025 $ WI3, WORK, DUMMA( 1 ) )
1026 IF( DUMMA( 1 ).LT.ULPINV )
1027 $ RESULT( 13 ) = DUMMA( 1 )*ANINV
1028 END IF
1029 *
1030 * Call SORMHR for Left eigenvectors of A, do test 14
1031 *
1032 NTEST = 14
1033 RESULT( 14 ) = ULPINV
1034 *
1035 CALL SORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
1036 $ LDU, TAU, EVECTY, LDU, WORK, NWORK, IINFO )
1037 IF( IINFO.NE.0 ) THEN
1038 WRITE( NOUNIT, FMT = 9999 )'SORMHR(L)', IINFO, N, JTYPE,
1039 $ IOLDSD
1040 INFO = ABS( IINFO )
1041 IF( IINFO.LT.0 )
1042 $ GO TO 250
1043 ELSE
1044 *
1045 * Test 14: | YA - WY | / ( |A| |Y| ulp )
1046 *
1047 * (from inverse iteration)
1048 *
1049 CALL SGET22( 'C', 'N', 'C', N, A, LDA, EVECTY, LDU, WR3,
1050 $ WI3, WORK, DUMMA( 3 ) )
1051 IF( DUMMA( 3 ).LT.ULPINV )
1052 $ RESULT( 14 ) = DUMMA( 3 )*ANINV
1053 END IF
1054 *
1055 * End of Loop -- Check for RESULT(j) > THRESH
1056 *
1057 250 CONTINUE
1058 *
1059 NTESTT = NTESTT + NTEST
1060 CALL SLAFTS( 'SHS', N, N, JTYPE, NTEST, RESULT, IOLDSD,
1061 $ THRESH, NOUNIT, NERRS )
1062 *
1063 260 CONTINUE
1064 270 CONTINUE
1065 *
1066 * Summary
1067 *
1068 CALL SLASUM( 'SHS', NOUNIT, NERRS, NTESTT )
1069 *
1070 RETURN
1071 *
1072 9999 FORMAT( ' SCHKHS: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
1073 $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
1074 9998 FORMAT( ' SCHKHS: ', A, ' Eigenvectors from ', A, ' incorrectly ',
1075 $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
1076 $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
1077 $ ')' )
1078 9997 FORMAT( ' SCHKHS: Selected ', A, ' Eigenvectors from ', A,
1079 $ ' do not match other eigenvectors ', 9X, 'N=', I6,
1080 $ ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
1081 *
1082 * End of SCHKHS
1083 *
1084 END