stgsen.f

          SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB,
         $                   ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL,
         $                   PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )
    *
    *  -- LAPACK routine (version 3.1.1) --
    *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
    *     January 2007
    *
    *     Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
    *
    *     .. Scalar Arguments ..
          LOGICAL            WANTQ, WANTZ
          INTEGER            IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
         $                   M, N
          REAL               PL, PR
    *     ..
    *     .. Array Arguments ..
          LOGICAL            SELECT( * )
          INTEGER            IWORK( * )
          REAL               A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
         $                   B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ),
         $                   WORK( * ), Z( LDZ, * )
    *     ..
    *
    *  Purpose
    *  =======
    *
    *  STGSEN reorders the generalized real Schur decomposition of a real
    *  matrix pair (A, B) (in terms of an orthonormal equivalence trans-
    *  formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
    *  appears in the leading diagonal blocks of the upper quasi-triangular
    *  matrix A and the upper triangular B. The leading columns of Q and
    *  Z form orthonormal bases of the corresponding left and right eigen-
    *  spaces (deflating subspaces). (A, B) must be in generalized real
    *  Schur canonical form (as returned by SGGES), i.e. A is block upper
    *  triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
    *  triangular.
    *
    *  STGSEN also computes the generalized eigenvalues
    *
    *              w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
    *
    *  of the reordered matrix pair (A, B).
    *
    *  Optionally, STGSEN computes the estimates of reciprocal condition
    *  numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
    *  (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
    *  between the matrix pairs (A11, B11) and (A22,B22) that correspond to
    *  the selected cluster and the eigenvalues outside the cluster, resp.,
    *  and norms of "projections" onto left and right eigenspaces w.r.t.
    *  the selected cluster in the (1,1)-block.
    *
    *  Arguments
    *  =========
    *
    *  IJOB    (input) INTEGER
    *          Specifies whether condition numbers are required for the
    *          cluster of eigenvalues (PL and PR) or the deflating subspaces
    *          (Difu and Difl):
    *           =0: Only reorder w.r.t. SELECT. No extras.
    *           =1: Reciprocal of norms of "projections" onto left and right
    *               eigenspaces w.r.t. the selected cluster (PL and PR).
    *           =2: Upper bounds on Difu and Difl. F-norm-based estimate
    *               (DIF(1:2)).
    *           =3: Estimate of Difu and Difl. 1-norm-based estimate
    *               (DIF(1:2)).
    *               About 5 times as expensive as IJOB = 2.
    *           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
    *               version to get it all.
    *           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
    *
    *  WANTQ   (input) LOGICAL
    *          .TRUE. : update the left transformation matrix Q;
    *          .FALSE.: do not update Q.
    *
    *  WANTZ   (input) LOGICAL
    *          .TRUE. : update the right transformation matrix Z;
    *          .FALSE.: do not update Z.
    *
    *  SELECT  (input) LOGICAL array, dimension (N)
    *          SELECT specifies the eigenvalues in the selected cluster.
    *          To select a real eigenvalue w(j), SELECT(j) must be set to
    *          .TRUE.. To select a complex conjugate pair of eigenvalues
    *          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
    *          either SELECT(j) or SELECT(j+1) or both must be set to
    *          .TRUE.; a complex conjugate pair of eigenvalues must be
    *          either both included in the cluster or both excluded.
    *
    *  N       (input) INTEGER
    *          The order of the matrices A and B. N >= 0.
    *
    *  A       (input/output) REAL array, dimension(LDA,N)
    *          On entry, the upper quasi-triangular matrix A, with (A, B) in
    *          generalized real Schur canonical form.
    *          On exit, A is overwritten by the reordered matrix A.
    *
    *  LDA     (input) INTEGER
    *          The leading dimension of the array A. LDA >= max(1,N).
    *
    *  B       (input/output) REAL array, dimension(LDB,N)
    *          On entry, the upper triangular matrix B, with (A, B) in
    *          generalized real Schur canonical form.
    *          On exit, B is overwritten by the reordered matrix B.
    *
    *  LDB     (input) INTEGER
    *          The leading dimension of the array B. LDB >= max(1,N).
    *
    *  ALPHAR  (output) REAL array, dimension (N)
    *  ALPHAI  (output) REAL array, dimension (N)
    *  BETA    (output) REAL array, dimension (N)
    *          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
    *          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i
    *          and BETA(j),j=1,...,N  are the diagonals of the complex Schur
    *          form (S,T) that would result if the 2-by-2 diagonal blocks of
    *          the real generalized Schur form of (A,B) were further reduced
    *          to triangular form using complex unitary transformations.
    *          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
    *          positive, then the j-th and (j+1)-st eigenvalues are a
    *          complex conjugate pair, with ALPHAI(j+1) negative.
    *
    *  Q       (input/output) REAL array, dimension (LDQ,N)
    *          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
    *          On exit, Q has been postmultiplied by the left orthogonal
    *          transformation matrix which reorder (A, B); The leading M
    *          columns of Q form orthonormal bases for the specified pair of
    *          left eigenspaces (deflating subspaces).
    *          If WANTQ = .FALSE., Q is not referenced.
    *
    *  LDQ     (input) INTEGER
    *          The leading dimension of the array Q.  LDQ >= 1;
    *          and if WANTQ = .TRUE., LDQ >= N.
    *
    *  Z       (input/output) REAL array, dimension (LDZ,N)
    *          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
    *          On exit, Z has been postmultiplied by the left orthogonal
    *          transformation matrix which reorder (A, B); The leading M
    *          columns of Z form orthonormal bases for the specified pair of
    *          left eigenspaces (deflating subspaces).
    *          If WANTZ = .FALSE., Z is not referenced.
    *
    *  LDZ     (input) INTEGER
    *          The leading dimension of the array Z. LDZ >= 1;
    *          If WANTZ = .TRUE., LDZ >= N.
    *
    *  M       (output) INTEGER
    *          The dimension of the specified pair of left and right eigen-
    *          spaces (deflating subspaces). 0 <= M <= N.
    *
    *  PL      (output) REAL
    *  PR      (output) REAL
    *          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
    *          reciprocal of the norm of "projections" onto left and right
    *          eigenspaces with respect to the selected cluster.
    *          0 < PL, PR <= 1.
    *          If M = 0 or M = N, PL = PR  = 1.
    *          If IJOB = 0, 2 or 3, PL and PR are not referenced.
    *
    *  DIF     (output) REAL array, dimension (2).
    *          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
    *          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
    *          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
    *          estimates of Difu and Difl.
    *          If M = 0 or N, DIF(1:2) = F-norm([A, B]).
    *          If IJOB = 0 or 1, DIF is not referenced.
    *
    *  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))
    *          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
    *
    *  LWORK   (input) INTEGER
    *          The dimension of the array WORK. LWORK >=  4*N+16.
    *          If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
    *          If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
    *
    *          If LWORK = -1, then a workspace query is assumed; the routine
    *          only calculates the optimal size of the WORK array, returns
    *          this value as the first entry of the WORK array, and no error
    *          message related to LWORK is issued by XERBLA.
    *
    *  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
    *          IF IJOB = 0, IWORK is not referenced.  Otherwise,
    *          on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
    *
    *  LIWORK  (input) INTEGER
    *          The dimension of the array IWORK. LIWORK >= 1.
    *          If IJOB = 1, 2 or 4, LIWORK >=  N+6.
    *          If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
    *
    *          If LIWORK = -1, then a workspace query is assumed; the
    *          routine only calculates the optimal size of the IWORK array,
    *          returns this value as the first entry of the IWORK array, and
    *          no error message related to LIWORK is issued by XERBLA.
    *
    *  INFO    (output) INTEGER
    *            =0: Successful exit.
    *            <0: If INFO = -i, the i-th argument had an illegal value.
    *            =1: Reordering of (A, B) failed because the transformed
    *                matrix pair (A, B) would be too far from generalized
    *                Schur form; the problem is very ill-conditioned.
    *                (A, B) may have been partially reordered.
    *                If requested, 0 is returned in DIF(*), PL and PR.
    *
    *  Further Details
    *  ===============
    *
    *  STGSEN first collects the selected eigenvalues by computing
    *  orthogonal U and W that move them to the top left corner of (A, B).
    *  In other words, the selected eigenvalues are the eigenvalues of
    *  (A11, B11) in:
    *
    *                U'*(A, B)*W = (A11 A12) (B11 B12) n1
    *                              ( 0  A22),( 0  B22) n2
    *                                n1  n2    n1  n2
    *
    *  where N = n1+n2 and U' means the transpose of U. The first n1 columns
    *  of U and W span the specified pair of left and right eigenspaces
    *  (deflating subspaces) of (A, B).
    *
    *  If (A, B) has been obtained from the generalized real Schur
    *  decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
    *  reordered generalized real Schur form of (C, D) is given by
    *
    *           (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
    *
    *  and the first n1 columns of Q*U and Z*W span the corresponding
    *  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
    *
    *  Note that if the selected eigenvalue is sufficiently ill-conditioned,
    *  then its value may differ significantly from its value before
    *  reordering.
    *
    *  The reciprocal condition numbers of the left and right eigenspaces
    *  spanned by the first n1 columns of U and W (or Q*U and Z*W) may
    *  be returned in DIF(1:2), corresponding to Difu and Difl, resp.
    *
    *  The Difu and Difl are defined as:
    *
    *       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
    *  and
    *       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
    *
    *  where sigma-min(Zu) is the smallest singular value of the
    *  (2*n1*n2)-by-(2*n1*n2) matrix
    *
    *       Zu = [ kron(In2, A11)  -kron(A22', In1) ]
    *            [ kron(In2, B11)  -kron(B22', In1) ].
    *
    *  Here, Inx is the identity matrix of size nx and A22' is the
    *  transpose of A22. kron(X, Y) is the Kronecker product between
    *  the matrices X and Y.
    *
    *  When DIF(2) is small, small changes in (A, B) can cause large changes
    *  in the deflating subspace. An approximate (asymptotic) bound on the
    *  maximum angular error in the computed deflating subspaces is
    *
    *       EPS * norm((A, B)) / DIF(2),
    *
    *  where EPS is the machine precision.
    *
    *  The reciprocal norm of the projectors on the left and right
    *  eigenspaces associated with (A11, B11) may be returned in PL and PR.
    *  They are computed as follows. First we compute L and R so that
    *  P*(A, B)*Q is block diagonal, where
    *
    *       P = ( I -L ) n1           Q = ( I R ) n1
    *           ( 0  I ) n2    and        ( 0 I ) n2
    *             n1 n2                    n1 n2
    *
    *  and (L, R) is the solution to the generalized Sylvester equation
    *
    *       A11*R - L*A22 = -A12
    *       B11*R - L*B22 = -B12
    *
    *  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
    *  An approximate (asymptotic) bound on the average absolute error of
    *  the selected eigenvalues is
    *
    *       EPS * norm((A, B)) / PL.
    *
    *  There are also global error bounds which valid for perturbations up
    *  to a certain restriction:  A lower bound (x) on the smallest
    *  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
    *  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
    *  (i.e. (A + E, B + F), is
    *
    *   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
    *
    *  An approximate bound on x can be computed from DIF(1:2), PL and PR.
    *
    *  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
    *  (L', R') and unperturbed (L, R) left and right deflating subspaces
    *  associated with the selected cluster in the (1,1)-blocks can be
    *  bounded as
    *
    *   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
    *   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
    *
    *  See LAPACK User's Guide section 4.11 or the following references
    *  for more information.
    *
    *  Note that if the default method for computing the Frobenius-norm-
    *  based estimate DIF is not wanted (see SLATDF), then the parameter
    *  IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF
    *  (IJOB = 2 will be used)). See STGSYL for more details.
    *
    *  Based on contributions by
    *     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
    *     Umea University, S-901 87 Umea, Sweden.
    *
    *  References
    *  ==========
    *
    *  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
    *      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
    *      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
    *      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
    *
    *  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
    *      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
    *      Estimation: Theory, Algorithms and Software,
    *      Report UMINF - 94.04, Department of Computing Science, Umea
    *      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
    *      Note 87. To appear in Numerical Algorithms, 1996.
    *
    *  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
    *      for Solving the Generalized Sylvester Equation and Estimating the
    *      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
    *      Department of Computing Science, Umea University, S-901 87 Umea,
    *      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
    *      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
    *      1996.
    *
    *  =====================================================================
    *
    *     .. Parameters ..
          INTEGER            IDIFJB
          PARAMETER          ( IDIFJB = 3 )
          REAL               ZERO, ONE
          PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
    *     ..
    *     .. Local Scalars ..
          LOGICAL            LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2,
         $                   WANTP
          INTEGER            I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN,
         $                   MN2, N1, N2
          REAL               DSCALE, DSUM, EPS, RDSCAL, SMLNUM
    *     ..
    *     .. Local Arrays ..
          INTEGER            ISAVE( 3 )
    *     ..
    *     .. External Subroutines ..
          EXTERNAL           SLACN2, SLACPY, SLAG2, SLASSQ, STGEXC, STGSYL,
         $                   XERBLA
    *     ..
    *     .. External Functions ..
          REAL               SLAMCH
          EXTERNAL           SLAMCH
    *     ..
    *     .. Intrinsic Functions ..
          INTRINSIC          MAX, SIGN, SQRT
    *     ..
    *     .. Executable Statements ..
    *
    *     Decode and test the input parameters
    *
          INFO = 0
          LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
    *
          IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
             INFO = -1
          ELSE IF( N.LT.0 ) THEN
             INFO = -5
          ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
             INFO = -7
          ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
             INFO = -9
          ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
             INFO = -14
          ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
             INFO = -16
          END IF
    *
          IF( INFO.NE.0 ) THEN
             CALL XERBLA( 'STGSEN', -INFO )
             RETURN
          END IF
    *
    *     Get machine constants
    *
          EPS = SLAMCH( 'P' )
          SMLNUM = SLAMCH( 'S' ) / EPS
          IERR = 0
    *
          WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
          WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
          WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
          WANTD = WANTD1 .OR. WANTD2
    *
    *     Set M to the dimension of the specified pair of deflating
    *     subspaces.
    *
          M = 0
          PAIR = .FALSE.
          DO 10 K = 1, N
             IF( PAIR ) THEN
                PAIR = .FALSE.
             ELSE
                IF( K.LT.N ) THEN
                   IF( A( K+1, K ).EQ.ZERO ) THEN
                      IF( SELECT( K ) )
         $               M = M + 1
                   ELSE
                      PAIR = .TRUE.
                      IF( SELECT( K ) .OR. SELECT( K+1 ) )
         $               M = M + 2
                   END IF
                ELSE
                   IF( SELECT( N ) )
         $            M = M + 1
                END IF
             END IF
       10 CONTINUE
    *
          IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
             LWMIN = MAX( 1, 4*N+16, 2*M*(N-M) )
             LIWMIN = MAX( 1, N+6 )
          ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
             LWMIN = MAX( 1, 4*N+16, 4*M*(N-M) )
             LIWMIN = MAX( 1, 2*M*(N-M), N+6 )
          ELSE
             LWMIN = MAX( 1, 4*N+16 )
             LIWMIN = 1
          END IF
    *
          WORK( 1 ) = LWMIN
          IWORK( 1 ) = LIWMIN
    *
          IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
             INFO = -22
          ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
             INFO = -24
          END IF
    *
          IF( INFO.NE.0 ) THEN
             CALL XERBLA( 'STGSEN', -INFO )
             RETURN
          ELSE IF( LQUERY ) THEN
             RETURN
          END IF
    *
    *     Quick return if possible.
    *
          IF( M.EQ.N .OR. M.EQ.0 ) THEN
             IF( WANTP ) THEN
                PL = ONE
                PR = ONE
             END IF
             IF( WANTD ) THEN
                DSCALE = ZERO
                DSUM = ONE
                DO 20 I = 1, N
                   CALL SLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
                   CALL SLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
       20       CONTINUE
                DIF( 1 ) = DSCALE*SQRT( DSUM )
                DIF( 2 ) = DIF( 1 )
             END IF
             GO TO 60
          END IF
    *
    *     Collect the selected blocks at the top-left corner of (A, B).
    *
          KS = 0
          PAIR = .FALSE.
          DO 30 K = 1, N
             IF( PAIR ) THEN
                PAIR = .FALSE.
             ELSE
    *
                SWAP = SELECT( K )
                IF( K.LT.N ) THEN
                   IF( A( K+1, K ).NE.ZERO ) THEN
                      PAIR = .TRUE.
                      SWAP = SWAP .OR. SELECT( K+1 )
                   END IF
                END IF
    *
                IF( SWAP ) THEN
                   KS = KS + 1
    *
    *              Swap the K-th block to position KS.
    *              Perform the reordering of diagonal blocks in (A, B)
    *              by orthogonal transformation matrices and update
    *              Q and Z accordingly (if requested):
    *
                   KK = K
                   IF( K.NE.KS )
         $            CALL STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
         $                         Z, LDZ, KK, KS, WORK, LWORK, IERR )
    *
                   IF( IERR.GT.0 ) THEN
    *
    *                 Swap is rejected: exit.
    *
                      INFO = 1
                      IF( WANTP ) THEN
                         PL = ZERO
                         PR = ZERO
                      END IF
                      IF( WANTD ) THEN
                         DIF( 1 ) = ZERO
                         DIF( 2 ) = ZERO
                      END IF
                      GO TO 60
                   END IF
    *
                   IF( PAIR )
         $            KS = KS + 1
                END IF
             END IF
       30 CONTINUE
          IF( WANTP ) THEN
    *
    *        Solve generalized Sylvester equation for R and L
    *        and compute PL and PR.
    *
             N1 = M
             N2 = N - M
             I = N1 + 1
             IJB = 0
             CALL SLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
             CALL SLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
         $                N1 )
             CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
         $                N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
         $                DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
         $                LWORK-2*N1*N2, IWORK, IERR )
    *
    *        Estimate the reciprocal of norms of "projections" onto left
    *        and right eigenspaces.
    *
             RDSCAL = ZERO
             DSUM = ONE
             CALL SLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
             PL = RDSCAL*SQRT( DSUM )
             IF( PL.EQ.ZERO ) THEN
                PL = ONE
             ELSE
                PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
             END IF
             RDSCAL = ZERO
             DSUM = ONE
             CALL SLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
             PR = RDSCAL*SQRT( DSUM )
             IF( PR.EQ.ZERO ) THEN
                PR = ONE
             ELSE
                PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
             END IF
          END IF
    *
          IF( WANTD ) THEN
    *
    *        Compute estimates of Difu and Difl.
    *
             IF( WANTD1 ) THEN
                N1 = M
                N2 = N - M
                I = N1 + 1
                IJB = IDIFJB
    *
    *           Frobenius norm-based Difu-estimate.
    *
                CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
         $                   N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
         $                   N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ),
         $                   LWORK-2*N1*N2, IWORK, IERR )
    *
    *           Frobenius norm-based Difl-estimate.
    *
                CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
         $                   N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
         $                   N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ),
         $                   LWORK-2*N1*N2, IWORK, IERR )
             ELSE
    *
    *
    *           Compute 1-norm-based estimates of Difu and Difl using
    *           reversed communication with SLACN2. In each step a
    *           generalized Sylvester equation or a transposed variant
    *           is solved.
    *
                KASE = 0
                N1 = M
                N2 = N - M
                I = N1 + 1
                IJB = 0
                MN2 = 2*N1*N2
    *
    *           1-norm-based estimate of Difu.
    *
       40       CONTINUE
                CALL SLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ),
         $                   KASE, ISAVE )
                IF( KASE.NE.0 ) THEN
                   IF( KASE.EQ.1 ) THEN
    *
    *                 Solve generalized Sylvester equation.
    *
                      CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
         $                         WORK, N1, B, LDB, B( I, I ), LDB,
         $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
         $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
         $                         IERR )
                   ELSE
    *
    *                 Solve the transposed variant.
    *
                      CALL STGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA,
         $                         WORK, N1, B, LDB, B( I, I ), LDB,
         $                         WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
         $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
         $                         IERR )
                   END IF
                   GO TO 40
                END IF
                DIF( 1 ) = DSCALE / DIF( 1 )
    *
    *           1-norm-based estimate of Difl.
    *
       50       CONTINUE
                CALL SLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ),
         $                   KASE, ISAVE )
                IF( KASE.NE.0 ) THEN
                   IF( KASE.EQ.1 ) THEN
    *
    *                 Solve generalized Sylvester equation.
    *
                      CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
         $                         WORK, N2, B( I, I ), LDB, B, LDB,
         $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
         $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
         $                         IERR )
                   ELSE
    *
    *                 Solve the transposed variant.
    *
                      CALL STGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA,
         $                         WORK, N2, B( I, I ), LDB, B, LDB,
         $                         WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
         $                         WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
         $                         IERR )
                   END IF
                   GO TO 50
                END IF
                DIF( 2 ) = DSCALE / DIF( 2 )
    *
             END IF
          END IF
    *
       60 CONTINUE
    *
    *     Compute generalized eigenvalues of reordered pair (A, B) and
    *     normalize the generalized Schur form.
    *
          PAIR = .FALSE.
          DO 70 K = 1, N
             IF( PAIR ) THEN
                PAIR = .FALSE.
             ELSE
    *
                IF( K.LT.N ) THEN
                   IF( A( K+1, K ).NE.ZERO ) THEN
                      PAIR = .TRUE.
                   END IF
                END IF
    *
                IF( PAIR ) THEN
    *
    *             Compute the eigenvalue(s) at position K.
    *
                   WORK( 1 ) = A( K, K )
                   WORK( 2 ) = A( K+1, K )
                   WORK( 3 ) = A( K, K+1 )
                   WORK( 4 ) = A( K+1, K+1 )
                   WORK( 5 ) = B( K, K )
                   WORK( 6 ) = B( K+1, K )
                   WORK( 7 ) = B( K, K+1 )
                   WORK( 8 ) = B( K+1, K+1 )
                   CALL SLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ),
         $                     BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ),
         $                     ALPHAI( K ) )
                   ALPHAI( K+1 ) = -ALPHAI( K )
    *
                ELSE
    *
                   IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN
    *
    *                 If B(K,K) is negative, make it positive
    *
                      DO 80 I = 1, N
                         A( K, I ) = -A( K, I )
                         B( K, I ) = -B( K, I )
                         Q( I, K ) = -Q( I, K )
       80             CONTINUE
                   END IF
    *
                   ALPHAR( K ) = A( K, K )
                   ALPHAI( K ) = ZERO
                   BETA( K ) = B( K, K )
    *
                END IF
             END IF
       70 CONTINUE
    *
          WORK( 1 ) = LWMIN
          IWORK( 1 ) = LIWMIN
    *
          RETURN
    *
    *     End of STGSEN
    *
          END