diff options
Diffstat (limited to 'SRC/ztrexc.f')
| -rw-r--r-- | SRC/ztrexc.f | 162 |
1 files changed, 162 insertions, 0 deletions
diff --git a/SRC/ztrexc.f b/SRC/ztrexc.f new file mode 100644 index 00000000..69313696 --- /dev/null +++ b/SRC/ztrexc.f @@ -0,0 +1,162 @@ + SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPQ + INTEGER IFST, ILST, INFO, LDQ, LDT, N +* .. +* .. Array Arguments .. + COMPLEX*16 Q( LDQ, * ), T( LDT, * ) +* .. +* +* Purpose +* ======= +* +* ZTREXC reorders the Schur factorization of a complex matrix +* A = Q*T*Q**H, so that the diagonal element of T with row index IFST +* is moved to row ILST. +* +* The Schur form T is reordered by a unitary similarity transformation +* Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by +* postmultplying it with Z. +* +* Arguments +* ========= +* +* COMPQ (input) CHARACTER*1 +* = 'V': update the matrix Q of Schur vectors; +* = 'N': do not update Q. +* +* N (input) INTEGER +* The order of the matrix T. N >= 0. +* +* T (input/output) COMPLEX*16 array, dimension (LDT,N) +* On entry, the upper triangular matrix T. +* On exit, the reordered upper triangular matrix. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max(1,N). +* +* Q (input/output) COMPLEX*16 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 +* unitary transformation matrix Z which reorders T. +* If COMPQ = 'N', Q is not referenced. +* +* LDQ (input) INTEGER +* The leading dimension of the array Q. LDQ >= max(1,N). +* +* IFST (input) INTEGER +* ILST (input) INTEGER +* Specify the reordering of the diagonal elements of T: +* The element with row index IFST is moved to row ILST by a +* sequence of transpositions between adjacent elements. +* 1 <= IFST <= N; 1 <= ILST <= N. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL WANTQ + INTEGER K, M1, M2, M3 + DOUBLE PRECISION CS + COMPLEX*16 SN, T11, T22, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARTG, ZROT +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Decode and test the input parameters. +* + INFO = 0 + WANTQ = LSAME( COMPQ, 'V' ) + IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN + INFO = -6 + ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN + INFO = -7 + ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTREXC', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.1 .OR. IFST.EQ.ILST ) + $ RETURN +* + IF( IFST.LT.ILST ) THEN +* +* Move the IFST-th diagonal element forward down the diagonal. +* + M1 = 0 + M2 = -1 + M3 = 1 + ELSE +* +* Move the IFST-th diagonal element backward up the diagonal. +* + M1 = -1 + M2 = 0 + M3 = -1 + END IF +* + DO 10 K = IFST + M1, ILST + M2, M3 +* +* Interchange the k-th and (k+1)-th diagonal elements. +* + T11 = T( K, K ) + T22 = T( K+1, K+1 ) +* +* Determine the transformation to perform the interchange. +* + CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP ) +* +* Apply transformation to the matrix T. +* + IF( K+2.LE.N ) + $ CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS, + $ SN ) + CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, + $ DCONJG( SN ) ) +* + T( K, K ) = T22 + T( K+1, K+1 ) = T11 +* + IF( WANTQ ) THEN +* +* Accumulate transformation in the matrix Q. +* + CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS, + $ DCONJG( SN ) ) + END IF +* + 10 CONTINUE +* + RETURN +* +* End of ZTREXC +* + END |