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

346 lines
11 KiB
Fortran
Raw Blame History

SUBROUTINE AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, C,
$ LDC, D, LDD, 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 perform a transformation on the parameters (A,B,C,D) of a
C system, which is equivalent to a bilinear transformation of the
C corresponding transfer function matrix.
C
C ARGUMENTS
C
C Mode Parameters
C
C TYPE CHARACTER*1
C Indicates the type of the original system and the
C transformation to be performed as follows:
C = 'D': discrete-time -> continuous-time;
C = 'C': continuous-time -> discrete-time.
C
C Input/Output Parameters
C
C N (input) INTEGER
C The order of the state matrix A. N >= 0.
C
C M (input) INTEGER
C The number of system inputs. M >= 0.
C
C P (input) INTEGER
C The number of system outputs. P >= 0.
C
C ALPHA, (input) DOUBLE PRECISION
C BETA Parameters specifying the bilinear transformation.
C Recommended values for stable systems: ALPHA = 1,
C BETA = 1. ALPHA <> 0, BETA <> 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 matrix A of the original system.
C On exit, the leading N-by-N part of this array contains
C _
C the state matrix A of the transformed 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 matrix B of the original system.
C On exit, the leading N-by-M part of this array contains
C _
C the input matrix B of the transformed 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 output matrix C of the original system.
C On exit, the leading P-by-N part of this array contains
C _
C the output matrix C of the transformed 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 D for the original system.
C On exit, the leading P-by-M part of this array contains
C _
C the input/output matrix D of the transformed system.
C
C LDD INTEGER
C The leading dimension of array D. LDD >= MAX(1,P).
C
C Workspace
C
C IWORK INTEGER array, dimension (N)
C
C DWORK DOUBLE PRECISION array, dimension (LDWORK)
C On exit, if INFO = 0, DWORK(1) returns the optimal value
C of LDWORK.
C
C LDWORK INTEGER
C The length of the array DWORK. LDWORK >= MAX(1,N).
C For optimum performance LDWORK >= MAX(1,N*NB), where NB
C is the optimal blocksize.
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 (ALPHA*I + A) is exactly singular;
C = 2: if the matrix (BETA*I - A) is exactly singular.
C
C METHOD
C
C The parameters of the discrete-time system are transformed into
C the parameters of the continuous-time system (TYPE = 'D'), or
C vice-versa (TYPE = 'C') by the transformation:
C
C 1. Discrete -> continuous
C _ -1
C A = beta*(alpha*I + A) * (A - alpha*I)
C _ -1
C B = sqrt(2*alpha*beta) * (alpha*I + A) * B
C _ -1
C C = sqrt(2*alpha*beta) * C * (alpha*I + A)
C _ -1
C D = D - C * (alpha*I + A) * B
C
C which is equivalent to the bilinear transformation
C
C z - alpha
C z -> s = beta --------- .
C z + alpha
C
C of one transfer matrix onto the other.
C
C 2. Continuous -> discrete
C _ -1
C A = alpha*(beta*I - A) * (beta*I + A)
C _ -1
C B = sqrt(2*alpha*beta) * (beta*I - A) * B
C _ -1
C C = sqrt(2*alpha*beta) * C * (beta*I - A)
C _ -1
C D = D + C * (beta*I - A) * B
C
C which is equivalent to the bilinear transformation
C
C beta + s
C s -> z = alpha -------- .
C beta - s
C
C of one transfer matrix onto the other.
C
C REFERENCES
C
C [1] Al-Saggaf, U.M. and Franklin, G.F.
C Model reduction via balanced realizations: a extension and
C frequency weighting techniques.
C IEEE Trans. Autom. Contr., AC-33, pp. 687-692, 1988.
C
C NUMERICAL ASPECTS
C 3
C The time taken is approximately proportional to N .
C The accuracy depends mainly on the condition number of the matrix
C to be inverted.
C
C CONTRIBUTORS
C
C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and
C A. Varga, German Aerospace Research Establishment,
C Oberpfaffenhofen, Germany, Nov. 1996.
C Supersedes Release 2.0 routine AB04AD by W. van der Linden, and
C A.J. Geurts, Technische Hogeschool Eindhoven, Holland.
C
C REVISIONS
C
C -
C
C KEYWORDS
C
C Bilinear transformation, continuous-time system, discrete-time
C system, state-space model.
C
C ******************************************************************
C
C .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO=0.0D0, ONE=1.0D0, TWO=2.0D0 )
C .. Scalar Arguments ..
CHARACTER TYPE
INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P
DOUBLE PRECISION ALPHA, BETA
C .. Array Arguments ..
INTEGER IWORK(*)
DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*)
C .. Local Scalars ..
LOGICAL LTYPE
INTEGER I, IP
DOUBLE PRECISION AB2, PALPHA, PBETA, SQRAB2
C .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
C .. External Subroutines ..
EXTERNAL DGEMM, DGETRF, DGETRS, DGETRI, DLASCL, DSCAL,
$ DSWAP, XERBLA
C .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SIGN, SQRT
C .. Executable Statements ..
C
INFO = 0
LTYPE = LSAME( TYPE, 'D' )
C
C Test the input scalar arguments.
C
IF( .NOT.LTYPE .AND. .NOT.LSAME( TYPE, 'C' ) ) 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( ALPHA.EQ.ZERO ) THEN
INFO = -5
ELSE IF( BETA.EQ.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -10
ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
INFO = -12
ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
INFO = -14
ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN
INFO = -17
END IF
C
IF ( INFO.NE.0 ) THEN
C
C Error return.
C
CALL XERBLA( 'AB04MD', -INFO )
RETURN
END IF
C
C Quick return if possible.
C
IF ( MAX( N, M, P ).EQ.0 )
$ RETURN
C
C (Note: Comments in the code beginning "Workspace:" describe the
C minimal amount of real workspace needed at that point in the
C code, as well as the preferred amount for good performance.
C NB refers to the optimal block size for the immediately
C following subroutine, as returned by ILAENV.)
C
IF (LTYPE) THEN
C
C Discrete-time to continuous-time with (ALPHA, BETA).
C
PALPHA = ALPHA
PBETA = BETA
ELSE
C
C Continuous-time to discrete-time with (ALPHA, BETA) is
C equivalent with discrete-time to continuous-time with
C (-BETA, -ALPHA), if B and C change the sign.
C
PALPHA = -BETA
PBETA = -ALPHA
END IF
C
AB2 = PALPHA*PBETA*TWO
SQRAB2 = SIGN( SQRT( ABS( AB2 ) ), PALPHA )
C -1
C Compute (alpha*I + A) .
C
DO 10 I = 1, N
A(I,I) = A(I,I) + PALPHA
10 CONTINUE
C
CALL DGETRF( N, N, A, LDA, IWORK, INFO )
C
IF (INFO.NE.0) THEN
C
C Error return.
C
IF (LTYPE) THEN
INFO = 1
ELSE
INFO = 2
END IF
RETURN
END IF
C -1
C Compute (alpha*I+A) *B.
C
CALL DGETRS( 'No transpose', N, M, A, LDA, IWORK, B, LDB, INFO )
C -1
C Compute D - C*(alpha*I+A) *B.
C
CALL DGEMM( 'No transpose', 'No transpose', P, M, N, -ONE, C,
$ LDC, B, LDB, ONE, D, LDD )
C
C Scale B by sqrt(2*alpha*beta).
C
CALL DLASCL( 'General', 0, 0, ONE, SQRAB2, N, M, B, LDB, INFO )
C -1
C Compute sqrt(2*alpha*beta)*C*(alpha*I + A) .
C
CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', P, N,
$ SQRAB2, A, LDA, C, LDC )
C
CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', P, N, ONE,
$ A, LDA, C, LDC )
C
C Apply column interchanges to the solution matrix.
C
DO 20 I = N-1, 1, -1
IP = IWORK(I)
IF ( IP.NE.I )
$ CALL DSWAP( P, C(1,I), 1, C(1,IP), 1 )
20 CONTINUE
C -1
C Compute beta*(alpha*I + A) *(A - alpha*I) as
C -1
C beta*I - 2*alpha*beta*(alpha*I + A) .
C
C Workspace: need N; prefer N*NB.
C
CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO )
C
DO 30 I = 1, N
CALL DSCAL(N, -AB2, A(1,I), 1)
A(I,I) = A(I,I) + PBETA
30 CONTINUE
C
RETURN
C *** Last line of AB04MD ***
END
Reference in New Issue View Git Blame Copy Permalink