LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
ddrgvx.f
Go to the documentation of this file.
1*> \brief \b DDRGVX
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 DDRGVX( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI,
12* ALPHAR, ALPHAI, BETA, VL, VR, ILO, IHI, LSCALE,
13* RSCALE, S, DTRU, DIF, DIFTRU, WORK, LWORK,
14* IWORK, LIWORK, RESULT, BWORK, INFO )
15*
16* .. Scalar Arguments ..
17* INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT,
18* $ NSIZE
19* DOUBLE PRECISION THRESH
20* ..
21* .. Array Arguments ..
22* LOGICAL BWORK( * )
23* INTEGER IWORK( * )
24* DOUBLE PRECISION A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
25* $ ALPHAR( * ), B( LDA, * ), BETA( * ),
26* $ BI( LDA, * ), DIF( * ), DIFTRU( * ), DTRU( * ),
27* $ LSCALE( * ), RESULT( 4 ), RSCALE( * ), S( * ),
28* $ VL( LDA, * ), VR( LDA, * ), WORK( * )
29* ..
30*
31*
32*> \par Purpose:
33* =============
34*>
35*> \verbatim
36*>
37*> DDRGVX checks the nonsymmetric generalized eigenvalue problem
38*> expert driver DGGEVX.
39*>
40*> DGGEVX computes the generalized eigenvalues, (optionally) the left
41*> and/or right eigenvectors, (optionally) computes a balancing
42*> transformation to improve the conditioning, and (optionally)
43*> reciprocal condition numbers for the eigenvalues and eigenvectors.
44*>
45*> When DDRGVX is called with NSIZE > 0, two types of test matrix pairs
46*> are generated by the subroutine DLATM6 and test the driver DGGEVX.
47*> The test matrices have the known exact condition numbers for
48*> eigenvalues. For the condition numbers of the eigenvectors
49*> corresponding the first and last eigenvalues are also know
50*> ``exactly'' (see DLATM6).
51*>
52*> For each matrix pair, the following tests will be performed and
53*> compared with the threshold THRESH.
54*>
55*> (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
56*>
57*> | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
58*>
59*> where l**H is the conjugate transpose of l.
60*>
61*> (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
62*>
63*> | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
64*>
65*> (3) The condition number S(i) of eigenvalues computed by DGGEVX
66*> differs less than a factor THRESH from the exact S(i) (see
67*> DLATM6).
68*>
69*> (4) DIF(i) computed by DTGSNA differs less than a factor 10*THRESH
70*> from the exact value (for the 1st and 5th vectors only).
71*>
72*> Test Matrices
73*> =============
74*>
75*> Two kinds of test matrix pairs
76*>
77*> (A, B) = inverse(YH) * (Da, Db) * inverse(X)
78*>
79*> are used in the tests:
80*>
81*> 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
82*> 0 2+a 0 0 0 0 1 0 0 0
83*> 0 0 3+a 0 0 0 0 1 0 0
84*> 0 0 0 4+a 0 0 0 0 1 0
85*> 0 0 0 0 5+a , 0 0 0 0 1 , and
86*>
87*> 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0
88*> 1 1 0 0 0 0 1 0 0 0
89*> 0 0 1 0 0 0 0 1 0 0
90*> 0 0 0 1+a 1+b 0 0 0 1 0
91*> 0 0 0 -1-b 1+a , 0 0 0 0 1 .
92*>
93*> In both cases the same inverse(YH) and inverse(X) are used to compute
94*> (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
95*>
96*> YH: = 1 0 -y y -y X = 1 0 -x -x x
97*> 0 1 -y y -y 0 1 x -x -x
98*> 0 0 1 0 0 0 0 1 0 0
99*> 0 0 0 1 0 0 0 0 1 0
100*> 0 0 0 0 1, 0 0 0 0 1 , where
101*>
102*> a, b, x and y will have all values independently of each other from
103*> { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }.
104*> \endverbatim
105*
106* Arguments:
107* ==========
108*
109*> \param[in] NSIZE
110*> \verbatim
111*> NSIZE is INTEGER
112*> The number of sizes of matrices to use. NSIZE must be at
113*> least zero. If it is zero, no randomly generated matrices
114*> are tested, but any test matrices read from NIN will be
115*> tested.
116*> \endverbatim
117*>
118*> \param[in] THRESH
119*> \verbatim
120*> THRESH is DOUBLE PRECISION
121*> A test will count as "failed" if the "error", computed as
122*> described above, exceeds THRESH. Note that the error
123*> is scaled to be O(1), so THRESH should be a reasonably
124*> small multiple of 1, e.g., 10 or 100. In particular,
125*> it should not depend on the precision (single vs. double)
126*> or the size of the matrix. It must be at least zero.
127*> \endverbatim
128*>
129*> \param[in] NIN
130*> \verbatim
131*> NIN is INTEGER
132*> The FORTRAN unit number for reading in the data file of
133*> problems to solve.
134*> \endverbatim
135*>
136*> \param[in] NOUT
137*> \verbatim
138*> NOUT is INTEGER
139*> The FORTRAN unit number for printing out error messages
140*> (e.g., if a routine returns IINFO not equal to 0.)
141*> \endverbatim
142*>
143*> \param[out] A
144*> \verbatim
145*> A is DOUBLE PRECISION array, dimension (LDA, NSIZE)
146*> Used to hold the matrix whose eigenvalues are to be
147*> computed. On exit, A contains the last matrix actually used.
148*> \endverbatim
149*>
150*> \param[in] LDA
151*> \verbatim
152*> LDA is INTEGER
153*> The leading dimension of A, B, AI, BI, Ao, and Bo.
154*> It must be at least 1 and at least NSIZE.
155*> \endverbatim
156*>
157*> \param[out] B
158*> \verbatim
159*> B is DOUBLE PRECISION array, dimension (LDA, NSIZE)
160*> Used to hold the matrix whose eigenvalues are to be
161*> computed. On exit, B contains the last matrix actually used.
162*> \endverbatim
163*>
164*> \param[out] AI
165*> \verbatim
166*> AI is DOUBLE PRECISION array, dimension (LDA, NSIZE)
167*> Copy of A, modified by DGGEVX.
168*> \endverbatim
169*>
170*> \param[out] BI
171*> \verbatim
172*> BI is DOUBLE PRECISION array, dimension (LDA, NSIZE)
173*> Copy of B, modified by DGGEVX.
174*> \endverbatim
175*>
176*> \param[out] ALPHAR
177*> \verbatim
178*> ALPHAR is DOUBLE PRECISION array, dimension (NSIZE)
179*> \endverbatim
180*>
181*> \param[out] ALPHAI
182*> \verbatim
183*> ALPHAI is DOUBLE PRECISION array, dimension (NSIZE)
184*> \endverbatim
185*>
186*> \param[out] BETA
187*> \verbatim
188*> BETA is DOUBLE PRECISION array, dimension (NSIZE)
189*>
190*> On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
191*> \endverbatim
192*>
193*> \param[out] VL
194*> \verbatim
195*> VL is DOUBLE PRECISION array, dimension (LDA, NSIZE)
196*> VL holds the left eigenvectors computed by DGGEVX.
197*> \endverbatim
198*>
199*> \param[out] VR
200*> \verbatim
201*> VR is DOUBLE PRECISION array, dimension (LDA, NSIZE)
202*> VR holds the right eigenvectors computed by DGGEVX.
203*> \endverbatim
204*>
205*> \param[out] ILO
206*> \verbatim
207*> ILO is INTEGER
208*> \endverbatim
209*>
210*> \param[out] IHI
211*> \verbatim
212*> IHI is INTEGER
213*> \endverbatim
214*>
215*> \param[out] LSCALE
216*> \verbatim
217*> LSCALE is DOUBLE PRECISION array, dimension (N)
218*> \endverbatim
219*>
220*> \param[out] RSCALE
221*> \verbatim
222*> RSCALE is DOUBLE PRECISION array, dimension (N)
223*> \endverbatim
224*>
225*> \param[out] S
226*> \verbatim
227*> S is DOUBLE PRECISION array, dimension (N)
228*> \endverbatim
229*>
230*> \param[out] DTRU
231*> \verbatim
232*> DTRU is DOUBLE PRECISION array, dimension (N)
233*> \endverbatim
234*>
235*> \param[out] DIF
236*> \verbatim
237*> DIF is DOUBLE PRECISION array, dimension (N)
238*> \endverbatim
239*>
240*> \param[out] DIFTRU
241*> \verbatim
242*> DIFTRU is DOUBLE PRECISION array, dimension (N)
243*> \endverbatim
244*>
245*> \param[out] WORK
246*> \verbatim
247*> WORK is DOUBLE PRECISION array, dimension (LWORK)
248*> \endverbatim
249*>
250*> \param[in] LWORK
251*> \verbatim
252*> LWORK is INTEGER
253*> Leading dimension of WORK. LWORK >= 2*N*N+12*N+16.
254*> \endverbatim
255*>
256*> \param[out] IWORK
257*> \verbatim
258*> IWORK is INTEGER array, dimension (LIWORK)
259*> \endverbatim
260*>
261*> \param[in] LIWORK
262*> \verbatim
263*> LIWORK is INTEGER
264*> Leading dimension of IWORK. Must be at least N+6.
265*> \endverbatim
266*>
267*> \param[out] RESULT
268*> \verbatim
269*> RESULT is DOUBLE PRECISION array, dimension (4)
270*> \endverbatim
271*>
272*> \param[out] BWORK
273*> \verbatim
274*> BWORK is LOGICAL array, dimension (N)
275*> \endverbatim
276*>
277*> \param[out] INFO
278*> \verbatim
279*> INFO is INTEGER
280*> = 0: successful exit
281*> < 0: if INFO = -i, the i-th argument had an illegal value.
282*> > 0: A routine returned an error code.
283*> \endverbatim
284*
285* Authors:
286* ========
287*
288*> \author Univ. of Tennessee
289*> \author Univ. of California Berkeley
290*> \author Univ. of Colorado Denver
291*> \author NAG Ltd.
292*
293*> \ingroup double_eig
294*
295* =====================================================================
296 SUBROUTINE ddrgvx( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI,
297 $ ALPHAR, ALPHAI, BETA, VL, VR, ILO, IHI, LSCALE,
298 $ RSCALE, S, DTRU, DIF, DIFTRU, WORK, LWORK,
299 $ IWORK, LIWORK, RESULT, BWORK, INFO )
300*
301* -- LAPACK test routine --
302* -- LAPACK is a software package provided by Univ. of Tennessee, --
303* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
304*
305* .. Scalar Arguments ..
306 INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT,
307 $ NSIZE
308 DOUBLE PRECISION THRESH
309* ..
310* .. Array Arguments ..
311 LOGICAL BWORK( * )
312 INTEGER IWORK( * )
313 DOUBLE PRECISION A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
314 $ alphar( * ), b( lda, * ), beta( * ),
315 $ bi( lda, * ), dif( * ), diftru( * ), dtru( * ),
316 $ lscale( * ), result( 4 ), rscale( * ), s( * ),
317 $ vl( lda, * ), vr( lda, * ), work( * )
318* ..
319*
320* =====================================================================
321*
322* .. Parameters ..
323 DOUBLE PRECISION ZERO, ONE, TEN, TNTH, HALF
324 PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0, ten = 1.0d+1,
325 $ tnth = 1.0d-1, half = 0.5d+0 )
326* ..
327* .. Local Scalars ..
328 INTEGER I, IPTYPE, IWA, IWB, IWX, IWY, J, LINFO,
329 $ MAXWRK, MINWRK, N, NERRS, NMAX, NPTKNT, NTESTT
330 DOUBLE PRECISION ABNORM, ANORM, BNORM, RATIO1, RATIO2, THRSH2,
331 $ ulp, ulpinv
332* ..
333* .. Local Arrays ..
334 DOUBLE PRECISION WEIGHT( 5 )
335* ..
336* .. External Functions ..
337 INTEGER ILAENV
338 DOUBLE PRECISION DLAMCH, DLANGE
339 EXTERNAL ILAENV, DLAMCH, DLANGE
340* ..
341* .. External Subroutines ..
342 EXTERNAL alasvm, dget52, dggevx, dlacpy, dlatm6, xerbla
343* ..
344* .. Intrinsic Functions ..
345 INTRINSIC abs, max, sqrt
346* ..
347* .. Executable Statements ..
348*
349* Check for errors
350*
351 info = 0
352*
353 nmax = 5
354*
355 IF( nsize.LT.0 ) THEN
356 info = -1
357 ELSE IF( thresh.LT.zero ) THEN
358 info = -2
359 ELSE IF( nin.LE.0 ) THEN
360 info = -3
361 ELSE IF( nout.LE.0 ) THEN
362 info = -4
363 ELSE IF( lda.LT.1 .OR. lda.LT.nmax ) THEN
364 info = -6
365 ELSE IF( liwork.LT.nmax+6 ) THEN
366 info = -26
367 END IF
368*
369* Compute workspace
370* (Note: Comments in the code beginning "Workspace:" describe the
371* minimal amount of workspace needed at that point in the code,
372* as well as the preferred amount for good performance.
373* NB refers to the optimal block size for the immediately
374* following subroutine, as returned by ILAENV.)
375*
376 minwrk = 1
377 IF( info.EQ.0 .AND. lwork.GE.1 ) THEN
378 minwrk = 2*nmax*nmax + 12*nmax + 16
379 maxwrk = 6*nmax + nmax*ilaenv( 1, 'DGEQRF', ' ', nmax, 1, nmax,
380 $ 0 )
381 maxwrk = max( maxwrk, 2*nmax*nmax+12*nmax+16 )
382 work( 1 ) = maxwrk
383 END IF
384*
385 IF( lwork.LT.minwrk )
386 $ info = -24
387*
388 IF( info.NE.0 ) THEN
389 CALL xerbla( 'DDRGVX', -info )
390 RETURN
391 END IF
392*
393 n = 5
394 ulp = dlamch( 'P' )
395 ulpinv = one / ulp
396 thrsh2 = ten*thresh
397 nerrs = 0
398 nptknt = 0
399 ntestt = 0
400*
401 IF( nsize.EQ.0 )
402 $ GO TO 90
403*
404* Parameters used for generating test matrices.
405*
406 weight( 1 ) = tnth
407 weight( 2 ) = half
408 weight( 3 ) = one
409 weight( 4 ) = one / weight( 2 )
410 weight( 5 ) = one / weight( 1 )
411*
412 DO 80 iptype = 1, 2
413 DO 70 iwa = 1, 5
414 DO 60 iwb = 1, 5
415 DO 50 iwx = 1, 5
416 DO 40 iwy = 1, 5
417*
418* generated a test matrix pair
419*
420 CALL dlatm6( iptype, 5, a, lda, b, vr, lda, vl,
421 $ lda, weight( iwa ), weight( iwb ),
422 $ weight( iwx ), weight( iwy ), dtru,
423 $ diftru )
424*
425* Compute eigenvalues/eigenvectors of (A, B).
426* Compute eigenvalue/eigenvector condition numbers
427* using computed eigenvectors.
428*
429 CALL dlacpy( 'F', n, n, a, lda, ai, lda )
430 CALL dlacpy( 'F', n, n, b, lda, bi, lda )
431*
432 CALL dggevx( 'N', 'V', 'V', 'B', n, ai, lda, bi,
433 $ lda, alphar, alphai, beta, vl, lda,
434 $ vr, lda, ilo, ihi, lscale, rscale,
435 $ anorm, bnorm, s, dif, work, lwork,
436 $ iwork, bwork, linfo )
437 IF( linfo.NE.0 ) THEN
438 result( 1 ) = ulpinv
439 WRITE( nout, fmt = 9999 )'DGGEVX', linfo, n,
440 $ iptype
441 GO TO 30
442 END IF
443*
444* Compute the norm(A, B)
445*
446 CALL dlacpy( 'Full', n, n, ai, lda, work, n )
447 CALL dlacpy( 'Full', n, n, bi, lda, work( n*n+1 ),
448 $ n )
449 abnorm = dlange( 'Fro', n, 2*n, work, n, work )
450*
451* Tests (1) and (2)
452*
453 result( 1 ) = zero
454 CALL dget52( .true., n, a, lda, b, lda, vl, lda,
455 $ alphar, alphai, beta, work,
456 $ result( 1 ) )
457 IF( result( 2 ).GT.thresh ) THEN
458 WRITE( nout, fmt = 9998 )'Left', 'DGGEVX',
459 $ result( 2 ), n, iptype, iwa, iwb, iwx, iwy
460 END IF
461*
462 result( 2 ) = zero
463 CALL dget52( .false., n, a, lda, b, lda, vr, lda,
464 $ alphar, alphai, beta, work,
465 $ result( 2 ) )
466 IF( result( 3 ).GT.thresh ) THEN
467 WRITE( nout, fmt = 9998 )'Right', 'DGGEVX',
468 $ result( 3 ), n, iptype, iwa, iwb, iwx, iwy
469 END IF
470*
471* Test (3)
472*
473 result( 3 ) = zero
474 DO 10 i = 1, n
475 IF( s( i ).EQ.zero ) THEN
476 IF( dtru( i ).GT.abnorm*ulp )
477 $ result( 3 ) = ulpinv
478 ELSE IF( dtru( i ).EQ.zero ) THEN
479 IF( s( i ).GT.abnorm*ulp )
480 $ result( 3 ) = ulpinv
481 ELSE
482 work( i ) = max( abs( dtru( i ) / s( i ) ),
483 $ abs( s( i ) / dtru( i ) ) )
484 result( 3 ) = max( result( 3 ), work( i ) )
485 END IF
486 10 CONTINUE
487*
488* Test (4)
489*
490 result( 4 ) = zero
491 IF( dif( 1 ).EQ.zero ) THEN
492 IF( diftru( 1 ).GT.abnorm*ulp )
493 $ result( 4 ) = ulpinv
494 ELSE IF( diftru( 1 ).EQ.zero ) THEN
495 IF( dif( 1 ).GT.abnorm*ulp )
496 $ result( 4 ) = ulpinv
497 ELSE IF( dif( 5 ).EQ.zero ) THEN
498 IF( diftru( 5 ).GT.abnorm*ulp )
499 $ result( 4 ) = ulpinv
500 ELSE IF( diftru( 5 ).EQ.zero ) THEN
501 IF( dif( 5 ).GT.abnorm*ulp )
502 $ result( 4 ) = ulpinv
503 ELSE
504 ratio1 = max( abs( diftru( 1 ) / dif( 1 ) ),
505 $ abs( dif( 1 ) / diftru( 1 ) ) )
506 ratio2 = max( abs( diftru( 5 ) / dif( 5 ) ),
507 $ abs( dif( 5 ) / diftru( 5 ) ) )
508 result( 4 ) = max( ratio1, ratio2 )
509 END IF
510*
511 ntestt = ntestt + 4
512*
513* Print out tests which fail.
514*
515 DO 20 j = 1, 4
516 IF( ( result( j ).GE.thrsh2 .AND. j.GE.4 ) .OR.
517 $ ( result( j ).GE.thresh .AND. j.LE.3 ) )
518 $ THEN
519*
520* If this is the first test to fail,
521* print a header to the data file.
522*
523 IF( nerrs.EQ.0 ) THEN
524 WRITE( nout, fmt = 9997 )'DXV'
525*
526* Print out messages for built-in examples
527*
528* Matrix types
529*
530 WRITE( nout, fmt = 9995 )
531 WRITE( nout, fmt = 9994 )
532 WRITE( nout, fmt = 9993 )
533*
534* Tests performed
535*
536 WRITE( nout, fmt = 9992 )'''',
537 $ 'transpose', ''''
538*
539 END IF
540 nerrs = nerrs + 1
541 IF( result( j ).LT.10000.0d0 ) THEN
542 WRITE( nout, fmt = 9991 )iptype, iwa,
543 $ iwb, iwx, iwy, j, result( j )
544 ELSE
545 WRITE( nout, fmt = 9990 )iptype, iwa,
546 $ iwb, iwx, iwy, j, result( j )
547 END IF
548 END IF
549 20 CONTINUE
550*
551 30 CONTINUE
552*
553 40 CONTINUE
554 50 CONTINUE
555 60 CONTINUE
556 70 CONTINUE
557 80 CONTINUE
558*
559 GO TO 150
560*
561 90 CONTINUE
562*
563* Read in data from file to check accuracy of condition estimation
564* Read input data until N=0
565*
566 READ( nin, fmt = *, END = 150 )n
567 IF( n.EQ.0 )
568 $ GO TO 150
569 DO 100 i = 1, n
570 READ( nin, fmt = * )( a( i, j ), j = 1, n )
571 100 CONTINUE
572 DO 110 i = 1, n
573 READ( nin, fmt = * )( b( i, j ), j = 1, n )
574 110 CONTINUE
575 READ( nin, fmt = * )( dtru( i ), i = 1, n )
576 READ( nin, fmt = * )( diftru( i ), i = 1, n )
577*
578 nptknt = nptknt + 1
579*
580* Compute eigenvalues/eigenvectors of (A, B).
581* Compute eigenvalue/eigenvector condition numbers
582* using computed eigenvectors.
583*
584 CALL dlacpy( 'F', n, n, a, lda, ai, lda )
585 CALL dlacpy( 'F', n, n, b, lda, bi, lda )
586*
587 CALL dggevx( 'N', 'V', 'V', 'B', n, ai, lda, bi, lda, alphar,
588 $ alphai, beta, vl, lda, vr, lda, ilo, ihi, lscale,
589 $ rscale, anorm, bnorm, s, dif, work, lwork, iwork,
590 $ bwork, linfo )
591*
592 IF( linfo.NE.0 ) THEN
593 result( 1 ) = ulpinv
594 WRITE( nout, fmt = 9987 )'DGGEVX', linfo, n, nptknt
595 GO TO 140
596 END IF
597*
598* Compute the norm(A, B)
599*
600 CALL dlacpy( 'Full', n, n, ai, lda, work, n )
601 CALL dlacpy( 'Full', n, n, bi, lda, work( n*n+1 ), n )
602 abnorm = dlange( 'Fro', n, 2*n, work, n, work )
603*
604* Tests (1) and (2)
605*
606 result( 1 ) = zero
607 CALL dget52( .true., n, a, lda, b, lda, vl, lda, alphar, alphai,
608 $ beta, work, result( 1 ) )
609 IF( result( 2 ).GT.thresh ) THEN
610 WRITE( nout, fmt = 9986 )'Left', 'DGGEVX', result( 2 ), n,
611 $ nptknt
612 END IF
613*
614 result( 2 ) = zero
615 CALL dget52( .false., n, a, lda, b, lda, vr, lda, alphar, alphai,
616 $ beta, work, result( 2 ) )
617 IF( result( 3 ).GT.thresh ) THEN
618 WRITE( nout, fmt = 9986 )'Right', 'DGGEVX', result( 3 ), n,
619 $ nptknt
620 END IF
621*
622* Test (3)
623*
624 result( 3 ) = zero
625 DO 120 i = 1, n
626 IF( s( i ).EQ.zero ) THEN
627 IF( dtru( i ).GT.abnorm*ulp )
628 $ result( 3 ) = ulpinv
629 ELSE IF( dtru( i ).EQ.zero ) THEN
630 IF( s( i ).GT.abnorm*ulp )
631 $ result( 3 ) = ulpinv
632 ELSE
633 work( i ) = max( abs( dtru( i ) / s( i ) ),
634 $ abs( s( i ) / dtru( i ) ) )
635 result( 3 ) = max( result( 3 ), work( i ) )
636 END IF
637 120 CONTINUE
638*
639* Test (4)
640*
641 result( 4 ) = zero
642 IF( dif( 1 ).EQ.zero ) THEN
643 IF( diftru( 1 ).GT.abnorm*ulp )
644 $ result( 4 ) = ulpinv
645 ELSE IF( diftru( 1 ).EQ.zero ) THEN
646 IF( dif( 1 ).GT.abnorm*ulp )
647 $ result( 4 ) = ulpinv
648 ELSE IF( dif( 5 ).EQ.zero ) THEN
649 IF( diftru( 5 ).GT.abnorm*ulp )
650 $ result( 4 ) = ulpinv
651 ELSE IF( diftru( 5 ).EQ.zero ) THEN
652 IF( dif( 5 ).GT.abnorm*ulp )
653 $ result( 4 ) = ulpinv
654 ELSE
655 ratio1 = max( abs( diftru( 1 ) / dif( 1 ) ),
656 $ abs( dif( 1 ) / diftru( 1 ) ) )
657 ratio2 = max( abs( diftru( 5 ) / dif( 5 ) ),
658 $ abs( dif( 5 ) / diftru( 5 ) ) )
659 result( 4 ) = max( ratio1, ratio2 )
660 END IF
661*
662 ntestt = ntestt + 4
663*
664* Print out tests which fail.
665*
666 DO 130 j = 1, 4
667 IF( result( j ).GE.thrsh2 ) THEN
668*
669* If this is the first test to fail,
670* print a header to the data file.
671*
672 IF( nerrs.EQ.0 ) THEN
673 WRITE( nout, fmt = 9997 )'DXV'
674*
675* Print out messages for built-in examples
676*
677* Matrix types
678*
679 WRITE( nout, fmt = 9996 )
680*
681* Tests performed
682*
683 WRITE( nout, fmt = 9992 )'''', 'transpose', ''''
684*
685 END IF
686 nerrs = nerrs + 1
687 IF( result( j ).LT.10000.0d0 ) THEN
688 WRITE( nout, fmt = 9989 )nptknt, n, j, result( j )
689 ELSE
690 WRITE( nout, fmt = 9988 )nptknt, n, j, result( j )
691 END IF
692 END IF
693 130 CONTINUE
694*
695 140 CONTINUE
696*
697 GO TO 90
698 150 CONTINUE
699*
700* Summary
701*
702 CALL alasvm( 'DXV', nout, nerrs, ntestt, 0 )
703*
704 work( 1 ) = maxwrk
705*
706 RETURN
707*
708 9999 FORMAT( ' DDRGVX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
709 $ i6, ', JTYPE=', i6, ')' )
710*
711 9998 FORMAT( ' DDRGVX: ', a, ' Eigenvectors from ', a, ' incorrectly ',
712 $ 'normalized.', / ' Bits of error=', 0p, g10.3, ',', 9x,
713 $ 'N=', i6, ', JTYPE=', i6, ', IWA=', i5, ', IWB=', i5,
714 $ ', IWX=', i5, ', IWY=', i5 )
715*
716 9997 FORMAT( / 1x, a3, ' -- Real Expert Eigenvalue/vector',
717 $ ' problem driver' )
718*
719 9996 FORMAT( ' Input Example' )
720*
721 9995 FORMAT( ' Matrix types: ', / )
722*
723 9994 FORMAT( ' TYPE 1: Da is diagonal, Db is identity, ',
724 $ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
725 $ / ' YH and X are left and right eigenvectors. ', / )
726*
727 9993 FORMAT( ' TYPE 2: Da is quasi-diagonal, Db is identity, ',
728 $ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
729 $ / ' YH and X are left and right eigenvectors. ', / )
730*
731 9992 FORMAT( / ' Tests performed: ', / 4x,
732 $ ' a is alpha, b is beta, l is a left eigenvector, ', / 4x,
733 $ ' r is a right eigenvector and ', a, ' means ', a, '.',
734 $ / ' 1 = max | ( b A - a B )', a, ' l | / const.',
735 $ / ' 2 = max | ( b A - a B ) r | / const.',
736 $ / ' 3 = max ( Sest/Stru, Stru/Sest ) ',
737 $ ' over all eigenvalues', /
738 $ ' 4 = max( DIFest/DIFtru, DIFtru/DIFest ) ',
739 $ ' over the 1st and 5th eigenvectors', / )
740*
741 9991 FORMAT( ' Type=', i2, ',', ' IWA=', i2, ', IWB=', i2, ', IWX=',
742 $ i2, ', IWY=', i2, ', result ', i2, ' is', 0p, f8.2 )
743 9990 FORMAT( ' Type=', i2, ',', ' IWA=', i2, ', IWB=', i2, ', IWX=',
744 $ i2, ', IWY=', i2, ', result ', i2, ' is', 1p, d10.3 )
745 9989 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
746 $ ' result ', i2, ' is', 0p, f8.2 )
747 9988 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
748 $ ' result ', i2, ' is', 1p, d10.3 )
749 9987 FORMAT( ' DDRGVX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
750 $ i6, ', Input example #', i2, ')' )
751*
752 9986 FORMAT( ' DDRGVX: ', a, ' Eigenvectors from ', a, ' incorrectly ',
753 $ 'normalized.', / ' Bits of error=', 0p, g10.3, ',', 9x,
754 $ 'N=', i6, ', Input Example #', i2, ')' )
755*
756*
757* End of DDRGVX
758*
759 END
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285
ddrgvx
subroutine ddrgvx(nsize, thresh, nin, nout, a, lda, b, ai, bi, alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, s, dtru, dif, diftru, work, lwork, iwork, liwork, result, bwork, info)
DDRGVX
Definition ddrgvx.f:300
dget52
subroutine dget52(left, n, a, lda, b, ldb, e, lde, alphar, alphai, beta, work, result)
DGET52
Definition dget52.f:199
dlatm6
subroutine dlatm6(type, n, a, lda, b, x, ldx, y, ldy, alpha, beta, wx, wy, s, dif)
DLATM6
Definition dlatm6.f:176
dggevx
subroutine dggevx(balanc, jobvl, jobvr, sense, n, a, lda, b, ldb, alphar, alphai, beta, vl, ldvl, vr, ldvr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, lwork, iwork, bwork, info)
DGGEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
Definition dggevx.f:391
dlacpy
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.
Definition dlacpy.f:103
dlange
double precision function dlange(norm, m, n, a, lda, work)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition dlange.f:114