File: MB03RX.f

package info (click to toggle)
dynare 4.3.0-2
  • links: PTS, VCS
  • area: main
  • in suites: wheezy
  • size: 40,640 kB
  • sloc: fortran: 82,231; cpp: 72,734; ansic: 28,874; pascal: 13,241; sh: 4,300; objc: 3,281; yacc: 2,833; makefile: 1,288; lex: 1,162; python: 162; lisp: 54; xml: 8
file content (226 lines) | stat: -rw-r--r-- 8,321 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
      SUBROUTINE MB03RX( JOBV, N, KL, KU, A, LDA, X, LDX, WR, WI,
     $                   DWORK )
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     <http://www.gnu.org/licenses/>.
C
C     PURPOSE
C
C     To reorder the diagonal blocks of the principal submatrix between
C     the indices KL and KU (KU >= KL) of a real Schur form matrix A
C     together with their eigenvalues, using orthogonal similarity
C     transformations, such that the block specified by KU is moved in
C     the position KL. The transformations are optionally postmultiplied
C     in a given matrix X.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBV    CHARACTER*1
C             Specifies whether or not the transformations are
C             accumulated, as follows:
C             = 'N':  The transformations are not accumulated;
C             = 'V':  The transformations are accumulated in X (the
C                     given matrix X is updated).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and X.  N >= 0.
C
C     KL      (input) INTEGER
C             The lower boundary index for the rows and columns of the
C             principal submatrix of A whose diagonal blocks are to be
C             reordered, and also the target position for the block to
C             be moved.  1 <= KL <= KU <= N.
C
C     KU      (input/output) INTEGER
C             On entry, KU specifies the upper boundary index for the
C             rows and columns of the principal submatrix of A whose
C             diagonal blocks are to be reordered, and also the original
C             position for the block to be moved.  1 <= KL <= KU <= N.
C             On exit, KU specifies the upper boundary index for the
C             rows and columns of the principal submatrix of A whose
C             diagonal blocks have been reordered. The given value will
C             be increased by 1 if the moved block was 2-by-2 and it has
C             been replaced by two 1-by-1 blocks. Otherwise, its input
C             value is preserved.
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 matrix A in real Schur canonical form.
C             On exit, the leading N-by-N part of this array contains
C             the ordered real Schur canonical form.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if JOBV = 'V', the leading N-by-N part of this
C             array must contain a given matrix X.
C             On exit, if JOBV = 'V', the leading N-by-N part of this
C             array contains the product of the given matrix X and the
C             transformation matrix that performed the reordering of A.
C             If JOBV = 'N', this array is not referenced.
C
C     LDX     INTEGER
C             The leading dimension of array X.
C             LDX >= 1,        if JOBV = 'N';
C             LDX >= MAX(1,N), if JOBV = 'V'.
C
C     WR,     (input/output) DOUBLE PRECISION arrays, dimension (N)
C     WI      On entry, these arrays must contain the real and imaginary
C             parts, respectively, of the eigenvalues of the matrix A.
C             On exit, these arrays contain the real and imaginary
C             parts, respectively, of the eigenvalues of the matrix A,
C             possibly reordered.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N)
C
C     METHOD
C
C     An attempt is made to move the block in the position (KU,KU) to
C     the position (KL,KL) by a sequence of orthogonal similarity
C     transformations, each swapping two consecutive blocks. The
C     standard algorithm [1], [2] usually succeeds to perform this
C     reordering. A failure of this algorithm means that two consecutive
C     blocks (one of them being the desired block possibly moved) are
C     too close to swap. In such a case, the leading block of the two
C     is tried to be moved in the position (KL,KL) and the procedure is
C     repeated.
C
C     REFERENCES
C
C     [1] Stewart, G.W.
C         HQR3 and EXCHQZ: FORTRAN subroutines for calculating and
C         ordering the eigenvalues of a real upper Hessenberg matrix.
C         ACM TOMS, 2, pp. 275-280, 1976.
C
C     [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically stable. If some eigenvalues are
C     ill-conditioned, their returned values could differ much from
C     their input values.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Eigenvalue, orthogonal transformation, real Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBV
      INTEGER           KL, KU, LDA, LDX, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*)
C     .. Local Scalars ..
      INTEGER           IERR, IFST, ILST, L
C     .. External Subroutines ..
      EXTERNAL          DTREXC
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SQRT
C     .. Executable Statements ..
C
      IF ( KU.GT.KL ) THEN
C
C        Try to move the block in position (KU,KU) to position (KL,KL).
C
         IFST = KU
C        REPEAT
   10    CONTINUE
         ILST = KL
         CALL DTREXC( JOBV, N, A, LDA, X, LDX, IFST, ILST, DWORK, IERR )
         IF ( IERR.NE.0 ) THEN
C
C           During calculations, two adjacent blocks were too close
C           to swap; the desired block cannot be moved further, but the
C           block above it is suitable and is tried for moving. The
C           number of repeat cycles is usually 1, and at most the number
C           of blocks between the current position and the position KL.
C
            IFST = ILST - 1
            IF ( IFST.GT.1 ) THEN
               IF ( A(IFST,IFST-1).NE.ZERO )
     $            IFST = ILST - 2
            END IF
            IF ( ILST.GT.KL )
     $         GO TO 10
         END IF
C        UNTIL ( ILST.EQ.KL on output from DTREXC )
C
C        Recompute the eigenvalues for the modified part of A.
C        Note that KU must be incremented if the moved block was 2-by-2
C        and it has been replaced by two 1-by-1 blocks.
C
         IF ( WI(KU).NE.ZERO ) THEN
            IF ( A(KU+1,KU).EQ.ZERO )
     $         KU = KU + 1
         END IF
C
         L = KL
C        WHILE ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) DO
   20    IF ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) THEN
            IF ( A(L+1,L).NE.ZERO ) THEN
C
C              A 2x2 block.
C
               WR(L)   =  A(L,L)
               WR(L+1) =  WR(L)
               WI(L)   =  SQRT( ABS( A(L,L+1) ) )*
     $                    SQRT( ABS( A(L+1,L) ) )
               WI(L+1) = -WI(L)
               L = L + 2
            ELSE
C
C              An 1x1 block.
C
               WR(L) = A(L,L)
               WI(L) = ZERO
               L = L + 1
            END IF
            GO TO 20
         ELSE IF ( L.EQ.N ) THEN
            WR(L) = A(L,L)
            WI(L) = ZERO
         END IF
C        END WHILE 20
      END IF
C
      RETURN
C *** Last line of MB03RX ***
      END