```001:       SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
002:      \$                  BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
003: *
004: *  -- LAPACK driver routine (version 3.2) --
005: *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
006: *     November 2006
007: *
008: *     .. Scalar Arguments ..
009:       CHARACTER          JOBVL, JOBVR
010:       INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, N
011: *     ..
012: *     .. Array Arguments ..
013:       REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
014:      \$                   B( LDB, * ), BETA( * ), VL( LDVL, * ),
015:      \$                   VR( LDVR, * ), WORK( * )
016: *     ..
017: *
018: *  Purpose
019: *  =======
020: *
021: *  SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
022: *  the generalized eigenvalues, and optionally, the left and/or right
023: *  generalized eigenvectors.
024: *
025: *  A generalized eigenvalue for a pair of matrices (A,B) is a scalar
026: *  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
027: *  singular. It is usually represented as the pair (alpha,beta), as
028: *  there is a reasonable interpretation for beta=0, and even for both
029: *  being zero.
030: *
031: *  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
032: *  of (A,B) satisfies
033: *
034: *                   A * v(j) = lambda(j) * B * v(j).
035: *
036: *  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
037: *  of (A,B) satisfies
038: *
039: *                   u(j)**H * A  = lambda(j) * u(j)**H * B .
040: *
041: *  where u(j)**H is the conjugate-transpose of u(j).
042: *
043: *
044: *  Arguments
045: *  =========
046: *
047: *  JOBVL   (input) CHARACTER*1
048: *          = 'N':  do not compute the left generalized eigenvectors;
049: *          = 'V':  compute the left generalized eigenvectors.
050: *
051: *  JOBVR   (input) CHARACTER*1
052: *          = 'N':  do not compute the right generalized eigenvectors;
053: *          = 'V':  compute the right generalized eigenvectors.
054: *
055: *  N       (input) INTEGER
056: *          The order of the matrices A, B, VL, and VR.  N >= 0.
057: *
058: *  A       (input/output) REAL array, dimension (LDA, N)
059: *          On entry, the matrix A in the pair (A,B).
060: *          On exit, A has been overwritten.
061: *
062: *  LDA     (input) INTEGER
063: *          The leading dimension of A.  LDA >= max(1,N).
064: *
065: *  B       (input/output) REAL array, dimension (LDB, N)
066: *          On entry, the matrix B in the pair (A,B).
067: *          On exit, B has been overwritten.
068: *
069: *  LDB     (input) INTEGER
070: *          The leading dimension of B.  LDB >= max(1,N).
071: *
072: *  ALPHAR  (output) REAL array, dimension (N)
073: *  ALPHAI  (output) REAL array, dimension (N)
074: *  BETA    (output) REAL array, dimension (N)
075: *          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
076: *          be the generalized eigenvalues.  If ALPHAI(j) is zero, then
077: *          the j-th eigenvalue is real; if positive, then the j-th and
078: *          (j+1)-st eigenvalues are a complex conjugate pair, with
079: *          ALPHAI(j+1) negative.
080: *
081: *          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
082: *          may easily over- or underflow, and BETA(j) may even be zero.
083: *          Thus, the user should avoid naively computing the ratio
084: *          alpha/beta.  However, ALPHAR and ALPHAI will be always less
085: *          than and usually comparable with norm(A) in magnitude, and
086: *          BETA always less than and usually comparable with norm(B).
087: *
088: *  VL      (output) REAL array, dimension (LDVL,N)
089: *          If JOBVL = 'V', the left eigenvectors u(j) are stored one
090: *          after another in the columns of VL, in the same order as
091: *          their eigenvalues. If the j-th eigenvalue is real, then
092: *          u(j) = VL(:,j), the j-th column of VL. If the j-th and
093: *          (j+1)-th eigenvalues form a complex conjugate pair, then
094: *          u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
095: *          Each eigenvector is scaled so the largest component has
096: *          abs(real part)+abs(imag. part)=1.
097: *          Not referenced if JOBVL = 'N'.
098: *
099: *  LDVL    (input) INTEGER
100: *          The leading dimension of the matrix VL. LDVL >= 1, and
101: *          if JOBVL = 'V', LDVL >= N.
102: *
103: *  VR      (output) REAL array, dimension (LDVR,N)
104: *          If JOBVR = 'V', the right eigenvectors v(j) are stored one
105: *          after another in the columns of VR, in the same order as
106: *          their eigenvalues. If the j-th eigenvalue is real, then
107: *          v(j) = VR(:,j), the j-th column of VR. If the j-th and
108: *          (j+1)-th eigenvalues form a complex conjugate pair, then
109: *          v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
110: *          Each eigenvector is scaled so the largest component has
111: *          abs(real part)+abs(imag. part)=1.
112: *          Not referenced if JOBVR = 'N'.
113: *
114: *  LDVR    (input) INTEGER
115: *          The leading dimension of the matrix VR. LDVR >= 1, and
116: *          if JOBVR = 'V', LDVR >= N.
117: *
118: *  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))
119: *          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
120: *
121: *  LWORK   (input) INTEGER
122: *          The dimension of the array WORK.  LWORK >= max(1,8*N).
123: *          For good performance, LWORK must generally be larger.
124: *
125: *          If LWORK = -1, then a workspace query is assumed; the routine
126: *          only calculates the optimal size of the WORK array, returns
127: *          this value as the first entry of the WORK array, and no error
128: *          message related to LWORK is issued by XERBLA.
129: *
130: *  INFO    (output) INTEGER
131: *          = 0:  successful exit
132: *          < 0:  if INFO = -i, the i-th argument had an illegal value.
133: *          = 1,...,N:
134: *                The QZ iteration failed.  No eigenvectors have been
135: *                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
136: *                should be correct for j=INFO+1,...,N.
137: *          > N:  =N+1: other than QZ iteration failed in SHGEQZ.
138: *                =N+2: error return from STGEVC.
139: *
140: *  =====================================================================
141: *
142: *     .. Parameters ..
143:       REAL               ZERO, ONE
144:       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
145: *     ..
146: *     .. Local Scalars ..
147:       LOGICAL            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
148:       CHARACTER          CHTEMP
149:       INTEGER            ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
150:      \$                   IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK,
151:      \$                   MINWRK
152:       REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
153:      \$                   SMLNUM, TEMP
154: *     ..
155: *     .. Local Arrays ..
156:       LOGICAL            LDUMMA( 1 )
157: *     ..
158: *     .. External Subroutines ..
159:       EXTERNAL           SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
160:      \$                   SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGEVC,
161:      \$                   XERBLA
162: *     ..
163: *     .. External Functions ..
164:       LOGICAL            LSAME
165:       INTEGER            ILAENV
166:       REAL               SLAMCH, SLANGE
167:       EXTERNAL           LSAME, ILAENV, SLAMCH, SLANGE
168: *     ..
169: *     .. Intrinsic Functions ..
170:       INTRINSIC          ABS, MAX, SQRT
171: *     ..
172: *     .. Executable Statements ..
173: *
174: *     Decode the input arguments
175: *
176:       IF( LSAME( JOBVL, 'N' ) ) THEN
177:          IJOBVL = 1
178:          ILVL = .FALSE.
179:       ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
180:          IJOBVL = 2
181:          ILVL = .TRUE.
182:       ELSE
183:          IJOBVL = -1
184:          ILVL = .FALSE.
185:       END IF
186: *
187:       IF( LSAME( JOBVR, 'N' ) ) THEN
188:          IJOBVR = 1
189:          ILVR = .FALSE.
190:       ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
191:          IJOBVR = 2
192:          ILVR = .TRUE.
193:       ELSE
194:          IJOBVR = -1
195:          ILVR = .FALSE.
196:       END IF
197:       ILV = ILVL .OR. ILVR
198: *
199: *     Test the input arguments
200: *
201:       INFO = 0
202:       LQUERY = ( LWORK.EQ.-1 )
203:       IF( IJOBVL.LE.0 ) THEN
204:          INFO = -1
205:       ELSE IF( IJOBVR.LE.0 ) THEN
206:          INFO = -2
207:       ELSE IF( N.LT.0 ) THEN
208:          INFO = -3
209:       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
210:          INFO = -5
211:       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
212:          INFO = -7
213:       ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
214:          INFO = -12
215:       ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
216:          INFO = -14
217:       END IF
218: *
219: *     Compute workspace
220: *      (Note: Comments in the code beginning "Workspace:" describe the
221: *       minimal amount of workspace needed at that point in the code,
222: *       as well as the preferred amount for good performance.
223: *       NB refers to the optimal block size for the immediately
224: *       following subroutine, as returned by ILAENV. The workspace is
225: *       computed assuming ILO = 1 and IHI = N, the worst case.)
226: *
227:       IF( INFO.EQ.0 ) THEN
228:          MINWRK = MAX( 1, 8*N )
229:          MAXWRK = MAX( 1, N*( 7 +
230:      \$                 ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) ) )
231:          MAXWRK = MAX( MAXWRK, N*( 7 +
232:      \$                 ILAENV( 1, 'SORMQR', ' ', N, 1, N, 0 ) ) )
233:          IF( ILVL ) THEN
234:             MAXWRK = MAX( MAXWRK, N*( 7 +
235:      \$                 ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) ) )
236:          END IF
237:          WORK( 1 ) = MAXWRK
238: *
239:          IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
240:      \$      INFO = -16
241:       END IF
242: *
243:       IF( INFO.NE.0 ) THEN
244:          CALL XERBLA( 'SGGEV ', -INFO )
245:          RETURN
246:       ELSE IF( LQUERY ) THEN
247:          RETURN
248:       END IF
249: *
250: *     Quick return if possible
251: *
252:       IF( N.EQ.0 )
253:      \$   RETURN
254: *
255: *     Get machine constants
256: *
257:       EPS = SLAMCH( 'P' )
258:       SMLNUM = SLAMCH( 'S' )
259:       BIGNUM = ONE / SMLNUM
260:       CALL SLABAD( SMLNUM, BIGNUM )
261:       SMLNUM = SQRT( SMLNUM ) / EPS
262:       BIGNUM = ONE / SMLNUM
263: *
264: *     Scale A if max element outside range [SMLNUM,BIGNUM]
265: *
266:       ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
267:       ILASCL = .FALSE.
268:       IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
269:          ANRMTO = SMLNUM
270:          ILASCL = .TRUE.
271:       ELSE IF( ANRM.GT.BIGNUM ) THEN
272:          ANRMTO = BIGNUM
273:          ILASCL = .TRUE.
274:       END IF
275:       IF( ILASCL )
276:      \$   CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
277: *
278: *     Scale B if max element outside range [SMLNUM,BIGNUM]
279: *
280:       BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
281:       ILBSCL = .FALSE.
282:       IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
283:          BNRMTO = SMLNUM
284:          ILBSCL = .TRUE.
285:       ELSE IF( BNRM.GT.BIGNUM ) THEN
286:          BNRMTO = BIGNUM
287:          ILBSCL = .TRUE.
288:       END IF
289:       IF( ILBSCL )
290:      \$   CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
291: *
292: *     Permute the matrices A, B to isolate eigenvalues if possible
293: *     (Workspace: need 6*N)
294: *
295:       ILEFT = 1
296:       IRIGHT = N + 1
297:       IWRK = IRIGHT + N
298:       CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
299:      \$             WORK( IRIGHT ), WORK( IWRK ), IERR )
300: *
301: *     Reduce B to triangular form (QR decomposition of B)
302: *     (Workspace: need N, prefer N*NB)
303: *
304:       IROWS = IHI + 1 - ILO
305:       IF( ILV ) THEN
306:          ICOLS = N + 1 - ILO
307:       ELSE
308:          ICOLS = IROWS
309:       END IF
310:       ITAU = IWRK
311:       IWRK = ITAU + IROWS
312:       CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
313:      \$             WORK( IWRK ), LWORK+1-IWRK, IERR )
314: *
315: *     Apply the orthogonal transformation to matrix A
316: *     (Workspace: need N, prefer N*NB)
317: *
318:       CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
319:      \$             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
320:      \$             LWORK+1-IWRK, IERR )
321: *
322: *     Initialize VL
323: *     (Workspace: need N, prefer N*NB)
324: *
325:       IF( ILVL ) THEN
326:          CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
327:          IF( IROWS.GT.1 ) THEN
328:             CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
329:      \$                   VL( ILO+1, ILO ), LDVL )
330:          END IF
331:          CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
332:      \$                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
333:       END IF
334: *
335: *     Initialize VR
336: *
337:       IF( ILVR )
338:      \$   CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
339: *
340: *     Reduce to generalized Hessenberg form
341: *     (Workspace: none needed)
342: *
343:       IF( ILV ) THEN
344: *
345: *        Eigenvectors requested -- work on whole matrix.
346: *
347:          CALL SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
348:      \$                LDVL, VR, LDVR, IERR )
349:       ELSE
350:          CALL SGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
351:      \$                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
352:       END IF
353: *
354: *     Perform QZ algorithm (Compute eigenvalues, and optionally, the
355: *     Schur forms and Schur vectors)
356: *     (Workspace: need N)
357: *
358:       IWRK = ITAU
359:       IF( ILV ) THEN
360:          CHTEMP = 'S'
361:       ELSE
362:          CHTEMP = 'E'
363:       END IF
364:       CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
365:      \$             ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
366:      \$             WORK( IWRK ), LWORK+1-IWRK, IERR )
367:       IF( IERR.NE.0 ) THEN
368:          IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
369:             INFO = IERR
370:          ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
371:             INFO = IERR - N
372:          ELSE
373:             INFO = N + 1
374:          END IF
375:          GO TO 110
376:       END IF
377: *
378: *     Compute Eigenvectors
379: *     (Workspace: need 6*N)
380: *
381:       IF( ILV ) THEN
382:          IF( ILVL ) THEN
383:             IF( ILVR ) THEN
384:                CHTEMP = 'B'
385:             ELSE
386:                CHTEMP = 'L'
387:             END IF
388:          ELSE
389:             CHTEMP = 'R'
390:          END IF
391:          CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
392:      \$                VR, LDVR, N, IN, WORK( IWRK ), IERR )
393:          IF( IERR.NE.0 ) THEN
394:             INFO = N + 2
395:             GO TO 110
396:          END IF
397: *
398: *        Undo balancing on VL and VR and normalization
399: *        (Workspace: none needed)
400: *
401:          IF( ILVL ) THEN
402:             CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
403:      \$                   WORK( IRIGHT ), N, VL, LDVL, IERR )
404:             DO 50 JC = 1, N
405:                IF( ALPHAI( JC ).LT.ZERO )
406:      \$            GO TO 50
407:                TEMP = ZERO
408:                IF( ALPHAI( JC ).EQ.ZERO ) THEN
409:                   DO 10 JR = 1, N
410:                      TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
411:    10             CONTINUE
412:                ELSE
413:                   DO 20 JR = 1, N
414:                      TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
415:      \$                      ABS( VL( JR, JC+1 ) ) )
416:    20             CONTINUE
417:                END IF
418:                IF( TEMP.LT.SMLNUM )
419:      \$            GO TO 50
420:                TEMP = ONE / TEMP
421:                IF( ALPHAI( JC ).EQ.ZERO ) THEN
422:                   DO 30 JR = 1, N
423:                      VL( JR, JC ) = VL( JR, JC )*TEMP
424:    30             CONTINUE
425:                ELSE
426:                   DO 40 JR = 1, N
427:                      VL( JR, JC ) = VL( JR, JC )*TEMP
428:                      VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
429:    40             CONTINUE
430:                END IF
431:    50       CONTINUE
432:          END IF
433:          IF( ILVR ) THEN
434:             CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
435:      \$                   WORK( IRIGHT ), N, VR, LDVR, IERR )
436:             DO 100 JC = 1, N
437:                IF( ALPHAI( JC ).LT.ZERO )
438:      \$            GO TO 100
439:                TEMP = ZERO
440:                IF( ALPHAI( JC ).EQ.ZERO ) THEN
441:                   DO 60 JR = 1, N
442:                      TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
443:    60             CONTINUE
444:                ELSE
445:                   DO 70 JR = 1, N
446:                      TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
447:      \$                      ABS( VR( JR, JC+1 ) ) )
448:    70             CONTINUE
449:                END IF
450:                IF( TEMP.LT.SMLNUM )
451:      \$            GO TO 100
452:                TEMP = ONE / TEMP
453:                IF( ALPHAI( JC ).EQ.ZERO ) THEN
454:                   DO 80 JR = 1, N
455:                      VR( JR, JC ) = VR( JR, JC )*TEMP
456:    80             CONTINUE
457:                ELSE
458:                   DO 90 JR = 1, N
459:                      VR( JR, JC ) = VR( JR, JC )*TEMP
460:                      VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
461:    90             CONTINUE
462:                END IF
463:   100       CONTINUE
464:          END IF
465: *
466: *        End of eigenvector calculation
467: *
468:       END IF
469: *
470: *     Undo scaling if necessary
471: *
472:       IF( ILASCL ) THEN
473:          CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
474:          CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
475:       END IF
476: *
477:       IF( ILBSCL ) THEN
478:          CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
479:       END IF
480: *
481:   110 CONTINUE
482: *
483:       WORK( 1 ) = MAXWRK
484: *
485:       RETURN
486: *
487: *     End of SGGEV
488: *
489:       END
490: ```