001:       SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
002:      $                   ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL,
003:      $                   PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
004: *
005: *  -- LAPACK routine (version 3.2) --
006: *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
007: *     January 2007
008: *
009: *     Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
010: *
011: *     .. Scalar Arguments ..
012:       LOGICAL            WANTQ, WANTZ
013:       INTEGER            IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
014:      $                   M, N
015:       REAL               PL, PR
016: *     ..
017: *     .. Array Arguments ..
018:       LOGICAL            SELECT( * )
019:       INTEGER            IWORK( * )
020:       REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
021:      $                   B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ),
022:      $                   WORK( * ), Z( LDZ, * )
023: *     ..
024: *
025: *  Purpose
026: *  =======
027: *
028: *  STGSEN reorders the generalized real Schur decomposition of a real
029: *  matrix pair (A, B) (in terms of an orthonormal equivalence trans-
030: *  formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
031: *  appears in the leading diagonal blocks of the upper quasi-triangular
032: *  matrix A and the upper triangular B. The leading columns of Q and
033: *  Z form orthonormal bases of the corresponding left and right eigen-
034: *  spaces (deflating subspaces). (A, B) must be in generalized real
035: *  Schur canonical form (as returned by SGGES), i.e. A is block upper
036: *  triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
037: *  triangular.
038: *
039: *  STGSEN also computes the generalized eigenvalues
040: *
041: *              w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
042: *
043: *  of the reordered matrix pair (A, B).
044: *
045: *  Optionally, STGSEN computes the estimates of reciprocal condition
046: *  numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
047: *  (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
048: *  between the matrix pairs (A11, B11) and (A22,B22) that correspond to
049: *  the selected cluster and the eigenvalues outside the cluster, resp.,
050: *  and norms of "projections" onto left and right eigenspaces w.r.t.
051: *  the selected cluster in the (1,1)-block.
052: *
053: *  Arguments
054: *  =========
055: *
056: *  IJOB    (input) INTEGER
057: *          Specifies whether condition numbers are required for the
058: *          cluster of eigenvalues (PL and PR) or the deflating subspaces
059: *          (Difu and Difl):
060: *           =0: Only reorder w.r.t. SELECT. No extras.
061: *           =1: Reciprocal of norms of "projections" onto left and right
062: *               eigenspaces w.r.t. the selected cluster (PL and PR).
063: *           =2: Upper bounds on Difu and Difl. F-norm-based estimate
064: *               (DIF(1:2)).
065: *           =3: Estimate of Difu and Difl. 1-norm-based estimate
066: *               (DIF(1:2)).
067: *               About 5 times as expensive as IJOB = 2.
068: *           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
069: *               version to get it all.
070: *           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
071: *
072: *  WANTQ   (input) LOGICAL
073: *          .TRUE. : update the left transformation matrix Q;
074: *          .FALSE.: do not update Q.
075: *
076: *  WANTZ   (input) LOGICAL
077: *          .TRUE. : update the right transformation matrix Z;
078: *          .FALSE.: do not update Z.
079: *
080: *  SELECT  (input) LOGICAL array, dimension (N)
081: *          SELECT specifies the eigenvalues in the selected cluster.
082: *          To select a real eigenvalue w(j), SELECT(j) must be set to
083: *          .TRUE.. To select a complex conjugate pair of eigenvalues
084: *          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
085: *          either SELECT(j) or SELECT(j+1) or both must be set to
086: *          .TRUE.; a complex conjugate pair of eigenvalues must be
087: *          either both included in the cluster or both excluded.
088: *
089: *  N       (input) INTEGER
090: *          The order of the matrices A and B. N >= 0.
091: *
092: *  A       (input/output) REAL array, dimension(LDA,N)
093: *          On entry, the upper quasi-triangular matrix A, with (A, B) in
094: *          generalized real Schur canonical form.
095: *          On exit, A is overwritten by the reordered matrix A.
096: *
097: *  LDA     (input) INTEGER
098: *          The leading dimension of the array A. LDA >= max(1,N).
099: *
100: *  B       (input/output) REAL array, dimension(LDB,N)
101: *          On entry, the upper triangular matrix B, with (A, B) in
102: *          generalized real Schur canonical form.
103: *          On exit, B is overwritten by the reordered matrix B.
104: *
105: *  LDB     (input) INTEGER
106: *          The leading dimension of the array B. LDB >= max(1,N).
107: *
108: *  ALPHAR  (output) REAL array, dimension (N)
109: *  ALPHAI  (output) REAL array, dimension (N)
110: *  BETA    (output) REAL array, dimension (N)
111: *          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
112: *          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i
113: *          and BETA(j),j=1,...,N  are the diagonals of the complex Schur
114: *          form (S,T) that would result if the 2-by-2 diagonal blocks of
115: *          the real generalized Schur form of (A,B) were further reduced
116: *          to triangular form using complex unitary transformations.
117: *          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
118: *          positive, then the j-th and (j+1)-st eigenvalues are a
119: *          complex conjugate pair, with ALPHAI(j+1) negative.
120: *
121: *  Q       (input/output) REAL array, dimension (LDQ,N)
122: *          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
123: *          On exit, Q has been postmultiplied by the left orthogonal
124: *          transformation matrix which reorder (A, B); The leading M
125: *          columns of Q form orthonormal bases for the specified pair of
126: *          left eigenspaces (deflating subspaces).
127: *          If WANTQ = .FALSE., Q is not referenced.
128: *
129: *  LDQ     (input) INTEGER
130: *          The leading dimension of the array Q.  LDQ >= 1;
131: *          and if WANTQ = .TRUE., LDQ >= N.
132: *
133: *  Z       (input/output) REAL array, dimension (LDZ,N)
134: *          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
135: *          On exit, Z has been postmultiplied by the left orthogonal
136: *          transformation matrix which reorder (A, B); The leading M
137: *          columns of Z form orthonormal bases for the specified pair of
138: *          left eigenspaces (deflating subspaces).
139: *          If WANTZ = .FALSE., Z is not referenced.
140: *
141: *  LDZ     (input) INTEGER
142: *          The leading dimension of the array Z. LDZ >= 1;
143: *          If WANTZ = .TRUE., LDZ >= N.
144: *
145: *  M       (output) INTEGER
146: *          The dimension of the specified pair of left and right eigen-
147: *          spaces (deflating subspaces). 0 <= M <= N.
148: *
149: *  PL      (output) REAL
150: *  PR      (output) REAL
151: *          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
152: *          reciprocal of the norm of "projections" onto left and right
153: *          eigenspaces with respect to the selected cluster.
154: *          0 < PL, PR <= 1.
155: *          If M = 0 or M = N, PL = PR  = 1.
156: *          If IJOB = 0, 2 or 3, PL and PR are not referenced.
157: *
158: *  DIF     (output) REAL array, dimension (2).
159: *          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
160: *          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
161: *          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
162: *          estimates of Difu and Difl.
163: *          If M = 0 or N, DIF(1:2) = F-norm([A, B]).
164: *          If IJOB = 0 or 1, DIF is not referenced.
165: *
166: *  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))
167: *          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
168: *
169: *  LWORK   (input) INTEGER
170: *          The dimension of the array WORK. LWORK >=  4*N+16.
171: *          If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
172: *          If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
173: *
174: *          If LWORK = -1, then a workspace query is assumed; the routine
175: *          only calculates the optimal size of the WORK array, returns
176: *          this value as the first entry of the WORK array, and no error
177: *          message related to LWORK is issued by XERBLA.
178: *
179: *  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
180: *          IF IJOB = 0, IWORK is not referenced.  Otherwise,
181: *          on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
182: *
183: *  LIWORK  (input) INTEGER
184: *          The dimension of the array IWORK. LIWORK >= 1.
185: *          If IJOB = 1, 2 or 4, LIWORK >=  N+6.
186: *          If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
187: *
188: *          If LIWORK = -1, then a workspace query is assumed; the
189: *          routine only calculates the optimal size of the IWORK array,
190: *          returns this value as the first entry of the IWORK array, and
191: *          no error message related to LIWORK is issued by XERBLA.
192: *
193: *  INFO    (output) INTEGER
194: *            =0: Successful exit.
195: *            <0: If INFO = -i, the i-th argument had an illegal value.
196: *            =1: Reordering of (A, B) failed because the transformed
197: *                matrix pair (A, B) would be too far from generalized
198: *                Schur form; the problem is very ill-conditioned.
199: *                (A, B) may have been partially reordered.
200: *                If requested, 0 is returned in DIF(*), PL and PR.
201: *
202: *  Further Details
203: *  ===============
204: *
205: *  STGSEN first collects the selected eigenvalues by computing
206: *  orthogonal U and W that move them to the top left corner of (A, B).
207: *  In other words, the selected eigenvalues are the eigenvalues of
208: *  (A11, B11) in:
209: *
210: *                U'*(A, B)*W = (A11 A12) (B11 B12) n1
211: *                              ( 0  A22),( 0  B22) n2
212: *                                n1  n2    n1  n2
213: *
214: *  where N = n1+n2 and U' means the transpose of U. The first n1 columns
215: *  of U and W span the specified pair of left and right eigenspaces
216: *  (deflating subspaces) of (A, B).
217: *
218: *  If (A, B) has been obtained from the generalized real Schur
219: *  decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
220: *  reordered generalized real Schur form of (C, D) is given by
221: *
222: *           (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
223: *
224: *  and the first n1 columns of Q*U and Z*W span the corresponding
225: *  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
226: *
227: *  Note that if the selected eigenvalue is sufficiently ill-conditioned,
228: *  then its value may differ significantly from its value before
229: *  reordering.
230: *
231: *  The reciprocal condition numbers of the left and right eigenspaces
232: *  spanned by the first n1 columns of U and W (or Q*U and Z*W) may
233: *  be returned in DIF(1:2), corresponding to Difu and Difl, resp.
234: *
235: *  The Difu and Difl are defined as:
236: *
237: *       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
238: *  and
239: *       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
240: *
241: *  where sigma-min(Zu) is the smallest singular value of the
242: *  (2*n1*n2)-by-(2*n1*n2) matrix
243: *
244: *       Zu = [ kron(In2, A11)  -kron(A22', In1) ]
245: *            [ kron(In2, B11)  -kron(B22', In1) ].
246: *
247: *  Here, Inx is the identity matrix of size nx and A22' is the
248: *  transpose of A22. kron(X, Y) is the Kronecker product between
249: *  the matrices X and Y.
250: *
251: *  When DIF(2) is small, small changes in (A, B) can cause large changes
252: *  in the deflating subspace. An approximate (asymptotic) bound on the
253: *  maximum angular error in the computed deflating subspaces is
254: *
255: *       EPS * norm((A, B)) / DIF(2),
256: *
257: *  where EPS is the machine precision.
258: *
259: *  The reciprocal norm of the projectors on the left and right
260: *  eigenspaces associated with (A11, B11) may be returned in PL and PR.
261: *  They are computed as follows. First we compute L and R so that
262: *  P*(A, B)*Q is block diagonal, where
263: *
264: *       P = ( I -L ) n1           Q = ( I R ) n1
265: *           ( 0  I ) n2    and        ( 0 I ) n2
266: *             n1 n2                    n1 n2
267: *
268: *  and (L, R) is the solution to the generalized Sylvester equation
269: *
270: *       A11*R - L*A22 = -A12
271: *       B11*R - L*B22 = -B12
272: *
273: *  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
274: *  An approximate (asymptotic) bound on the average absolute error of
275: *  the selected eigenvalues is
276: *
277: *       EPS * norm((A, B)) / PL.
278: *
279: *  There are also global error bounds which valid for perturbations up
280: *  to a certain restriction:  A lower bound (x) on the smallest
281: *  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
282: *  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
283: *  (i.e. (A + E, B + F), is
284: *
285: *   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
286: *
287: *  An approximate bound on x can be computed from DIF(1:2), PL and PR.
288: *
289: *  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
290: *  (L', R') and unperturbed (L, R) left and right deflating subspaces
291: *  associated with the selected cluster in the (1,1)-blocks can be
292: *  bounded as
293: *
294: *   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
295: *   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
296: *
297: *  See LAPACK User's Guide section 4.11 or the following references
298: *  for more information.
299: *
300: *  Note that if the default method for computing the Frobenius-norm-
301: *  based estimate DIF is not wanted (see SLATDF), then the parameter
302: *  IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF
303: *  (IJOB = 2 will be used)). See STGSYL for more details.
304: *
305: *  Based on contributions by
306: *     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
307: *     Umea University, S-901 87 Umea, Sweden.
308: *
309: *  References
310: *  ==========
311: *
312: *  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
313: *      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
314: *      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
315: *      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
316: *
317: *  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
318: *      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
319: *      Estimation: Theory, Algorithms and Software,
320: *      Report UMINF - 94.04, Department of Computing Science, Umea
321: *      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
322: *      Note 87. To appear in Numerical Algorithms, 1996.
323: *
324: *  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
325: *      for Solving the Generalized Sylvester Equation and Estimating the
326: *      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
327: *      Department of Computing Science, Umea University, S-901 87 Umea,
328: *      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
329: *      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
330: *      1996.
331: *
332: *  =====================================================================
333: *
334: *     .. Parameters ..
335:       INTEGER            IDIFJB
336:       PARAMETER          ( IDIFJB = 3 )
337:       REAL               ZERO, ONE
338:       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
339: *     ..
340: *     .. Local Scalars ..
341:       LOGICAL            LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2,
342:      $                   WANTP
343:       INTEGER            I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN,
344:      $                   MN2, N1, N2
345:       REAL               DSCALE, DSUM, EPS, RDSCAL, SMLNUM
346: *     ..
347: *     .. Local Arrays ..
348:       INTEGER            ISAVE( 3 )
349: *     ..
350: *     .. External Subroutines ..
351:       EXTERNAL           SLACN2, SLACPY, SLAG2, SLASSQ, STGEXC, STGSYL,
352:      $                   XERBLA
353: *     ..
354: *     .. External Functions ..
355:       REAL               SLAMCH
356:       EXTERNAL           SLAMCH
357: *     ..
358: *     .. Intrinsic Functions ..
359:       INTRINSIC          MAX, SIGN, SQRT
360: *     ..
361: *     .. Executable Statements ..
362: *
363: *     Decode and test the input parameters
364: *
365:       INFO = 0
366:       LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
367: *
368:       IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
369:          INFO = -1
370:       ELSE IF( N.LT.0 ) THEN
371:          INFO = -5
372:       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
373:          INFO = -7
374:       ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
375:          INFO = -9
376:       ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
377:          INFO = -14
378:       ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
379:          INFO = -16
380:       END IF
381: *
382:       IF( INFO.NE.0 ) THEN
383:          CALL XERBLA( 'STGSEN', -INFO )
384:          RETURN
385:       END IF
386: *
387: *     Get machine constants
388: *
389:       EPS = SLAMCH( 'P' )
390:       SMLNUM = SLAMCH( 'S' ) / EPS
391:       IERR = 0
392: *
393:       WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
394:       WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
395:       WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
396:       WANTD = WANTD1 .OR. WANTD2
397: *
398: *     Set M to the dimension of the specified pair of deflating
399: *     subspaces.
400: *
401:       M = 0
402:       PAIR = .FALSE.
403:       DO 10 K = 1, N
404:          IF( PAIR ) THEN
405:             PAIR = .FALSE.
406:          ELSE
407:             IF( K.LT.N ) THEN
408:                IF( A( K+1, K ).EQ.ZERO ) THEN
409:                   IF( SELECT( K ) )
410:      $               M = M + 1
411:                ELSE
412:                   PAIR = .TRUE.
413:                   IF( SELECT( K ) .OR. SELECT( K+1 ) )
414:      $               M = M + 2
415:                END IF
416:             ELSE
417:                IF( SELECT( N ) )
418:      $            M = M + 1
419:             END IF
420:          END IF
421:    10 CONTINUE
422: *
423:       IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
424:          LWMIN = MAX( 1, 4*N+16, 2*M*(N-M) )
425:          LIWMIN = MAX( 1, N+6 )
426:       ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
427:          LWMIN = MAX( 1, 4*N+16, 4*M*(N-M) )
428:          LIWMIN = MAX( 1, 2*M*(N-M), N+6 )
429:       ELSE
430:          LWMIN = MAX( 1, 4*N+16 )
431:          LIWMIN = 1
432:       END IF
433: *
434:       WORK( 1 ) = LWMIN
435:       IWORK( 1 ) = LIWMIN
436: *
437:       IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
438:          INFO = -22
439:       ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
440:          INFO = -24
441:       END IF
442: *
443:       IF( INFO.NE.0 ) THEN
444:          CALL XERBLA( 'STGSEN', -INFO )
445:          RETURN
446:       ELSE IF( LQUERY ) THEN
447:          RETURN
448:       END IF
449: *
450: *     Quick return if possible.
451: *
452:       IF( M.EQ.N .OR. M.EQ.0 ) THEN
453:          IF( WANTP ) THEN
454:             PL = ONE
455:             PR = ONE
456:          END IF
457:          IF( WANTD ) THEN
458:             DSCALE = ZERO
459:             DSUM = ONE
460:             DO 20 I = 1, N
461:                CALL SLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
462:                CALL SLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
463:    20       CONTINUE
464:             DIF( 1 ) = DSCALE*SQRT( DSUM )
465:             DIF( 2 ) = DIF( 1 )
466:          END IF
467:          GO TO 60
468:       END IF
469: *
470: *     Collect the selected blocks at the top-left corner of (A, B).
471: *
472:       KS = 0
473:       PAIR = .FALSE.
474:       DO 30 K = 1, N
475:          IF( PAIR ) THEN
476:             PAIR = .FALSE.
477:          ELSE
478: *
479:             SWAP = SELECT( K )
480:             IF( K.LT.N ) THEN
481:                IF( A( K+1, K ).NE.ZERO ) THEN
482:                   PAIR = .TRUE.
483:                   SWAP = SWAP .OR. SELECT( K+1 )
484:                END IF
485:             END IF
486: *
487:             IF( SWAP ) THEN
488:                KS = KS + 1
489: *
490: *              Swap the K-th block to position KS.
491: *              Perform the reordering of diagonal blocks in (A, B)
492: *              by orthogonal transformation matrices and update
493: *              Q and Z accordingly (if requested):
494: *
495:                KK = K
496:                IF( K.NE.KS )
497:      $            CALL STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
498:      $                         Z, LDZ, KK, KS, WORK, LWORK, IERR )
499: *
500:                IF( IERR.GT.0 ) THEN
501: *
502: *                 Swap is rejected: exit.
503: *
504:                   INFO = 1
505:                   IF( WANTP ) THEN
506:                      PL = ZERO
507:                      PR = ZERO
508:                   END IF
509:                   IF( WANTD ) THEN
510:                      DIF( 1 ) = ZERO
511:                      DIF( 2 ) = ZERO
512:                   END IF
513:                   GO TO 60
514:                END IF
515: *
516:                IF( PAIR )
517:      $            KS = KS + 1
518:             END IF
519:          END IF
520:    30 CONTINUE
521:       IF( WANTP ) THEN
522: *
523: *        Solve generalized Sylvester equation for R and L
524: *        and compute PL and PR.
525: *
526:          N1 = M
527:          N2 = N - M
528:          I = N1 + 1
529:          IJB = 0
530:          CALL SLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
531:          CALL SLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
532:      $                N1 )
533:          CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
534:      $                N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
535:      $                DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
536:      $                LWORK-2*N1*N2, IWORK, IERR )
537: *
538: *        Estimate the reciprocal of norms of "projections" onto left
539: *        and right eigenspaces.
540: *
541:          RDSCAL = ZERO
542:          DSUM = ONE
543:          CALL SLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
544:          PL = RDSCAL*SQRT( DSUM )
545:          IF( PL.EQ.ZERO ) THEN
546:             PL = ONE
547:          ELSE
548:             PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
549:          END IF
550:          RDSCAL = ZERO
551:          DSUM = ONE
552:          CALL SLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
553:          PR = RDSCAL*SQRT( DSUM )
554:          IF( PR.EQ.ZERO ) THEN
555:             PR = ONE
556:          ELSE
557:             PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
558:          END IF
559:       END IF
560: *
561:       IF( WANTD ) THEN
562: *
563: *        Compute estimates of Difu and Difl.
564: *
565:          IF( WANTD1 ) THEN
566:             N1 = M
567:             N2 = N - M
568:             I = N1 + 1
569:             IJB = IDIFJB
570: *
571: *           Frobenius norm-based Difu-estimate.
572: *
573:             CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
574:      $                   N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
575:      $                   N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ),
576:      $                   LWORK-2*N1*N2, IWORK, IERR )
577: *
578: *           Frobenius norm-based Difl-estimate.
579: *
580:             CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
581:      $                   N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
582:      $                   N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ),
583:      $                   LWORK-2*N1*N2, IWORK, IERR )
584:          ELSE
585: *
586: *
587: *           Compute 1-norm-based estimates of Difu and Difl using
588: *           reversed communication with SLACN2. In each step a
589: *           generalized Sylvester equation or a transposed variant
590: *           is solved.
591: *
592:             KASE = 0
593:             N1 = M
594:             N2 = N - M
595:             I = N1 + 1
596:             IJB = 0
597:             MN2 = 2*N1*N2
598: *
599: *           1-norm-based estimate of Difu.
600: *
601:    40       CONTINUE
602:             CALL SLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ),
603:      $                   KASE, ISAVE )
604:             IF( KASE.NE.0 ) THEN
605:                IF( KASE.EQ.1 ) THEN
606: *
607: *                 Solve generalized Sylvester equation.
608: *
609:                   CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
610:      $                         WORK, N1, B, LDB, B( I, I ), LDB,
611:      $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
612:      $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
613:      $                         IERR )
614:                ELSE
615: *
616: *                 Solve the transposed variant.
617: *
618:                   CALL STGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA,
619:      $                         WORK, N1, B, LDB, B( I, I ), LDB,
620:      $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
621:      $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
622:      $                         IERR )
623:                END IF
624:                GO TO 40
625:             END IF
626:             DIF( 1 ) = DSCALE / DIF( 1 )
627: *
628: *           1-norm-based estimate of Difl.
629: *
630:    50       CONTINUE
631:             CALL SLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ),
632:      $                   KASE, ISAVE )
633:             IF( KASE.NE.0 ) THEN
634:                IF( KASE.EQ.1 ) THEN
635: *
636: *                 Solve generalized Sylvester equation.
637: *
638:                   CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
639:      $                         WORK, N2, B( I, I ), LDB, B, LDB,
640:      $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
641:      $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
642:      $                         IERR )
643:                ELSE
644: *
645: *                 Solve the transposed variant.
646: *
647:                   CALL STGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA,
648:      $                         WORK, N2, B( I, I ), LDB, B, LDB,
649:      $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
650:      $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
651:      $                         IERR )
652:                END IF
653:                GO TO 50
654:             END IF
655:             DIF( 2 ) = DSCALE / DIF( 2 )
656: *
657:          END IF
658:       END IF
659: *
660:    60 CONTINUE
661: *
662: *     Compute generalized eigenvalues of reordered pair (A, B) and 
663: *     normalize the generalized Schur form.
664: *
665:       PAIR = .FALSE.
666:       DO 70 K = 1, N
667:          IF( PAIR ) THEN
668:             PAIR = .FALSE.
669:          ELSE
670: *
671:             IF( K.LT.N ) THEN
672:                IF( A( K+1, K ).NE.ZERO ) THEN
673:                   PAIR = .TRUE.
674:                END IF
675:             END IF
676: *
677:             IF( PAIR ) THEN
678: *
679: *             Compute the eigenvalue(s) at position K.
680: *
681:                WORK( 1 ) = A( K, K )
682:                WORK( 2 ) = A( K+1, K )
683:                WORK( 3 ) = A( K, K+1 )
684:                WORK( 4 ) = A( K+1, K+1 )
685:                WORK( 5 ) = B( K, K )
686:                WORK( 6 ) = B( K+1, K )
687:                WORK( 7 ) = B( K, K+1 )
688:                WORK( 8 ) = B( K+1, K+1 )
689:                CALL SLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ),
690:      $                     BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ),
691:      $                     ALPHAI( K ) )
692:                ALPHAI( K+1 ) = -ALPHAI( K )
693: *
694:             ELSE
695: *
696:                IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN
697: *
698: *                 If B(K,K) is negative, make it positive
699: *
700:                   DO 80 I = 1, N
701:                      A( K, I ) = -A( K, I )
702:                      B( K, I ) = -B( K, I )
703:                      Q( I, K ) = -Q( I, K )
704:    80             CONTINUE
705:                END IF
706: *
707:                ALPHAR( K ) = A( K, K )
708:                ALPHAI( K ) = ZERO
709:                BETA( K ) = B( K, K )
710: *
711:             END IF
712:          END IF
713:    70 CONTINUE
714: *
715:       WORK( 1 ) = LWMIN
716:       IWORK( 1 ) = LIWMIN
717: *
718:       RETURN
719: *
720: *     End of STGSEN
721: *
722:       END
723: