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 . 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