File: MC03ND.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 (495 lines) | stat: -rw-r--r-- 18,289 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
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
      SUBROUTINE MC03ND( MP, NP, DP, P, LDP1, LDP2, DK, GAM, NULLSP,
     $                   LDNULL, KER, LDKER1, LDKER2, TOL, IWORK, 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     <http://www.gnu.org/licenses/>.
C
C     PURPOSE
C
C     To compute the coefficients of a minimal polynomial basis
C                                                 DK
C         K(s) = K(0) + K(1) * s + ... + K(DK) * s
C
C     for the right nullspace of the MP-by-NP polynomial matrix of
C     degree DP, given by
C                                                 DP
C         P(s) = P(0) + P(1) * s + ... + P(DP) * s  ,
C
C     which corresponds to solving the polynomial matrix equation
C     P(s) * K(s) = 0.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     MP      (input) INTEGER
C             The number of rows of the polynomial matrix P(s).
C             MP >= 0.
C
C     NP      (input) INTEGER
C             The number of columns of the polynomial matrix P(s).
C             NP >= 0.
C
C     DP      (input) INTEGER
C             The degree of the polynomial matrix P(s).  DP >= 1.
C
C     P       (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1)
C             The leading MP-by-NP-by-(DP+1) part of this array must
C             contain the coefficients of the polynomial matrix P(s).
C             Specifically, P(i,j,k) must contain the (i,j)-th element
C             of P(k-1), which is the cofficient of s**(k-1) of P(s),
C             where i = 1,2,...,MP, j = 1,2,...,NP and k = 1,2,...,DP+1.
C
C     LDP1    INTEGER
C             The leading dimension of array P.  LDP1 >= MAX(1,MP).
C
C     LDP2    INTEGER
C             The second dimension of array P.   LDP2 >= MAX(1,NP).
C
C     DK      (output) INTEGER
C             The degree of the minimal polynomial basis K(s) for the
C             right nullspace of P(s) unless DK = -1, in which case
C             there is no right nullspace.
C
C     GAM     (output) INTEGER array, dimension (DP*MP+1)
C             The leading (DK+1) elements of this array contain
C             information about the ordering of the right nullspace
C             vectors stored in array NULLSP.
C
C     NULLSP  (output) DOUBLE PRECISION array, dimension
C             (LDNULL,(DP*MP+1)*NP)
C             The leading NP-by-SUM(i*GAM(i)) part of this array
C             contains the right nullspace vectors of P(s) in condensed
C             form (as defined in METHOD), where i = 1,2,...,DK+1.
C
C     LDNULL  INTEGER
C             The leading dimension of array NULLSP.
C             LDNULL >= MAX(1,NP).
C
C     KER     (output) DOUBLE PRECISION array, dimension
C             (LDKER1,LDKER2,DP*MP+1)
C             The leading NP-by-nk-by-(DK+1) part of this array contains
C             the coefficients of the minimal polynomial basis K(s),
C             where nk = SUM(GAM(i)) and i = 1,2,...,DK+1. Specifically,
C             KER(i,j,m) contains the (i,j)-th element of K(m-1), which
C             is the coefficient of s**(m-1) of K(s), where i = 1,2,...,
C             NP, j = 1,2,...,nk and m = 1,2,...,DK+1.
C
C     LDKER1  INTEGER
C             The leading dimension of array KER.  LDKER1 >= MAX(1,NP).
C
C     LDKER2  INTEGER
C             The second dimension of array KER.   LDKER2 >= MAX(1,NP).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance below which matrix elements are considered
C             to be zero. If the user sets TOL to be less than
C             10 * EPS * MAX( ||A|| , ||E|| ), then the tolerance is
C                                  F       F
C             taken as 10 * EPS * MAX( ||A|| , ||E|| ), where EPS is the
C                                           F       F
C             machine precision (see LAPACK Library Routine DLAMCH) and
C             A and E are matrices (as defined in METHOD).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (m+2*MAX(n,m+1)+n),
C             where m = DP*MP and n = (DP-1)*MP + NP.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= m*n*n + 2*m*n + 2*n*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             > 0:  if incorrect rank decisions were taken during the
C                   computations. This failure is not likely to occur.
C                   The possible values are:
C                     k, 1 <= k <= DK+1, the k-th diagonal submatrix had
C                           not a full row rank;
C                     DK+2, if incorrect dimensions of a full column
C                           rank submatrix;
C                     DK+3, if incorrect dimensions of a full row rank
C                           submatrix.
C
C     METHOD
C
C     The computation of the right nullspace of the MP-by-NP polynomial
C     matrix P(s) of degree DP given by
C                                                  DP-1            DP
C        P(s) = P(0) + P(1) * s + ... + P(DP-1) * s     + P(DP) * s
C
C     is performed via the pencil s*E - A, associated with P(s), where
C
C            | I              |           | 0         -P(DP) |
C            |   .            |           | I .          .   |
C        A = |     .          |  and  E = |   . .        .   |.      (1)
C            |       .        |           |     . 0      .   |
C            |         I      |           |       I 0 -P(2)  |
C            |           P(0) |           |         I -P(1)  |
C
C     The pencil s*E - A is transformed by unitary matrices Q and Z such
C     that
C
C                     | sE(eps)-A(eps) |        X       |      X     |
C                     |----------------|----------------|------------|
C                     |        0       | sE(inf)-A(inf) |      X     |
C        Q'(s*E-A)Z = |=================================|============|.
C                     |                                 |            |
C                     |                0                | sE(r)-A(r) |
C
C     Since s*E(inf)-A(inf) and s*E(r)-A(r) have full column rank, the
C     minimal polynomial basis for the right nullspace of Q'(s*E-A)Z
C     (and consequently the basis for the right nullspace of s*E - A) is
C     completely determined by s*E(eps)-A(eps).
C
C     Let Veps(s) be a minimal polynomial basis for the right nullspace
C     of s*E(eps)-A(eps). Then
C
C                   | Veps(s) |
C        V(s) = Z * |---------|
C                   |    0    |
C
C     is a minimal polynomial basis for the right nullspace of s*E - A.
C     From the structure of s*E - A it can be shown that if V(s) is
C     partitioned as
C
C               | Vo(s) | (DP-1)*MP
C        V(s) = |------ |
C               | Ve(s) | NP
C
C     then the columns of Ve(s) form a minimal polynomial basis for the
C     right nullspace of P(s).
C
C     The vectors of Ve(s) are computed and stored in array NULLSP in
C     the following condensed form:
C
C        ||      ||      |      ||      |      |      ||      |     |
C        || U1,0 || U2,0 | U2,1 || U3,0 | U3,1 | U3,2 || U4,0 | ... |,
C        ||      ||      |      ||      |      |      ||      |     |
C
C     where Ui,j is an NP-by-GAM(i) matrix which contains the i-th block
C     of columns of K(j), the j-th coefficient of the polynomial matrix
C     representation for the right nullspace
C                                                  DK
C        K(s) = K(0) + K(1) * s + . . . + K(DK) * s  .
C
C     The coefficients K(0), K(1), ..., K(DK) are NP-by-nk matrices
C     given by
C
C        K(0)  = | U1,0 | U2,0 | U3,0 | . . .          | U(DK+1,0) |
C
C        K(1)  = |  0   | U2,1 | U3,1 | . . .          | U(DK+1,1) |
C
C        K(2)  = |  0   |  0   | U3,2 | . . .          | U(DK+1,2) |
C
C          .     .     .     .     .     .     .     .     .     .
C
C        K(DK) = |  0   |  0   |  0   | . . .    |  0  | U(DK+1,DK)|.
C
C     Note that the degree of K(s) satisfies the inequality DK <=
C     DP * MIN(MP,NP) and that the dimension of K(s) satisfies the
C     inequality (NP-MP) <= nk <= NP.
C
C     REFERENCES
C
C     [1] Beelen, Th.G.J.
C         New Algorithms for Computing the Kronecker structure of a
C         Pencil with Applications to Systems and Control Theory.
C         Ph.D.Thesis, Eindhoven University of Technology, 1987.
C
C     [2] Van Den Hurk, G.J.H.H.
C         New Algorithms for Solving Polynomial Matrix Problems.
C         Master's Thesis, Eindhoven University of Technology, 1987.
C
C     NUMERICAL ASPECTS
C
C     The algorithm used by the routine involves the construction of a
C     special block echelon form with pivots considered to be non-zero
C     when they are larger than TOL. These pivots are then inverted in
C     order to construct the columns of the kernel of the polynomial
C     matrix. If TOL is chosen to be too small then these inversions may
C     be sensitive whereas increasing TOL will make the inversions more
C     robust but will affect the block echelon form (and hence the
C     column degrees of the polynomial kernel). Furthermore, if the
C     elements of the computed polynomial kernel are large relative to
C     the polynomial matrix, then the user should consider trying
C     several values of TOL.
C
C     FURTHER COMMENTS
C
C     It also possible to compute a minimal polynomial basis for the
C     right nullspace of a pencil, since a pencil is a polynomial matrix
C     of degree 1. Thus for the pencil (s*E - A), the required input is
C     P(1)  = E and P(0) = -A.
C
C     The routine can also be used to compute a minimal polynomial
C     basis for the left nullspace of a polynomial matrix by simply
C     transposing P(s).
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC03BD by A.J. Geurts and MC03BZ by
C     Th.G.J. Beelen, A.J. Geurts, and G.J.H.H. van den Hurk.
C
C     REVISIONS
C
C     Jan. 1998.
C
C     KEYWORDS
C
C     Echelon form, elementary polynomial operations, input output
C     description, polynomial matrix, polynomial operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TEN
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
C     .. Scalar Arguments ..
      INTEGER           DK, DP, INFO, LDKER1, LDKER2, LDNULL, LDP1,
     $                  LDP2, LDWORK, MP, NP
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           GAM(*), IWORK(*)
      DOUBLE PRECISION  DWORK(*), KER(LDKER1,LDKER2,*),
     $                  NULLSP(LDNULL,*), P(LDP1,LDP2,*)
C     .. Local Scalars ..
      INTEGER           GAMJ, H, I, IDIFF, IFIR, J, JWORKA, JWORKE,
     $                  JWORKQ, JWORKV, JWORKZ, K, M, MUK, N, NBLCKS,
     $                  NBLCKI, NCA, NCV, NRA, NUK, RANKE, SGAMK, TAIL,
     $                  VC1, VR2
      DOUBLE PRECISION  TOLER
C     .. Local Arrays ..
      INTEGER           MNEI(3)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLANGE, DLAPY2
      EXTERNAL          DLAMCH, DLANGE, DLAPY2
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DLACPY, DLASET, MB04UD, MB04VD, MC03NX,
     $                  MC03NY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, SQRT
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      M = DP*MP
      H = M - MP
      N = H + NP
      INFO = 0
      IF( MP.LT.0 ) THEN
         INFO = -1
      ELSE IF( NP.LT.0 ) THEN
         INFO = -2
      ELSE IF( DP.LE.0 ) THEN
         INFO = -3
      ELSE IF( LDP1.LT.MAX( 1, MP ) ) THEN
         INFO = -5
      ELSE IF( LDP2.LT.MAX( 1, NP ) ) THEN
         INFO = -6
      ELSE IF( LDNULL.LT.MAX( 1, NP ) ) THEN
         INFO = -10
      ELSE IF( LDKER1.LT.MAX( 1, NP ) ) THEN
         INFO = -12
      ELSE IF( LDKER2.LT.MAX( 1, NP ) ) THEN
         INFO = -13
      ELSE IF( LDWORK.LT.( N*( M*N + 2*( M + N ) ) ) ) THEN
         INFO = -17
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MC03ND', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MP.EQ.0 .OR. NP.EQ.0 ) THEN
         DK = -1
         RETURN
      END IF
C
      JWORKA = 1
      JWORKE = JWORKA + M*N
      JWORKZ = JWORKE + M*N
      JWORKV = JWORKZ + N*N
      JWORKQ = JWORKA
C
C     Construct the matrices A and E in the pencil s*E-A in (1).
C     Workspace:  2*M*N.
C
      CALL MC03NX( MP, NP, DP, P, LDP1, LDP2, DWORK(JWORKA), M,
     $             DWORK(JWORKE), M )
C
C     Computation of the tolerance.
C
      TOLER = MAX( DLANGE( 'F', M,  NP, DWORK(JWORKE+H*M), M, DWORK ),
     $             DLANGE( 'F', MP, NP, P, LDP1, DWORK ) )
      TOLER = TEN*DLAMCH( 'Epsilon' )
     $           *DLAPY2( TOLER, SQRT( DBLE( H ) ) )
      IF ( TOLER.LE.TOL ) TOLER = TOL
C
C     Reduction of E to column echelon form E0 = Q' x E x Z and
C     transformation of A, A0 = Q' x A x Z.
C     Workspace:  2*M*N + N*N + max(M,N).
C
      CALL MB04UD( 'No Q', 'Identity Z', M, N, DWORK(JWORKA), M,
     $             DWORK(JWORKE), M, DWORK(JWORKQ), M, DWORK(JWORKZ), N,
     $             RANKE, IWORK, TOLER, DWORK(JWORKV), INFO )
C
C     The contents of ISTAIR is transferred from MB04UD to MB04VD by
C     IWORK(i), i=1,...,M.
C     In the sequel the arrays IMUK and INUK are part of IWORK, namely:
C     IWORK(i), i = M+1,...,M+max(N,M+1), contains IMUK,
C     IWORK(i), i = M+max(N,M+1)+1,...,M+2*max(N,M+1), contains INUK.
C     IWORK(i), i = M+2*max(N,M+1)+1,...,M+2*max(N,M+1)+N, contains
C               IMUK0 (not needed), and is also used as workspace.
C
      MUK  = M + 1
      NUK  = MUK + MAX( N, M+1 )
      TAIL = NUK + MAX( N, M+1 )
C
      CALL MB04VD( 'Separation', 'No Q', 'Update Z', M, N, RANKE,
     $             DWORK(JWORKA), M, DWORK(JWORKE), M, DWORK(JWORKQ), M,
     $             DWORK(JWORKZ), N, IWORK, NBLCKS, NBLCKI, IWORK(MUK),
     $             IWORK(NUK), IWORK(TAIL), MNEI, TOLER, IWORK(TAIL),
     $             INFO )
      IF ( INFO.GT.0 ) THEN
C
C        Incorrect rank decisions.
C
         INFO = INFO + NBLCKS
         RETURN
      END IF
C
C     If NBLCKS < 1, or the column dimension of s*E(eps) - A(eps) is
C     zero, then there is no right nullspace.
C
      IF ( NBLCKS.LT.1 .OR. MNEI(2).EQ.0 ) THEN
         DK = -1
         RETURN
      END IF
C
C     Start of the computation of the minimal basis.
C
      DK = NBLCKS - 1
      NRA = MNEI(1)
      NCA = MNEI(2)
C
C     Determine a minimal basis VEPS(s) for the right nullspace of the
C     pencil s*E(eps)-A(eps) associated with the polynomial matrix P(s).
C     Workspace:  2*M*N + N*N + N*N*(M+1).
C
      CALL MC03NY( NBLCKS, NRA, NCA, DWORK(JWORKA), M, DWORK(JWORKE), M,
     $             IWORK(MUK), IWORK(NUK), DWORK(JWORKV), N, INFO )
C
      IF ( INFO.GT.0 )
     $   RETURN
C
      NCV = IWORK(MUK) - IWORK(NUK)
      GAM(1) = NCV
      IWORK(1) = 0
      IWORK(TAIL) = IWORK(MUK)
C
      DO 20 I = 2, NBLCKS
         IDIFF = IWORK(MUK+I-1) - IWORK(NUK+I-1)
         GAM(I) = IDIFF
         IWORK(I) = NCV
         NCV = NCV + I*IDIFF
         IWORK(TAIL+I-1) = IWORK(TAIL+I-2) + IWORK(MUK+I-1)
   20 CONTINUE
C
C     Determine a basis for the right nullspace of the polynomial
C     matrix P(s). This basis is stored in array NULLSP in condensed
C     form.
C
      CALL DLASET( 'Full', NP, NCV, ZERO, ZERO, NULLSP, LDNULL )
C
C                                                |VEPS(s)|
C     The last NP rows of the product matrix Z x |-------| contain the
C                                                |   0   |
C     polynomial basis for the right nullspace of the polynomial matrix
C     P(s) in condensed form. The multiplication is restricted to the
C     nonzero submatrices Vij,k of VEPS, the result is stored in the
C     array NULLSP.
C
      VC1 = 1
C
      DO 60 I = 1, NBLCKS
         VR2 = IWORK(TAIL+I-1)
C
         DO 40 J = 1, I
C
C           Multiplication of Z(H+1:N,1:VR2) with V.i,j-1 stored in
C           VEPS(1:VR2,VC1:VC1+GAM(I)-1).
C
            CALL DGEMM( 'No transpose', 'No transpose', NP, GAM(I), VR2,
     $                  ONE, DWORK(JWORKZ+H), N,
     $                  DWORK(JWORKV+(VC1-1)*N), N, ZERO, NULLSP(1,VC1),
     $                  LDNULL )
            VC1 = VC1 + GAM(I)
            VR2 = VR2 - IWORK(MUK+I-J)
   40    CONTINUE
C
   60 CONTINUE
C
C     Transfer of the columns of NULLSP to KER in order to obtain the
C     polynomial matrix representation of K(s), the right nullspace
C     of P(s).
C
      SGAMK = 1
C
      DO 100 K = 1, NBLCKS
         CALL DLASET( 'Full', NP, SGAMK-1, ZERO, ZERO, KER(1,1,K),
     $                LDKER1 )
         IFIR = SGAMK
C
C        Copy the appropriate columns of NULLSP into KER(k).
C        SGAMK = 1 + SUM(i=1,..,k-1) GAM(i), is the first nontrivial
C        column of KER(k), the first SGAMK - 1 columns of KER(k) are
C        zero. IFIR denotes the position of the first column in KER(k)
C        in the set of columns copied for a value of J.
C        VC1 is the first column of NULLSP to be copied.
C
         DO 80 J = K, NBLCKS
            GAMJ = GAM(J)
            VC1 = IWORK(J) + (K-1)*GAMJ + 1
            CALL DLACPY( 'Full', NP, GAMJ, NULLSP(1,VC1), LDNULL,
     $                   KER(1,IFIR,K), LDKER1 )
            IFIR = IFIR + GAMJ
   80    CONTINUE
C
         SGAMK = SGAMK + GAM(K)
  100 CONTINUE
C
      RETURN
C *** Last line of MC03ND ***
      END