stgex2()

subroutine stgex2	(	logical	wantq,
		logical	wantz,
		integer	n,
		real, dimension( lda, * )	a,
		integer	lda,
		real, dimension( ldb, * )	b,
		integer	ldb,
		real, dimension( ldq, * )	q,
		integer	ldq,
		real, dimension( ldz, * )	z,
		integer	ldz,
		integer	j1,
		integer	n1,
		integer	n2,
		real, dimension( * )	work,
		integer	lwork,
		integer	info
	)

STGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an orthogonal equivalence transformation.

Download STGEX2 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

 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

Parameters

[in]	WANTQ	WANTQ is LOGICAL .TRUE. : update the left transformation matrix Q; .FALSE.: do not update Q.
[in]	WANTZ	WANTZ is LOGICAL .TRUE. : update the right transformation matrix Z; .FALSE.: do not update Z.
[in]	N	N is INTEGER The order of the matrices A and B. N >= 0.
[in,out]	A	A is REAL array, dimension (LDA,N) On entry, the matrix A in the pair (A, B). On exit, the updated matrix A.
[in]	LDA	LDA is INTEGER The leading dimension of the array A. LDA >= max(1,N).
[in,out]	B	B is REAL array, dimension (LDB,N) On entry, the matrix B in the pair (A, B). On exit, the updated matrix B.
[in]	LDB	LDB is INTEGER The leading dimension of the array B. LDB >= max(1,N).
[in,out]	Q	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..
[in]	LDQ	LDQ is INTEGER The leading dimension of the array Q. LDQ >= 1. If WANTQ = .TRUE., LDQ >= N.
[in,out]	Z	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..
[in]	LDZ	LDZ is INTEGER The leading dimension of the array Z. LDZ >= 1. If WANTZ = .TRUE., LDZ >= N.
[in]	J1	J1 is INTEGER The index to the first block (A11, B11). 1 <= J1 <= N.
[in]	N1	N1 is INTEGER The order of the first block (A11, B11). N1 = 0, 1 or 2.
[in]	N2	N2 is INTEGER The order of the second block (A22, B22). N2 = 0, 1 or 2.
[out]	WORK	WORK is REAL array, dimension (MAX(1,LWORK)).
[in]	LWORK	LWORK is INTEGER The dimension of the array WORK. LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )
[out]	INFO	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).

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

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.

Contributors:

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.

Definition at line 219 of file stgex2.f.

*
*  -- 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 ) = 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
*

Here is the call graph for this function:

Here is the caller graph for this function: