stepan
/
dynare
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
dynare/mex/sources/libslicot/AB09DD.f

279 lines
8.8 KiB
Fortran
Raw Blame History

SUBROUTINE AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC,
$ D, LDD, RCOND, IWORK, DWORK, 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 a reduced order model by using singular perturbation
C approximation formulas.
C
C ARGUMENTS
C
C Mode Parameters
C
C DICO CHARACTER*1
C Specifies the type of the original system as follows:
C = 'C': continuous-time system;
C = 'D': discrete-time system.
C
C Input/Output Parameters
C
C N (input) INTEGER
C The dimension of the state vector, i.e. the order of the
C matrix A; also the number of rows of matrix B and the
C number of columns of the matrix C. N >= 0.
C
C M (input) INTEGER
C The dimension of input vector, i.e. the number of columns
C of matrices B and D. M >= 0.
C
C P (input) INTEGER
C The dimension of output vector, i.e. the number of rows of
C matrices C and D. P >= 0.
C
C NR (input) INTEGER
C The order of the reduced order system. N >= NR >= 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 state dynamics matrix of the original system.
C On exit, the leading NR-by-NR part of this array contains
C the state dynamics matrix Ar of the reduced order system.
C
C LDA INTEGER
C The leading dimension of array A. LDA >= MAX(1,N).
C
C B (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C On entry, the leading N-by-M part of this array must
C contain the input/state matrix of the original system.
C On exit, the leading NR-by-M part of this array contains
C the input/state matrix Br of the reduced order system.
C
C LDB INTEGER
C The leading dimension of array B. LDB >= MAX(1,N).
C
C C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C On entry, the leading P-by-N part of this array must
C contain the state/output matrix of the original system.
C On exit, the leading P-by-NR part of this array contains
C the state/output matrix Cr of the reduced order system.
C
C LDC INTEGER
C The leading dimension of array C. LDC >= MAX(1,P).
C
C D (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C On entry, the leading P-by-M part of this array must
C contain the input/output matrix of the original system.
C On exit, the leading P-by-M part of this array contains
C the input/output matrix Dr of the reduced order system.
C If NR = 0 and the given system is stable, then D contains
C the steady state gain of the system.
C
C LDD INTEGER
C The leading dimension of array D. LDD >= MAX(1,P).
C
C RCOND (output) DOUBLE PRECISION
C The reciprocal condition number of the matrix A22-g*I
C (see METHOD).
C
C Workspace
C
C IWORK INTEGER array, dimension 2*(N-NR)
C
C DWORK DOUBLE PRECISION array, dimension 4*(N-NR)
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: if the matrix A22-g*I (see METHOD) is numerically
C singular.
C
C METHOD
C
C Given the system (A,B,C,D), partition the system matrices as
C
C ( A11 A12 ) ( B1 )
C A = ( ) , B = ( ) , C = ( C1 C2 ),
C ( A21 A22 ) ( B2 )
C
C where A11 is NR-by-NR, B1 is NR-by-M, C1 is P-by-NR, and the other
C submatrices have appropriate dimensions.
C
C The matrices of the reduced order system (Ar,Br,Cr,Dr) are
C computed according to the following residualization formulas:
C -1 -1
C Ar = A11 + A12*(g*I-A22) *A21 , Br = B1 + A12*(g*I-A22) *B2
C -1 -1
C Cr = C1 + C2*(g*I-A22) *A21 , Dr = D + C2*(g*I-A22) *B2
C
C where g = 0 if DICO = 'C' and g = 1 if DICO = 'D'.
C
C CONTRIBUTOR
C
C C. Oara and A. Varga, German Aerospace Center,
C DLR Oberpfaffenhofen, March 1998.
C Based on the RASP routine SRESID.
C
C REVISIONS
C
C -
C
C KEYWORDS
C
C Model reduction, multivariable system, state-space model.
C
C ******************************************************************
C
C .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
C .. Scalar Arguments ..
CHARACTER DICO
INTEGER INFO, LDA, LDB, LDC, LDD, M, N, NR, P
DOUBLE PRECISION RCOND
C .. Array Arguments ..
DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*)
INTEGER IWORK(*)
C .. Local Scalars
LOGICAL DISCR
INTEGER I, J, K, NS
DOUBLE PRECISION A22NRM
C .. External Functions ..
LOGICAL LSAME
DOUBLE PRECISION DLAMCH, DLANGE
EXTERNAL DLAMCH, DLANGE, LSAME
C .. External Subroutines ..
EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, XERBLA
C .. Intrinsic Functions ..
INTRINSIC MAX
C .. Executable Statements ..
C
C Check the input scalar arguments.
C
INFO = 0
DISCR = LSAME( DICO, 'D' )
IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( P.LT.0 ) THEN
INFO = -4
ELSE IF( NR.LT.0 .OR. NR.GT.N ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -9
ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
INFO = -11
ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
INFO = -13
END IF
C
IF( INFO.NE.0 ) THEN
C
C Error return.
C
CALL XERBLA( 'AB09DD', -INFO )
RETURN
END IF
C
C Quick return if possible.
C
IF( NR.EQ.N ) THEN
RCOND = ONE
RETURN
END IF
C
K = NR + 1
NS = N - NR
C
C Compute: T = -A22 if DICO = 'C' and
C T = -A22+I if DICO = 'D'.
C
DO 20 J = K, N
DO 10 I = K, N
A(I,J) = -A(I,J)
10 CONTINUE
IF( DISCR ) A(J,J) = A(J,J) + ONE
20 CONTINUE
C
C Compute the LU decomposition of T.
C
A22NRM = DLANGE( '1-norm', NS, NS, A(K,K), LDA, DWORK )
CALL DGETRF( NS, NS, A(K,K), LDA, IWORK, INFO )
IF( INFO.GT.0 ) THEN
C
C Error return.
C
RCOND = ZERO
INFO = 1
RETURN
END IF
CALL DGECON( '1-norm', NS, A(K,K), LDA, A22NRM, RCOND, DWORK,
$ IWORK(NS+1), INFO )
IF( RCOND.LE.DLAMCH('E') ) THEN
C
C Error return.
C
INFO = 1
RETURN
END IF
C
C Compute A21 <- INV(T)*A21.
C
CALL DGETRS( 'NoTranspose', NS, NR, A(K,K), LDA, IWORK, A(K,1),
$ LDA, INFO )
C
C Compute B2 <- INV(T)*B2.
C
CALL DGETRS( 'NoTranspose', NS, M, A(K,K), LDA, IWORK, B(K,1),
$ LDB, INFO )
C
C Compute the residualized systems matrices.
C Ar = A11 + A12*INV(T)*A21.
C
CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, NS, ONE, A(1,K),
$ LDA, A(K,1), LDA, ONE, A, LDA )
C
C Br = B1 + A12*INV(T)*B2.
C
CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, NS, ONE, A(1,K),
$ LDA, B(K,1), LDB, ONE, B, LDB )
C
C Cr = C1 + C2*INV(T)*A21.
C
CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, NS, ONE, C(1,K),
$ LDC, A(K,1), LDA, ONE, C, LDC )
C
C Dr = D + C2*INV(T)*B2.
C
CALL DGEMM( 'NoTranspose', 'NoTranspose', P, M, NS, ONE, C(1,K),
$ LDC, B(K,1), LDB, ONE, D, LDD )
C
RETURN
C *** Last line of AB09DD ***
END
Reference in New Issue View Git Blame Copy Permalink