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