407 lines
14 KiB
Fortran
407 lines
14 KiB
Fortran
SUBROUTINE SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C,
|
|
$ LDC, 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 solve for X the discrete-time Sylvester equation
|
|
C
|
|
C X + AXB = C,
|
|
C
|
|
C with at least one of the matrices A or B in Schur form and the
|
|
C other in Hessenberg or Schur form (both either upper or lower);
|
|
C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices,
|
|
C respectively.
|
|
C
|
|
C ARGUMENTS
|
|
C
|
|
C Mode Parameters
|
|
C
|
|
C ABSCHU CHARACTER*1
|
|
C Indicates whether A and/or B is/are in Schur or
|
|
C Hessenberg form as follows:
|
|
C = 'A': A is in Schur form, B is in Hessenberg form;
|
|
C = 'B': B is in Schur form, A is in Hessenberg form;
|
|
C = 'S': Both A and B are in Schur form.
|
|
C
|
|
C ULA CHARACTER*1
|
|
C Indicates whether A is in upper or lower Schur form or
|
|
C upper or lower Hessenberg form as follows:
|
|
C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and
|
|
C upper Schur form otherwise;
|
|
C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and
|
|
C lower Schur form otherwise.
|
|
C
|
|
C ULB CHARACTER*1
|
|
C Indicates whether B is in upper or lower Schur form or
|
|
C upper or lower Hessenberg form as follows:
|
|
C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and
|
|
C upper Schur form otherwise;
|
|
C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and
|
|
C lower Schur form otherwise.
|
|
C
|
|
C Input/Output Parameters
|
|
C
|
|
C N (input) INTEGER
|
|
C The order of the matrix A. N >= 0.
|
|
C
|
|
C M (input) INTEGER
|
|
C The order of the matrix B. M >= 0.
|
|
C
|
|
C A (input) DOUBLE PRECISION array, dimension (LDA,N)
|
|
C The leading N-by-N part of this array must contain the
|
|
C coefficient matrix A of the equation.
|
|
C
|
|
C LDA INTEGER
|
|
C The leading dimension of array A. LDA >= MAX(1,N).
|
|
C
|
|
C B (input) DOUBLE PRECISION array, dimension (LDB,M)
|
|
C The leading M-by-M part of this array must contain the
|
|
C coefficient matrix B of the equation.
|
|
C
|
|
C LDB INTEGER
|
|
C The leading dimension of array B. LDB >= MAX(1,M).
|
|
C
|
|
C C (input/output) DOUBLE PRECISION array, dimension (LDC,M)
|
|
C On entry, the leading N-by-M part of this array must
|
|
C contain the coefficient matrix C of the equation.
|
|
C On exit, if INFO = 0, the leading N-by-M part of this
|
|
C array contains the solution matrix X of the problem.
|
|
C
|
|
C LDC INTEGER
|
|
C The leading dimension of array C. LDC >= MAX(1,N).
|
|
C
|
|
C Tolerances
|
|
C
|
|
C TOL DOUBLE PRECISION
|
|
C The tolerance to be used to test for near singularity in
|
|
C the Sylvester equation. If the user sets TOL > 0, then the
|
|
C given value of TOL is used as a lower bound for the
|
|
C reciprocal condition number; a matrix whose estimated
|
|
C condition number is less than 1/TOL is considered to be
|
|
C nonsingular. If the user sets TOL <= 0, then a default
|
|
C tolerance, defined by TOLDEF = EPS, is used instead, where
|
|
C EPS is the machine precision (see LAPACK Library routine
|
|
C DLAMCH).
|
|
C This parameter is not referenced if ABSCHU = 'S',
|
|
C ULA = 'U', and ULB = 'U'.
|
|
C
|
|
C Workspace
|
|
C
|
|
C IWORK INTEGER array, dimension (2*MAX(M,N))
|
|
C This parameter is not referenced if ABSCHU = 'S',
|
|
C ULA = 'U', and ULB = 'U'.
|
|
C
|
|
C DWORK DOUBLE PRECISION array, dimension (LDWORK)
|
|
C
|
|
C LDWORK INTEGER
|
|
C The length of the array DWORK.
|
|
C LDWORK = 2*N, if ABSCHU = 'S', ULA = 'U', and ULB = 'U';
|
|
C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise.
|
|
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 a (numerically) singular matrix T was encountered
|
|
C during the computation of the solution matrix X.
|
|
C That is, the estimated reciprocal condition number
|
|
C of T is less than or equal to TOL.
|
|
C
|
|
C METHOD
|
|
C
|
|
C Matrices A and B are assumed to be in (upper or lower) Hessenberg
|
|
C or Schur form (with at least one of them in Schur form). The
|
|
C solution matrix X is then computed by rows or columns via the back
|
|
C substitution scheme proposed by Golub, Nash and Van Loan (see
|
|
C [1]), which involves the solution of triangular systems of
|
|
C equations that are constructed recursively and which may be nearly
|
|
C singular if A and -B have almost reciprocal eigenvalues. If near
|
|
C singularity is detected, then the routine returns with the Error
|
|
C Indicator (INFO) set to 1.
|
|
C
|
|
C REFERENCES
|
|
C
|
|
C [1] Golub, G.H., Nash, S. and Van Loan, C.F.
|
|
C A Hessenberg-Schur method for the problem AX + XB = C.
|
|
C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
|
|
C
|
|
C [2] Sima, V.
|
|
C Algorithms for Linear-quadratic Optimization.
|
|
C Marcel Dekker, Inc., New York, 1996.
|
|
C
|
|
C NUMERICAL ASPECTS
|
|
C 2 2
|
|
C The algorithm requires approximately 5M N + 0.5MN operations in
|
|
C 2 2
|
|
C the worst case and 2.5M N + 0.5MN operations in the best case
|
|
C (where M is the order of the matrix in Hessenberg form and N is
|
|
C the order of the matrix in Schur form) and is mixed stable (see
|
|
C [1]).
|
|
C
|
|
C CONTRIBUTORS
|
|
C
|
|
C D. Sima, University of Bucharest, May 2000.
|
|
C
|
|
C REVISIONS
|
|
C
|
|
C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000.
|
|
C
|
|
C KEYWORDS
|
|
C
|
|
C Hessenberg form, orthogonal transformation, real Schur form,
|
|
C Sylvester equation.
|
|
C
|
|
C ******************************************************************
|
|
C
|
|
C .. Parameters ..
|
|
DOUBLE PRECISION ONE, ZERO
|
|
PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
|
|
C .. Scalar Arguments ..
|
|
CHARACTER ABSCHU, ULA, ULB
|
|
INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N
|
|
DOUBLE PRECISION TOL
|
|
C .. Array Arguments ..
|
|
INTEGER IWORK(*)
|
|
DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*)
|
|
C .. Local Scalars ..
|
|
CHARACTER ABSCHR
|
|
LOGICAL LABSCB, LABSCS, LULA, LULB
|
|
INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK,
|
|
$ LDW, MAXMN
|
|
DOUBLE PRECISION SCALE, TOL1
|
|
C .. External Functions ..
|
|
LOGICAL LSAME
|
|
DOUBLE PRECISION DLAMCH
|
|
EXTERNAL DLAMCH, LSAME
|
|
C .. External Subroutines ..
|
|
EXTERNAL DCOPY, SB04PY, SB04RV, SB04RW, SB04RX, SB04RY,
|
|
$ XERBLA
|
|
C .. Intrinsic Functions ..
|
|
INTRINSIC MAX
|
|
C .. Executable Statements ..
|
|
C
|
|
INFO = 0
|
|
MAXMN = MAX( M, N )
|
|
LABSCB = LSAME( ABSCHU, 'B' )
|
|
LABSCS = LSAME( ABSCHU, 'S' )
|
|
LULA = LSAME( ULA, 'U' )
|
|
LULB = LSAME( ULB, 'U' )
|
|
C
|
|
C Test the input scalar arguments.
|
|
C
|
|
IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND.
|
|
$ .NOT.LSAME( ABSCHU, 'A' ) ) THEN
|
|
INFO = -1
|
|
ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN
|
|
INFO = -2
|
|
ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN
|
|
INFO = -3
|
|
ELSE IF( N.LT.0 ) THEN
|
|
INFO = -4
|
|
ELSE IF( M.LT.0 ) THEN
|
|
INFO = -5
|
|
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
|
|
INFO = -7
|
|
ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
|
|
INFO = -9
|
|
ELSE IF( LDC.LT.MAX( 1, N ) ) THEN
|
|
INFO = -11
|
|
ELSE IF( LDWORK.LT.2*N .OR.
|
|
$ ( LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) .AND.
|
|
$ .NOT.( LABSCS .AND. LULA .AND. LULB ) ) ) THEN
|
|
INFO = -15
|
|
END IF
|
|
C
|
|
IF ( INFO.NE.0 ) THEN
|
|
C
|
|
C Error return.
|
|
C
|
|
CALL XERBLA( 'SB04RD', -INFO )
|
|
RETURN
|
|
END IF
|
|
C
|
|
C Quick return if possible.
|
|
C
|
|
IF ( MAXMN.EQ.0 )
|
|
$ RETURN
|
|
C
|
|
IF ( LABSCS .AND. LULA .AND. LULB ) THEN
|
|
C
|
|
C If both matrices are in a real Schur form, use SB04PY.
|
|
C
|
|
CALL SB04PY( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA,
|
|
$ B, LDB, C, LDC, SCALE, DWORK, INFO )
|
|
IF ( SCALE.NE.ONE )
|
|
$ INFO = 1
|
|
RETURN
|
|
END IF
|
|
C
|
|
LDW = 2*MAXMN
|
|
JWORK = LDW*LDW + 3*LDW + 1
|
|
TOL1 = TOL
|
|
IF ( TOL1.LE.ZERO )
|
|
$ TOL1 = DLAMCH( 'Epsilon' )
|
|
C
|
|
C Choose the smallest of both matrices as the one in Hessenberg
|
|
C form when possible.
|
|
C
|
|
ABSCHR = ABSCHU
|
|
IF ( LABSCS ) THEN
|
|
IF ( N.GT.M ) THEN
|
|
ABSCHR = 'A'
|
|
ELSE
|
|
ABSCHR = 'B'
|
|
END IF
|
|
END IF
|
|
IF ( LSAME( ABSCHR, 'B' ) ) THEN
|
|
C
|
|
C B is in Schur form: recursion on the columns of B.
|
|
C
|
|
IF ( LULB ) THEN
|
|
C
|
|
C B is upper: forward recursion.
|
|
C
|
|
IBEG = 1
|
|
IEND = M
|
|
FWD = 1
|
|
INCR = 0
|
|
ELSE
|
|
C
|
|
C B is lower: backward recursion.
|
|
C
|
|
IBEG = M
|
|
IEND = 1
|
|
FWD = -1
|
|
INCR = -1
|
|
END IF
|
|
I = IBEG
|
|
C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO
|
|
20 IF ( ( IEND - I )*FWD.GE.0 ) THEN
|
|
C
|
|
C Test for 1-by-1 or 2-by-2 diagonal block in the Schur
|
|
C form.
|
|
C
|
|
IF ( I.EQ.IEND ) THEN
|
|
ISTEP = 1
|
|
ELSE
|
|
IF ( B(I+FWD,I).EQ.ZERO ) THEN
|
|
ISTEP = 1
|
|
ELSE
|
|
ISTEP = 2
|
|
END IF
|
|
END IF
|
|
C
|
|
IF ( ISTEP.EQ.1 ) THEN
|
|
CALL SB04RW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB,
|
|
$ A, LDA, DWORK(JWORK), DWORK )
|
|
CALL SB04RY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK),
|
|
$ TOL1, IWORK, DWORK, LDW, INFO )
|
|
IF ( INFO.EQ.1 )
|
|
$ RETURN
|
|
CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 )
|
|
ELSE
|
|
IPINCR = I + INCR
|
|
CALL SB04RV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB,
|
|
$ A, LDA, DWORK(JWORK), DWORK )
|
|
CALL SB04RX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR),
|
|
$ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1),
|
|
$ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1,
|
|
$ IWORK, DWORK, LDW, INFO )
|
|
IF ( INFO.EQ.1 )
|
|
$ RETURN
|
|
CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 )
|
|
CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 )
|
|
END IF
|
|
I = I + FWD*ISTEP
|
|
GO TO 20
|
|
END IF
|
|
C END WHILE 20
|
|
ELSE
|
|
C
|
|
C A is in Schur form: recursion on the rows of A.
|
|
C
|
|
IF ( LULA ) THEN
|
|
C
|
|
C A is upper: backward recursion.
|
|
C
|
|
IBEG = N
|
|
IEND = 1
|
|
FWD = -1
|
|
INCR = -1
|
|
ELSE
|
|
C
|
|
C A is lower: forward recursion.
|
|
C
|
|
IBEG = 1
|
|
IEND = N
|
|
FWD = 1
|
|
INCR = 0
|
|
END IF
|
|
I = IBEG
|
|
C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO
|
|
40 IF ( ( IEND - I )*FWD.GE.0 ) THEN
|
|
C
|
|
C Test for 1-by-1 or 2-by-2 diagonal block in the Schur
|
|
C form.
|
|
C
|
|
IF ( I.EQ.IEND ) THEN
|
|
ISTEP = 1
|
|
ELSE
|
|
IF ( A(I,I+FWD).EQ.ZERO ) THEN
|
|
ISTEP = 1
|
|
ELSE
|
|
ISTEP = 2
|
|
END IF
|
|
END IF
|
|
C
|
|
IF ( ISTEP.EQ.1 ) THEN
|
|
CALL SB04RW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA,
|
|
$ B, LDB, DWORK(JWORK), DWORK )
|
|
CALL SB04RY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK),
|
|
$ TOL1, IWORK, DWORK, LDW, INFO )
|
|
IF ( INFO.EQ.1 )
|
|
$ RETURN
|
|
CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC )
|
|
ELSE
|
|
IPINCR = I + INCR
|
|
CALL SB04RV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA,
|
|
$ B, LDB, DWORK(JWORK), DWORK )
|
|
CALL SB04RX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR),
|
|
$ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1),
|
|
$ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1,
|
|
$ IWORK, DWORK, LDW, INFO )
|
|
IF ( INFO.EQ.1 )
|
|
$ RETURN
|
|
CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC )
|
|
CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC )
|
|
END IF
|
|
I = I + FWD*ISTEP
|
|
GO TO 40
|
|
END IF
|
|
C END WHILE 40
|
|
END IF
|
|
C
|
|
RETURN
|
|
C *** Last line of SB04RD ***
|
|
END
|