strsen()

subroutine strsen	(	character	job,
		character	compq,
		logical, dimension( * )	select,
		integer	n,
		real, dimension( ldt, * )	t,
		integer	ldt,
		real, dimension( ldq, * )	q,
		integer	ldq,
		real, dimension( * )	wr,
		real, dimension( * )	wi,
		integer	m,
		real	s,
		real	sep,
		real, dimension( * )	work,
		integer	lwork,
		integer, dimension( * )	iwork,
		integer	liwork,
		integer	info )

STRSEN

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

Purpose:

!>
!> STRSEN reorders the real Schur factorization of a real matrix
!> A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
!> the leading diagonal blocks of the upper quasi-triangular matrix T,
!> and the leading columns of Q form an orthonormal basis of the
!> corresponding right invariant subspace.
!>
!> Optionally the routine computes the reciprocal condition numbers of
!> the cluster of eigenvalues and/or the invariant subspace.
!>
!> T must be in Schur canonical form (as returned by SHSEQR), that is,
!> block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
!> 2-by-2 diagonal block has its diagonal elements equal and its
!> off-diagonal elements of opposite sign.
!> 

Parameters

[in]	JOB	!> JOB is CHARACTER*1 !> Specifies whether condition numbers are required for the !> cluster of eigenvalues (S) or the invariant subspace (SEP): !> = 'N': none; !> = 'E': for eigenvalues only (S); !> = 'V': for invariant subspace only (SEP); !> = 'B': for both eigenvalues and invariant subspace (S and !> SEP). !>
[in]	COMPQ	!> COMPQ is CHARACTER*1 !> = 'V': update the matrix Q of Schur vectors; !> = 'N': do not update Q. !>
[in]	SELECT	!> SELECT is 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. !>
[in]	N	!> N is INTEGER !> The order of the matrix T. N >= 0. !>
[in,out]	T	!> T is REAL array, dimension (LDT,N) !> On entry, the upper quasi-triangular matrix T, in Schur !> canonical form. !> On exit, T is overwritten by the reordered matrix T, again in !> Schur canonical form, with the selected eigenvalues in the !> leading diagonal blocks. !>
[in]	LDT	!> LDT is INTEGER !> The leading dimension of the array T. LDT >= max(1,N). !>
[in,out]	Q	!> Q is REAL array, dimension (LDQ,N) !> On entry, if COMPQ = 'V', the matrix Q of Schur vectors. !> On exit, if COMPQ = 'V', Q has been postmultiplied by the !> orthogonal transformation matrix which reorders T; the !> leading M columns of Q form an orthonormal basis for the !> specified invariant subspace. !> If COMPQ = 'N', Q is not referenced. !>
[in]	LDQ	!> LDQ is INTEGER !> The leading dimension of the array Q. !> LDQ >= 1; and if COMPQ = 'V', LDQ >= N. !>
[out]	WR	!> WR is REAL array, dimension (N) !>
[out]	WI	!> WI is REAL array, dimension (N) !> !> The real and imaginary parts, respectively, of the reordered !> eigenvalues of T. The eigenvalues are stored in the same !> order as on the diagonal of T, with WR(i) = T(i,i) and, if !> T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and !> WI(i+1) = -WI(i). Note that if a complex eigenvalue is !> sufficiently ill-conditioned, then its value may differ !> significantly from its value before reordering. !>
[out]	M	!> M is INTEGER !> The dimension of the specified invariant subspace. !> 0 < = M <= N. !>
[out]	S	!> S is REAL !> If JOB = 'E' or 'B', S is a lower bound on the reciprocal !> condition number for the selected cluster of eigenvalues. !> S cannot underestimate the true reciprocal condition number !> by more than a factor of sqrt(N). If M = 0 or N, S = 1. !> If JOB = 'N' or 'V', S is not referenced. !>
[out]	SEP	!> SEP is REAL !> If JOB = 'V' or 'B', SEP is the estimated reciprocal !> condition number of the specified invariant subspace. If !> M = 0 or N, SEP = norm(T). !> If JOB = 'N' or 'E', SEP is not referenced. !>
[out]	WORK	!> WORK is REAL array, dimension (MAX(1,LWORK)) !> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. !>
[in]	LWORK	!> LWORK is INTEGER !> The dimension of the array WORK. !> If JOB = 'N', LWORK >= max(1,N); !> if JOB = 'E', LWORK >= max(1,M*(N-M)); !> if JOB = 'V' or 'B', LWORK >= max(1,2*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. !>
[out]	IWORK	!> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) !> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. !>
[in]	LIWORK	!> LIWORK is INTEGER !> The dimension of the array IWORK. !> If JOB = 'N' or 'E', LIWORK >= 1; !> if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)). !> !> 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. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit !> < 0: if INFO = -i, the i-th argument had an illegal value !> = 1: reordering of T failed because some eigenvalues are too !> close to separate (the problem is very ill-conditioned); !> T may have been partially reordered, and WR and WI !> contain the eigenvalues in the same order as in T; S and !> SEP (if requested) are set to zero. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  STRSEN first collects the selected eigenvalues by computing an
!>  orthogonal transformation Z to move them to the top left corner of T.
!>  In other words, the selected eigenvalues are the eigenvalues of T11
!>  in:
!>
!>          Z**T * T * Z = ( T11 T12 ) n1
!>                         (  0  T22 ) n2
!>                            n1  n2
!>
!>  where N = n1+n2 and Z**T means the transpose of Z. The first n1 columns
!>  of Z span the specified invariant subspace of T.
!>
!>  If T has been obtained from the real Schur factorization of a matrix
!>  A = Q*T*Q**T, then the reordered real Schur factorization of A is given
!>  by A = (Q*Z)*(Z**T*T*Z)*(Q*Z)**T, and the first n1 columns of Q*Z span
!>  the corresponding invariant subspace of A.
!>
!>  The reciprocal condition number of the average of the eigenvalues of
!>  T11 may be returned in S. S lies between 0 (very badly conditioned)
!>  and 1 (very well conditioned). It is computed as follows. First we
!>  compute R so that
!>
!>                         P = ( I  R ) n1
!>                             ( 0  0 ) n2
!>                               n1 n2
!>
!>  is the projector on the invariant subspace associated with T11.
!>  R is the solution of the Sylvester equation:
!>
!>                        T11*R - R*T22 = T12.
!>
!>  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
!>  the two-norm of M. Then S is computed as the lower bound
!>
!>                      (1 + F-norm(R)**2)**(-1/2)
!>
!>  on the reciprocal of 2-norm(P), the true reciprocal condition number.
!>  S cannot underestimate 1 / 2-norm(P) by more than a factor of
!>  sqrt(N).
!>
!>  An approximate error bound for the computed average of the
!>  eigenvalues of T11 is
!>
!>                         EPS * norm(T) / S
!>
!>  where EPS is the machine precision.
!>
!>  The reciprocal condition number of the right invariant subspace
!>  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
!>  SEP is defined as the separation of T11 and T22:
!>
!>                     sep( T11, T22 ) = sigma-min( C )
!>
!>  where sigma-min(C) is the smallest singular value of the
!>  n1*n2-by-n1*n2 matrix
!>
!>     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
!>
!>  I(m) is an m by m identity matrix, and kprod denotes the Kronecker
!>  product. We estimate sigma-min(C) by the reciprocal of an estimate of
!>  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
!>  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
!>
!>  When SEP is small, small changes in T can cause large changes in
!>  the invariant subspace. An approximate bound on the maximum angular
!>  error in the computed right invariant subspace is
!>
!>                      EPS * norm(T) / SEP
!> 

Definition at line 310 of file strsen.f.

*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          COMPQ, JOB
      INTEGER            INFO, LDQ, LDT, LIWORK, LWORK, M, N
      REAL               S, SEP
*     ..
*     .. Array Arguments ..
      LOGICAL            SELECT( * )
      INTEGER            IWORK( * )
      REAL               Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ),
     $                   WR( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      parameter( zero = 0.0e+0, one = 1.0e+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS,
     $                    WANTSP
      INTEGER            IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2,
     $                   NN
      REAL               EST, RNORM, SCALE
*     ..
*     .. Local Arrays ..
      INTEGER            ISAVE( 3 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SLANGE, SROUNDUP_LWORK
      EXTERNAL           lsame, slange, sroundup_lwork
*     ..
*     .. External Subroutines ..
      EXTERNAL           slacn2, slacpy, strexc, strsyl,
     $                   xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          abs, max, sqrt
*     ..
*     .. Executable Statements ..
*
*     Decode and test the input parameters
*
      wantbh = lsame( job, 'B' )
      wants = lsame( job, 'E' ) .OR. wantbh
      wantsp = lsame( job, 'V' ) .OR. wantbh
      wantq = lsame( compq, 'V' )
*
      info = 0
      lquery = ( lwork.EQ.-1 )
      IF( .NOT.lsame( job, 'N' ) .AND. .NOT.wants .AND. .NOT.wantsp )
     $     THEN
         info = -1
      ELSE IF( .NOT.lsame( compq, 'N' ) .AND. .NOT.wantq ) THEN
         info = -2
      ELSE IF( n.LT.0 ) THEN
         info = -4
      ELSE IF( ldt.LT.max( 1, n ) ) THEN
         info = -6
      ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) ) THEN
         info = -8
      ELSE
*
*        Set M to the dimension of the specified invariant subspace,
*        and test LWORK and LIWORK.
*
         m = 0
         pair = .false.
         DO 10 k = 1, n
            IF( pair ) THEN
               pair = .false.
            ELSE
               IF( k.LT.n ) THEN
                  IF( t( 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
*
         n1 = m
         n2 = n - m
         nn = n1*n2
*
         IF(  wantsp ) THEN
            lwmin = max( 1, 2*nn )
            liwmin = max( 1, nn )
         ELSE IF( lsame( job, 'N' ) ) THEN
            lwmin = max( 1, n )
            liwmin = 1
         ELSE IF( lsame( job, 'E' ) ) THEN
            lwmin = max( 1, nn )
            liwmin = 1
         END IF
*
         IF( lwork.LT.lwmin .AND. .NOT.lquery ) THEN
            info = -15
         ELSE IF( liwork.LT.liwmin .AND. .NOT.lquery ) THEN
            info = -17
         END IF
      END IF
*
      IF( info.EQ.0 ) THEN
         work( 1 ) = sroundup_lwork(lwmin)
         iwork( 1 ) = liwmin
      END IF
*
      IF( info.NE.0 ) THEN
         CALL xerbla( 'STRSEN', -info )
         RETURN
      ELSE IF( lquery ) THEN
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( m.EQ.n .OR. m.EQ.0 ) THEN
         IF( wants )
     $      s = one
         IF( wantsp )
     $      sep = slange( '1', n, n, t, ldt, work )
         GO TO 40
      END IF
*
*     Collect the selected blocks at the top-left corner of T.
*
      ks = 0
      pair = .false.
      DO 20 k = 1, n
         IF( pair ) THEN
            pair = .false.
         ELSE
            swap = SELECT( k )
            IF( k.LT.n ) THEN
               IF( t( 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.
*
               ierr = 0
               kk = k
               IF( k.NE.ks )
     $            CALL strexc( compq, n, t, ldt, q, ldq, kk, ks,
     $                         work,
     $                         ierr )
               IF( ierr.EQ.1 .OR. ierr.EQ.2 ) THEN
*
*                 Blocks too close to swap: exit.
*
                  info = 1
                  IF( wants )
     $               s = zero
                  IF( wantsp )
     $               sep = zero
                  GO TO 40
               END IF
               IF( pair )
     $            ks = ks + 1
            END IF
         END IF
   20 CONTINUE
*
      IF( wants ) THEN
*
*        Solve Sylvester equation for R:
*
*           T11*R - R*T22 = scale*T12
*
         CALL slacpy( 'F', n1, n2, t( 1, n1+1 ), ldt, work, n1 )
         CALL strsyl( 'N', 'N', -1, n1, n2, t, ldt, t( n1+1, n1+1 ),
     $                ldt, work, n1, scale, ierr )
*
*        Estimate the reciprocal of the condition number of the cluster
*        of eigenvalues.
*
         rnorm = slange( 'F', n1, n2, work, n1, work )
         IF( rnorm.EQ.zero ) THEN
            s = one
         ELSE
            s = scale / ( sqrt( scale*scale / rnorm+rnorm )*
     $          sqrt( rnorm ) )
         END IF
      END IF
*
      IF( wantsp ) THEN
*
*        Estimate sep(T11,T22).
*
         est = zero
         kase = 0
   30    CONTINUE
         CALL slacn2( nn, work( nn+1 ), work, iwork, est, kase,
     $                isave )
         IF( kase.NE.0 ) THEN
            IF( kase.EQ.1 ) THEN
*
*              Solve  T11*R - R*T22 = scale*X.
*
               CALL strsyl( 'N', 'N', -1, n1, n2, t, ldt,
     $                      t( n1+1, n1+1 ), ldt, work, n1, scale,
     $                      ierr )
            ELSE
*
*              Solve T11**T*R - R*T22**T = scale*X.
*
               CALL strsyl( 'T', 'T', -1, n1, n2, t, ldt,
     $                      t( n1+1, n1+1 ), ldt, work, n1, scale,
     $                      ierr )
            END IF
            GO TO 30
         END IF
*
         sep = scale / est
      END IF
*
   40 CONTINUE
*
*     Store the output eigenvalues in WR and WI.
*
      DO 50 k = 1, n
         wr( k ) = t( k, k )
         wi( k ) = zero
   50 CONTINUE
      DO 60 k = 1, n - 1
         IF( t( k+1, k ).NE.zero ) THEN
            wi( k ) = sqrt( abs( t( k, k+1 ) ) )*
     $                sqrt( abs( t( k+1, k ) ) )
            wi( k+1 ) = -wi( k )
         END IF
   60 CONTINUE
*
      work( 1 ) = sroundup_lwork(lwmin)
      iwork( 1 ) = liwmin
*
      RETURN
*
*     End of STRSEN
*

Here is the call graph for this function:

Here is the caller graph for this function: