LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
schkgg.f
Go to the documentation of this file.
1*> \brief \b SCHKGG
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 SCHKGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
12* TSTDIF, THRSHN, NOUNIT, A, LDA, B, H, T, S1,
13* S2, P1, P2, U, LDU, V, Q, Z, ALPHR1, ALPHI1,
14* BETA1, ALPHR3, ALPHI3, BETA3, EVECTL, EVECTR,
15* WORK, LWORK, LLWORK, RESULT, INFO )
16*
17* .. Scalar Arguments ..
18* LOGICAL TSTDIF
19* INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES
20* REAL THRESH, THRSHN
21* ..
22* .. Array Arguments ..
23* LOGICAL DOTYPE( * ), LLWORK( * )
24* INTEGER ISEED( 4 ), NN( * )
25* REAL A( LDA, * ), ALPHI1( * ), ALPHI3( * ),
26* $ ALPHR1( * ), ALPHR3( * ), B( LDA, * ),
27* $ BETA1( * ), BETA3( * ), EVECTL( LDU, * ),
28* $ EVECTR( LDU, * ), H( LDA, * ), P1( LDA, * ),
29* $ P2( LDA, * ), Q( LDU, * ), RESULT( 15 ),
30* $ S1( LDA, * ), S2( LDA, * ), T( LDA, * ),
31* $ U( LDU, * ), V( LDU, * ), WORK( * ),
32* $ Z( LDU, * )
33* ..
34*
35*
36*> \par Purpose:
37* =============
38*>
39*> \verbatim
40*>
41*> SCHKGG checks the nonsymmetric generalized eigenvalue problem
42*> routines.
43*> T T T
44*> SGGHRD factors A and B as U H V and U T V , where means
45*> transpose, H is hessenberg, T is triangular and U and V are
46*> orthogonal.
47*> T T
48*> SHGEQZ factors H and T as Q S Z and Q P Z , where P is upper
49*> triangular, S is in generalized Schur form (block upper triangular,
50*> with 1x1 and 2x2 blocks on the diagonal, the 2x2 blocks
51*> corresponding to complex conjugate pairs of generalized
52*> eigenvalues), and Q and Z are orthogonal. It also computes the
53*> generalized eigenvalues (alpha(1),beta(1)),...,(alpha(n),beta(n)),
54*> where alpha(j)=S(j,j) and beta(j)=P(j,j) -- thus,
55*> w(j) = alpha(j)/beta(j) is a root of the generalized eigenvalue
56*> problem
57*>
58*> det( A - w(j) B ) = 0
59*>
60*> and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
61*> problem
62*>
63*> det( m(j) A - B ) = 0
64*>
65*> STGEVC computes the matrix L of left eigenvectors and the matrix R
66*> of right eigenvectors for the matrix pair ( S, P ). In the
67*> description below, l and r are left and right eigenvectors
68*> corresponding to the generalized eigenvalues (alpha,beta).
69*>
70*> When SCHKGG is called, a number of matrix "sizes" ("n's") and a
71*> number of matrix "types" are specified. For each size ("n")
72*> and each type of matrix, one matrix will be generated and used
73*> to test the nonsymmetric eigenroutines. For each matrix, 15
74*> tests will be performed. The first twelve "test ratios" should be
75*> small -- O(1). They will be compared with the threshold THRESH:
76*>
77*> T
78*> (1) | A - U H V | / ( |A| n ulp )
79*>
80*> T
81*> (2) | B - U T V | / ( |B| n ulp )
82*>
83*> T
84*> (3) | I - UU | / ( n ulp )
85*>
86*> T
87*> (4) | I - VV | / ( n ulp )
88*>
89*> T
90*> (5) | H - Q S Z | / ( |H| n ulp )
91*>
92*> T
93*> (6) | T - Q P Z | / ( |T| n ulp )
94*>
95*> T
96*> (7) | I - QQ | / ( n ulp )
97*>
98*> T
99*> (8) | I - ZZ | / ( n ulp )
100*>
101*> (9) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
102*>
103*> | l**H * (beta S - alpha P) | / ( ulp max( |beta S|, |alpha P| ) )
104*>
105*> (10) max over all left eigenvalue/-vector pairs (beta/alpha,l') of
106*> T
107*> | l'**H * (beta H - alpha T) | / ( ulp max( |beta H|, |alpha T| ) )
108*>
109*> where the eigenvectors l' are the result of passing Q to
110*> STGEVC and back transforming (HOWMNY='B').
111*>
112*> (11) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
113*>
114*> | (beta S - alpha T) r | / ( ulp max( |beta S|, |alpha T| ) )
115*>
116*> (12) max over all right eigenvalue/-vector pairs (beta/alpha,r') of
117*>
118*> | (beta H - alpha T) r' | / ( ulp max( |beta H|, |alpha T| ) )
119*>
120*> where the eigenvectors r' are the result of passing Z to
121*> STGEVC and back transforming (HOWMNY='B').
122*>
123*> The last three test ratios will usually be small, but there is no
124*> mathematical requirement that they be so. They are therefore
125*> compared with THRESH only if TSTDIF is .TRUE.
126*>
127*> (13) | S(Q,Z computed) - S(Q,Z not computed) | / ( |S| ulp )
128*>
129*> (14) | P(Q,Z computed) - P(Q,Z not computed) | / ( |P| ulp )
130*>
131*> (15) max( |alpha(Q,Z computed) - alpha(Q,Z not computed)|/|S| ,
132*> |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp
133*>
134*> In addition, the normalization of L and R are checked, and compared
135*> with the threshold THRSHN.
136*>
137*> Test Matrices
138*> ---- --------
139*>
140*> The sizes of the test matrices are specified by an array
141*> NN(1:NSIZES); the value of each element NN(j) specifies one size.
142*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
143*> DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
144*> Currently, the list of possible types is:
145*>
146*> (1) ( 0, 0 ) (a pair of zero matrices)
147*>
148*> (2) ( I, 0 ) (an identity and a zero matrix)
149*>
150*> (3) ( 0, I ) (an identity and a zero matrix)
151*>
152*> (4) ( I, I ) (a pair of identity matrices)
153*>
154*> t t
155*> (5) ( J , J ) (a pair of transposed Jordan blocks)
156*>
157*> t ( I 0 )
158*> (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
159*> ( 0 I ) ( 0 J )
160*> and I is a k x k identity and J a (k+1)x(k+1)
161*> Jordan block; k=(N-1)/2
162*>
163*> (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
164*> matrix with those diagonal entries.)
165*> (8) ( I, D )
166*>
167*> (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
168*>
169*> (10) ( small*D, big*I )
170*>
171*> (11) ( big*I, small*D )
172*>
173*> (12) ( small*I, big*D )
174*>
175*> (13) ( big*D, big*I )
176*>
177*> (14) ( small*D, small*I )
178*>
179*> (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
180*> D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
181*> t t
182*> (16) U ( J , J ) V where U and V are random orthogonal matrices.
183*>
184*> (17) U ( T1, T2 ) V where T1 and T2 are upper triangular matrices
185*> with random O(1) entries above the diagonal
186*> and diagonal entries diag(T1) =
187*> ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
188*> ( 0, N-3, N-4,..., 1, 0, 0 )
189*>
190*> (18) U ( T1, T2 ) V diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
191*> diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
192*> s = machine precision.
193*>
194*> (19) U ( T1, T2 ) V diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
195*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
196*>
197*> N-5
198*> (20) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
199*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
200*>
201*> (21) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
202*> diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
203*> where r1,..., r(N-4) are random.
204*>
205*> (22) U ( big*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
206*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
207*>
208*> (23) U ( small*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
209*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
210*>
211*> (24) U ( small*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
212*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
213*>
214*> (25) U ( big*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
215*> diag(T2) = ( 0, 1, ..., 1, 0, 0 )
216*>
217*> (26) U ( T1, T2 ) V where T1 and T2 are random upper-triangular
218*> matrices.
219*> \endverbatim
220*
221* Arguments:
222* ==========
223*
224*> \param[in] NSIZES
225*> \verbatim
226*> NSIZES is INTEGER
227*> The number of sizes of matrices to use. If it is zero,
228*> SCHKGG does nothing. It must be at least zero.
229*> \endverbatim
230*>
231*> \param[in] NN
232*> \verbatim
233*> NN is INTEGER array, dimension (NSIZES)
234*> An array containing the sizes to be used for the matrices.
235*> Zero values will be skipped. The values must be at least
236*> zero.
237*> \endverbatim
238*>
239*> \param[in] NTYPES
240*> \verbatim
241*> NTYPES is INTEGER
242*> The number of elements in DOTYPE. If it is zero, SCHKGG
243*> does nothing. It must be at least zero. If it is MAXTYP+1
244*> and NSIZES is 1, then an additional type, MAXTYP+1 is
245*> defined, which is to use whatever matrix is in A. This
246*> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
247*> DOTYPE(MAXTYP+1) is .TRUE. .
248*> \endverbatim
249*>
250*> \param[in] DOTYPE
251*> \verbatim
252*> DOTYPE is LOGICAL array, dimension (NTYPES)
253*> If DOTYPE(j) is .TRUE., then for each size in NN a
254*> matrix of that size and of type j will be generated.
255*> If NTYPES is smaller than the maximum number of types
256*> defined (PARAMETER MAXTYP), then types NTYPES+1 through
257*> MAXTYP will not be generated. If NTYPES is larger
258*> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
259*> will be ignored.
260*> \endverbatim
261*>
262*> \param[in,out] ISEED
263*> \verbatim
264*> ISEED is INTEGER array, dimension (4)
265*> On entry ISEED specifies the seed of the random number
266*> generator. The array elements should be between 0 and 4095;
267*> if not they will be reduced mod 4096. Also, ISEED(4) must
268*> be odd. The random number generator uses a linear
269*> congruential sequence limited to small integers, and so
270*> should produce machine independent random numbers. The
271*> values of ISEED are changed on exit, and can be used in the
272*> next call to SCHKGG to continue the same random number
273*> sequence.
274*> \endverbatim
275*>
276*> \param[in] THRESH
277*> \verbatim
278*> THRESH is REAL
279*> A test will count as "failed" if the "error", computed as
280*> described above, exceeds THRESH. Note that the error is
281*> scaled to be O(1), so THRESH should be a reasonably small
282*> multiple of 1, e.g., 10 or 100. In particular, it should
283*> not depend on the precision (single vs. double) or the size
284*> of the matrix. It must be at least zero.
285*> \endverbatim
286*>
287*> \param[in] TSTDIF
288*> \verbatim
289*> TSTDIF is LOGICAL
290*> Specifies whether test ratios 13-15 will be computed and
291*> compared with THRESH.
292*> = .FALSE.: Only test ratios 1-12 will be computed and tested.
293*> Ratios 13-15 will be set to zero.
294*> = .TRUE.: All the test ratios 1-15 will be computed and
295*> tested.
296*> \endverbatim
297*>
298*> \param[in] THRSHN
299*> \verbatim
300*> THRSHN is REAL
301*> Threshold for reporting eigenvector normalization error.
302*> If the normalization of any eigenvector differs from 1 by
303*> more than THRSHN*ulp, then a special error message will be
304*> printed. (This is handled separately from the other tests,
305*> since only a compiler or programming error should cause an
306*> error message, at least if THRSHN is at least 5--10.)
307*> \endverbatim
308*>
309*> \param[in] NOUNIT
310*> \verbatim
311*> NOUNIT is INTEGER
312*> The FORTRAN unit number for printing out error messages
313*> (e.g., if a routine returns IINFO not equal to 0.)
314*> \endverbatim
315*>
316*> \param[in,out] A
317*> \verbatim
318*> A is REAL array, dimension
319*> (LDA, max(NN))
320*> Used to hold the original A matrix. Used as input only
321*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
322*> DOTYPE(MAXTYP+1)=.TRUE.
323*> \endverbatim
324*>
325*> \param[in] LDA
326*> \verbatim
327*> LDA is INTEGER
328*> The leading dimension of A, B, H, T, S1, P1, S2, and P2.
329*> It must be at least 1 and at least max( NN ).
330*> \endverbatim
331*>
332*> \param[in,out] B
333*> \verbatim
334*> B is REAL array, dimension
335*> (LDA, max(NN))
336*> Used to hold the original B matrix. Used as input only
337*> if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
338*> DOTYPE(MAXTYP+1)=.TRUE.
339*> \endverbatim
340*>
341*> \param[out] H
342*> \verbatim
343*> H is REAL array, dimension (LDA, max(NN))
344*> The upper Hessenberg matrix computed from A by SGGHRD.
345*> \endverbatim
346*>
347*> \param[out] T
348*> \verbatim
349*> T is REAL array, dimension (LDA, max(NN))
350*> The upper triangular matrix computed from B by SGGHRD.
351*> \endverbatim
352*>
353*> \param[out] S1
354*> \verbatim
355*> S1 is REAL array, dimension (LDA, max(NN))
356*> The Schur (block upper triangular) matrix computed from H by
357*> SHGEQZ when Q and Z are also computed.
358*> \endverbatim
359*>
360*> \param[out] S2
361*> \verbatim
362*> S2 is REAL array, dimension (LDA, max(NN))
363*> The Schur (block upper triangular) matrix computed from H by
364*> SHGEQZ when Q and Z are not computed.
365*> \endverbatim
366*>
367*> \param[out] P1
368*> \verbatim
369*> P1 is REAL array, dimension (LDA, max(NN))
370*> The upper triangular matrix computed from T by SHGEQZ
371*> when Q and Z are also computed.
372*> \endverbatim
373*>
374*> \param[out] P2
375*> \verbatim
376*> P2 is REAL array, dimension (LDA, max(NN))
377*> The upper triangular matrix computed from T by SHGEQZ
378*> when Q and Z are not computed.
379*> \endverbatim
380*>
381*> \param[out] U
382*> \verbatim
383*> U is REAL array, dimension (LDU, max(NN))
384*> The (left) orthogonal matrix computed by SGGHRD.
385*> \endverbatim
386*>
387*> \param[in] LDU
388*> \verbatim
389*> LDU is INTEGER
390*> The leading dimension of U, V, Q, Z, EVECTL, and EVECTR. It
391*> must be at least 1 and at least max( NN ).
392*> \endverbatim
393*>
394*> \param[out] V
395*> \verbatim
396*> V is REAL array, dimension (LDU, max(NN))
397*> The (right) orthogonal matrix computed by SGGHRD.
398*> \endverbatim
399*>
400*> \param[out] Q
401*> \verbatim
402*> Q is REAL array, dimension (LDU, max(NN))
403*> The (left) orthogonal matrix computed by SHGEQZ.
404*> \endverbatim
405*>
406*> \param[out] Z
407*> \verbatim
408*> Z is REAL array, dimension (LDU, max(NN))
409*> The (left) orthogonal matrix computed by SHGEQZ.
410*> \endverbatim
411*>
412*> \param[out] ALPHR1
413*> \verbatim
414*> ALPHR1 is REAL array, dimension (max(NN))
415*> \endverbatim
416*>
417*> \param[out] ALPHI1
418*> \verbatim
419*> ALPHI1 is REAL array, dimension (max(NN))
420*> \endverbatim
421*>
422*> \param[out] BETA1
423*> \verbatim
424*> BETA1 is REAL array, dimension (max(NN))
425*>
426*> The generalized eigenvalues of (A,B) computed by SHGEQZ
427*> when Q, Z, and the full Schur matrices are computed.
428*> On exit, ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th
429*> generalized eigenvalue of the matrices in A and B.
430*> \endverbatim
431*>
432*> \param[out] ALPHR3
433*> \verbatim
434*> ALPHR3 is REAL array, dimension (max(NN))
435*> \endverbatim
436*>
437*> \param[out] ALPHI3
438*> \verbatim
439*> ALPHI3 is REAL array, dimension (max(NN))
440*> \endverbatim
441*>
442*> \param[out] BETA3
443*> \verbatim
444*> BETA3 is REAL array, dimension (max(NN))
445*> \endverbatim
446*>
447*> \param[out] EVECTL
448*> \verbatim
449*> EVECTL is REAL array, dimension (LDU, max(NN))
450*> The (block lower triangular) left eigenvector matrix for
451*> the matrices in S1 and P1. (See STGEVC for the format.)
452*> \endverbatim
453*>
454*> \param[out] EVECTR
455*> \verbatim
456*> EVECTR is REAL array, dimension (LDU, max(NN))
457*> The (block upper triangular) right eigenvector matrix for
458*> the matrices in S1 and P1. (See STGEVC for the format.)
459*> \endverbatim
460*>
461*> \param[out] WORK
462*> \verbatim
463*> WORK is REAL array, dimension (LWORK)
464*> \endverbatim
465*>
466*> \param[in] LWORK
467*> \verbatim
468*> LWORK is INTEGER
469*> The number of entries in WORK. This must be at least
470*> max( 2 * N**2, 6*N, 1 ), for all N=NN(j).
471*> \endverbatim
472*>
473*> \param[out] LLWORK
474*> \verbatim
475*> LLWORK is LOGICAL array, dimension (max(NN))
476*> \endverbatim
477*>
478*> \param[out] RESULT
479*> \verbatim
480*> RESULT is REAL array, dimension (15)
481*> The values computed by the tests described above.
482*> The values are currently limited to 1/ulp, to avoid
483*> overflow.
484*> \endverbatim
485*>
486*> \param[out] INFO
487*> \verbatim
488*> INFO is INTEGER
489*> = 0: successful exit
490*> < 0: if INFO = -i, the i-th argument had an illegal value
491*> > 0: A routine returned an error code. INFO is the
492*> absolute value of the INFO value returned.
493*> \endverbatim
494*
495* Authors:
496* ========
497*
498*> \author Univ. of Tennessee
499*> \author Univ. of California Berkeley
500*> \author Univ. of Colorado Denver
501*> \author NAG Ltd.
502*
503*> \ingroup single_eig
504*
505* =====================================================================
506 SUBROUTINE schkgg( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
507 $ TSTDIF, THRSHN, NOUNIT, A, LDA, B, H, T, S1,
508 $ S2, P1, P2, U, LDU, V, Q, Z, ALPHR1, ALPHI1,
509 $ BETA1, ALPHR3, ALPHI3, BETA3, EVECTL, EVECTR,
510 $ WORK, LWORK, LLWORK, RESULT, INFO )
511*
512* -- LAPACK test routine --
513* -- LAPACK is a software package provided by Univ. of Tennessee, --
514* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
515*
516* .. Scalar Arguments ..
517 LOGICAL TSTDIF
518 INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES
519 REAL THRESH, THRSHN
520* ..
521* .. Array Arguments ..
522 LOGICAL DOTYPE( * ), LLWORK( * )
523 INTEGER ISEED( 4 ), NN( * )
524 REAL A( LDA, * ), ALPHI1( * ), ALPHI3( * ),
525 $ ALPHR1( * ), ALPHR3( * ), B( LDA, * ),
526 $ beta1( * ), beta3( * ), evectl( ldu, * ),
527 $ evectr( ldu, * ), h( lda, * ), p1( lda, * ),
528 $ p2( lda, * ), q( ldu, * ), result( 15 ),
529 $ s1( lda, * ), s2( lda, * ), t( lda, * ),
530 $ u( ldu, * ), v( ldu, * ), work( * ),
531 $ z( ldu, * )
532* ..
533*
534* =====================================================================
535*
536* .. Parameters ..
537 REAL ZERO, ONE
538 PARAMETER ( ZERO = 0.0, one = 1.0 )
539 INTEGER MAXTYP
540 PARAMETER ( MAXTYP = 26 )
541* ..
542* .. Local Scalars ..
543 LOGICAL BADNN
544 INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
545 $ LWKOPT, MTYPES, N, N1, NERRS, NMATS, NMAX,
546 $ NTEST, NTESTT
547 REAL ANORM, BNORM, SAFMAX, SAFMIN, TEMP1, TEMP2,
548 $ ulp, ulpinv
549* ..
550* .. Local Arrays ..
551 INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
552 $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
553 $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
554 $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
555 $ kbzero( maxtyp ), kclass( maxtyp ),
556 $ ktrian( maxtyp ), kz1( 6 ), kz2( 6 )
557 REAL DUMMA( 4 ), RMAGN( 0: 3 )
558* ..
559* .. External Functions ..
560 REAL SLAMCH, SLANGE, SLARND
561 EXTERNAL slamch, slange, slarnd
562* ..
563* .. External Subroutines ..
564 EXTERNAL sgeqr2, sget51, sget52, sgghrd, shgeqz, slabad,
566 $ stgevc, xerbla
567* ..
568* .. Intrinsic Functions ..
569 INTRINSIC abs, max, min, real, sign
570* ..
571* .. Data statements ..
572 DATA kclass / 15*1, 10*2, 1*3 /
573 DATA kz1 / 0, 1, 2, 1, 3, 3 /
574 DATA kz2 / 0, 0, 1, 2, 1, 1 /
575 DATA kadd / 0, 0, 0, 0, 3, 2 /
576 DATA katype / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
577 $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
578 DATA kbtype / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
579 $ 1, 1, -4, 2, -4, 8*8, 0 /
580 DATA kazero / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
581 $ 4*5, 4*3, 1 /
582 DATA kbzero / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
583 $ 4*6, 4*4, 1 /
584 DATA kamagn / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
585 $ 2, 1 /
586 DATA kbmagn / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
587 $ 2, 1 /
588 DATA ktrian / 16*0, 10*1 /
589 DATA iasign / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
590 $ 5*2, 0 /
591 DATA ibsign / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
592* ..
593* .. Executable Statements ..
594*
595* Check for errors
596*
597 info = 0
598*
599 badnn = .false.
600 nmax = 1
601 DO 10 j = 1, nsizes
602 nmax = max( nmax, nn( j ) )
603 IF( nn( j ).LT.0 )
604 $ badnn = .true.
605 10 CONTINUE
606*
607* Maximum blocksize and shift -- we assume that blocksize and number
608* of shifts are monotone increasing functions of N.
609*
610 lwkopt = max( 6*nmax, 2*nmax*nmax, 1 )
611*
612* Check for errors
613*
614 IF( nsizes.LT.0 ) THEN
615 info = -1
616 ELSE IF( badnn ) THEN
617 info = -2
618 ELSE IF( ntypes.LT.0 ) THEN
619 info = -3
620 ELSE IF( thresh.LT.zero ) THEN
621 info = -6
622 ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
623 info = -10
624 ELSE IF( ldu.LE.1 .OR. ldu.LT.nmax ) THEN
625 info = -19
626 ELSE IF( lwkopt.GT.lwork ) THEN
627 info = -30
628 END IF
629*
630 IF( info.NE.0 ) THEN
631 CALL xerbla( 'SCHKGG', -info )
632 RETURN
633 END IF
634*
635* Quick return if possible
636*
637 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
638 $ RETURN
639*
640 safmin = slamch( 'Safe minimum' )
641 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
642 safmin = safmin / ulp
643 safmax = one / safmin
644 CALL slabad( safmin, safmax )
645 ulpinv = one / ulp
646*
647* The values RMAGN(2:3) depend on N, see below.
648*
649 rmagn( 0 ) = zero
650 rmagn( 1 ) = one
651*
652* Loop over sizes, types
653*
654 ntestt = 0
655 nerrs = 0
656 nmats = 0
657*
658 DO 240 jsize = 1, nsizes
659 n = nn( jsize )
660 n1 = max( 1, n )
661 rmagn( 2 ) = safmax*ulp / real( n1 )
662 rmagn( 3 ) = safmin*ulpinv*n1
663*
664 IF( nsizes.NE.1 ) THEN
665 mtypes = min( maxtyp, ntypes )
666 ELSE
667 mtypes = min( maxtyp+1, ntypes )
668 END IF
669*
670 DO 230 jtype = 1, mtypes
671 IF( .NOT.dotype( jtype ) )
672 $ GO TO 230
673 nmats = nmats + 1
674 ntest = 0
675*
676* Save ISEED in case of an error.
677*
678 DO 20 j = 1, 4
679 ioldsd( j ) = iseed( j )
680 20 CONTINUE
681*
682* Initialize RESULT
683*
684 DO 30 j = 1, 15
685 result( j ) = zero
686 30 CONTINUE
687*
688* Compute A and B
689*
690* Description of control parameters:
691*
692* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
693* =3 means random.
694* KATYPE: the "type" to be passed to SLATM4 for computing A.
695* KAZERO: the pattern of zeros on the diagonal for A:
696* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
697* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
698* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
699* non-zero entries.)
700* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
701* =2: large, =3: small.
702* IASIGN: 1 if the diagonal elements of A are to be
703* multiplied by a random magnitude 1 number, =2 if
704* randomly chosen diagonal blocks are to be rotated
705* to form 2x2 blocks.
706* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
707* KTRIAN: =0: don't fill in the upper triangle, =1: do.
708* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
709* RMAGN: used to implement KAMAGN and KBMAGN.
710*
711 IF( mtypes.GT.maxtyp )
712 $ GO TO 110
713 iinfo = 0
714 IF( kclass( jtype ).LT.3 ) THEN
715*
716* Generate A (w/o rotation)
717*
718 IF( abs( katype( jtype ) ).EQ.3 ) THEN
719 in = 2*( ( n-1 ) / 2 ) + 1
720 IF( in.NE.n )
721 $ CALL slaset( 'Full', n, n, zero, zero, a, lda )
722 ELSE
723 in = n
724 END IF
725 CALL slatm4( katype( jtype ), in, kz1( kazero( jtype ) ),
726 $ kz2( kazero( jtype ) ), iasign( jtype ),
727 $ rmagn( kamagn( jtype ) ), ulp,
728 $ rmagn( ktrian( jtype )*kamagn( jtype ) ), 2,
729 $ iseed, a, lda )
730 iadd = kadd( kazero( jtype ) )
731 IF( iadd.GT.0 .AND. iadd.LE.n )
732 $ a( iadd, iadd ) = rmagn( kamagn( jtype ) )
733*
734* Generate B (w/o rotation)
735*
736 IF( abs( kbtype( jtype ) ).EQ.3 ) THEN
737 in = 2*( ( n-1 ) / 2 ) + 1
738 IF( in.NE.n )
739 $ CALL slaset( 'Full', n, n, zero, zero, b, lda )
740 ELSE
741 in = n
742 END IF
743 CALL slatm4( kbtype( jtype ), in, kz1( kbzero( jtype ) ),
744 $ kz2( kbzero( jtype ) ), ibsign( jtype ),
745 $ rmagn( kbmagn( jtype ) ), one,
746 $ rmagn( ktrian( jtype )*kbmagn( jtype ) ), 2,
747 $ iseed, b, lda )
748 iadd = kadd( kbzero( jtype ) )
749 IF( iadd.NE.0 .AND. iadd.LE.n )
750 $ b( iadd, iadd ) = rmagn( kbmagn( jtype ) )
751*
752 IF( kclass( jtype ).EQ.2 .AND. n.GT.0 ) THEN
753*
754* Include rotations
755*
756* Generate U, V as Householder transformations times
757* a diagonal matrix.
758*
759 DO 50 jc = 1, n - 1
760 DO 40 jr = jc, n
761 u( jr, jc ) = slarnd( 3, iseed )
762 v( jr, jc ) = slarnd( 3, iseed )
763 40 CONTINUE
764 CALL slarfg( n+1-jc, u( jc, jc ), u( jc+1, jc ), 1,
765 $ work( jc ) )
766 work( 2*n+jc ) = sign( one, u( jc, jc ) )
767 u( jc, jc ) = one
768 CALL slarfg( n+1-jc, v( jc, jc ), v( jc+1, jc ), 1,
769 $ work( n+jc ) )
770 work( 3*n+jc ) = sign( one, v( jc, jc ) )
771 v( jc, jc ) = one
772 50 CONTINUE
773 u( n, n ) = one
774 work( n ) = zero
775 work( 3*n ) = sign( one, slarnd( 2, iseed ) )
776 v( n, n ) = one
777 work( 2*n ) = zero
778 work( 4*n ) = sign( one, slarnd( 2, iseed ) )
779*
780* Apply the diagonal matrices
781*
782 DO 70 jc = 1, n
783 DO 60 jr = 1, n
784 a( jr, jc ) = work( 2*n+jr )*work( 3*n+jc )*
785 $ a( jr, jc )
786 b( jr, jc ) = work( 2*n+jr )*work( 3*n+jc )*
787 $ b( jr, jc )
788 60 CONTINUE
789 70 CONTINUE
790 CALL sorm2r( 'L', 'N', n, n, n-1, u, ldu, work, a,
791 $ lda, work( 2*n+1 ), iinfo )
792 IF( iinfo.NE.0 )
793 $ GO TO 100
794 CALL sorm2r( 'R', 'T', n, n, n-1, v, ldu, work( n+1 ),
795 $ a, lda, work( 2*n+1 ), iinfo )
796 IF( iinfo.NE.0 )
797 $ GO TO 100
798 CALL sorm2r( 'L', 'N', n, n, n-1, u, ldu, work, b,
799 $ lda, work( 2*n+1 ), iinfo )
800 IF( iinfo.NE.0 )
801 $ GO TO 100
802 CALL sorm2r( 'R', 'T', n, n, n-1, v, ldu, work( n+1 ),
803 $ b, lda, work( 2*n+1 ), iinfo )
804 IF( iinfo.NE.0 )
805 $ GO TO 100
806 END IF
807 ELSE
808*
809* Random matrices
810*
811 DO 90 jc = 1, n
812 DO 80 jr = 1, n
813 a( jr, jc ) = rmagn( kamagn( jtype ) )*
814 $ slarnd( 2, iseed )
815 b( jr, jc ) = rmagn( kbmagn( jtype ) )*
816 $ slarnd( 2, iseed )
817 80 CONTINUE
818 90 CONTINUE
819 END IF
820*
821 anorm = slange( '1', n, n, a, lda, work )
822 bnorm = slange( '1', n, n, b, lda, work )
823*
824 100 CONTINUE
825*
826 IF( iinfo.NE.0 ) THEN
827 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
828 $ ioldsd
829 info = abs( iinfo )
830 RETURN
831 END IF
832*
833 110 CONTINUE
834*
835* Call SGEQR2, SORM2R, and SGGHRD to compute H, T, U, and V
836*
837 CALL slacpy( ' ', n, n, a, lda, h, lda )
838 CALL slacpy( ' ', n, n, b, lda, t, lda )
839 ntest = 1
840 result( 1 ) = ulpinv
841*
842 CALL sgeqr2( n, n, t, lda, work, work( n+1 ), iinfo )
843 IF( iinfo.NE.0 ) THEN
844 WRITE( nounit, fmt = 9999 )'SGEQR2', iinfo, n, jtype,
845 $ ioldsd
846 info = abs( iinfo )
847 GO TO 210
848 END IF
849*
850 CALL sorm2r( 'L', 'T', n, n, n, t, lda, work, h, lda,
851 $ work( n+1 ), iinfo )
852 IF( iinfo.NE.0 ) THEN
853 WRITE( nounit, fmt = 9999 )'SORM2R', iinfo, n, jtype,
854 $ ioldsd
855 info = abs( iinfo )
856 GO TO 210
857 END IF
858*
859 CALL slaset( 'Full', n, n, zero, one, u, ldu )
860 CALL sorm2r( 'R', 'N', n, n, n, t, lda, work, u, ldu,
861 $ work( n+1 ), iinfo )
862 IF( iinfo.NE.0 ) THEN
863 WRITE( nounit, fmt = 9999 )'SORM2R', iinfo, n, jtype,
864 $ ioldsd
865 info = abs( iinfo )
866 GO TO 210
867 END IF
868*
869 CALL sgghrd( 'V', 'I', n, 1, n, h, lda, t, lda, u, ldu, v,
870 $ ldu, iinfo )
871 IF( iinfo.NE.0 ) THEN
872 WRITE( nounit, fmt = 9999 )'SGGHRD', iinfo, n, jtype,
873 $ ioldsd
874 info = abs( iinfo )
875 GO TO 210
876 END IF
877 ntest = 4
878*
879* Do tests 1--4
880*
881 CALL sget51( 1, n, a, lda, h, lda, u, ldu, v, ldu, work,
882 $ result( 1 ) )
883 CALL sget51( 1, n, b, lda, t, lda, u, ldu, v, ldu, work,
884 $ result( 2 ) )
885 CALL sget51( 3, n, b, lda, t, lda, u, ldu, u, ldu, work,
886 $ result( 3 ) )
887 CALL sget51( 3, n, b, lda, t, lda, v, ldu, v, ldu, work,
888 $ result( 4 ) )
889*
890* Call SHGEQZ to compute S1, P1, S2, P2, Q, and Z, do tests.
891*
892* Compute T1 and UZ
893*
894* Eigenvalues only
895*
896 CALL slacpy( ' ', n, n, h, lda, s2, lda )
897 CALL slacpy( ' ', n, n, t, lda, p2, lda )
898 ntest = 5
899 result( 5 ) = ulpinv
900*
901 CALL shgeqz( 'E', 'N', 'N', n, 1, n, s2, lda, p2, lda,
902 $ alphr3, alphi3, beta3, q, ldu, z, ldu, work,
903 $ lwork, iinfo )
904 IF( iinfo.NE.0 ) THEN
905 WRITE( nounit, fmt = 9999 )'SHGEQZ(E)', iinfo, n, jtype,
906 $ ioldsd
907 info = abs( iinfo )
908 GO TO 210
909 END IF
910*
911* Eigenvalues and Full Schur Form
912*
913 CALL slacpy( ' ', n, n, h, lda, s2, lda )
914 CALL slacpy( ' ', n, n, t, lda, p2, lda )
915*
916 CALL shgeqz( 'S', 'N', 'N', n, 1, n, s2, lda, p2, lda,
917 $ alphr1, alphi1, beta1, q, ldu, z, ldu, work,
918 $ lwork, iinfo )
919 IF( iinfo.NE.0 ) THEN
920 WRITE( nounit, fmt = 9999 )'SHGEQZ(S)', iinfo, n, jtype,
921 $ ioldsd
922 info = abs( iinfo )
923 GO TO 210
924 END IF
925*
926* Eigenvalues, Schur Form, and Schur Vectors
927*
928 CALL slacpy( ' ', n, n, h, lda, s1, lda )
929 CALL slacpy( ' ', n, n, t, lda, p1, lda )
930*
931 CALL shgeqz( 'S', 'I', 'I', n, 1, n, s1, lda, p1, lda,
932 $ alphr1, alphi1, beta1, q, ldu, z, ldu, work,
933 $ lwork, iinfo )
934 IF( iinfo.NE.0 ) THEN
935 WRITE( nounit, fmt = 9999 )'SHGEQZ(V)', iinfo, n, jtype,
936 $ ioldsd
937 info = abs( iinfo )
938 GO TO 210
939 END IF
940*
941 ntest = 8
942*
943* Do Tests 5--8
944*
945 CALL sget51( 1, n, h, lda, s1, lda, q, ldu, z, ldu, work,
946 $ result( 5 ) )
947 CALL sget51( 1, n, t, lda, p1, lda, q, ldu, z, ldu, work,
948 $ result( 6 ) )
949 CALL sget51( 3, n, t, lda, p1, lda, q, ldu, q, ldu, work,
950 $ result( 7 ) )
951 CALL sget51( 3, n, t, lda, p1, lda, z, ldu, z, ldu, work,
952 $ result( 8 ) )
953*
954* Compute the Left and Right Eigenvectors of (S1,P1)
955*
956* 9: Compute the left eigenvector Matrix without
957* back transforming:
958*
959 ntest = 9
960 result( 9 ) = ulpinv
961*
962* To test "SELECT" option, compute half of the eigenvectors
963* in one call, and half in another
964*
965 i1 = n / 2
966 DO 120 j = 1, i1
967 llwork( j ) = .true.
968 120 CONTINUE
969 DO 130 j = i1 + 1, n
970 llwork( j ) = .false.
971 130 CONTINUE
972*
973 CALL stgevc( 'L', 'S', llwork, n, s1, lda, p1, lda, evectl,
974 $ ldu, dumma, ldu, n, in, work, iinfo )
975 IF( iinfo.NE.0 ) THEN
976 WRITE( nounit, fmt = 9999 )'STGEVC(L,S1)', iinfo, n,
977 $ jtype, ioldsd
978 info = abs( iinfo )
979 GO TO 210
980 END IF
981*
982 i1 = in
983 DO 140 j = 1, i1
984 llwork( j ) = .false.
985 140 CONTINUE
986 DO 150 j = i1 + 1, n
987 llwork( j ) = .true.
988 150 CONTINUE
989*
990 CALL stgevc( 'L', 'S', llwork, n, s1, lda, p1, lda,
991 $ evectl( 1, i1+1 ), ldu, dumma, ldu, n, in,
992 $ work, iinfo )
993 IF( iinfo.NE.0 ) THEN
994 WRITE( nounit, fmt = 9999 )'STGEVC(L,S2)', iinfo, n,
995 $ jtype, ioldsd
996 info = abs( iinfo )
997 GO TO 210
998 END IF
999*
1000 CALL sget52( .true., n, s1, lda, p1, lda, evectl, ldu,
1001 $ alphr1, alphi1, beta1, work, dumma( 1 ) )
1002 result( 9 ) = dumma( 1 )
1003 IF( dumma( 2 ).GT.thrshn ) THEN
1004 WRITE( nounit, fmt = 9998 )'Left', 'STGEVC(HOWMNY=S)',
1005 $ dumma( 2 ), n, jtype, ioldsd
1006 END IF
1007*
1008* 10: Compute the left eigenvector Matrix with
1009* back transforming:
1010*
1011 ntest = 10
1012 result( 10 ) = ulpinv
1013 CALL slacpy( 'F', n, n, q, ldu, evectl, ldu )
1014 CALL stgevc( 'L', 'B', llwork, n, s1, lda, p1, lda, evectl,
1015 $ ldu, dumma, ldu, n, in, work, iinfo )
1016 IF( iinfo.NE.0 ) THEN
1017 WRITE( nounit, fmt = 9999 )'STGEVC(L,B)', iinfo, n,
1018 $ jtype, ioldsd
1019 info = abs( iinfo )
1020 GO TO 210
1021 END IF
1022*
1023 CALL sget52( .true., n, h, lda, t, lda, evectl, ldu, alphr1,
1024 $ alphi1, beta1, work, dumma( 1 ) )
1025 result( 10 ) = dumma( 1 )
1026 IF( dumma( 2 ).GT.thrshn ) THEN
1027 WRITE( nounit, fmt = 9998 )'Left', 'STGEVC(HOWMNY=B)',
1028 $ dumma( 2 ), n, jtype, ioldsd
1029 END IF
1030*
1031* 11: Compute the right eigenvector Matrix without
1032* back transforming:
1033*
1034 ntest = 11
1035 result( 11 ) = ulpinv
1036*
1037* To test "SELECT" option, compute half of the eigenvectors
1038* in one call, and half in another
1039*
1040 i1 = n / 2
1041 DO 160 j = 1, i1
1042 llwork( j ) = .true.
1043 160 CONTINUE
1044 DO 170 j = i1 + 1, n
1045 llwork( j ) = .false.
1046 170 CONTINUE
1047*
1048 CALL stgevc( 'R', 'S', llwork, n, s1, lda, p1, lda, dumma,
1049 $ ldu, evectr, ldu, n, in, work, iinfo )
1050 IF( iinfo.NE.0 ) THEN
1051 WRITE( nounit, fmt = 9999 )'STGEVC(R,S1)', iinfo, n,
1052 $ jtype, ioldsd
1053 info = abs( iinfo )
1054 GO TO 210
1055 END IF
1056*
1057 i1 = in
1058 DO 180 j = 1, i1
1059 llwork( j ) = .false.
1060 180 CONTINUE
1061 DO 190 j = i1 + 1, n
1062 llwork( j ) = .true.
1063 190 CONTINUE
1064*
1065 CALL stgevc( 'R', 'S', llwork, n, s1, lda, p1, lda, dumma,
1066 $ ldu, evectr( 1, i1+1 ), ldu, n, in, work,
1067 $ iinfo )
1068 IF( iinfo.NE.0 ) THEN
1069 WRITE( nounit, fmt = 9999 )'STGEVC(R,S2)', iinfo, n,
1070 $ jtype, ioldsd
1071 info = abs( iinfo )
1072 GO TO 210
1073 END IF
1074*
1075 CALL sget52( .false., n, s1, lda, p1, lda, evectr, ldu,
1076 $ alphr1, alphi1, beta1, work, dumma( 1 ) )
1077 result( 11 ) = dumma( 1 )
1078 IF( dumma( 2 ).GT.thresh ) THEN
1079 WRITE( nounit, fmt = 9998 )'Right', 'STGEVC(HOWMNY=S)',
1080 $ dumma( 2 ), n, jtype, ioldsd
1081 END IF
1082*
1083* 12: Compute the right eigenvector Matrix with
1084* back transforming:
1085*
1086 ntest = 12
1087 result( 12 ) = ulpinv
1088 CALL slacpy( 'F', n, n, z, ldu, evectr, ldu )
1089 CALL stgevc( 'R', 'B', llwork, n, s1, lda, p1, lda, dumma,
1090 $ ldu, evectr, ldu, n, in, work, iinfo )
1091 IF( iinfo.NE.0 ) THEN
1092 WRITE( nounit, fmt = 9999 )'STGEVC(R,B)', iinfo, n,
1093 $ jtype, ioldsd
1094 info = abs( iinfo )
1095 GO TO 210
1096 END IF
1097*
1098 CALL sget52( .false., n, h, lda, t, lda, evectr, ldu,
1099 $ alphr1, alphi1, beta1, work, dumma( 1 ) )
1100 result( 12 ) = dumma( 1 )
1101 IF( dumma( 2 ).GT.thresh ) THEN
1102 WRITE( nounit, fmt = 9998 )'Right', 'STGEVC(HOWMNY=B)',
1103 $ dumma( 2 ), n, jtype, ioldsd
1104 END IF
1105*
1106* Tests 13--15 are done only on request
1107*
1108 IF( tstdif ) THEN
1109*
1110* Do Tests 13--14
1111*
1112 CALL sget51( 2, n, s1, lda, s2, lda, q, ldu, z, ldu,
1113 $ work, result( 13 ) )
1114 CALL sget51( 2, n, p1, lda, p2, lda, q, ldu, z, ldu,
1115 $ work, result( 14 ) )
1116*
1117* Do Test 15
1118*
1119 temp1 = zero
1120 temp2 = zero
1121 DO 200 j = 1, n
1122 temp1 = max( temp1, abs( alphr1( j )-alphr3( j ) )+
1123 $ abs( alphi1( j )-alphi3( j ) ) )
1124 temp2 = max( temp2, abs( beta1( j )-beta3( j ) ) )
1125 200 CONTINUE
1126*
1127 temp1 = temp1 / max( safmin, ulp*max( temp1, anorm ) )
1128 temp2 = temp2 / max( safmin, ulp*max( temp2, bnorm ) )
1129 result( 15 ) = max( temp1, temp2 )
1130 ntest = 15
1131 ELSE
1132 result( 13 ) = zero
1133 result( 14 ) = zero
1134 result( 15 ) = zero
1135 ntest = 12
1136 END IF
1137*
1138* End of Loop -- Check for RESULT(j) > THRESH
1139*
1140 210 CONTINUE
1141*
1142 ntestt = ntestt + ntest
1143*
1144* Print out tests which fail.
1145*
1146 DO 220 jr = 1, ntest
1147 IF( result( jr ).GE.thresh ) THEN
1148*
1149* If this is the first test to fail,
1150* print a header to the data file.
1151*
1152 IF( nerrs.EQ.0 ) THEN
1153 WRITE( nounit, fmt = 9997 )'SGG'
1154*
1155* Matrix types
1156*
1157 WRITE( nounit, fmt = 9996 )
1158 WRITE( nounit, fmt = 9995 )
1159 WRITE( nounit, fmt = 9994 )'Orthogonal'
1160*
1161* Tests performed
1162*
1163 WRITE( nounit, fmt = 9993 )'orthogonal', '''',
1164 $ 'transpose', ( '''', j = 1, 10 )
1165*
1166 END IF
1167 nerrs = nerrs + 1
1168 IF( result( jr ).LT.10000.0 ) THEN
1169 WRITE( nounit, fmt = 9992 )n, jtype, ioldsd, jr,
1170 $ result( jr )
1171 ELSE
1172 WRITE( nounit, fmt = 9991 )n, jtype, ioldsd, jr,
1173 $ result( jr )
1174 END IF
1175 END IF
1176 220 CONTINUE
1177*
1178 230 CONTINUE
1179 240 CONTINUE
1180*
1181* Summary
1182*
1183 CALL slasum( 'SGG', nounit, nerrs, ntestt )
1184 RETURN
1185*
1186 9999 FORMAT( ' SCHKGG: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
1187 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1188*
1189 9998 FORMAT( ' SCHKGG: ', a, ' Eigenvectors from ', a, ' incorrectly ',
1190 $ 'normalized.', / ' Bits of error=', 0p, g10.3, ',', 9x,
1191 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5,
1192 $ ')' )
1193*
1194 9997 FORMAT( / 1x, a3, ' -- Real Generalized eigenvalue problem' )
1195*
1196 9996 FORMAT( ' Matrix types (see SCHKGG for details): ' )
1197*
1198 9995 FORMAT( ' Special Matrices:', 23x,
1199 $ '(J''=transposed Jordan block)',
1200 $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
1201 $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
1202 $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
1203 $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
1204 $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
1205 $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
1206 9994 FORMAT( ' Matrices Rotated by Random ', a, ' Matrices U, V:',
1207 $ / ' 16=Transposed Jordan Blocks 19=geometric ',
1208 $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
1209 $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
1210 $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
1211 $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
1212 $ '23=(small,large) 24=(small,small) 25=(large,large)',
1213 $ / ' 26=random O(1) matrices.' )
1214*
1215 9993 FORMAT( / ' Tests performed: (H is Hessenberg, S is Schur, B, ',
1216 $ 'T, P are triangular,', / 20x, 'U, V, Q, and Z are ', a,
1217 $ ', l and r are the', / 20x,
1218 $ 'appropriate left and right eigenvectors, resp., a is',
1219 $ / 20x, 'alpha, b is beta, and ', a, ' means ', a, '.)',
1220 $ / ' 1 = | A - U H V', a,
1221 $ ' | / ( |A| n ulp ) 2 = | B - U T V', a,
1222 $ ' | / ( |B| n ulp )', / ' 3 = | I - UU', a,
1223 $ ' | / ( n ulp ) 4 = | I - VV', a,
1224 $ ' | / ( n ulp )', / ' 5 = | H - Q S Z', a,
1225 $ ' | / ( |H| n ulp )', 6x, '6 = | T - Q P Z', a,
1226 $ ' | / ( |T| n ulp )', / ' 7 = | I - QQ', a,
1227 $ ' | / ( n ulp ) 8 = | I - ZZ', a,
1228 $ ' | / ( n ulp )', / ' 9 = max | ( b S - a P )', a,
1229 $ ' l | / const. 10 = max | ( b H - a T )', a,
1230 $ ' l | / const.', /
1231 $ ' 11= max | ( b S - a P ) r | / const. 12 = max | ( b H',
1232 $ ' - a T ) r | / const.', / 1x )
1233*
1234 9992 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
1235 $ 4( i4, ',' ), ' result ', i2, ' is', 0p, f8.2 )
1236 9991 FORMAT( ' Matrix order=', i5, ', type=', i2, ', seed=',
1237 $ 4( i4, ',' ), ' result ', i2, ' is', 1p, e10.3 )
1238*
1239* End of SCHKGG
1240*
1241 END
subroutine slabad(SMALL, LARGE)
SLABAD
Definition: slabad.f:74
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: slaset.f:110
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:103
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
subroutine stgevc(SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
STGEVC
Definition: stgevc.f:295
subroutine shgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO)
SHGEQZ
Definition: shgeqz.f:304
subroutine sgeqr2(M, N, A, LDA, TAU, WORK, INFO)
SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition: sgeqr2.f:130
subroutine slarfg(N, ALPHA, X, INCX, TAU)
SLARFG generates an elementary reflector (Householder matrix).
Definition: slarfg.f:106
subroutine sorm2r(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
SORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sge...
Definition: sorm2r.f:159
subroutine sgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
SGGHRD
Definition: sgghrd.f:207
subroutine schkgg(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, TSTDIF, THRSHN, NOUNIT, A, LDA, B, H, T, S1, S2, P1, P2, U, LDU, V, Q, Z, ALPHR1, ALPHI1, BETA1, ALPHR3, ALPHI3, BETA3, EVECTL, EVECTR, WORK, LWORK, LLWORK, RESULT, INFO)
SCHKGG
Definition: schkgg.f:511
subroutine sget51(ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK, RESULT)
SGET51
Definition: sget51.f:149
subroutine sget52(LEFT, N, A, LDA, B, LDB, E, LDE, ALPHAR, ALPHAI, BETA, WORK, RESULT)
SGET52
Definition: sget52.f:199
subroutine slatm4(ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND, TRIANG, IDIST, ISEED, A, LDA)
SLATM4
Definition: slatm4.f:175
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM
Definition: slasum.f:41