stgex2.f

Go to the documentation of this file.

*> \brief \b STGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an orthogonal equivalence transformation.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> Download STGEX2 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stgex2.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/stgex2.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stgex2.f">
*> [TXT]</a>
*
*  Definition:
*  ===========
*
*       SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
*                          LDZ, J1, N1, N2, WORK, LWORK, INFO )
*
*       .. Scalar Arguments ..
*       LOGICAL            WANTQ, WANTZ
*       INTEGER            INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
*      $                   WORK( * ), Z( LDZ, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
*> of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
*> (A, B) by an orthogonal equivalence transformation.
*>
*> (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.
*>
*> Optionally, the matrices Q and Z of generalized Schur vectors are
*> updated.
*>
*>        Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T
*>        Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T
*>
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] WANTQ
*> \verbatim
*>          WANTQ is LOGICAL
*>          .TRUE. : update the left transformation matrix Q;
*>          .FALSE.: do not update Q.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*>          WANTZ is LOGICAL
*>          .TRUE. : update the right transformation matrix Z;
*>          .FALSE.: do not update Z.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          On entry, the matrix A in the pair (A, B).
*>          On exit, the updated matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB,N)
*>          On entry, the matrix B in the pair (A, B).
*>          On exit, the updated matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*>          Q is REAL array, dimension (LDQ,N)
*>          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
*>          On exit, the updated matrix Q.
*>          Not referenced if WANTQ = .FALSE..
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*>          LDQ is INTEGER
*>          The leading dimension of the array Q. LDQ >= 1.
*>          If WANTQ = .TRUE., LDQ >= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*>          Z is REAL array, dimension (LDZ,N)
*>          On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
*>          On exit, the updated matrix Z.
*>          Not referenced if WANTZ = .FALSE..
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*>          LDZ is INTEGER
*>          The leading dimension of the array Z. LDZ >= 1.
*>          If WANTZ = .TRUE., LDZ >= N.
*> \endverbatim
*>
*> \param[in] J1
*> \verbatim
*>          J1 is INTEGER
*>          The index to the first block (A11, B11). 1 <= J1 <= N.
*> \endverbatim
*>
*> \param[in] N1
*> \verbatim
*>          N1 is INTEGER
*>          The order of the first block (A11, B11). N1 = 0, 1 or 2.
*> \endverbatim
*>
*> \param[in] N2
*> \verbatim
*>          N2 is INTEGER
*>          The order of the second block (A22, B22). N2 = 0, 1 or 2.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (MAX(1,LWORK)).
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.
*>          LWORK >=  MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>            =0: Successful exit
*>            >0: If INFO = 1, the transformed matrix (A, B) would be
*>                too far from generalized Schur form; the blocks are
*>                not swapped and (A, B) and (Q, Z) are unchanged.
*>                The problem of swapping is too ill-conditioned.
*>            <0: If INFO = -16: LWORK is too small. Appropriate value
*>                for LWORK is returned in WORK(1).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup tgex2
*
*> \par Further Details:
*  =====================
*>
*>  In the current code both weak and strong stability tests are
*>  performed. The user can omit the strong stability test by changing
*>  the internal logical parameter WANDS to .FALSE.. See ref. [2] for
*>  details.
*
*> \par Contributors:
*  ==================
*>
*>     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*>     Umea University, S-901 87 Umea, Sweden.
*
*> \par References:
*  ================
*>
*> \verbatim
*>
*>  [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.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE stgex2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
     $                   LDZ, J1, N1, N2, WORK, LWORK, INFO )
*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      LOGICAL            WANTQ, WANTZ
      INTEGER            INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
     $                   work( * ), z( ldz, * )
*     ..
*
*  =====================================================================
*  Replaced various illegal calls to SCOPY by calls to SLASET, or by DO
*  loops. Sven Hammarling, 1/5/02.
*
*     .. Parameters ..
      REAL               ZERO, ONE
      parameter( zero = 0.0e+0, one = 1.0e+0 )
      REAL               TWENTY
      parameter( twenty = 2.0e+01 )
      INTEGER            LDST
      parameter( ldst = 4 )
      LOGICAL            WANDS
      parameter( wands = .true. )
*     ..
*     .. Local Scalars ..
      LOGICAL            STRONG, WEAK
      INTEGER            I, IDUM, LINFO, M
      REAL               BQRA21, BRQA21, DDUM, DNORMA, DNORMB,
     $                   dscale,
     $                   dsum, eps, f, g, sa, sb, scale, smlnum,
     $                   thresha, threshb
*     ..
*     .. Local Arrays ..
      INTEGER            IWORK( LDST + 2 )
      REAL               AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ),
     $                   ircop( ldst, ldst ), li( ldst, ldst ),
     $                   licop( ldst, ldst ), s( ldst, ldst ),
     $                   scpy( ldst, ldst ), t( ldst, ldst ),
     $                   taul( ldst ), taur( ldst ), tcpy( ldst, ldst )
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           slamch
*     ..
*     .. External Subroutines ..
      EXTERNAL           sgemm, sgeqr2, sgerq2, slacpy, slagv2,
     $                   slartg,
     $                   slaset, slassq, sorg2r, sorgr2, sorm2r, sormr2,
     $                   srot, sscal, stgsy2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, sqrt
*     ..
*     .. Executable Statements ..
*
      info = 0
*
*     Quick return if possible
*
      IF( n.LE.1 .OR. n1.LE.0 .OR. n2.LE.0 )
     $   RETURN
      IF( n1.GT.n .OR. ( j1+n1 ).GT.n )
     $   RETURN
      m = n1 + n2
      IF( lwork.LT.max( n*m, m*m*2 ) ) THEN
         info = -16
         work( 1 ) = real( max( n*m, m*m*2 ) )
         RETURN
      END IF
*
      weak = .false.
      strong = .false.
*
*     Make a local copy of selected block
*
      CALL slaset( 'Full', ldst, ldst, zero, zero, li, ldst )
      CALL slaset( 'Full', ldst, ldst, zero, zero, ir, ldst )
      CALL slacpy( 'Full', m, m, a( j1, j1 ), lda, s, ldst )
      CALL slacpy( 'Full', m, m, b( j1, j1 ), ldb, t, ldst )
*
*     Compute threshold for testing acceptance of swapping.
*
      eps = slamch( 'P' )
      smlnum = slamch( 'S' ) / eps
      dscale = zero
      dsum = one
      CALL slacpy( 'Full', m, m, s, ldst, work, m )
      CALL slassq( m*m, work, 1, dscale, dsum )
      dnorma = dscale*sqrt( dsum )
      dscale = zero
      dsum = one
      CALL slacpy( 'Full', m, m, t, ldst, work, m )
      CALL slassq( m*m, work, 1, dscale, dsum )
      dnormb = dscale*sqrt( dsum )
*
*     THRES has been changed from
*        THRESH = MAX( TEN*EPS*SA, SMLNUM )
*     to
*        THRESH = MAX( TWENTY*EPS*SA, SMLNUM )
*     on 04/01/10.
*     "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by
*     Jim Demmel and Guillaume Revy. See forum post 1783.
*
      thresha = max( twenty*eps*dnorma, smlnum )
      threshb = max( twenty*eps*dnormb, smlnum )
*
      IF( m.EQ.2 ) THEN
*
*        CASE 1: Swap 1-by-1 and 1-by-1 blocks.
*
*        Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks
*        using Givens rotations and perform the swap tentatively.
*
         f = s( 2, 2 )*t( 1, 1 ) - t( 2, 2 )*s( 1, 1 )
         g = s( 2, 2 )*t( 1, 2 ) - t( 2, 2 )*s( 1, 2 )
         sa = abs( s( 2, 2 ) ) * abs( t( 1, 1 ) )
         sb = abs( s( 1, 1 ) ) * abs( t( 2, 2 ) )
         CALL slartg( f, g, ir( 1, 2 ), ir( 1, 1 ), ddum )
         ir( 2, 1 ) = -ir( 1, 2 )
         ir( 2, 2 ) = ir( 1, 1 )
         CALL srot( 2, s( 1, 1 ), 1, s( 1, 2 ), 1, ir( 1, 1 ),
     $              ir( 2, 1 ) )
         CALL srot( 2, t( 1, 1 ), 1, t( 1, 2 ), 1, ir( 1, 1 ),
     $              ir( 2, 1 ) )
         IF( sa.GE.sb ) THEN
            CALL slartg( s( 1, 1 ), s( 2, 1 ), li( 1, 1 ), li( 2,
     $                   1 ),
     $                   ddum )
         ELSE
            CALL slartg( t( 1, 1 ), t( 2, 1 ), li( 1, 1 ), li( 2,
     $                   1 ),
     $                   ddum )
         END IF
         CALL srot( 2, s( 1, 1 ), ldst, s( 2, 1 ), ldst, li( 1, 1 ),
     $              li( 2, 1 ) )
         CALL srot( 2, t( 1, 1 ), ldst, t( 2, 1 ), ldst, li( 1, 1 ),
     $              li( 2, 1 ) )
         li( 2, 2 ) = li( 1, 1 )
         li( 1, 2 ) = -li( 2, 1 )
*
*        Weak stability test: |S21| <= O(EPS F-norm((A)))
*                           and  |T21| <= O(EPS F-norm((B)))
*
         weak = abs( s( 2, 1 ) ) .LE. thresha .AND.
     $      abs( t( 2, 1 ) ) .LE. threshb
         IF( .NOT.weak )
     $      GO TO 70
*
         IF( wands ) THEN
*
*           Strong stability test:
*               F-norm((A-QL**H*S*QR)) <= O(EPS*F-norm((A)))
*               and
*               F-norm((B-QL**H*T*QR)) <= O(EPS*F-norm((B)))
*
            CALL slacpy( 'Full', m, m, a( j1, j1 ), lda,
     $                   work( m*m+1 ),
     $                   m )
            CALL sgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst,
     $                  zero,
     $                  work, m )
            CALL sgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst,
     $                  one,
     $                  work( m*m+1 ), m )
            dscale = zero
            dsum = one
            CALL slassq( m*m, work( m*m+1 ), 1, dscale, dsum )
            sa = dscale*sqrt( dsum )
*
            CALL slacpy( 'Full', m, m, b( j1, j1 ), ldb,
     $                   work( m*m+1 ),
     $                   m )
            CALL sgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst,
     $                  zero,
     $                  work, m )
            CALL sgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst,
     $                  one,
     $                  work( m*m+1 ), m )
            dscale = zero
            dsum = one
            CALL slassq( m*m, work( m*m+1 ), 1, dscale, dsum )
            sb = dscale*sqrt( dsum )
            strong = sa.LE.thresha .AND. sb.LE.threshb
            IF( .NOT.strong )
     $         GO TO 70
         END IF
*
*        Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
*               (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
*
         CALL srot( j1+1, a( 1, j1 ), 1, a( 1, j1+1 ), 1, ir( 1, 1 ),
     $              ir( 2, 1 ) )
         CALL srot( j1+1, b( 1, j1 ), 1, b( 1, j1+1 ), 1, ir( 1, 1 ),
     $              ir( 2, 1 ) )
         CALL srot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda,
     $              li( 1, 1 ), li( 2, 1 ) )
         CALL srot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb,
     $              li( 1, 1 ), li( 2, 1 ) )
*
*        Set  N1-by-N2 (2,1) - blocks to ZERO.
*
         a( j1+1, j1 ) = zero
         b( j1+1, j1 ) = zero
*
*        Accumulate transformations into Q and Z if requested.
*
         IF( wantz )
     $      CALL srot( n, z( 1, j1 ), 1, z( 1, j1+1 ), 1, ir( 1, 1 ),
     $                 ir( 2, 1 ) )
         IF( wantq )
     $      CALL srot( n, q( 1, j1 ), 1, q( 1, j1+1 ), 1, li( 1, 1 ),
     $                 li( 2, 1 ) )
*
*        Exit with INFO = 0 if swap was successfully performed.
*
         RETURN
*
      ELSE
*
*        CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2
*                and 2-by-2 blocks.
*
*        Solve the generalized Sylvester equation
*                 S11 * R - L * S22 = SCALE * S12
*                 T11 * R - L * T22 = SCALE * T12
*        for R and L. Solutions in LI and IR.
*
         CALL slacpy( 'Full', n1, n2, t( 1, n1+1 ), ldst, li, ldst )
         CALL slacpy( 'Full', n1, n2, s( 1, n1+1 ), ldst,
     $                ir( n2+1, n1+1 ), ldst )
         CALL stgsy2( 'N', 0, n1, n2, s, ldst, s( n1+1, n1+1 ), ldst,
     $                ir( n2+1, n1+1 ), ldst, t, ldst, t( n1+1, n1+1 ),
     $                ldst, li, ldst, scale, dsum, dscale, iwork, idum,
     $                linfo )
         IF( linfo.NE.0 )
     $      GO TO 70
*
*        Compute orthogonal matrix QL:
*
*                    QL**T * LI = [ TL ]
*                                 [ 0  ]
*        where
*                    LI =  [      -L              ]
*                          [ SCALE * identity(N2) ]
*
         DO 10 i = 1, n2
            CALL sscal( n1, -one, li( 1, i ), 1 )
            li( n1+i, i ) = scale
   10    CONTINUE
         CALL sgeqr2( m, n2, li, ldst, taul, work, linfo )
         IF( linfo.NE.0 )
     $      GO TO 70
         CALL sorg2r( m, m, n2, li, ldst, taul, work, linfo )
         IF( linfo.NE.0 )
     $      GO TO 70
*
*        Compute orthogonal matrix RQ:
*
*                    IR * RQ**T =   [ 0  TR],
*
*         where IR = [ SCALE * identity(N1), R ]
*
         DO 20 i = 1, n1
            ir( n2+i, i ) = scale
   20    CONTINUE
         CALL sgerq2( n1, m, ir( n2+1, 1 ), ldst, taur, work, linfo )
         IF( linfo.NE.0 )
     $      GO TO 70
         CALL sorgr2( m, m, n1, ir, ldst, taur, work, linfo )
         IF( linfo.NE.0 )
     $      GO TO 70
*
*        Perform the swapping tentatively:
*
         CALL sgemm( 'T', 'N', m, m, m, one, li, ldst, s, ldst, zero,
     $               work, m )
         CALL sgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero,
     $               s,
     $               ldst )
         CALL sgemm( 'T', 'N', m, m, m, one, li, ldst, t, ldst, zero,
     $               work, m )
         CALL sgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero,
     $               t,
     $               ldst )
         CALL slacpy( 'F', m, m, s, ldst, scpy, ldst )
         CALL slacpy( 'F', m, m, t, ldst, tcpy, ldst )
         CALL slacpy( 'F', m, m, ir, ldst, ircop, ldst )
         CALL slacpy( 'F', m, m, li, ldst, licop, ldst )
*
*        Triangularize the B-part by an RQ factorization.
*        Apply transformation (from left) to A-part, giving S.
*
         CALL sgerq2( m, m, t, ldst, taur, work, linfo )
         IF( linfo.NE.0 )
     $      GO TO 70
         CALL sormr2( 'R', 'T', m, m, m, t, ldst, taur, s, ldst,
     $                work,
     $                linfo )
         IF( linfo.NE.0 )
     $      GO TO 70
         CALL sormr2( 'L', 'N', m, m, m, t, ldst, taur, ir, ldst,
     $                work,
     $                linfo )
         IF( linfo.NE.0 )
     $      GO TO 70
*
*        Compute F-norm(S21) in BRQA21. (T21 is 0.)
*
         dscale = zero
         dsum = one
         DO 30 i = 1, n2
            CALL slassq( n1, s( n2+1, i ), 1, dscale, dsum )
   30    CONTINUE
         brqa21 = dscale*sqrt( dsum )
*
*        Triangularize the B-part by a QR factorization.
*        Apply transformation (from right) to A-part, giving S.
*
         CALL sgeqr2( m, m, tcpy, ldst, taul, work, linfo )
         IF( linfo.NE.0 )
     $      GO TO 70
         CALL sorm2r( 'L', 'T', m, m, m, tcpy, ldst, taul, scpy,
     $                ldst,
     $                work, info )
         CALL sorm2r( 'R', 'N', m, m, m, tcpy, ldst, taul, licop,
     $                ldst,
     $                work, info )
         IF( linfo.NE.0 )
     $      GO TO 70
*
*        Compute F-norm(S21) in BQRA21. (T21 is 0.)
*
         dscale = zero
         dsum = one
         DO 40 i = 1, n2
            CALL slassq( n1, scpy( n2+1, i ), 1, dscale, dsum )
   40    CONTINUE
         bqra21 = dscale*sqrt( dsum )
*
*        Decide which method to use.
*          Weak stability test:
*             F-norm(S21) <= O(EPS * F-norm((S)))
*
         IF( bqra21.LE.brqa21 .AND. bqra21.LE.thresha ) THEN
            CALL slacpy( 'F', m, m, scpy, ldst, s, ldst )
            CALL slacpy( 'F', m, m, tcpy, ldst, t, ldst )
            CALL slacpy( 'F', m, m, ircop, ldst, ir, ldst )
            CALL slacpy( 'F', m, m, licop, ldst, li, ldst )
         ELSE IF( brqa21.GE.thresha ) THEN
            GO TO 70
         END IF
*
*        Set lower triangle of B-part to zero
*
         CALL slaset( 'Lower', m-1, m-1, zero, zero, t(2,1), ldst )
*
         IF( wands ) THEN
*
*           Strong stability test:
*               F-norm((A-QL**H*S*QR)) <= O(EPS*F-norm((A)))
*               and
*               F-norm((B-QL**H*T*QR)) <= O(EPS*F-norm((B)))
*
            CALL slacpy( 'Full', m, m, a( j1, j1 ), lda,
     $                   work( m*m+1 ),
     $                   m )
            CALL sgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst,
     $                  zero,
     $                  work, m )
            CALL sgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst,
     $                  one,
     $                  work( m*m+1 ), m )
            dscale = zero
            dsum = one
            CALL slassq( m*m, work( m*m+1 ), 1, dscale, dsum )
            sa = dscale*sqrt( dsum )
*
            CALL slacpy( 'Full', m, m, b( j1, j1 ), ldb,
     $                   work( m*m+1 ),
     $                   m )
            CALL sgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst,
     $                  zero,
     $                  work, m )
            CALL sgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst,
     $                  one,
     $                  work( m*m+1 ), m )
            dscale = zero
            dsum = one
            CALL slassq( m*m, work( m*m+1 ), 1, dscale, dsum )
            sb = dscale*sqrt( dsum )
            strong = sa.LE.thresha .AND. sb.LE.threshb
            IF( .NOT.strong )
     $         GO TO 70
*
         END IF
*
*        If the swap is accepted ("weakly" and "strongly"), apply the
*        transformations and set N1-by-N2 (2,1)-block to zero.
*
         CALL slaset( 'Full', n1, n2, zero, zero, s(n2+1,1), ldst )
*
*        copy back M-by-M diagonal block starting at index J1 of (A, B)
*
         CALL slacpy( 'F', m, m, s, ldst, a( j1, j1 ), lda )
         CALL slacpy( 'F', m, m, t, ldst, b( j1, j1 ), ldb )
         CALL slaset( 'Full', ldst, ldst, zero, zero, t, ldst )
*
*        Standardize existing 2-by-2 blocks.
*
         CALL slaset( 'Full', m, m, zero, zero, work, m )
         work( 1 ) = one
         t( 1, 1 ) = one
         idum = lwork - m*m - 2
         IF( n2.GT.1 ) THEN
            CALL slagv2( a( j1, j1 ), lda, b( j1, j1 ), ldb, ar, ai,
     $                   be,
     $                   work( 1 ), work( 2 ), t( 1, 1 ), t( 2, 1 ) )
            work( m+1 ) = -work( 2 )
            work( m+2 ) = work( 1 )
            t( n2, n2 ) = t( 1, 1 )
            t( 1, 2 ) = -t( 2, 1 )
         END IF
         work( m*m ) = one
         t( m, m ) = one
*
         IF( n1.GT.1 ) THEN
            CALL slagv2( a( j1+n2, j1+n2 ), lda, b( j1+n2, j1+n2 ),
     $                   ldb,
     $                   taur, taul, work( m*m+1 ), work( n2*m+n2+1 ),
     $                   work( n2*m+n2+2 ), t( n2+1, n2+1 ),
     $                   t( m, m-1 ) )
            work( m*m ) = work( n2*m+n2+1 )
            work( m*m-1 ) = -work( n2*m+n2+2 )
            t( m, m ) = t( n2+1, n2+1 )
            t( m-1, m ) = -t( m, m-1 )
         END IF
         CALL sgemm( 'T', 'N', n2, n1, n2, one, work, m, a( j1,
     $               j1+n2 ),
     $               lda, zero, work( m*m+1 ), n2 )
         CALL slacpy( 'Full', n2, n1, work( m*m+1 ), n2, a( j1,
     $                j1+n2 ),
     $                lda )
         CALL sgemm( 'T', 'N', n2, n1, n2, one, work, m, b( j1,
     $               j1+n2 ),
     $               ldb, zero, work( m*m+1 ), n2 )
         CALL slacpy( 'Full', n2, n1, work( m*m+1 ), n2, b( j1,
     $                j1+n2 ),
     $                ldb )
         CALL sgemm( 'N', 'N', m, m, m, one, li, ldst, work, m, zero,
     $               work( m*m+1 ), m )
         CALL slacpy( 'Full', m, m, work( m*m+1 ), m, li, ldst )
         CALL sgemm( 'N', 'N', n2, n1, n1, one, a( j1, j1+n2 ), lda,
     $               t( n2+1, n2+1 ), ldst, zero, work, n2 )
         CALL slacpy( 'Full', n2, n1, work, n2, a( j1, j1+n2 ), lda )
         CALL sgemm( 'N', 'N', n2, n1, n1, one, b( j1, j1+n2 ), ldb,
     $               t( n2+1, n2+1 ), ldst, zero, work, n2 )
         CALL slacpy( 'Full', n2, n1, work, n2, b( j1, j1+n2 ), ldb )
         CALL sgemm( 'T', 'N', m, m, m, one, ir, ldst, t, ldst, zero,
     $               work, m )
         CALL slacpy( 'Full', m, m, work, m, ir, ldst )
*
*        Accumulate transformations into Q and Z if requested.
*
         IF( wantq ) THEN
            CALL sgemm( 'N', 'N', n, m, m, one, q( 1, j1 ), ldq, li,
     $                  ldst, zero, work, n )
            CALL slacpy( 'Full', n, m, work, n, q( 1, j1 ), ldq )
*
         END IF
*
         IF( wantz ) THEN
            CALL sgemm( 'N', 'N', n, m, m, one, z( 1, j1 ), ldz, ir,
     $                  ldst, zero, work, n )
            CALL slacpy( 'Full', n, m, work, n, z( 1, j1 ), ldz )
*
         END IF
*
*        Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
*                (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
*
         i = j1 + m
         IF( i.LE.n ) THEN
            CALL sgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,
     $                  a( j1, i ), lda, zero, work, m )
            CALL slacpy( 'Full', m, n-i+1, work, m, a( j1, i ), lda )
            CALL sgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,
     $                  b( j1, i ), ldb, zero, work, m )
            CALL slacpy( 'Full', m, n-i+1, work, m, b( j1, i ), ldb )
         END IF
         i = j1 - 1
         IF( i.GT.0 ) THEN
            CALL sgemm( 'N', 'N', i, m, m, one, a( 1, j1 ), lda, ir,
     $                  ldst, zero, work, i )
            CALL slacpy( 'Full', i, m, work, i, a( 1, j1 ), lda )
            CALL sgemm( 'N', 'N', i, m, m, one, b( 1, j1 ), ldb, ir,
     $                  ldst, zero, work, i )
            CALL slacpy( 'Full', i, m, work, i, b( 1, j1 ), ldb )
         END IF
*
*        Exit with INFO = 0 if swap was successfully performed.
*
         RETURN
*
      END IF
*
*     Exit with INFO = 1 if swap was rejected.
*
   70 CONTINUE
*
      info = 1
      RETURN
*
*     End of STGEX2
*
      END