LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
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  IF( nsize.EQ.0 )
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  IF( linfo.NE.0 ) 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  IF( result( 2 ).GT.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  IF( result( 3 ).GT.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  IF( s( i ).EQ.zero ) THEN
478  IF( stru( i ).GT.abnorm*ulp )
479  $ result( 3 ) = ulpinv
480  ELSE IF( stru( i ).EQ.zero ) THEN
481  IF( s( i ).GT.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  IF( dif( 1 ).EQ.zero ) THEN
494  IF( diftru( 1 ).GT.abnorm*ulp )
495  $ result( 4 ) = ulpinv
496  ELSE IF( diftru( 1 ).EQ.zero ) THEN
497  IF( dif( 1 ).GT.abnorm*ulp )
498  $ result( 4 ) = ulpinv
499  ELSE IF( dif( 5 ).EQ.zero ) THEN
500  IF( diftru( 5 ).GT.abnorm*ulp )
501  $ result( 4 ) = ulpinv
502  ELSE IF( diftru( 5 ).EQ.zero ) THEN
503  IF( dif( 5 ).GT.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  IF( ( result( j ).GE.thrsh2 .AND. j.GE.4 ) .OR.
519  $ ( result( j ).GE.thresh .AND. j.LE.3 ) )
520  $ THEN
521 *
522 * If this is the first test to fail,
523 * print a header to the data file.
524 *
525  IF( nerrs.EQ.0 ) 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  IF( result( j ).LT.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  IF( n.EQ.0 )
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  IF( linfo.NE.0 ) 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  IF( result( 2 ).GT.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  IF( result( 3 ).GT.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  IF( s( i ).EQ.zero ) THEN
629  IF( stru( i ).GT.abnorm*ulp )
630  $ result( 3 ) = ulpinv
631  ELSE IF( stru( i ).EQ.zero ) THEN
632  IF( s( i ).GT.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  IF( dif( 1 ).EQ.zero ) THEN
645  IF( diftru( 1 ).GT.abnorm*ulp )
646  $ result( 4 ) = ulpinv
647  ELSE IF( diftru( 1 ).EQ.zero ) THEN
648  IF( dif( 1 ).GT.abnorm*ulp )
649  $ result( 4 ) = ulpinv
650  ELSE IF( dif( 5 ).EQ.zero ) THEN
651  IF( diftru( 5 ).GT.abnorm*ulp )
652  $ result( 4 ) = ulpinv
653  ELSE IF( diftru( 5 ).EQ.zero ) THEN
654  IF( dif( 5 ).GT.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  IF( result( j ).GE.thrsh2 ) THEN
670 *
671 * If this is the first test to fail,
672 * print a header to the data file.
673 *
674  IF( nerrs.EQ.0 ) 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  IF( result( j ).LT.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
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 alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
Definition: alasvm.f:73
subroutine slatm6(TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, BETA, WX, WY, S, DIF)
SLATM6
Definition: slatm6.f:176
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: slange.f:114
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
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
subroutine sget52(LEFT, N, A, LDA, B, LDB, E, LDE, ALPHAR, ALPHAI, BETA, WORK, RESULT)
SGET52
Definition: sget52.f:199