LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
zchkst.f
Go to the documentation of this file.
1*> \brief \b ZCHKST
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8* Definition:
9* ===========
10*
11* SUBROUTINE ZCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
12* NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5,
13* WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK,
14* LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT,
15* INFO )
16*
17* .. Scalar Arguments ..
18* INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT,
19* $ NSIZES, NTYPES
20* DOUBLE PRECISION THRESH
21* ..
22* .. Array Arguments ..
23* LOGICAL DOTYPE( * )
24* INTEGER ISEED( 4 ), IWORK( * ), NN( * )
25* DOUBLE PRECISION D1( * ), D2( * ), D3( * ), D4( * ), D5( * ),
26* $ RESULT( * ), RWORK( * ), SD( * ), SE( * ),
27* $ WA1( * ), WA2( * ), WA3( * ), WR( * )
28* COMPLEX*16 A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ),
29* $ V( LDU, * ), VP( * ), WORK( * ), Z( LDU, * )
30* ..
31*
32*
33*> \par Purpose:
34* =============
35*>
36*> \verbatim
37*>
38*> ZCHKST checks the Hermitian eigenvalue problem routines.
39*>
40*> ZHETRD factors A as U S U* , where * means conjugate transpose,
41*> S is real symmetric tridiagonal, and U is unitary.
42*> ZHETRD can use either just the lower or just the upper triangle
43*> of A; ZCHKST checks both cases.
44*> U is represented as a product of Householder
45*> transformations, whose vectors are stored in the first
46*> n-1 columns of V, and whose scale factors are in TAU.
47*>
48*> ZHPTRD does the same as ZHETRD, except that A and V are stored
49*> in "packed" format.
50*>
51*> ZUNGTR constructs the matrix U from the contents of V and TAU.
52*>
53*> ZUPGTR constructs the matrix U from the contents of VP and TAU.
54*>
55*> ZSTEQR factors S as Z D1 Z* , where Z is the unitary
56*> matrix of eigenvectors and D1 is a diagonal matrix with
57*> the eigenvalues on the diagonal. D2 is the matrix of
58*> eigenvalues computed when Z is not computed.
59*>
60*> DSTERF computes D3, the matrix of eigenvalues, by the
61*> PWK method, which does not yield eigenvectors.
62*>
63*> ZPTEQR factors S as Z4 D4 Z4* , for a
64*> Hermitian positive definite tridiagonal matrix.
65*> D5 is the matrix of eigenvalues computed when Z is not
66*> computed.
67*>
68*> DSTEBZ computes selected eigenvalues. WA1, WA2, and
69*> WA3 will denote eigenvalues computed to high
70*> absolute accuracy, with different range options.
71*> WR will denote eigenvalues computed to high relative
72*> accuracy.
73*>
74*> ZSTEIN computes Y, the eigenvectors of S, given the
75*> eigenvalues.
76*>
77*> ZSTEDC factors S as Z D1 Z* , where Z is the unitary
78*> matrix of eigenvectors and D1 is a diagonal matrix with
79*> the eigenvalues on the diagonal ('I' option). It may also
80*> update an input unitary matrix, usually the output
81*> from ZHETRD/ZUNGTR or ZHPTRD/ZUPGTR ('V' option). It may
82*> also just compute eigenvalues ('N' option).
83*>
84*> ZSTEMR factors S as Z D1 Z* , where Z is the unitary
85*> matrix of eigenvectors and D1 is a diagonal matrix with
86*> the eigenvalues on the diagonal ('I' option). ZSTEMR
87*> uses the Relatively Robust Representation whenever possible.
88*>
89*> When ZCHKST is called, a number of matrix "sizes" ("n's") and a
90*> number of matrix "types" are specified. For each size ("n")
91*> and each type of matrix, one matrix will be generated and used
92*> to test the Hermitian eigenroutines. For each matrix, a number
93*> of tests will be performed:
94*>
95*> (1) | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='U', ... )
96*>
97*> (2) | I - UV* | / ( n ulp ) ZUNGTR( UPLO='U', ... )
98*>
99*> (3) | A - V S V* | / ( |A| n ulp ) ZHETRD( UPLO='L', ... )
100*>
101*> (4) | I - UV* | / ( n ulp ) ZUNGTR( UPLO='L', ... )
102*>
103*> (5-8) Same as 1-4, but for ZHPTRD and ZUPGTR.
104*>
105*> (9) | S - Z D Z* | / ( |S| n ulp ) ZSTEQR('V',...)
106*>
107*> (10) | I - ZZ* | / ( n ulp ) ZSTEQR('V',...)
108*>
109*> (11) | D1 - D2 | / ( |D1| ulp ) ZSTEQR('N',...)
110*>
111*> (12) | D1 - D3 | / ( |D1| ulp ) DSTERF
112*>
113*> (13) 0 if the true eigenvalues (computed by sturm count)
114*> of S are within THRESH of
115*> those in D1. 2*THRESH if they are not. (Tested using
116*> DSTECH)
117*>
118*> For S positive definite,
119*>
120*> (14) | S - Z4 D4 Z4* | / ( |S| n ulp ) ZPTEQR('V',...)
121*>
122*> (15) | I - Z4 Z4* | / ( n ulp ) ZPTEQR('V',...)
123*>
124*> (16) | D4 - D5 | / ( 100 |D4| ulp ) ZPTEQR('N',...)
125*>
126*> When S is also diagonally dominant by the factor gamma < 1,
127*>
128*> (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) ,
129*> i
130*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
131*> DSTEBZ( 'A', 'E', ...)
132*>
133*> (18) | WA1 - D3 | / ( |D3| ulp ) DSTEBZ( 'A', 'E', ...)
134*>
135*> (19) ( max { min | WA2(i)-WA3(j) | } +
136*> i j
137*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
138*> i j
139*> DSTEBZ( 'I', 'E', ...)
140*>
141*> (20) | S - Y WA1 Y* | / ( |S| n ulp ) DSTEBZ, ZSTEIN
142*>
143*> (21) | I - Y Y* | / ( n ulp ) DSTEBZ, ZSTEIN
144*>
145*> (22) | S - Z D Z* | / ( |S| n ulp ) ZSTEDC('I')
146*>
147*> (23) | I - ZZ* | / ( n ulp ) ZSTEDC('I')
148*>
149*> (24) | S - Z D Z* | / ( |S| n ulp ) ZSTEDC('V')
150*>
151*> (25) | I - ZZ* | / ( n ulp ) ZSTEDC('V')
152*>
153*> (26) | D1 - D2 | / ( |D1| ulp ) ZSTEDC('V') and
154*> ZSTEDC('N')
155*>
156*> Test 27 is disabled at the moment because ZSTEMR does not
157*> guarantee high relatvie accuracy.
158*>
159*> (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
160*> i
161*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
162*> ZSTEMR('V', 'A')
163*>
164*> (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
165*> i
166*> omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
167*> ZSTEMR('V', 'I')
168*>
169*> Tests 29 through 34 are disable at present because ZSTEMR
170*> does not handle partial spectrum requests.
171*>
172*> (29) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'I')
173*>
174*> (30) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'I')
175*>
176*> (31) ( max { min | WA2(i)-WA3(j) | } +
177*> i j
178*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
179*> i j
180*> ZSTEMR('N', 'I') vs. CSTEMR('V', 'I')
181*>
182*> (32) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'V')
183*>
184*> (33) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'V')
185*>
186*> (34) ( max { min | WA2(i)-WA3(j) | } +
187*> i j
188*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
189*> i j
190*> ZSTEMR('N', 'V') vs. CSTEMR('V', 'V')
191*>
192*> (35) | S - Z D Z* | / ( |S| n ulp ) ZSTEMR('V', 'A')
193*>
194*> (36) | I - ZZ* | / ( n ulp ) ZSTEMR('V', 'A')
195*>
196*> (37) ( max { min | WA2(i)-WA3(j) | } +
197*> i j
198*> max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
199*> i j
200*> ZSTEMR('N', 'A') vs. CSTEMR('V', 'A')
201*>
202*> The "sizes" are specified by an array NN(1:NSIZES); the value of
203*> each element NN(j) specifies one size.
204*> The "types" are specified by a logical array DOTYPE( 1:NTYPES );
205*> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
206*> Currently, the list of possible types is:
207*>
208*> (1) The zero matrix.
209*> (2) The identity matrix.
210*>
211*> (3) A diagonal matrix with evenly spaced entries
212*> 1, ..., ULP and random signs.
213*> (ULP = (first number larger than 1) - 1 )
214*> (4) A diagonal matrix with geometrically spaced entries
215*> 1, ..., ULP and random signs.
216*> (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
217*> and random signs.
218*>
219*> (6) Same as (4), but multiplied by SQRT( overflow threshold )
220*> (7) Same as (4), but multiplied by SQRT( underflow threshold )
221*>
222*> (8) A matrix of the form U* D U, where U is unitary and
223*> D has evenly spaced entries 1, ..., ULP with random signs
224*> on the diagonal.
225*>
226*> (9) A matrix of the form U* D U, where U is unitary and
227*> D has geometrically spaced entries 1, ..., ULP with random
228*> signs on the diagonal.
229*>
230*> (10) A matrix of the form U* D U, where U is unitary and
231*> D has "clustered" entries 1, ULP,..., ULP with random
232*> signs on the diagonal.
233*>
234*> (11) Same as (8), but multiplied by SQRT( overflow threshold )
235*> (12) Same as (8), but multiplied by SQRT( underflow threshold )
236*>
237*> (13) Hermitian matrix with random entries chosen from (-1,1).
238*> (14) Same as (13), but multiplied by SQRT( overflow threshold )
239*> (15) Same as (13), but multiplied by SQRT( underflow threshold )
240*> (16) Same as (8), but diagonal elements are all positive.
241*> (17) Same as (9), but diagonal elements are all positive.
242*> (18) Same as (10), but diagonal elements are all positive.
243*> (19) Same as (16), but multiplied by SQRT( overflow threshold )
244*> (20) Same as (16), but multiplied by SQRT( underflow threshold )
245*> (21) A diagonally dominant tridiagonal matrix with geometrically
246*> spaced diagonal entries 1, ..., ULP.
247*> \endverbatim
248*
249* Arguments:
250* ==========
251*
252*> \param[in] NSIZES
253*> \verbatim
254*> NSIZES is INTEGER
255*> The number of sizes of matrices to use. If it is zero,
256*> ZCHKST does nothing. It must be at least zero.
257*> \endverbatim
258*>
259*> \param[in] NN
260*> \verbatim
261*> NN is INTEGER array, dimension (NSIZES)
262*> An array containing the sizes to be used for the matrices.
263*> Zero values will be skipped. The values must be at least
264*> zero.
265*> \endverbatim
266*>
267*> \param[in] NTYPES
268*> \verbatim
269*> NTYPES is INTEGER
270*> The number of elements in DOTYPE. If it is zero, ZCHKST
271*> does nothing. It must be at least zero. If it is MAXTYP+1
272*> and NSIZES is 1, then an additional type, MAXTYP+1 is
273*> defined, which is to use whatever matrix is in A. This
274*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
275*> DOTYPE(MAXTYP+1) is .TRUE. .
276*> \endverbatim
277*>
278*> \param[in] DOTYPE
279*> \verbatim
280*> DOTYPE is LOGICAL array, dimension (NTYPES)
281*> If DOTYPE(j) is .TRUE., then for each size in NN a
282*> matrix of that size and of type j will be generated.
283*> If NTYPES is smaller than the maximum number of types
284*> defined (PARAMETER MAXTYP), then types NTYPES+1 through
285*> MAXTYP will not be generated. If NTYPES is larger
286*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
287*> will be ignored.
288*> \endverbatim
289*>
290*> \param[in,out] ISEED
291*> \verbatim
292*> ISEED is INTEGER array, dimension (4)
293*> On entry ISEED specifies the seed of the random number
294*> generator. The array elements should be between 0 and 4095;
295*> if not they will be reduced mod 4096. Also, ISEED(4) must
296*> be odd. The random number generator uses a linear
297*> congruential sequence limited to small integers, and so
298*> should produce machine independent random numbers. The
299*> values of ISEED are changed on exit, and can be used in the
300*> next call to ZCHKST to continue the same random number
301*> sequence.
302*> \endverbatim
303*>
304*> \param[in] THRESH
305*> \verbatim
306*> THRESH is DOUBLE PRECISION
307*> A test will count as "failed" if the "error", computed as
308*> described above, exceeds THRESH. Note that the error
309*> is scaled to be O(1), so THRESH should be a reasonably
310*> small multiple of 1, e.g., 10 or 100. In particular,
311*> it should not depend on the precision (single vs. double)
312*> or the size of the matrix. It must be at least zero.
313*> \endverbatim
314*>
315*> \param[in] NOUNIT
316*> \verbatim
317*> NOUNIT is INTEGER
318*> The FORTRAN unit number for printing out error messages
319*> (e.g., if a routine returns IINFO not equal to 0.)
320*> \endverbatim
321*>
322*> \param[in,out] A
323*> \verbatim
324*> A is COMPLEX*16 array of
325*> dimension ( LDA , max(NN) )
326*> Used to hold the matrix whose eigenvalues are to be
327*> computed. On exit, A contains the last matrix actually
328*> used.
329*> \endverbatim
330*>
331*> \param[in] LDA
332*> \verbatim
333*> LDA is INTEGER
334*> The leading dimension of A. It must be at
335*> least 1 and at least max( NN ).
336*> \endverbatim
337*>
338*> \param[out] AP
339*> \verbatim
340*> AP is COMPLEX*16 array of
341*> dimension( max(NN)*max(NN+1)/2 )
342*> The matrix A stored in packed format.
343*> \endverbatim
344*>
345*> \param[out] SD
346*> \verbatim
347*> SD is DOUBLE PRECISION array of
348*> dimension( max(NN) )
349*> The diagonal of the tridiagonal matrix computed by ZHETRD.
350*> On exit, SD and SE contain the tridiagonal form of the
351*> matrix in A.
352*> \endverbatim
353*>
354*> \param[out] SE
355*> \verbatim
356*> SE is DOUBLE PRECISION array of
357*> dimension( max(NN) )
358*> The off-diagonal of the tridiagonal matrix computed by
359*> ZHETRD. On exit, SD and SE contain the tridiagonal form of
360*> the matrix in A.
361*> \endverbatim
362*>
363*> \param[out] D1
364*> \verbatim
365*> D1 is DOUBLE PRECISION array of
366*> dimension( max(NN) )
367*> The eigenvalues of A, as computed by ZSTEQR simultaneously
368*> with Z. On exit, the eigenvalues in D1 correspond with the
369*> matrix in A.
370*> \endverbatim
371*>
372*> \param[out] D2
373*> \verbatim
374*> D2 is DOUBLE PRECISION array of
375*> dimension( max(NN) )
376*> The eigenvalues of A, as computed by ZSTEQR if Z is not
377*> computed. On exit, the eigenvalues in D2 correspond with
378*> the matrix in A.
379*> \endverbatim
380*>
381*> \param[out] D3
382*> \verbatim
383*> D3 is DOUBLE PRECISION array of
384*> dimension( max(NN) )
385*> The eigenvalues of A, as computed by DSTERF. On exit, the
386*> eigenvalues in D3 correspond with the matrix in A.
387*> \endverbatim
388*>
389*> \param[out] D4
390*> \verbatim
391*> D4 is DOUBLE PRECISION array of
392*> dimension( max(NN) )
393*> The eigenvalues of A, as computed by ZPTEQR(V).
394*> ZPTEQR factors S as Z4 D4 Z4*
395*> On exit, the eigenvalues in D4 correspond with the matrix in A.
396*> \endverbatim
397*>
398*> \param[out] D5
399*> \verbatim
400*> D5 is DOUBLE PRECISION array of
401*> dimension( max(NN) )
402*> The eigenvalues of A, as computed by ZPTEQR(N)
403*> when Z is not computed. On exit, the
404*> eigenvalues in D4 correspond with the matrix in A.
405*> \endverbatim
406*>
407*> \param[out] WA1
408*> \verbatim
409*> WA1 is DOUBLE PRECISION array of
410*> dimension( max(NN) )
411*> All eigenvalues of A, computed to high
412*> absolute accuracy, with different range options.
413*> as computed by DSTEBZ.
414*> \endverbatim
415*>
416*> \param[out] WA2
417*> \verbatim
418*> WA2 is DOUBLE PRECISION array of
419*> dimension( max(NN) )
420*> Selected eigenvalues of A, computed to high
421*> absolute accuracy, with different range options.
422*> as computed by DSTEBZ.
423*> Choose random values for IL and IU, and ask for the
424*> IL-th through IU-th eigenvalues.
425*> \endverbatim
426*>
427*> \param[out] WA3
428*> \verbatim
429*> WA3 is DOUBLE PRECISION array of
430*> dimension( max(NN) )
431*> Selected eigenvalues of A, computed to high
432*> absolute accuracy, with different range options.
433*> as computed by DSTEBZ.
434*> Determine the values VL and VU of the IL-th and IU-th
435*> eigenvalues and ask for all eigenvalues in this range.
436*> \endverbatim
437*>
438*> \param[out] WR
439*> \verbatim
440*> WR is DOUBLE PRECISION array of
441*> dimension( max(NN) )
442*> All eigenvalues of A, computed to high
443*> absolute accuracy, with different options.
444*> as computed by DSTEBZ.
445*> \endverbatim
446*>
447*> \param[out] U
448*> \verbatim
449*> U is COMPLEX*16 array of
450*> dimension( LDU, max(NN) ).
451*> The unitary matrix computed by ZHETRD + ZUNGTR.
452*> \endverbatim
453*>
454*> \param[in] LDU
455*> \verbatim
456*> LDU is INTEGER
457*> The leading dimension of U, Z, and V. It must be at least 1
458*> and at least max( NN ).
459*> \endverbatim
460*>
461*> \param[out] V
462*> \verbatim
463*> V is COMPLEX*16 array of
464*> dimension( LDU, max(NN) ).
465*> The Housholder vectors computed by ZHETRD in reducing A to
466*> tridiagonal form. The vectors computed with UPLO='U' are
467*> in the upper triangle, and the vectors computed with UPLO='L'
468*> are in the lower triangle. (As described in ZHETRD, the
469*> sub- and superdiagonal are not set to 1, although the
470*> true Householder vector has a 1 in that position. The
471*> routines that use V, such as ZUNGTR, set those entries to
472*> 1 before using them, and then restore them later.)
473*> \endverbatim
474*>
475*> \param[out] VP
476*> \verbatim
477*> VP is COMPLEX*16 array of
478*> dimension( max(NN)*max(NN+1)/2 )
479*> The matrix V stored in packed format.
480*> \endverbatim
481*>
482*> \param[out] TAU
483*> \verbatim
484*> TAU is COMPLEX*16 array of
485*> dimension( max(NN) )
486*> The Householder factors computed by ZHETRD in reducing A
487*> to tridiagonal form.
488*> \endverbatim
489*>
490*> \param[out] Z
491*> \verbatim
492*> Z is COMPLEX*16 array of
493*> dimension( LDU, max(NN) ).
494*> The unitary matrix of eigenvectors computed by ZSTEQR,
495*> ZPTEQR, and ZSTEIN.
496*> \endverbatim
497*>
498*> \param[out] WORK
499*> \verbatim
500*> WORK is COMPLEX*16 array of
501*> dimension( LWORK )
502*> \endverbatim
503*>
504*> \param[in] LWORK
505*> \verbatim
506*> LWORK is INTEGER
507*> The number of entries in WORK. This must be at least
508*> 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2
509*> where Nmax = max( NN(j), 2 ) and lg = log base 2.
510*> \endverbatim
511*>
512*> \param[out] IWORK
513*> \verbatim
514*> IWORK is INTEGER array,
515*> Workspace.
516*> \endverbatim
517*>
518*> \param[out] LIWORK
519*> \verbatim
520*> LIWORK is INTEGER
521*> The number of entries in IWORK. This must be at least
522*> 6 + 6*Nmax + 5 * Nmax * lg Nmax
523*> where Nmax = max( NN(j), 2 ) and lg = log base 2.
524*> \endverbatim
525*>
526*> \param[out] RWORK
527*> \verbatim
528*> RWORK is DOUBLE PRECISION array
529*> \endverbatim
530*>
531*> \param[in] LRWORK
532*> \verbatim
533*> LRWORK is INTEGER
534*> The number of entries in LRWORK (dimension( ??? )
535*> \endverbatim
536*>
537*> \param[out] RESULT
538*> \verbatim
539*> RESULT is DOUBLE PRECISION array, dimension (26)
540*> The values computed by the tests described above.
541*> The values are currently limited to 1/ulp, to avoid
542*> overflow.
543*> \endverbatim
544*>
545*> \param[out] INFO
546*> \verbatim
547*> INFO is INTEGER
548*> If 0, then everything ran OK.
549*> -1: NSIZES < 0
550*> -2: Some NN(j) < 0
551*> -3: NTYPES < 0
552*> -5: THRESH < 0
553*> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
554*> -23: LDU < 1 or LDU < NMAX.
555*> -29: LWORK too small.
556*> If ZLATMR, CLATMS, ZHETRD, ZUNGTR, ZSTEQR, DSTERF,
557*> or ZUNMC2 returns an error code, the
558*> absolute value of it is returned.
559*>
560*>-----------------------------------------------------------------------
561*>
562*> Some Local Variables and Parameters:
563*> ---- ----- --------- --- ----------
564*> ZERO, ONE Real 0 and 1.
565*> MAXTYP The number of types defined.
566*> NTEST The number of tests performed, or which can
567*> be performed so far, for the current matrix.
568*> NTESTT The total number of tests performed so far.
569*> NBLOCK Blocksize as returned by ENVIR.
570*> NMAX Largest value in NN.
571*> NMATS The number of matrices generated so far.
572*> NERRS The number of tests which have exceeded THRESH
573*> so far.
574*> COND, IMODE Values to be passed to the matrix generators.
575*> ANORM Norm of A; passed to matrix generators.
576*>
577*> OVFL, UNFL Overflow and underflow thresholds.
578*> ULP, ULPINV Finest relative precision and its inverse.
579*> RTOVFL, RTUNFL Square roots of the previous 2 values.
580*> The following four arrays decode JTYPE:
581*> KTYPE(j) The general type (1-10) for type "j".
582*> KMODE(j) The MODE value to be passed to the matrix
583*> generator for type "j".
584*> KMAGN(j) The order of magnitude ( O(1),
585*> O(overflow^(1/2) ), O(underflow^(1/2) )
586*> \endverbatim
587*
588* Authors:
589* ========
590*
591*> \author Univ. of Tennessee
592*> \author Univ. of California Berkeley
593*> \author Univ. of Colorado Denver
594*> \author NAG Ltd.
595*
596*> \ingroup complex16_eig
597*
598* =====================================================================
599 SUBROUTINE zchkst( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
600 $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5,
601 $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK,
602 $ LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT,
603 $ INFO )
604*
605* -- LAPACK test routine --
606* -- LAPACK is a software package provided by Univ. of Tennessee, --
607* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
608*
609* .. Scalar Arguments ..
610 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT,
611 $ NSIZES, NTYPES
612 DOUBLE PRECISION THRESH
613* ..
614* .. Array Arguments ..
615 LOGICAL DOTYPE( * )
616 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
617 DOUBLE PRECISION D1( * ), D2( * ), D3( * ), D4( * ), D5( * ),
618 $ RESULT( * ), RWORK( * ), SD( * ), SE( * ),
619 $ wa1( * ), wa2( * ), wa3( * ), wr( * )
620 COMPLEX*16 A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ),
621 $ v( ldu, * ), vp( * ), work( * ), z( ldu, * )
622* ..
623*
624* =====================================================================
625*
626* .. Parameters ..
627 DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN
628 PARAMETER ( ZERO = 0.0d0, one = 1.0d0, two = 2.0d0,
629 $ eight = 8.0d0, ten = 10.0d0, hun = 100.0d0 )
630 COMPLEX*16 CZERO, CONE
631 parameter( czero = ( 0.0d+0, 0.0d+0 ),
632 $ cone = ( 1.0d+0, 0.0d+0 ) )
633 DOUBLE PRECISION HALF
634 parameter( half = one / two )
635 INTEGER MAXTYP
636 PARAMETER ( MAXTYP = 21 )
637 LOGICAL CRANGE
638 parameter( crange = .false. )
639 LOGICAL CREL
640 parameter( crel = .false. )
641* ..
642* .. Local Scalars ..
643 LOGICAL BADNN, TRYRAC
644 INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP,
645 $ ITYPE, IU, J, JC, JR, JSIZE, JTYPE, LGN,
646 $ LIWEDC, LOG2UI, LRWEDC, LWEDC, M, M2, M3,
647 $ mtypes, n, nap, nblock, nerrs, nmats, nmax,
648 $ nsplit, ntest, ntestt
649 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
650 $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP,
651 $ ULPINV, UNFL, VL, VU
652* ..
653* .. Local Arrays ..
654 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
655 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
656 $ KTYPE( MAXTYP )
657 DOUBLE PRECISION DUMMA( 1 )
658* ..
659* .. External Functions ..
660 INTEGER ILAENV
661 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
662 EXTERNAL ILAENV, DLAMCH, DLARND, DSXT1
663* ..
664* .. External Subroutines ..
665 EXTERNAL dcopy, dlasum, dstebz, dstech, dsterf, xerbla,
666 $ zcopy, zhet21, zhetrd, zhpt21, zhptrd, zlacpy,
667 $ zlaset, zlatmr, zlatms, zpteqr, zstedc, zstemr,
668 $ zstein, zsteqr, zstt21, zstt22, zungtr, zupgtr
669* ..
670* .. Intrinsic Functions ..
671 INTRINSIC abs, dble, dconjg, int, log, max, min, sqrt
672* ..
673* .. Data statements ..
674 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
675 $ 8, 8, 9, 9, 9, 9, 9, 10 /
676 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
677 $ 2, 3, 1, 1, 1, 2, 3, 1 /
678 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
679 $ 0, 0, 4, 3, 1, 4, 4, 3 /
680* ..
681* .. Executable Statements ..
682*
683* Keep ftnchek happy
684 idumma( 1 ) = 1
685*
686* Check for errors
687*
688 ntestt = 0
689 info = 0
690*
691* Important constants
692*
693 badnn = .false.
694 tryrac = .true.
695 nmax = 1
696 DO 10 j = 1, nsizes
697 nmax = max( nmax, nn( j ) )
698 IF( nn( j ).LT.0 )
699 $ badnn = .true.
700 10 CONTINUE
701*
702 nblock = ilaenv( 1, 'ZHETRD', 'L', nmax, -1, -1, -1 )
703 nblock = min( nmax, max( 1, nblock ) )
704*
705* Check for errors
706*
707 IF( nsizes.LT.0 ) THEN
708 info = -1
709 ELSE IF( badnn ) THEN
710 info = -2
711 ELSE IF( ntypes.LT.0 ) THEN
712 info = -3
713 ELSE IF( lda.LT.nmax ) THEN
714 info = -9
715 ELSE IF( ldu.LT.nmax ) THEN
716 info = -23
717 ELSE IF( 2*max( 2, nmax )**2.GT.lwork ) THEN
718 info = -29
719 END IF
720*
721 IF( info.NE.0 ) THEN
722 CALL xerbla( 'ZCHKST', -info )
723 RETURN
724 END IF
725*
726* Quick return if possible
727*
728 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
729 $ RETURN
730*
731* More Important constants
732*
733 unfl = dlamch( 'Safe minimum' )
734 ovfl = one / unfl
735 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
736 ulpinv = one / ulp
737 log2ui = int( log( ulpinv ) / log( two ) )
738 rtunfl = sqrt( unfl )
739 rtovfl = sqrt( ovfl )
740*
741* Loop over sizes, types
742*
743 DO 20 i = 1, 4
744 iseed2( i ) = iseed( i )
745 20 CONTINUE
746 nerrs = 0
747 nmats = 0
748*
749 DO 310 jsize = 1, nsizes
750 n = nn( jsize )
751 IF( n.GT.0 ) THEN
752 lgn = int( log( dble( n ) ) / log( two ) )
753 IF( 2**lgn.LT.n )
754 $ lgn = lgn + 1
755 IF( 2**lgn.LT.n )
756 $ lgn = lgn + 1
757 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
758 lrwedc = 1 + 3*n + 2*n*lgn + 4*n**2
759 liwedc = 6 + 6*n + 5*n*lgn
760 ELSE
761 lwedc = 8
762 lrwedc = 7
763 liwedc = 12
764 END IF
765 nap = ( n*( n+1 ) ) / 2
766 aninv = one / dble( max( 1, n ) )
767*
768 IF( nsizes.NE.1 ) THEN
769 mtypes = min( maxtyp, ntypes )
770 ELSE
771 mtypes = min( maxtyp+1, ntypes )
772 END IF
773*
774 DO 300 jtype = 1, mtypes
775 IF( .NOT.dotype( jtype ) )
776 $ GO TO 300
777 nmats = nmats + 1
778 ntest = 0
779*
780 DO 30 j = 1, 4
781 ioldsd( j ) = iseed( j )
782 30 CONTINUE
783*
784* Compute "A"
785*
786* Control parameters:
787*
788* KMAGN KMODE KTYPE
789* =1 O(1) clustered 1 zero
790* =2 large clustered 2 identity
791* =3 small exponential (none)
792* =4 arithmetic diagonal, (w/ eigenvalues)
793* =5 random log Hermitian, w/ eigenvalues
794* =6 random (none)
795* =7 random diagonal
796* =8 random Hermitian
797* =9 positive definite
798* =10 diagonally dominant tridiagonal
799*
800 IF( mtypes.GT.maxtyp )
801 $ GO TO 100
802*
803 itype = ktype( jtype )
804 imode = kmode( jtype )
805*
806* Compute norm
807*
808 GO TO ( 40, 50, 60 )kmagn( jtype )
809*
810 40 CONTINUE
811 anorm = one
812 GO TO 70
813*
814 50 CONTINUE
815 anorm = ( rtovfl*ulp )*aninv
816 GO TO 70
817*
818 60 CONTINUE
819 anorm = rtunfl*n*ulpinv
820 GO TO 70
821*
822 70 CONTINUE
823*
824 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
825 iinfo = 0
826 IF( jtype.LE.15 ) THEN
827 cond = ulpinv
828 ELSE
829 cond = ulpinv*aninv / ten
830 END IF
831*
832* Special Matrices -- Identity & Jordan block
833*
834* Zero
835*
836 IF( itype.EQ.1 ) THEN
837 iinfo = 0
838*
839 ELSE IF( itype.EQ.2 ) THEN
840*
841* Identity
842*
843 DO 80 jc = 1, n
844 a( jc, jc ) = anorm
845 80 CONTINUE
846*
847 ELSE IF( itype.EQ.4 ) THEN
848*
849* Diagonal Matrix, [Eigen]values Specified
850*
851 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
852 $ anorm, 0, 0, 'N', a, lda, work, iinfo )
853*
854*
855 ELSE IF( itype.EQ.5 ) THEN
856*
857* Hermitian, eigenvalues specified
858*
859 CALL zlatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
860 $ anorm, n, n, 'N', a, lda, work, iinfo )
861*
862 ELSE IF( itype.EQ.7 ) THEN
863*
864* Diagonal, random eigenvalues
865*
866 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
867 $ 'T', 'N', work( n+1 ), 1, one,
868 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
869 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
870*
871 ELSE IF( itype.EQ.8 ) THEN
872*
873* Hermitian, random eigenvalues
874*
875 CALL zlatmr( n, n, 'S', iseed, 'H', work, 6, one, cone,
876 $ 'T', 'N', work( n+1 ), 1, one,
877 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
878 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
879*
880 ELSE IF( itype.EQ.9 ) THEN
881*
882* Positive definite, eigenvalues specified.
883*
884 CALL zlatms( n, n, 'S', iseed, 'P', rwork, imode, cond,
885 $ anorm, n, n, 'N', a, lda, work, iinfo )
886*
887 ELSE IF( itype.EQ.10 ) THEN
888*
889* Positive definite tridiagonal, eigenvalues specified.
890*
891 CALL zlatms( n, n, 'S', iseed, 'P', rwork, imode, cond,
892 $ anorm, 1, 1, 'N', a, lda, work, iinfo )
893 DO 90 i = 2, n
894 temp1 = abs( a( i-1, i ) )
895 temp2 = sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
896 IF( temp1.GT.half*temp2 ) THEN
897 a( i-1, i ) = a( i-1, i )*
898 $ ( half*temp2 / ( unfl+temp1 ) )
899 a( i, i-1 ) = dconjg( a( i-1, i ) )
900 END IF
901 90 CONTINUE
902*
903 ELSE
904*
905 iinfo = 1
906 END IF
907*
908 IF( iinfo.NE.0 ) THEN
909 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
910 $ ioldsd
911 info = abs( iinfo )
912 RETURN
913 END IF
914*
915 100 CONTINUE
916*
917* Call ZHETRD and ZUNGTR to compute S and U from
918* upper triangle.
919*
920 CALL zlacpy( 'U', n, n, a, lda, v, ldu )
921*
922 ntest = 1
923 CALL zhetrd( 'U', n, v, ldu, sd, se, tau, work, lwork,
924 $ iinfo )
925*
926 IF( iinfo.NE.0 ) THEN
927 WRITE( nounit, fmt = 9999 )'ZHETRD(U)', iinfo, n, jtype,
928 $ ioldsd
929 info = abs( iinfo )
930 IF( iinfo.LT.0 ) THEN
931 RETURN
932 ELSE
933 result( 1 ) = ulpinv
934 GO TO 280
935 END IF
936 END IF
937*
938 CALL zlacpy( 'U', n, n, v, ldu, u, ldu )
939*
940 ntest = 2
941 CALL zungtr( 'U', n, u, ldu, tau, work, lwork, iinfo )
942 IF( iinfo.NE.0 ) THEN
943 WRITE( nounit, fmt = 9999 )'ZUNGTR(U)', iinfo, n, jtype,
944 $ ioldsd
945 info = abs( iinfo )
946 IF( iinfo.LT.0 ) THEN
947 RETURN
948 ELSE
949 result( 2 ) = ulpinv
950 GO TO 280
951 END IF
952 END IF
953*
954* Do tests 1 and 2
955*
956 CALL zhet21( 2, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
957 $ ldu, tau, work, rwork, result( 1 ) )
958 CALL zhet21( 3, 'Upper', n, 1, a, lda, sd, se, u, ldu, v,
959 $ ldu, tau, work, rwork, result( 2 ) )
960*
961* Call ZHETRD and ZUNGTR to compute S and U from
962* lower triangle, do tests.
963*
964 CALL zlacpy( 'L', n, n, a, lda, v, ldu )
965*
966 ntest = 3
967 CALL zhetrd( 'L', n, v, ldu, sd, se, tau, work, lwork,
968 $ iinfo )
969*
970 IF( iinfo.NE.0 ) THEN
971 WRITE( nounit, fmt = 9999 )'ZHETRD(L)', iinfo, n, jtype,
972 $ ioldsd
973 info = abs( iinfo )
974 IF( iinfo.LT.0 ) THEN
975 RETURN
976 ELSE
977 result( 3 ) = ulpinv
978 GO TO 280
979 END IF
980 END IF
981*
982 CALL zlacpy( 'L', n, n, v, ldu, u, ldu )
983*
984 ntest = 4
985 CALL zungtr( 'L', n, u, ldu, tau, work, lwork, iinfo )
986 IF( iinfo.NE.0 ) THEN
987 WRITE( nounit, fmt = 9999 )'ZUNGTR(L)', iinfo, n, jtype,
988 $ ioldsd
989 info = abs( iinfo )
990 IF( iinfo.LT.0 ) THEN
991 RETURN
992 ELSE
993 result( 4 ) = ulpinv
994 GO TO 280
995 END IF
996 END IF
997*
998 CALL zhet21( 2, 'Lower', n, 1, a, lda, sd, se, u, ldu, v,
999 $ ldu, tau, work, rwork, result( 3 ) )
1000 CALL zhet21( 3, 'Lower', n, 1, a, lda, sd, se, u, ldu, v,
1001 $ ldu, tau, work, rwork, result( 4 ) )
1002*
1003* Store the upper triangle of A in AP
1004*
1005 i = 0
1006 DO 120 jc = 1, n
1007 DO 110 jr = 1, jc
1008 i = i + 1
1009 ap( i ) = a( jr, jc )
1010 110 CONTINUE
1011 120 CONTINUE
1012*
1013* Call ZHPTRD and ZUPGTR to compute S and U from AP
1014*
1015 CALL zcopy( nap, ap, 1, vp, 1 )
1016*
1017 ntest = 5
1018 CALL zhptrd( 'U', n, vp, sd, se, tau, iinfo )
1019*
1020 IF( iinfo.NE.0 ) THEN
1021 WRITE( nounit, fmt = 9999 )'ZHPTRD(U)', iinfo, n, jtype,
1022 $ ioldsd
1023 info = abs( iinfo )
1024 IF( iinfo.LT.0 ) THEN
1025 RETURN
1026 ELSE
1027 result( 5 ) = ulpinv
1028 GO TO 280
1029 END IF
1030 END IF
1031*
1032 ntest = 6
1033 CALL zupgtr( 'U', n, vp, tau, u, ldu, work, iinfo )
1034 IF( iinfo.NE.0 ) THEN
1035 WRITE( nounit, fmt = 9999 )'ZUPGTR(U)', iinfo, n, jtype,
1036 $ ioldsd
1037 info = abs( iinfo )
1038 IF( iinfo.LT.0 ) THEN
1039 RETURN
1040 ELSE
1041 result( 6 ) = ulpinv
1042 GO TO 280
1043 END IF
1044 END IF
1045*
1046* Do tests 5 and 6
1047*
1048 CALL zhpt21( 2, 'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1049 $ work, rwork, result( 5 ) )
1050 CALL zhpt21( 3, 'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1051 $ work, rwork, result( 6 ) )
1052*
1053* Store the lower triangle of A in AP
1054*
1055 i = 0
1056 DO 140 jc = 1, n
1057 DO 130 jr = jc, n
1058 i = i + 1
1059 ap( i ) = a( jr, jc )
1060 130 CONTINUE
1061 140 CONTINUE
1062*
1063* Call ZHPTRD and ZUPGTR to compute S and U from AP
1064*
1065 CALL zcopy( nap, ap, 1, vp, 1 )
1066*
1067 ntest = 7
1068 CALL zhptrd( 'L', n, vp, sd, se, tau, iinfo )
1069*
1070 IF( iinfo.NE.0 ) THEN
1071 WRITE( nounit, fmt = 9999 )'ZHPTRD(L)', iinfo, n, jtype,
1072 $ ioldsd
1073 info = abs( iinfo )
1074 IF( iinfo.LT.0 ) THEN
1075 RETURN
1076 ELSE
1077 result( 7 ) = ulpinv
1078 GO TO 280
1079 END IF
1080 END IF
1081*
1082 ntest = 8
1083 CALL zupgtr( 'L', n, vp, tau, u, ldu, work, iinfo )
1084 IF( iinfo.NE.0 ) THEN
1085 WRITE( nounit, fmt = 9999 )'ZUPGTR(L)', iinfo, n, jtype,
1086 $ ioldsd
1087 info = abs( iinfo )
1088 IF( iinfo.LT.0 ) THEN
1089 RETURN
1090 ELSE
1091 result( 8 ) = ulpinv
1092 GO TO 280
1093 END IF
1094 END IF
1095*
1096 CALL zhpt21( 2, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1097 $ work, rwork, result( 7 ) )
1098 CALL zhpt21( 3, 'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1099 $ work, rwork, result( 8 ) )
1100*
1101* Call ZSTEQR to compute D1, D2, and Z, do tests.
1102*
1103* Compute D1 and Z
1104*
1105 CALL dcopy( n, sd, 1, d1, 1 )
1106 IF( n.GT.0 )
1107 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1108 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1109*
1110 ntest = 9
1111 CALL zsteqr( 'V', n, d1, rwork, z, ldu, rwork( n+1 ),
1112 $ iinfo )
1113 IF( iinfo.NE.0 ) THEN
1114 WRITE( nounit, fmt = 9999 )'ZSTEQR(V)', iinfo, n, jtype,
1115 $ ioldsd
1116 info = abs( iinfo )
1117 IF( iinfo.LT.0 ) THEN
1118 RETURN
1119 ELSE
1120 result( 9 ) = ulpinv
1121 GO TO 280
1122 END IF
1123 END IF
1124*
1125* Compute D2
1126*
1127 CALL dcopy( n, sd, 1, d2, 1 )
1128 IF( n.GT.0 )
1129 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1130*
1131 ntest = 11
1132 CALL zsteqr( 'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1133 $ iinfo )
1134 IF( iinfo.NE.0 ) THEN
1135 WRITE( nounit, fmt = 9999 )'ZSTEQR(N)', iinfo, n, jtype,
1136 $ ioldsd
1137 info = abs( iinfo )
1138 IF( iinfo.LT.0 ) THEN
1139 RETURN
1140 ELSE
1141 result( 11 ) = ulpinv
1142 GO TO 280
1143 END IF
1144 END IF
1145*
1146* Compute D3 (using PWK method)
1147*
1148 CALL dcopy( n, sd, 1, d3, 1 )
1149 IF( n.GT.0 )
1150 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1151*
1152 ntest = 12
1153 CALL dsterf( n, d3, rwork, iinfo )
1154 IF( iinfo.NE.0 ) THEN
1155 WRITE( nounit, fmt = 9999 )'DSTERF', iinfo, n, jtype,
1156 $ ioldsd
1157 info = abs( iinfo )
1158 IF( iinfo.LT.0 ) THEN
1159 RETURN
1160 ELSE
1161 result( 12 ) = ulpinv
1162 GO TO 280
1163 END IF
1164 END IF
1165*
1166* Do Tests 9 and 10
1167*
1168 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1169 $ result( 9 ) )
1170*
1171* Do Tests 11 and 12
1172*
1173 temp1 = zero
1174 temp2 = zero
1175 temp3 = zero
1176 temp4 = zero
1177*
1178 DO 150 j = 1, n
1179 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1180 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1181 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1182 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1183 150 CONTINUE
1184*
1185 result( 11 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1186 result( 12 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1187*
1188* Do Test 13 -- Sturm Sequence Test of Eigenvalues
1189* Go up by factors of two until it succeeds
1190*
1191 ntest = 13
1192 temp1 = thresh*( half-ulp )
1193*
1194 DO 160 j = 0, log2ui
1195 CALL dstech( n, sd, se, d1, temp1, rwork, iinfo )
1196 IF( iinfo.EQ.0 )
1197 $ GO TO 170
1198 temp1 = temp1*two
1199 160 CONTINUE
1200*
1201 170 CONTINUE
1202 result( 13 ) = temp1
1203*
1204* For positive definite matrices ( JTYPE.GT.15 ) call ZPTEQR
1205* and do tests 14, 15, and 16 .
1206*
1207 IF( jtype.GT.15 ) THEN
1208*
1209* Compute D4 and Z4
1210*
1211 CALL dcopy( n, sd, 1, d4, 1 )
1212 IF( n.GT.0 )
1213 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1214 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1215*
1216 ntest = 14
1217 CALL zpteqr( 'V', n, d4, rwork, z, ldu, rwork( n+1 ),
1218 $ iinfo )
1219 IF( iinfo.NE.0 ) THEN
1220 WRITE( nounit, fmt = 9999 )'ZPTEQR(V)', iinfo, n,
1221 $ jtype, ioldsd
1222 info = abs( iinfo )
1223 IF( iinfo.LT.0 ) THEN
1224 RETURN
1225 ELSE
1226 result( 14 ) = ulpinv
1227 GO TO 280
1228 END IF
1229 END IF
1230*
1231* Do Tests 14 and 15
1232*
1233 CALL zstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1234 $ rwork, result( 14 ) )
1235*
1236* Compute D5
1237*
1238 CALL dcopy( n, sd, 1, d5, 1 )
1239 IF( n.GT.0 )
1240 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1241*
1242 ntest = 16
1243 CALL zpteqr( 'N', n, d5, rwork, z, ldu, rwork( n+1 ),
1244 $ iinfo )
1245 IF( iinfo.NE.0 ) THEN
1246 WRITE( nounit, fmt = 9999 )'ZPTEQR(N)', iinfo, n,
1247 $ jtype, ioldsd
1248 info = abs( iinfo )
1249 IF( iinfo.LT.0 ) THEN
1250 RETURN
1251 ELSE
1252 result( 16 ) = ulpinv
1253 GO TO 280
1254 END IF
1255 END IF
1256*
1257* Do Test 16
1258*
1259 temp1 = zero
1260 temp2 = zero
1261 DO 180 j = 1, n
1262 temp1 = max( temp1, abs( d4( j ) ), abs( d5( j ) ) )
1263 temp2 = max( temp2, abs( d4( j )-d5( j ) ) )
1264 180 CONTINUE
1265*
1266 result( 16 ) = temp2 / max( unfl,
1267 $ hun*ulp*max( temp1, temp2 ) )
1268 ELSE
1269 result( 14 ) = zero
1270 result( 15 ) = zero
1271 result( 16 ) = zero
1272 END IF
1273*
1274* Call DSTEBZ with different options and do tests 17-18.
1275*
1276* If S is positive definite and diagonally dominant,
1277* ask for all eigenvalues with high relative accuracy.
1278*
1279 vl = zero
1280 vu = zero
1281 il = 0
1282 iu = 0
1283 IF( jtype.EQ.21 ) THEN
1284 ntest = 17
1285 abstol = unfl + unfl
1286 CALL dstebz( 'A', 'E', n, vl, vu, il, iu, abstol, sd, se,
1287 $ m, nsplit, wr, iwork( 1 ), iwork( n+1 ),
1288 $ rwork, iwork( 2*n+1 ), iinfo )
1289 IF( iinfo.NE.0 ) THEN
1290 WRITE( nounit, fmt = 9999 )'DSTEBZ(A,rel)', iinfo, n,
1291 $ jtype, ioldsd
1292 info = abs( iinfo )
1293 IF( iinfo.LT.0 ) THEN
1294 RETURN
1295 ELSE
1296 result( 17 ) = ulpinv
1297 GO TO 280
1298 END IF
1299 END IF
1300*
1301* Do test 17
1302*
1303 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1304 $ ( one-half )**4
1305*
1306 temp1 = zero
1307 DO 190 j = 1, n
1308 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1309 $ ( abstol+abs( d4( j ) ) ) )
1310 190 CONTINUE
1311*
1312 result( 17 ) = temp1 / temp2
1313 ELSE
1314 result( 17 ) = zero
1315 END IF
1316*
1317* Now ask for all eigenvalues with high absolute accuracy.
1318*
1319 ntest = 18
1320 abstol = unfl + unfl
1321 CALL dstebz( 'A', 'E', n, vl, vu, il, iu, abstol, sd, se, m,
1322 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1323 $ iwork( 2*n+1 ), iinfo )
1324 IF( iinfo.NE.0 ) THEN
1325 WRITE( nounit, fmt = 9999 )'DSTEBZ(A)', iinfo, n, jtype,
1326 $ ioldsd
1327 info = abs( iinfo )
1328 IF( iinfo.LT.0 ) THEN
1329 RETURN
1330 ELSE
1331 result( 18 ) = ulpinv
1332 GO TO 280
1333 END IF
1334 END IF
1335*
1336* Do test 18
1337*
1338 temp1 = zero
1339 temp2 = zero
1340 DO 200 j = 1, n
1341 temp1 = max( temp1, abs( d3( j ) ), abs( wa1( j ) ) )
1342 temp2 = max( temp2, abs( d3( j )-wa1( j ) ) )
1343 200 CONTINUE
1344*
1345 result( 18 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1346*
1347* Choose random values for IL and IU, and ask for the
1348* IL-th through IU-th eigenvalues.
1349*
1350 ntest = 19
1351 IF( n.LE.1 ) THEN
1352 il = 1
1353 iu = n
1354 ELSE
1355 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1356 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1357 IF( iu.LT.il ) THEN
1358 itemp = iu
1359 iu = il
1360 il = itemp
1361 END IF
1362 END IF
1363*
1364 CALL dstebz( 'I', 'E', n, vl, vu, il, iu, abstol, sd, se,
1365 $ m2, nsplit, wa2, iwork( 1 ), iwork( n+1 ),
1366 $ rwork, iwork( 2*n+1 ), iinfo )
1367 IF( iinfo.NE.0 ) THEN
1368 WRITE( nounit, fmt = 9999 )'DSTEBZ(I)', iinfo, n, jtype,
1369 $ ioldsd
1370 info = abs( iinfo )
1371 IF( iinfo.LT.0 ) THEN
1372 RETURN
1373 ELSE
1374 result( 19 ) = ulpinv
1375 GO TO 280
1376 END IF
1377 END IF
1378*
1379* Determine the values VL and VU of the IL-th and IU-th
1380* eigenvalues and ask for all eigenvalues in this range.
1381*
1382 IF( n.GT.0 ) THEN
1383 IF( il.NE.1 ) THEN
1384 vl = wa1( il ) - max( half*( wa1( il )-wa1( il-1 ) ),
1385 $ ulp*anorm, two*rtunfl )
1386 ELSE
1387 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1388 $ ulp*anorm, two*rtunfl )
1389 END IF
1390 IF( iu.NE.n ) THEN
1391 vu = wa1( iu ) + max( half*( wa1( iu+1 )-wa1( iu ) ),
1392 $ ulp*anorm, two*rtunfl )
1393 ELSE
1394 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1395 $ ulp*anorm, two*rtunfl )
1396 END IF
1397 ELSE
1398 vl = zero
1399 vu = one
1400 END IF
1401*
1402 CALL dstebz( 'V', 'E', n, vl, vu, il, iu, abstol, sd, se,
1403 $ m3, nsplit, wa3, iwork( 1 ), iwork( n+1 ),
1404 $ rwork, iwork( 2*n+1 ), iinfo )
1405 IF( iinfo.NE.0 ) THEN
1406 WRITE( nounit, fmt = 9999 )'DSTEBZ(V)', iinfo, n, jtype,
1407 $ ioldsd
1408 info = abs( iinfo )
1409 IF( iinfo.LT.0 ) THEN
1410 RETURN
1411 ELSE
1412 result( 19 ) = ulpinv
1413 GO TO 280
1414 END IF
1415 END IF
1416*
1417 IF( m3.EQ.0 .AND. n.NE.0 ) THEN
1418 result( 19 ) = ulpinv
1419 GO TO 280
1420 END IF
1421*
1422* Do test 19
1423*
1424 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1425 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1426 IF( n.GT.0 ) THEN
1427 temp3 = max( abs( wa1( n ) ), abs( wa1( 1 ) ) )
1428 ELSE
1429 temp3 = zero
1430 END IF
1431*
1432 result( 19 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1433*
1434* Call ZSTEIN to compute eigenvectors corresponding to
1435* eigenvalues in WA1. (First call DSTEBZ again, to make sure
1436* it returns these eigenvalues in the correct order.)
1437*
1438 ntest = 21
1439 CALL dstebz( 'A', 'B', n, vl, vu, il, iu, abstol, sd, se, m,
1440 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1441 $ iwork( 2*n+1 ), iinfo )
1442 IF( iinfo.NE.0 ) THEN
1443 WRITE( nounit, fmt = 9999 )'DSTEBZ(A,B)', iinfo, n,
1444 $ jtype, ioldsd
1445 info = abs( iinfo )
1446 IF( iinfo.LT.0 ) THEN
1447 RETURN
1448 ELSE
1449 result( 20 ) = ulpinv
1450 result( 21 ) = ulpinv
1451 GO TO 280
1452 END IF
1453 END IF
1454*
1455 CALL zstein( n, sd, se, m, wa1, iwork( 1 ), iwork( n+1 ), z,
1456 $ ldu, rwork, iwork( 2*n+1 ), iwork( 3*n+1 ),
1457 $ iinfo )
1458 IF( iinfo.NE.0 ) THEN
1459 WRITE( nounit, fmt = 9999 )'ZSTEIN', iinfo, n, jtype,
1460 $ ioldsd
1461 info = abs( iinfo )
1462 IF( iinfo.LT.0 ) THEN
1463 RETURN
1464 ELSE
1465 result( 20 ) = ulpinv
1466 result( 21 ) = ulpinv
1467 GO TO 280
1468 END IF
1469 END IF
1470*
1471* Do tests 20 and 21
1472*
1473 CALL zstt21( n, 0, sd, se, wa1, dumma, z, ldu, work, rwork,
1474 $ result( 20 ) )
1475*
1476* Call ZSTEDC(I) to compute D1 and Z, do tests.
1477*
1478* Compute D1 and Z
1479*
1480 inde = 1
1481 indrwk = inde + n
1482 CALL dcopy( n, sd, 1, d1, 1 )
1483 IF( n.GT.0 )
1484 $ CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1485 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1486*
1487 ntest = 22
1488 CALL zstedc( 'I', n, d1, rwork( inde ), z, ldu, work, lwedc,
1489 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1490 IF( iinfo.NE.0 ) THEN
1491 WRITE( nounit, fmt = 9999 )'ZSTEDC(I)', iinfo, n, jtype,
1492 $ ioldsd
1493 info = abs( iinfo )
1494 IF( iinfo.LT.0 ) THEN
1495 RETURN
1496 ELSE
1497 result( 22 ) = ulpinv
1498 GO TO 280
1499 END IF
1500 END IF
1501*
1502* Do Tests 22 and 23
1503*
1504 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1505 $ result( 22 ) )
1506*
1507* Call ZSTEDC(V) to compute D1 and Z, do tests.
1508*
1509* Compute D1 and Z
1510*
1511 CALL dcopy( n, sd, 1, d1, 1 )
1512 IF( n.GT.0 )
1513 $ CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1514 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1515*
1516 ntest = 24
1517 CALL zstedc( 'V', n, d1, rwork( inde ), z, ldu, work, lwedc,
1518 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1519 IF( iinfo.NE.0 ) THEN
1520 WRITE( nounit, fmt = 9999 )'ZSTEDC(V)', iinfo, n, jtype,
1521 $ ioldsd
1522 info = abs( iinfo )
1523 IF( iinfo.LT.0 ) THEN
1524 RETURN
1525 ELSE
1526 result( 24 ) = ulpinv
1527 GO TO 280
1528 END IF
1529 END IF
1530*
1531* Do Tests 24 and 25
1532*
1533 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1534 $ result( 24 ) )
1535*
1536* Call ZSTEDC(N) to compute D2, do tests.
1537*
1538* Compute D2
1539*
1540 CALL dcopy( n, sd, 1, d2, 1 )
1541 IF( n.GT.0 )
1542 $ CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1543 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1544*
1545 ntest = 26
1546 CALL zstedc( 'N', n, d2, rwork( inde ), z, ldu, work, lwedc,
1547 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1548 IF( iinfo.NE.0 ) THEN
1549 WRITE( nounit, fmt = 9999 )'ZSTEDC(N)', iinfo, n, jtype,
1550 $ ioldsd
1551 info = abs( iinfo )
1552 IF( iinfo.LT.0 ) THEN
1553 RETURN
1554 ELSE
1555 result( 26 ) = ulpinv
1556 GO TO 280
1557 END IF
1558 END IF
1559*
1560* Do Test 26
1561*
1562 temp1 = zero
1563 temp2 = zero
1564*
1565 DO 210 j = 1, n
1566 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1567 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1568 210 CONTINUE
1569*
1570 result( 26 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1571*
1572* Only test ZSTEMR if IEEE compliant
1573*
1574 IF( ilaenv( 10, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1575 $ ilaenv( 11, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN
1576*
1577* Call ZSTEMR, do test 27 (relative eigenvalue accuracy)
1578*
1579* If S is positive definite and diagonally dominant,
1580* ask for all eigenvalues with high relative accuracy.
1581*
1582 vl = zero
1583 vu = zero
1584 il = 0
1585 iu = 0
1586 IF( jtype.EQ.21 .AND. crel ) THEN
1587 ntest = 27
1588 abstol = unfl + unfl
1589 CALL zstemr( 'V', 'A', n, sd, se, vl, vu, il, iu,
1590 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1591 $ rwork, lrwork, iwork( 2*n+1 ), lwork-2*n,
1592 $ iinfo )
1593 IF( iinfo.NE.0 ) THEN
1594 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,A,rel)',
1595 $ iinfo, n, jtype, ioldsd
1596 info = abs( iinfo )
1597 IF( iinfo.LT.0 ) THEN
1598 RETURN
1599 ELSE
1600 result( 27 ) = ulpinv
1601 GO TO 270
1602 END IF
1603 END IF
1604*
1605* Do test 27
1606*
1607 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1608 $ ( one-half )**4
1609*
1610 temp1 = zero
1611 DO 220 j = 1, n
1612 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1613 $ ( abstol+abs( d4( j ) ) ) )
1614 220 CONTINUE
1615*
1616 result( 27 ) = temp1 / temp2
1617*
1618 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1619 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1620 IF( iu.LT.il ) THEN
1621 itemp = iu
1622 iu = il
1623 il = itemp
1624 END IF
1625*
1626 IF( crange ) THEN
1627 ntest = 28
1628 abstol = unfl + unfl
1629 CALL zstemr( 'V', 'I', n, sd, se, vl, vu, il, iu,
1630 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1631 $ rwork, lrwork, iwork( 2*n+1 ),
1632 $ lwork-2*n, iinfo )
1633*
1634 IF( iinfo.NE.0 ) THEN
1635 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,I,rel)',
1636 $ iinfo, n, jtype, ioldsd
1637 info = abs( iinfo )
1638 IF( iinfo.LT.0 ) THEN
1639 RETURN
1640 ELSE
1641 result( 28 ) = ulpinv
1642 GO TO 270
1643 END IF
1644 END IF
1645*
1646*
1647* Do test 28
1648*
1649 temp2 = two*( two*n-one )*ulp*
1650 $ ( one+eight*half**2 ) / ( one-half )**4
1651*
1652 temp1 = zero
1653 DO 230 j = il, iu
1654 temp1 = max( temp1, abs( wr( j-il+1 )-d4( n-j+
1655 $ 1 ) ) / ( abstol+abs( wr( j-il+1 ) ) ) )
1656 230 CONTINUE
1657*
1658 result( 28 ) = temp1 / temp2
1659 ELSE
1660 result( 28 ) = zero
1661 END IF
1662 ELSE
1663 result( 27 ) = zero
1664 result( 28 ) = zero
1665 END IF
1666*
1667* Call ZSTEMR(V,I) to compute D1 and Z, do tests.
1668*
1669* Compute D1 and Z
1670*
1671 CALL dcopy( n, sd, 1, d5, 1 )
1672 IF( n.GT.0 )
1673 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1674 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1675*
1676 IF( crange ) THEN
1677 ntest = 29
1678 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1679 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1680 IF( iu.LT.il ) THEN
1681 itemp = iu
1682 iu = il
1683 il = itemp
1684 END IF
1685 CALL zstemr( 'V', 'I', n, d5, rwork, vl, vu, il, iu,
1686 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1687 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1688 $ liwork-2*n, iinfo )
1689 IF( iinfo.NE.0 ) THEN
1690 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,I)', iinfo,
1691 $ n, jtype, ioldsd
1692 info = abs( iinfo )
1693 IF( iinfo.LT.0 ) THEN
1694 RETURN
1695 ELSE
1696 result( 29 ) = ulpinv
1697 GO TO 280
1698 END IF
1699 END IF
1700*
1701* Do Tests 29 and 30
1702*
1703*
1704* Call ZSTEMR to compute D2, do tests.
1705*
1706* Compute D2
1707*
1708 CALL dcopy( n, sd, 1, d5, 1 )
1709 IF( n.GT.0 )
1710 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1711*
1712 ntest = 31
1713 CALL zstemr( 'N', 'I', n, d5, rwork, vl, vu, il, iu,
1714 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1715 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1716 $ liwork-2*n, iinfo )
1717 IF( iinfo.NE.0 ) THEN
1718 WRITE( nounit, fmt = 9999 )'ZSTEMR(N,I)', iinfo,
1719 $ n, jtype, ioldsd
1720 info = abs( iinfo )
1721 IF( iinfo.LT.0 ) THEN
1722 RETURN
1723 ELSE
1724 result( 31 ) = ulpinv
1725 GO TO 280
1726 END IF
1727 END IF
1728*
1729* Do Test 31
1730*
1731 temp1 = zero
1732 temp2 = zero
1733*
1734 DO 240 j = 1, iu - il + 1
1735 temp1 = max( temp1, abs( d1( j ) ),
1736 $ abs( d2( j ) ) )
1737 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1738 240 CONTINUE
1739*
1740 result( 31 ) = temp2 / max( unfl,
1741 $ ulp*max( temp1, temp2 ) )
1742*
1743*
1744* Call ZSTEMR(V,V) to compute D1 and Z, do tests.
1745*
1746* Compute D1 and Z
1747*
1748 CALL dcopy( n, sd, 1, d5, 1 )
1749 IF( n.GT.0 )
1750 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1751 CALL zlaset( 'Full', n, n, czero, cone, z, ldu )
1752*
1753 ntest = 32
1754*
1755 IF( n.GT.0 ) THEN
1756 IF( il.NE.1 ) THEN
1757 vl = d2( il ) - max( half*
1758 $ ( d2( il )-d2( il-1 ) ), ulp*anorm,
1759 $ two*rtunfl )
1760 ELSE
1761 vl = d2( 1 ) - max( half*( d2( n )-d2( 1 ) ),
1762 $ ulp*anorm, two*rtunfl )
1763 END IF
1764 IF( iu.NE.n ) THEN
1765 vu = d2( iu ) + max( half*
1766 $ ( d2( iu+1 )-d2( iu ) ), ulp*anorm,
1767 $ two*rtunfl )
1768 ELSE
1769 vu = d2( n ) + max( half*( d2( n )-d2( 1 ) ),
1770 $ ulp*anorm, two*rtunfl )
1771 END IF
1772 ELSE
1773 vl = zero
1774 vu = one
1775 END IF
1776*
1777 CALL zstemr( 'V', 'V', n, d5, rwork, vl, vu, il, iu,
1778 $ m, d1, z, ldu, m, iwork( 1 ), tryrac,
1779 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1780 $ liwork-2*n, iinfo )
1781 IF( iinfo.NE.0 ) THEN
1782 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,V)', iinfo,
1783 $ n, jtype, ioldsd
1784 info = abs( iinfo )
1785 IF( iinfo.LT.0 ) THEN
1786 RETURN
1787 ELSE
1788 result( 32 ) = ulpinv
1789 GO TO 280
1790 END IF
1791 END IF
1792*
1793* Do Tests 32 and 33
1794*
1795 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1796 $ m, rwork, result( 32 ) )
1797*
1798* Call ZSTEMR to compute D2, do tests.
1799*
1800* Compute D2
1801*
1802 CALL dcopy( n, sd, 1, d5, 1 )
1803 IF( n.GT.0 )
1804 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1805*
1806 ntest = 34
1807 CALL zstemr( 'N', 'V', n, d5, rwork, vl, vu, il, iu,
1808 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1809 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1810 $ liwork-2*n, iinfo )
1811 IF( iinfo.NE.0 ) THEN
1812 WRITE( nounit, fmt = 9999 )'ZSTEMR(N,V)', iinfo,
1813 $ n, jtype, ioldsd
1814 info = abs( iinfo )
1815 IF( iinfo.LT.0 ) THEN
1816 RETURN
1817 ELSE
1818 result( 34 ) = ulpinv
1819 GO TO 280
1820 END IF
1821 END IF
1822*
1823* Do Test 34
1824*
1825 temp1 = zero
1826 temp2 = zero
1827*
1828 DO 250 j = 1, iu - il + 1
1829 temp1 = max( temp1, abs( d1( j ) ),
1830 $ abs( d2( j ) ) )
1831 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1832 250 CONTINUE
1833*
1834 result( 34 ) = temp2 / max( unfl,
1835 $ ulp*max( temp1, temp2 ) )
1836 ELSE
1837 result( 29 ) = zero
1838 result( 30 ) = zero
1839 result( 31 ) = zero
1840 result( 32 ) = zero
1841 result( 33 ) = zero
1842 result( 34 ) = zero
1843 END IF
1844*
1845*
1846* Call ZSTEMR(V,A) to compute D1 and Z, do tests.
1847*
1848* Compute D1 and Z
1849*
1850 CALL dcopy( n, sd, 1, d5, 1 )
1851 IF( n.GT.0 )
1852 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1853*
1854 ntest = 35
1855*
1856 CALL zstemr( 'V', 'A', n, d5, rwork, vl, vu, il, iu,
1857 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1858 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1859 $ liwork-2*n, iinfo )
1860 IF( iinfo.NE.0 ) THEN
1861 WRITE( nounit, fmt = 9999 )'ZSTEMR(V,A)', iinfo, n,
1862 $ jtype, ioldsd
1863 info = abs( iinfo )
1864 IF( iinfo.LT.0 ) THEN
1865 RETURN
1866 ELSE
1867 result( 35 ) = ulpinv
1868 GO TO 280
1869 END IF
1870 END IF
1871*
1872* Do Tests 35 and 36
1873*
1874 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1875 $ rwork, result( 35 ) )
1876*
1877* Call ZSTEMR to compute D2, do tests.
1878*
1879* Compute D2
1880*
1881 CALL dcopy( n, sd, 1, d5, 1 )
1882 IF( n.GT.0 )
1883 $ CALL dcopy( n-1, se, 1, rwork, 1 )
1884*
1885 ntest = 37
1886 CALL zstemr( 'N', 'A', n, d5, rwork, vl, vu, il, iu,
1887 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1888 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1889 $ liwork-2*n, iinfo )
1890 IF( iinfo.NE.0 ) THEN
1891 WRITE( nounit, fmt = 9999 )'ZSTEMR(N,A)', iinfo, n,
1892 $ jtype, ioldsd
1893 info = abs( iinfo )
1894 IF( iinfo.LT.0 ) THEN
1895 RETURN
1896 ELSE
1897 result( 37 ) = ulpinv
1898 GO TO 280
1899 END IF
1900 END IF
1901*
1902* Do Test 34
1903*
1904 temp1 = zero
1905 temp2 = zero
1906*
1907 DO 260 j = 1, n
1908 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1909 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1910 260 CONTINUE
1911*
1912 result( 37 ) = temp2 / max( unfl,
1913 $ ulp*max( temp1, temp2 ) )
1914 END IF
1915 270 CONTINUE
1916 280 CONTINUE
1917 ntestt = ntestt + ntest
1918*
1919* End of Loop -- Check for RESULT(j) > THRESH
1920*
1921*
1922* Print out tests which fail.
1923*
1924 DO 290 jr = 1, ntest
1925 IF( result( jr ).GE.thresh ) THEN
1926*
1927* If this is the first test to fail,
1928* print a header to the data file.
1929*
1930 IF( nerrs.EQ.0 ) THEN
1931 WRITE( nounit, fmt = 9998 )'ZST'
1932 WRITE( nounit, fmt = 9997 )
1933 WRITE( nounit, fmt = 9996 )
1934 WRITE( nounit, fmt = 9995 )'Hermitian'
1935 WRITE( nounit, fmt = 9994 )
1936*
1937* Tests performed
1938*
1939 WRITE( nounit, fmt = 9987 )
1940 END IF
1941 nerrs = nerrs + 1
1942 IF( result( jr ).LT.10000.0d0 ) THEN
1943 WRITE( nounit, fmt = 9989 )n, jtype, ioldsd, jr,
1944 $ result( jr )
1945 ELSE
1946 WRITE( nounit, fmt = 9988 )n, jtype, ioldsd, jr,
1947 $ result( jr )
1948 END IF
1949 END IF
1950 290 CONTINUE
1951 300 CONTINUE
1952 310 CONTINUE
1953*
1954* Summary
1955*
1956 CALL dlasum( 'ZST', nounit, nerrs, ntestt )
1957 RETURN
1958*
1959 9999 FORMAT( ' ZCHKST: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1960 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1961*
1962 9998 FORMAT( / 1x, a3, ' -- Complex Hermitian eigenvalue problem' )
1963 9997 FORMAT( ' Matrix types (see ZCHKST for details): ' )
1964*
1965 9996 FORMAT( / ' Special Matrices:',
1966 $ / ' 1=Zero matrix. ',
1967 $ ' 5=Diagonal: clustered entries.',
1968 $ / ' 2=Identity matrix. ',
1969 $ ' 6=Diagonal: large, evenly spaced.',
1970 $ / ' 3=Diagonal: evenly spaced entries. ',
1971 $ ' 7=Diagonal: small, evenly spaced.',
1972 $ / ' 4=Diagonal: geometr. spaced entries.' )
1973 9995 FORMAT( ' Dense ', a, ' Matrices:',
1974 $ / ' 8=Evenly spaced eigenvals. ',
1975 $ ' 12=Small, evenly spaced eigenvals.',
1976 $ / ' 9=Geometrically spaced eigenvals. ',
1977 $ ' 13=Matrix with random O(1) entries.',
1978 $ / ' 10=Clustered eigenvalues. ',
1979 $ ' 14=Matrix with large random entries.',
1980 $ / ' 11=Large, evenly spaced eigenvals. ',
1981 $ ' 15=Matrix with small random entries.' )
1982 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues',
1983 $ / ' 17=Positive definite, geometrically spaced eigenvlaues',
1984 $ / ' 18=Positive definite, clustered eigenvalues',
1985 $ / ' 19=Positive definite, small evenly spaced eigenvalues',
1986 $ / ' 20=Positive definite, large evenly spaced eigenvalues',
1987 $ / ' 21=Diagonally dominant tridiagonal, geometrically',
1988 $ ' spaced eigenvalues' )
1989*
1990 9989 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
1991 $ 4( i4, ',' ), ' result ', i3, ' is', 0p, f8.2 )
1992 9988 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
1993 $ 4( i4, ',' ), ' result ', i3, ' is', 1p, d10.3 )
1994*
1995 9987 FORMAT( / 'Test performed: see ZCHKST for details.', / )
1996* End of ZCHKST
1997*
1998 END
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
dlasum
subroutine dlasum(type, iounit, ie, nrun)
DLASUM
Definition dlasum.f:43
dstech
subroutine dstech(n, a, b, eig, tol, work, info)
DSTECH
Definition dstech.f:101
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82
zhetrd
subroutine zhetrd(uplo, n, a, lda, d, e, tau, work, lwork, info)
ZHETRD
Definition zhetrd.f:192
zhptrd
subroutine zhptrd(uplo, n, ap, d, e, tau, info)
ZHPTRD
Definition zhptrd.f:151
zlacpy
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
Definition zlacpy.f:103
zlaset
subroutine zlaset(uplo, m, n, alpha, beta, a, lda)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition zlaset.f:106
zpteqr
subroutine zpteqr(compz, n, d, e, z, ldz, work, info)
ZPTEQR
Definition zpteqr.f:145
dstebz
subroutine dstebz(range, order, n, vl, vu, il, iu, abstol, d, e, m, nsplit, w, iblock, isplit, work, iwork, info)
DSTEBZ
Definition dstebz.f:273
zstedc
subroutine zstedc(compz, n, d, e, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZSTEDC
Definition zstedc.f:206
zstein
subroutine zstein(n, d, e, m, w, iblock, isplit, z, ldz, work, iwork, ifail, info)
ZSTEIN
Definition zstein.f:182
zstemr
subroutine zstemr(jobz, range, n, d, e, vl, vu, il, iu, m, w, z, ldz, nzc, isuppz, tryrac, work, lwork, iwork, liwork, info)
ZSTEMR
Definition zstemr.f:339
zsteqr
subroutine zsteqr(compz, n, d, e, z, ldz, work, info)
ZSTEQR
Definition zsteqr.f:132
dsterf
subroutine dsterf(n, d, e, info)
DSTERF
Definition dsterf.f:86
zungtr
subroutine zungtr(uplo, n, a, lda, tau, work, lwork, info)
ZUNGTR
Definition zungtr.f:123
zupgtr
subroutine zupgtr(uplo, n, ap, tau, q, ldq, work, info)
ZUPGTR
Definition zupgtr.f:114
zchkst
subroutine zchkst(nsizes, nn, ntypes, dotype, iseed, thresh, nounit, a, lda, ap, sd, se, d1, d2, d3, d4, d5, wa1, wa2, wa3, wr, u, ldu, v, vp, tau, z, work, lwork, rwork, lrwork, iwork, liwork, result, info)
ZCHKST
Definition zchkst.f:604
zhet21
subroutine zhet21(itype, uplo, n, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, rwork, result)
ZHET21
Definition zhet21.f:214
zhpt21
subroutine zhpt21(itype, uplo, n, kband, ap, d, e, u, ldu, vp, tau, work, rwork, result)
ZHPT21
Definition zhpt21.f:228
zlatmr
subroutine zlatmr(m, n, dist, iseed, sym, d, mode, cond, dmax, rsign, grade, dl, model, condl, dr, moder, condr, pivtng, ipivot, kl, ku, sparse, anorm, pack, a, lda, iwork, info)
ZLATMR
Definition zlatmr.f:490
zlatms
subroutine zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS
Definition zlatms.f:332
zstt21
subroutine zstt21(n, kband, ad, ae, sd, se, u, ldu, work, rwork, result)
ZSTT21
Definition zstt21.f:133
zstt22
subroutine zstt22(n, m, kband, ad, ae, sd, se, u, ldu, work, ldwork, rwork, result)
ZSTT22
Definition zstt22.f:145