SUBROUTINE MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK, $ INFO ) C C SLICOT RELEASE 5.0. C C Copyright (c) 2002-2009 NICONET e.V. C C This program is free software: you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation, either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public License C along with this program. If not, see C . C C PURPOSE C C To reorder a matrix X in skew-Hamiltonian Schur form: C C [ A G ] T C X = [ T ], G = -G, C [ 0 A ] C C or in Hamiltonian Schur form: C C [ A G ] T C X = [ T ], G = G, C [ 0 -A ] C C where A is in upper quasi-triangular form, so that a selected C cluster of eigenvalues appears in the leading diagonal blocks C of the matrix A (in X) and the leading columns of [ U1; -U2 ] form C an orthonormal basis for the corresponding right invariant C subspace. C C If X is skew-Hamiltonian, then each eigenvalue appears twice; one C copy corresponds to the j-th diagonal element and the other to the C (n+j)-th diagonal element of X. The logical array LOWER controls C which copy is to be reordered to the leading part of A. C C If X is Hamiltonian then the eigenvalues appear in pairs C (lambda,-lambda); lambda corresponds to the j-th diagonal C element and -lambda to the (n+j)-th diagonal element of X. C The logical array LOWER controls whether lambda or -lambda is to C be reordered to the leading part of A. C C The matrix A must be in Schur canonical form (as returned by the C LAPACK routine DHSEQR), that is, block upper triangular with C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has C its diagonal elements equal and its off-diagonal elements of C opposite sign. C C ARGUMENTS C C Mode Parameters C C TYP CHARACTER*1 C Specifies the type of the input matrix X: C = 'S': X is skew-Hamiltonian; C = 'H': X is Hamiltonian. C C COMPU CHARACTER*1 C = 'U': update the matrices U1 and U2 containing the C Schur vectors; C = 'N': do not update U1 and U2. C C SELECT (input/output) LOGICAL array, dimension (N) C SELECT specifies the eigenvalues in the selected cluster. C To select a real eigenvalue w(j), SELECT(j) must be set C to .TRUE.. To select a complex conjugate pair of C eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 C diagonal block, both SELECT(j) and SELECT(j+1) must be set C to .TRUE.; a complex conjugate pair of eigenvalues must be C either both included in the cluster or both excluded. C C LOWER (input/output) LOGICAL array, dimension (N) C LOWER controls which copy of a selected eigenvalue is C included in the cluster. If SELECT(j) is set to .TRUE. C for a real eigenvalue w(j); then LOWER(j) must be set to C .TRUE. if the eigenvalue corresponding to the (n+j)-th C diagonal element of X is to be reordered to the leading C part; and LOWER(j) must be set to .FALSE. if the C eigenvalue corresponding to the j-th diagonal element of C X is to be reordered to the leading part. Similarly, for C a complex conjugate pair of eigenvalues w(j) and w(j+1), C both LOWER(j) and LOWER(j+1) must be set to .TRUE. if the C eigenvalues corresponding to the (n+j:n+j+1,n+j:n+j+1) C diagonal block of X are to be reordered to the leading C part. C C Input/Output Parameters C C N (input) INTEGER C The order of the matrix A. N >= 0. C C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) C On entry, the leading N-by-N part of this array must C contain the upper quasi-triangular matrix A in Schur C canonical form. C On exit, the leading N-by-N part of this array contains C the reordered matrix A, again in Schur canonical form, C with the selected eigenvalues in the diagonal blocks. C C LDA INTEGER C The leading dimension of the array A. LDA >= MAX(1,N). C C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) C On entry, if TYP = 'S', the leading N-by-N part of this C array must contain the strictly upper triangular part of C the skew-symmetric matrix G. The rest of this array is not C referenced. C On entry, if TYP = 'H', the leading N-by-N part of this C array must contain the upper triangular part of the C symmetric matrix G. The rest of this array is not C referenced. C On exit, if TYP = 'S', the leading N-by-N part of this C array contains the strictly upper triangular part of the C skew-symmetric matrix G, updated by the orthogonal C symplectic transformation which reorders X. C On exit, if TYP = 'H', the leading N-by-N part of this C array contains the upper triangular part of the symmetric C matrix G, updated by the orthogonal symplectic C transformation which reorders X. C C LDG INTEGER C The leading dimension of the array G. LDG >= MAX(1,N). C C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) C On entry, if COMPU = 'U', the leading N-by-N part of this C array must contain U1, the (1,1) block of an orthogonal C symplectic matrix U = [ U1, U2; -U2, U1 ]. C On exit, if COMPU = 'U', the leading N-by-N part of this C array contains the (1,1) block of the matrix U, C postmultiplied by the orthogonal symplectic transformation C which reorders X. The leading M columns of U form an C orthonormal basis for the specified invariant subspace. C If COMPU = 'N', this array is not referenced. C C LDU1 INTEGER C The leading dimension of the array U1. C LDU1 >= MAX(1,N), if COMPU = 'U'; C LDU1 >= 1, otherwise. C C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) C On entry, if COMPU = 'U', the leading N-by-N part of this C array must contain U2, the (1,2) block of an orthogonal C symplectic matrix U = [ U1, U2; -U2, U1 ]. C On exit, if COMPU = 'U', the leading N-by-N part of this C array contains the (1,2) block of the matrix U, C postmultiplied by the orthogonal symplectic transformation C which reorders X. C If COMPU = 'N', this array is not referenced. C C LDU2 INTEGER C The leading dimension of the array U2. C LDU2 >= MAX(1,N), if COMPU = 'U'; C LDU2 >= 1, otherwise. C C WR (output) DOUBLE PRECISION array, dimension (N) C WI (output) DOUBLE PRECISION array, dimension (N) C The real and imaginary parts, respectively, of the C reordered eigenvalues of A. The eigenvalues are stored C in the same order as on the diagonal of A, with C WR(i) = A(i,i) and, if A(i:i+1,i:i+1) is a 2-by-2 diagonal C block, WI(i) > 0 and WI(i+1) = -WI(i). Note that if an C eigenvalue is sufficiently ill-conditioned, then its value C may differ significantly from its value before reordering. C C M (output) INTEGER C The dimension of the specified invariant subspace. C 0 <= M <= N. C C Workspace C C DWORK DOUBLE PRECISION array, dimension (LDWORK) C On exit, if INFO = 0, DWORK(1) returns the optimal C value of LDWORK. C On exit, if INFO = -18, DWORK(1) returns the minimum C value of LDWORK. C C LDWORK INTEGER C The length of the array DWORK. LDWORK >= MAX(1,N). C C Error Indicator C C INFO INTEGER C = 0: successful exit; C < 0: if INFO = -i, the i-th argument had an illegal C value. C = 1: reordering of X failed because some eigenvalue pairs C are too close to separate (the problem is very C ill-conditioned); X may have been partially C reordered, and WR and WI contain the eigenvalues in C the same order as in X. C C REFERENCES C C [1] Bai, Z. and Demmel, J.W. C On Swapping Diagonal Blocks in Real Schur Form. C Linear Algebra Appl., 186, pp. 73-95, 1993. C C [2] Benner, P., Kressner, D., and Mehrmann, V. C Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory, C Algorithms and Applications. Techn. Report, TU Berlin, 2003. C C CONTRIBUTORS C C D. Kressner, Technical Univ. Berlin, Germany, and C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. C C REVISIONS C C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAORD). C C KEYWORDS C C Hamiltonian matrix, skew-Hamiltonian matrix, invariant subspace. C C ****************************************************************** C C .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) C .. Scalar Arguments .. CHARACTER COMPU, TYP INTEGER INFO, LDA, LDG, LDU1, LDU2, LDWORK, M, N C .. Array Arguments .. LOGICAL LOWER(*), SELECT(*) DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*), $ U2(LDU2,*), WI(*), WR(*) C .. Local Scalars .. LOGICAL FLOW, ISHAM, PAIR, SWAP, WANTU INTEGER HERE, IERR, IFST, ILST, K, KS, NBF, NBL, NBNEXT, $ WRKMIN C .. External Functions .. LOGICAL LSAME EXTERNAL LSAME C .. External Subroutines .. EXTERNAL MB03TS, XERBLA C .. Intrinsic Functions .. INTRINSIC DBLE, MAX C C .. Executable Statements .. C C Decode and check input parameters. C ISHAM = LSAME( TYP, 'H' ) WANTU = LSAME( COMPU, 'U' ) WRKMIN = MAX( 1, N ) INFO = 0 IF ( .NOT.ISHAM .AND. .NOT.LSAME( TYP, 'S' ) ) THEN INFO = -1 ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN INFO = -2 ELSE IF ( N.LT.0 ) THEN INFO = -5 ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN INFO = -11 ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN INFO = -13 ELSE IF ( LDWORK.LT.WRKMIN ) THEN INFO = -18 DWORK(1) = DBLE( WRKMIN ) END IF C C Return if there were illegal values. C IF ( INFO.NE.0 ) THEN CALL XERBLA( 'MB03TD', -INFO ) RETURN END IF C C Set M to the dimension of the specified invariant subspace. C 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 C C Quick return if possible. C IF ( N.EQ.0 ) THEN DWORK(1) = ONE RETURN END IF C C Collect the selected blocks at the top-left corner of X. C KS = 0 PAIR = .FALSE. DO 60 K = 1, N IF ( PAIR ) THEN PAIR = .FALSE. ELSE SWAP = SELECT(K) FLOW = LOWER(K) IF ( K.LT.N ) THEN IF ( A(K+1,K).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP.OR.SELECT(K+1) FLOW = FLOW.OR.LOWER(K+1) END IF END IF C IF ( PAIR ) THEN NBF = 2 ELSE NBF = 1 END IF C IF ( SWAP ) THEN KS = KS + 1 IF ( FLOW ) THEN C C Step 1: Swap the K-th block to position N. C IFST = K ILST = N NBL = 1 IF ( ILST.GT.1 ) THEN IF ( A(ILST,ILST-1).NE.ZERO ) THEN ILST = ILST - 1 NBL = 2 END IF END IF C C Update ILST. C IF ( NBF.EQ.2 .AND. NBL.EQ.1 ) $ ILST = ILST - 1 IF ( NBF.EQ.1 .AND. NBL.EQ.2 ) $ ILST = ILST + 1 C IF ( ILST.EQ.IFST ) $ GO TO 30 C HERE = IFST C 20 CONTINUE C C Swap block with next one below. C IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN C C Current block is either 1-by-1 or 2-by-2. C NBNEXT = 1 IF ( HERE+NBF+1.LE.N ) THEN IF ( A(HERE+NBF+1,HERE+NBF).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, HERE, NBF, NBNEXT, $ DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF HERE = HERE + NBNEXT C C Test if 2-by-2 block breaks into two 1-by-1 blocks. C IF ( NBF.EQ.2 ) THEN IF ( A(HERE+1,HERE).EQ.ZERO ) $ NBF = 3 END IF C ELSE C C Current block consists of two 1-by-1 blocks each of C which must be swapped individually. C NBNEXT = 1 IF ( HERE+3.LE.N ) THEN IF ( A(HERE+3,HERE+2).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, HERE+1, 1, NBNEXT, $ DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF IF ( NBNEXT.EQ.1 ) THEN C C Swap two 1-by-1 blocks, no problems possible. C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE, 1, $ NBNEXT, DWORK, IERR ) HERE = HERE + 1 ELSE C C Recompute NBNEXT in case 2 by 2 split. C IF ( A(HERE+2,HERE+1).EQ.ZERO ) $ NBNEXT = 1 IF ( NBNEXT.EQ.2 ) THEN C C 2-by-2 block did not split C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE, 1, $ NBNEXT, DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF HERE = HERE + 2 ELSE C C 2-by-2 block did split C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE, 1, 1, $ DWORK, IERR ) CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE+1, 1, $ 1, DWORK, IERR ) HERE = HERE + 2 END IF END IF END IF IF ( HERE.LT.ILST ) $ GO TO 20 C 30 CONTINUE C C Step 2: Apply an orthogonal symplectic transformation C to swap the last blocks in A and -A' (or A'). C IF ( NBF.EQ.1 ) THEN C C Exchange columns/rows N <-> 2*N. No problems C possible. C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, N, 1, 1, $ DWORK, IERR ) C ELSE IF ( NBF.EQ.2 ) THEN C C Swap last block with its equivalent by an C orthogonal symplectic transformation. C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, N-1, 2, 2, $ DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF C C Test if 2-by-2 block breaks into two 1-by-1 blocks. C IF ( A(N-1,N).EQ.ZERO ) $ NBF = 3 ELSE C C Block did split. Swap (N-1)-th and N-th elements C consecutively by symplectic generalized C permutations and one rotation. C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, N-1, 1, 1, DWORK, $ IERR ) CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) END IF IFST = N IF ( PAIR ) $ IFST = N-1 ELSE IFST = K END IF C C Step 3: Swap the K-th / N-th block to position KS. C ILST = KS NBL = 1 IF ( ILST.GT.1 ) THEN IF ( A(ILST,ILST-1).NE.ZERO ) THEN ILST = ILST - 1 NBL = 2 END IF END IF C IF ( ILST.EQ.IFST ) $ GO TO 50 C HERE = IFST 40 CONTINUE C C Swap block with next one above. C IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN C C Current block either 1 by 1 or 2 by 2. C NBNEXT = 1 IF ( HERE.GE.3 ) THEN IF ( A(HERE-1,HERE-2).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, $ NBF, DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF HERE = HERE - NBNEXT C C Test if 2-by-2 block breaks into two 1-by-1 blocks. C IF ( NBF.EQ.2 ) THEN IF ( A(HERE+1,HERE).EQ.ZERO ) $ NBF = 3 END IF C ELSE C C Current block consists of two 1 by 1 blocks each of C which must be swapped individually. C NBNEXT = 1 IF ( HERE.GE.3 ) THEN IF ( A(HERE-1,HERE-2).NE.ZERO ) $ NBNEXT = 2 END IF CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, $ 1, DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF IF ( NBNEXT.EQ.1 ) THEN C C Swap two 1-by-1 blocks, no problems possible. C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, $ LDU1, U2, LDU2, HERE, NBNEXT, 1, $ DWORK, IERR ) HERE = HERE - 1 ELSE C C Recompute NBNEXT in case 2-by-2 split. C IF ( A(HERE,HERE-1).EQ.ZERO ) $ NBNEXT = 1 IF ( NBNEXT.EQ.2 ) THEN C C 2-by-2 block did not split C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE-1, 2, 1, $ DWORK, IERR ) IF ( IERR.NE.0 ) THEN INFO = 1 GO TO 70 END IF HERE = HERE - 2 ELSE C C 2-by-2 block did split C CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE, 1, 1, $ DWORK, IERR ) CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, $ U1, LDU1, U2, LDU2, HERE-1, 1, 1, $ DWORK, IERR ) HERE = HERE - 2 END IF END IF END IF C IF ( HERE.GT.ILST ) $ GO TO 40 C 50 CONTINUE IF ( PAIR ) $ KS = KS + 1 END IF END IF 60 CONTINUE C 70 CONTINUE C C Store eigenvalues. C DO 80 K = 1, N WR(K) = A(K,K) WI(K) = ZERO 80 CONTINUE DO 90 K = 1, N - 1 IF ( A(K+1,K).NE.ZERO ) THEN WI(K) = SQRT( ABS( A(K,K+1) ) )* $ SQRT( ABS( A(K+1,K) ) ) WI(K+1) = -WI(K) END IF 90 CONTINUE C DWORK(1) = DBLE( WRKMIN ) C RETURN C *** Last line of MB03TD *** END