SUBROUTINE SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C,
$ LDC, TOL, IWORK, DWORK, LDWORK, INFO )
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