694 lines
24 KiB
Fortran
694 lines
24 KiB
Fortran
SUBROUTINE SB03OY( DISCR, LTRANS, ISGN, S, LDS, R, LDR, A, LDA,
|
|
$ SCALE, 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 the Cholesky factor U of X,
|
|
C
|
|
C op(U)'*op(U) = X,
|
|
C
|
|
C where U is a two-by-two upper triangular matrix, either the
|
|
C continuous-time two-by-two Lyapunov equation
|
|
C 2
|
|
C op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R),
|
|
C
|
|
C when DISCR = .FALSE., or the discrete-time two-by-two Lyapunov
|
|
C equation
|
|
C 2
|
|
C op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R),
|
|
C
|
|
C when DISCR = .TRUE., where op(K) = K or K' (i.e., the transpose of
|
|
C the matrix K), S is a two-by-two matrix with complex conjugate
|
|
C eigenvalues, R is a two-by-two upper triangular matrix,
|
|
C ISGN = -1 or 1, and scale is an output scale factor, set less
|
|
C than or equal to 1 to avoid overflow in X. The routine also
|
|
C computes two matrices, B and A, so that
|
|
C 2
|
|
C B*U = U*S and A*U = scale *R, if LTRANS = .FALSE., or
|
|
C 2
|
|
C U*B = S*U and U*A = scale *R, if LTRANS = .TRUE.,
|
|
C which are used by the general Lyapunov solver.
|
|
C In the continuous-time case ISGN*S must be stable, so that its
|
|
C eigenvalues must have strictly negative real parts.
|
|
C In the discrete-time case S must be convergent if ISGN = 1, that
|
|
C is, its eigenvalues must have moduli less than unity, or S must
|
|
C be completely divergent if ISGN = -1, that is, its eigenvalues
|
|
C must have moduli greater than unity.
|
|
C
|
|
C ARGUMENTS
|
|
C
|
|
C Mode Parameters
|
|
C
|
|
C DISCR LOGICAL
|
|
C Specifies the equation to be solved: 2
|
|
C = .FALSE.: op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R);
|
|
C 2
|
|
C = .TRUE. : op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R).
|
|
C
|
|
C LTRANS LOGICAL
|
|
C Specifies the form of op(K) to be used, as follows:
|
|
C = .FALSE.: op(K) = K (No transpose);
|
|
C = .TRUE. : op(K) = K**T (Transpose).
|
|
C
|
|
C ISGN INTEGER
|
|
C Specifies the sign of the equation as described before.
|
|
C ISGN may only be 1 or -1.
|
|
C
|
|
C Input/Output Parameters
|
|
C
|
|
C S (input/output) DOUBLE PRECISION array, dimension (LDS,2)
|
|
C On entry, S must contain a 2-by-2 matrix.
|
|
C On exit, S contains a 2-by-2 matrix B such that B*U = U*S,
|
|
C if LTRANS = .FALSE., or U*B = S*U, if LTRANS = .TRUE..
|
|
C Notice that if U is nonsingular then
|
|
C B = U*S*inv( U ), if LTRANS = .FALSE.
|
|
C B = inv( U )*S*U, if LTRANS = .TRUE..
|
|
C
|
|
C LDS INTEGER
|
|
C The leading dimension of array S. LDS >= 2.
|
|
C
|
|
C R (input/output) DOUBLE PRECISION array, dimension (LDR,2)
|
|
C On entry, R must contain a 2-by-2 upper triangular matrix.
|
|
C The element R( 2, 1 ) is not referenced.
|
|
C On exit, R contains U, the 2-by-2 upper triangular
|
|
C Cholesky factor of the solution X, X = op(U)'*op(U).
|
|
C
|
|
C LDR INTEGER
|
|
C The leading dimension of array R. LDR >= 2.
|
|
C
|
|
C A (output) DOUBLE PRECISION array, dimension (LDA,2)
|
|
C A contains a 2-by-2 upper triangular matrix A satisfying
|
|
C A*U/scale = scale*R, if LTRANS = .FALSE., or
|
|
C U*A/scale = scale*R, if LTRANS = .TRUE..
|
|
C Notice that if U is nonsingular then
|
|
C A = scale*scale*R*inv( U ), if LTRANS = .FALSE.
|
|
C A = scale*scale*inv( U )*R, if LTRANS = .TRUE..
|
|
C
|
|
C LDA INTEGER
|
|
C The leading dimension of array A. LDA >= 2.
|
|
C
|
|
C SCALE (output) DOUBLE PRECISION
|
|
C The scale factor, scale, set less than or equal to 1 to
|
|
C prevent the solution overflowing.
|
|
C
|
|
C Error Indicator
|
|
C
|
|
C INFO INTEGER
|
|
C = 0: successful exit;
|
|
C = 1: if the Lyapunov equation is (nearly) singular
|
|
C (warning indicator);
|
|
C if DISCR = .FALSE., this means that while the
|
|
C matrix S has computed eigenvalues with negative real
|
|
C parts, it is only just stable in the sense that
|
|
C small perturbations in S can make one or more of the
|
|
C eigenvalues have a non-negative real part;
|
|
C if DISCR = .TRUE., this means that while the
|
|
C matrix S has computed eigenvalues inside the unit
|
|
C circle, it is nevertheless only just convergent, in
|
|
C the sense that small perturbations in S can make one
|
|
C or more of the eigenvalues lie outside the unit
|
|
C circle;
|
|
C perturbed values were used to solve the equation
|
|
C (but the matrix S is unchanged);
|
|
C = 2: if DISCR = .FALSE., and ISGN*S is not stable or
|
|
C if DISCR = .TRUE., ISGN = 1 and S is not convergent
|
|
C or if DISCR = .TRUE., ISGN = -1 and S is not
|
|
C completely divergent;
|
|
C = 4: if S has real eigenvalues.
|
|
C
|
|
C NOTE: In the interests of speed, this routine does not check all
|
|
C inputs for errors.
|
|
C
|
|
C METHOD
|
|
C
|
|
C The LAPACK scheme for solving 2-by-2 Sylvester equations is
|
|
C adapted for 2-by-2 Lyapunov equations, but directly computing the
|
|
C Cholesky factor of the solution.
|
|
C
|
|
C REFERENCES
|
|
C
|
|
C [1] Hammarling S. J.
|
|
C Numerical solution of the stable, non-negative definite
|
|
C Lyapunov equation.
|
|
C IMA J. Num. Anal., 2, pp. 303-325, 1982.
|
|
C
|
|
C NUMERICAL ASPECTS
|
|
C
|
|
C The algorithm is backward stable.
|
|
C
|
|
C CONTRIBUTOR
|
|
C
|
|
C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
|
|
C Supersedes Release 2.0 routine SB03CY by Sven Hammarling,
|
|
C NAG Ltd., United Kingdom, November 1986.
|
|
C Partly based on SB03CY and PLYAP2 by A. Varga, University of
|
|
C Bochum, May 1992.
|
|
C
|
|
C REVISIONS
|
|
C
|
|
C Dec. 1997, April 1998.
|
|
C
|
|
C KEYWORDS
|
|
C
|
|
C Lyapunov equation, orthogonal transformation, real Schur form.
|
|
C
|
|
C *****************************************************************
|
|
C
|
|
C .. Parameters ..
|
|
DOUBLE PRECISION ZERO, ONE, TWO, FOUR
|
|
PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
|
|
$ FOUR = 4.0D0 )
|
|
C .. Scalar Arguments ..
|
|
LOGICAL DISCR, LTRANS
|
|
INTEGER INFO, ISGN, LDA, LDR, LDS
|
|
DOUBLE PRECISION SCALE
|
|
C .. Array Arguments ..
|
|
DOUBLE PRECISION A(LDA,*), R(LDR,*), S(LDS,*)
|
|
C .. Local Scalars ..
|
|
DOUBLE PRECISION ABSB, ABSG, ABST, ALPHA, BIGNUM, E1, E2, EPS,
|
|
$ ETA, P1, P3, P3I, P3R, S11, S12, S21, S22,
|
|
$ SCALOC, SGN, SMIN, SMLNUM, SNP, SNQ, SNT, TEMPI,
|
|
$ TEMPR, V1, V3
|
|
C .. Local Arrays ..
|
|
DOUBLE PRECISION CSP(2), CSQ(2), CST(2), DELTA(2), DP(2), DT(2),
|
|
$ G(2), GAMMA(2), P2(2), T(2), TEMP(2), V2(2),
|
|
$ X11(2), X12(2), X21(2), X22(2), Y(2)
|
|
C .. External Functions ..
|
|
DOUBLE PRECISION DLAMCH, DLAPY2, DLAPY3
|
|
EXTERNAL DLAMCH, DLAPY2, DLAPY3
|
|
C .. External Subroutines ..
|
|
EXTERNAL DLABAD, DLANV2, SB03OV
|
|
C .. Intrinsic Functions ..
|
|
INTRINSIC ABS, MAX, SIGN, SQRT
|
|
C .. Executable Statements ..
|
|
C
|
|
C The comments in this routine refer to notation and equation
|
|
C numbers in sections 6 and 10 of [1].
|
|
C
|
|
C Find the eigenvalue lambda = E1 - i*E2 of s11.
|
|
C
|
|
INFO = 0
|
|
SGN = ISGN
|
|
S11 = S(1,1)
|
|
S12 = S(1,2)
|
|
S21 = S(2,1)
|
|
S22 = S(2,2)
|
|
C
|
|
C Set constants to control overflow.
|
|
C
|
|
EPS = DLAMCH( 'P' )
|
|
SMLNUM = DLAMCH( 'S' )
|
|
BIGNUM = ONE / SMLNUM
|
|
CALL DLABAD( SMLNUM, BIGNUM )
|
|
SMLNUM = SMLNUM*FOUR / EPS
|
|
BIGNUM = ONE / SMLNUM
|
|
C
|
|
SMIN = MAX( SMLNUM, EPS*MAX( ABS( S11 ), ABS( S12 ),
|
|
$ ABS( S21 ), ABS( S22 ) ) )
|
|
SCALE = ONE
|
|
C
|
|
CALL DLANV2( S11, S12, S21, S22, TEMPR, TEMPI, E1, E2, CSP, CSQ )
|
|
IF ( TEMPI.EQ.ZERO ) THEN
|
|
INFO = 4
|
|
RETURN
|
|
END IF
|
|
ABSB = DLAPY2( E1, E2 )
|
|
IF ( DISCR ) THEN
|
|
IF ( SGN*( ABSB - ONE ).GE.ZERO ) THEN
|
|
INFO = 2
|
|
RETURN
|
|
END IF
|
|
ELSE
|
|
IF ( SGN*E1.GE.ZERO ) THEN
|
|
INFO = 2
|
|
RETURN
|
|
END IF
|
|
END IF
|
|
C
|
|
C Compute the cos and sine that define Qhat. The sine is real.
|
|
C
|
|
TEMP(1) = S(1,1) - E1
|
|
TEMP(2) = E2
|
|
IF ( LTRANS ) TEMP(2) = -E2
|
|
CALL SB03OV( TEMP, S(2,1), CSQ, SNQ )
|
|
C
|
|
C beta in (6.9) is given by beta = E1 + i*E2, compute t.
|
|
C
|
|
TEMP(1) = CSQ(1)*S(1,2) - SNQ*S(1,1)
|
|
TEMP(2) = CSQ(2)*S(1,2)
|
|
TEMPR = CSQ(1)*S(2,2) - SNQ*S(2,1)
|
|
TEMPI = CSQ(2)*S(2,2)
|
|
T(1) = CSQ(1)*TEMP(1) - CSQ(2)*TEMP(2) + SNQ*TEMPR
|
|
T(2) = CSQ(1)*TEMP(2) + CSQ(2)*TEMP(1) + SNQ*TEMPI
|
|
C
|
|
IF ( LTRANS ) THEN
|
|
C ( -- )
|
|
C Case op(M) = M'. Note that the modified R is ( p3 p2 ).
|
|
C ( 0 p1 )
|
|
C
|
|
C Compute the cos and sine that define Phat.
|
|
C
|
|
TEMP(1) = CSQ(1)*R(2,2) - SNQ*R(1,2)
|
|
TEMP(2) = -CSQ(2)*R(2,2)
|
|
CALL SB03OV( TEMP, -SNQ*R(1,1), CSP, SNP )
|
|
C
|
|
C Compute p1, p2 and p3 of the relation corresponding to (6.11).
|
|
C
|
|
P1 = TEMP(1)
|
|
TEMP(1) = CSQ(1)*R(1,2) + SNQ*R(2,2)
|
|
TEMP(2) = -CSQ(2)*R(1,2)
|
|
TEMPR = CSQ(1)*R(1,1)
|
|
TEMPI = -CSQ(2)*R(1,1)
|
|
P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR
|
|
P2(2) = -CSP(1)*TEMP(2) - CSP(2)*TEMP(1) - SNP*TEMPI
|
|
P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1)
|
|
P3I = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*TEMP(2)
|
|
ELSE
|
|
C
|
|
C Case op(M) = M.
|
|
C
|
|
C Compute the cos and sine that define Phat.
|
|
C
|
|
TEMP(1) = CSQ(1)*R(1,1) + SNQ*R(1,2)
|
|
TEMP(2) = CSQ(2)*R(1,1)
|
|
CALL SB03OV( TEMP, SNQ*R(2,2), CSP, SNP )
|
|
C
|
|
C Compute p1, p2 and p3 of (6.11).
|
|
C
|
|
P1 = TEMP(1)
|
|
TEMP(1) = CSQ(1)*R(1,2) - SNQ*R(1,1)
|
|
TEMP(2) = CSQ(2)*R(1,2)
|
|
TEMPR = CSQ(1)*R(2,2)
|
|
TEMPI = CSQ(2)*R(2,2)
|
|
P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR
|
|
P2(2) = CSP(1)*TEMP(2) + CSP(2)*TEMP(1) + SNP*TEMPI
|
|
P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1)
|
|
P3I = CSP(2)*TEMPR - CSP(1)*TEMPI + SNP*TEMP(2)
|
|
END IF
|
|
C
|
|
C Make p3 real by multiplying by conjg ( p3 )/abs( p3 ) to give
|
|
C
|
|
C p3 := abs( p3 ).
|
|
C
|
|
IF ( P3I.EQ.ZERO ) THEN
|
|
P3 = ABS( P3R )
|
|
DP(1) = SIGN( ONE, P3R )
|
|
DP(2) = ZERO
|
|
ELSE
|
|
P3 = DLAPY2( P3R, P3I )
|
|
DP(1) = P3R/P3
|
|
DP(2) = -P3I/P3
|
|
END IF
|
|
C
|
|
C Now compute the quantities v1, v2, v3 and y in (6.13) - (6.15),
|
|
C or (10.23) - (10.25). Care is taken to avoid overflows.
|
|
C
|
|
IF ( DISCR ) THEN
|
|
ALPHA = SQRT( ABS( ONE - ABSB )*( ONE + ABSB ) )
|
|
ELSE
|
|
ALPHA = SQRT( ABS( TWO*E1 ) )
|
|
END IF
|
|
C
|
|
SCALOC = ONE
|
|
IF( ALPHA.LT.SMIN ) THEN
|
|
ALPHA = SMIN
|
|
INFO = 1
|
|
END IF
|
|
ABST = ABS( P1 )
|
|
IF( ALPHA.LT.ONE .AND. ABST.GT.ONE ) THEN
|
|
IF( ABST.GT.BIGNUM*ALPHA )
|
|
$ SCALOC = ONE / ABST
|
|
END IF
|
|
IF( SCALOC.NE.ONE ) THEN
|
|
P1 = SCALOC*P1
|
|
P2(1) = SCALOC*P2(1)
|
|
P2(2) = SCALOC*P2(2)
|
|
P3 = SCALOC*P3
|
|
SCALE = SCALOC*SCALE
|
|
END IF
|
|
V1 = P1/ALPHA
|
|
C
|
|
IF ( DISCR ) THEN
|
|
G(1) = ( ONE - E1 )*( ONE + E1 ) + E2**2
|
|
G(2) = -TWO*E1*E2
|
|
ABSG = DLAPY2( G(1), G(2) )
|
|
SCALOC = ONE
|
|
IF( ABSG.LT.SMIN ) THEN
|
|
ABSG = SMIN
|
|
INFO = 1
|
|
END IF
|
|
TEMP(1) = SGN*ALPHA*P2(1) + V1*( E1*T(1) - E2*T(2) )
|
|
TEMP(2) = SGN*ALPHA*P2(2) + V1*( E1*T(2) + E2*T(1) )
|
|
ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) )
|
|
IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN
|
|
IF( ABST.GT.BIGNUM*ABSG )
|
|
$ SCALOC = ONE / ABST
|
|
END IF
|
|
IF( SCALOC.NE.ONE ) THEN
|
|
V1 = SCALOC*V1
|
|
TEMP(1) = SCALOC*TEMP(1)
|
|
TEMP(2) = SCALOC*TEMP(2)
|
|
P1 = SCALOC*P1
|
|
P2(1) = SCALOC*P2(1)
|
|
P2(2) = SCALOC*P2(2)
|
|
P3 = SCALOC*P3
|
|
SCALE = SCALOC*SCALE
|
|
END IF
|
|
TEMP(1) = TEMP(1)/ABSG
|
|
TEMP(2) = TEMP(2)/ABSG
|
|
C
|
|
SCALOC = ONE
|
|
V2(1) = G(1)*TEMP(1) + G(2)*TEMP(2)
|
|
V2(2) = G(1)*TEMP(2) - G(2)*TEMP(1)
|
|
ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) )
|
|
IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN
|
|
IF( ABST.GT.BIGNUM*ABSG )
|
|
$ SCALOC = ONE / ABST
|
|
END IF
|
|
IF( SCALOC.NE.ONE ) THEN
|
|
V1 = SCALOC*V1
|
|
V2(1) = SCALOC*V2(1)
|
|
V2(2) = SCALOC*V2(2)
|
|
P1 = SCALOC*P1
|
|
P2(1) = SCALOC*P2(1)
|
|
P2(2) = SCALOC*P2(2)
|
|
P3 = SCALOC*P3
|
|
SCALE = SCALOC*SCALE
|
|
END IF
|
|
V2(1) = V2(1)/ABSG
|
|
V2(2) = V2(2)/ABSG
|
|
C
|
|
SCALOC = ONE
|
|
TEMP(1) = P1*T(1) - TWO*E2*P2(2)
|
|
TEMP(2) = P1*T(2) + TWO*E2*P2(1)
|
|
ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) )
|
|
IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN
|
|
IF( ABST.GT.BIGNUM*ABSG )
|
|
$ SCALOC = ONE / ABST
|
|
END IF
|
|
IF( SCALOC.NE.ONE ) THEN
|
|
TEMP(1) = SCALOC*TEMP(1)
|
|
TEMP(2) = SCALOC*TEMP(2)
|
|
V1 = SCALOC*V1
|
|
V2(1) = SCALOC*V2(1)
|
|
V2(2) = SCALOC*V2(2)
|
|
P3 = SCALOC*P3
|
|
SCALE = SCALOC*SCALE
|
|
END IF
|
|
TEMP(1) = TEMP(1)/ABSG
|
|
TEMP(2) = TEMP(2)/ABSG
|
|
C
|
|
SCALOC = ONE
|
|
Y(1) = -( G(1)*TEMP(1) + G(2)*TEMP(2) )
|
|
Y(2) = -( G(1)*TEMP(2) - G(2)*TEMP(1) )
|
|
ABST = MAX( ABS( Y(1) ), ABS( Y(2) ) )
|
|
IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN
|
|
IF( ABST.GT.BIGNUM*ABSG )
|
|
$ SCALOC = ONE / ABST
|
|
END IF
|
|
IF( SCALOC.NE.ONE ) THEN
|
|
Y(1) = SCALOC*Y(1)
|
|
Y(2) = SCALOC*Y(2)
|
|
V1 = SCALOC*V1
|
|
V2(1) = SCALOC*V2(1)
|
|
V2(2) = SCALOC*V2(2)
|
|
P3 = SCALOC*P3
|
|
SCALE = SCALOC*SCALE
|
|
END IF
|
|
Y(1) = Y(1)/ABSG
|
|
Y(2) = Y(2)/ABSG
|
|
ELSE
|
|
C
|
|
SCALOC = ONE
|
|
IF( ABSB.LT.SMIN ) THEN
|
|
ABSB = SMIN
|
|
INFO = 1
|
|
END IF
|
|
TEMP(1) = SGN*ALPHA*P2(1) + V1*T(1)
|
|
TEMP(2) = SGN*ALPHA*P2(2) + V1*T(2)
|
|
ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) )
|
|
IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN
|
|
IF( ABST.GT.BIGNUM*ABSB )
|
|
$ SCALOC = ONE / ABST
|
|
END IF
|
|
IF( SCALOC.NE.ONE ) THEN
|
|
V1 = SCALOC*V1
|
|
TEMP(1) = SCALOC*TEMP(1)
|
|
TEMP(2) = SCALOC*TEMP(2)
|
|
P2(1) = SCALOC*P2(1)
|
|
P2(2) = SCALOC*P2(2)
|
|
P3 = SCALOC*P3
|
|
SCALE = SCALOC*SCALE
|
|
END IF
|
|
TEMP(1) = TEMP(1)/( TWO*ABSB )
|
|
TEMP(2) = TEMP(2)/( TWO*ABSB )
|
|
SCALOC = ONE
|
|
V2(1) = -( E1*TEMP(1) + E2*TEMP(2) )
|
|
V2(2) = -( E1*TEMP(2) - E2*TEMP(1) )
|
|
ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) )
|
|
IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN
|
|
IF( ABST.GT.BIGNUM*ABSB )
|
|
$ SCALOC = ONE / ABST
|
|
END IF
|
|
IF( SCALOC.NE.ONE ) THEN
|
|
V1 = SCALOC*V1
|
|
V2(1) = SCALOC*V2(1)
|
|
V2(2) = SCALOC*V2(2)
|
|
P2(1) = SCALOC*P2(1)
|
|
P2(2) = SCALOC*P2(2)
|
|
P3 = SCALOC*P3
|
|
SCALE = SCALOC*SCALE
|
|
END IF
|
|
V2(1) = V2(1)/ABSB
|
|
V2(2) = V2(2)/ABSB
|
|
Y(1) = P2(1) - ALPHA*V2(1)
|
|
Y(2) = P2(2) - ALPHA*V2(2)
|
|
END IF
|
|
C
|
|
SCALOC = ONE
|
|
V3 = DLAPY3( P3, Y(1), Y(2) )
|
|
IF( ALPHA.LT.ONE .AND. V3.GT.ONE ) THEN
|
|
IF( V3.GT.BIGNUM*ALPHA )
|
|
$ SCALOC = ONE / V3
|
|
END IF
|
|
IF( SCALOC.NE.ONE ) THEN
|
|
V1 = SCALOC*V1
|
|
V2(1) = SCALOC*V2(1)
|
|
V2(2) = SCALOC*V2(2)
|
|
V3 = SCALOC*V3
|
|
P3 = SCALOC*P3
|
|
SCALE = SCALOC*SCALE
|
|
END IF
|
|
V3 = V3/ALPHA
|
|
C
|
|
IF ( LTRANS ) THEN
|
|
C
|
|
C Case op(M) = M'.
|
|
C
|
|
C Form X = conjg( Qhat' )*v11.
|
|
C
|
|
X11(1) = CSQ(1)*V3
|
|
X11(2) = CSQ(2)*V3
|
|
X21(1) = SNQ*V3
|
|
X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) - SNQ*V1
|
|
X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1)
|
|
X22(1) = CSQ(1)*V1 + SNQ*V2(1)
|
|
X22(2) = -CSQ(2)*V1 - SNQ*V2(2)
|
|
C
|
|
C Obtain u11 from the RQ-factorization of X. The conjugate of
|
|
C X22 should be taken.
|
|
C
|
|
X22(2) = -X22(2)
|
|
CALL SB03OV( X22, X21(1), CST, SNT )
|
|
R(2,2) = X22(1)
|
|
R(1,2) = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1)
|
|
TEMPR = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1)
|
|
TEMPI = CST(1)*X11(2) - CST(2)*X11(1) - SNT*X12(2)
|
|
IF ( TEMPI.EQ.ZERO ) THEN
|
|
R(1,1) = ABS( TEMPR )
|
|
DT(1) = SIGN( ONE, TEMPR )
|
|
DT(2) = ZERO
|
|
ELSE
|
|
R(1,1) = DLAPY2( TEMPR, TEMPI )
|
|
DT(1) = TEMPR/R(1,1)
|
|
DT(2) = -TEMPI/R(1,1)
|
|
END IF
|
|
ELSE
|
|
C
|
|
C Case op(M) = M.
|
|
C
|
|
C Now form X = v11*conjg( Qhat' ).
|
|
C
|
|
X11(1) = CSQ(1)*V1 - SNQ*V2(1)
|
|
X11(2) = -CSQ(2)*V1 + SNQ*V2(2)
|
|
X21(1) = -SNQ*V3
|
|
X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) + SNQ*V1
|
|
X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1)
|
|
X22(1) = CSQ(1)*V3
|
|
X22(2) = CSQ(2)*V3
|
|
C
|
|
C Obtain u11 from the QR-factorization of X.
|
|
C
|
|
CALL SB03OV( X11, X21(1), CST, SNT )
|
|
R(1,1) = X11(1)
|
|
R(1,2) = CST(1)*X12(1) + CST(2)*X12(2) + SNT*X22(1)
|
|
TEMPR = CST(1)*X22(1) - CST(2)*X22(2) - SNT*X12(1)
|
|
TEMPI = CST(1)*X22(2) + CST(2)*X22(1) - SNT*X12(2)
|
|
IF ( TEMPI.EQ.ZERO ) THEN
|
|
R(2,2) = ABS( TEMPR )
|
|
DT(1) = SIGN( ONE, TEMPR )
|
|
DT(2) = ZERO
|
|
ELSE
|
|
R(2,2) = DLAPY2( TEMPR, TEMPI )
|
|
DT(1) = TEMPR/R(2,2)
|
|
DT(2) = -TEMPI/R(2,2)
|
|
END IF
|
|
END IF
|
|
C
|
|
C The computations below are not needed when B and A are not
|
|
C useful. Compute delta, eta and gamma as in (6.21) or (10.26).
|
|
C
|
|
IF ( ( Y(1).EQ.ZERO ).AND.( Y(2).EQ.ZERO ) ) THEN
|
|
DELTA(1) = ZERO
|
|
DELTA(2) = ZERO
|
|
GAMMA(1) = ZERO
|
|
GAMMA(2) = ZERO
|
|
ETA = ALPHA
|
|
ELSE
|
|
DELTA(1) = Y(1)/V3
|
|
DELTA(2) = Y(2)/V3
|
|
GAMMA(1) = -ALPHA*DELTA(1)
|
|
GAMMA(2) = -ALPHA*DELTA(2)
|
|
ETA = P3/V3
|
|
IF ( DISCR ) THEN
|
|
TEMPR = E1*DELTA(1) - E2*DELTA(2)
|
|
DELTA(2) = E1*DELTA(2) + E2*DELTA(1)
|
|
DELTA(1) = TEMPR
|
|
END IF
|
|
END IF
|
|
C
|
|
IF ( LTRANS ) THEN
|
|
C
|
|
C Case op(M) = M'.
|
|
C
|
|
C Find X = conjg( That' )*( inv( v11 )*s11hat*v11 ).
|
|
C ( Defer the scaling.)
|
|
C
|
|
X11(1) = CST(1)*E1 + CST(2)*E2
|
|
X11(2) = -CST(1)*E2 + CST(2)*E1
|
|
X21(1) = SNT*E1
|
|
X21(2) = -SNT*E2
|
|
X12(1) = SGN*( CST(1)*GAMMA(1) + CST(2)*GAMMA(2) ) - SNT*E1
|
|
X12(2) = SGN*( -CST(1)*GAMMA(2) + CST(2)*GAMMA(1) ) - SNT*E2
|
|
X22(1) = CST(1)*E1 + CST(2)*E2 + SGN*SNT*GAMMA(1)
|
|
X22(2) = CST(1)*E2 - CST(2)*E1 - SGN*SNT*GAMMA(2)
|
|
C
|
|
C Now find B = X*That. ( Include the scaling here.)
|
|
C
|
|
S(1,1) = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1)
|
|
TEMPR = CST(1)*X21(1) + CST(2)*X21(2) - SNT*X22(1)
|
|
TEMPI = CST(1)*X21(2) - CST(2)*X21(1) - SNT*X22(2)
|
|
S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI
|
|
TEMPR = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1)
|
|
TEMPI = CST(1)*X12(2) + CST(2)*X12(1) + SNT*X11(2)
|
|
S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI
|
|
S(2,2) = CST(1)*X22(1) - CST(2)*X22(2) + SNT*X21(1)
|
|
C
|
|
C Form X = ( inv( v11 )*p11 )*conjg( Phat' ).
|
|
C
|
|
TEMPR = DP(1)*ETA
|
|
TEMPI = -DP(2)*ETA
|
|
X11(1) = CSP(1)*TEMPR - CSP(2)*TEMPI + SNP*DELTA(1)
|
|
X11(2) = CSP(1)*TEMPI + CSP(2)*TEMPR - SNP*DELTA(2)
|
|
X21(1) = SNP*ALPHA
|
|
X12(1) = -SNP*TEMPR + CSP(1)*DELTA(1) - CSP(2)*DELTA(2)
|
|
X12(2) = -SNP*TEMPI - CSP(1)*DELTA(2) - CSP(2)*DELTA(1)
|
|
X22(1) = CSP(1)*ALPHA
|
|
X22(2) = -CSP(2)*ALPHA
|
|
C
|
|
C Finally form A = conjg( That' )*X.
|
|
C
|
|
TEMPR = CST(1)*X11(1) - CST(2)*X11(2) - SNT*X21(1)
|
|
TEMPI = CST(1)*X22(2) + CST(2)*X22(1)
|
|
A(1,1) = DT(1)*TEMPR + DT(2)*TEMPI
|
|
TEMPR = CST(1)*X12(1) - CST(2)*X12(2) - SNT*X22(1)
|
|
TEMPI = CST(1)*X12(2) + CST(2)*X12(1) - SNT*X22(1)
|
|
A(1,2) = DT(1)*TEMPR + DT(2)*TEMPI
|
|
A(2,1) = ZERO
|
|
A(2,2) = CST(1)*X22(1) + CST(2)*X22(2) + SNT*X12(1)
|
|
ELSE
|
|
C
|
|
C Case op(M) = M.
|
|
C
|
|
C Find X = That*( v11*s11hat*inv( v11 ) ). ( Defer the scaling.)
|
|
C
|
|
X11(1) = CST(1)*E1 + CST(2)*E2
|
|
X11(2) = CST(1)*E2 - CST(2)*E1
|
|
X21(1) = -SNT*E1
|
|
X21(2) = -SNT*E2
|
|
X12(1) = SGN*( CST(1)*GAMMA(1) - CST(2)*GAMMA(2) ) + SNT*E1
|
|
X12(2) = SGN*( -CST(1)*GAMMA(2) - CST(2)*GAMMA(1) ) - SNT*E2
|
|
X22(1) = CST(1)*E1 + CST(2)*E2 - SGN*SNT*GAMMA(1)
|
|
X22(2) = -CST(1)*E2 + CST(2)*E1 + SGN*SNT*GAMMA(2)
|
|
C
|
|
C Now find B = X*conjg( That' ). ( Include the scaling here.)
|
|
C
|
|
S(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1)
|
|
TEMPR = CST(1)*X21(1) - CST(2)*X21(2) + SNT*X22(1)
|
|
TEMPI = CST(1)*X21(2) + CST(2)*X21(1) + SNT*X22(2)
|
|
S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI
|
|
TEMPR = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1)
|
|
TEMPI = CST(1)*X12(2) - CST(2)*X12(1) - SNT*X11(2)
|
|
S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI
|
|
S(2,2) = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1)
|
|
C
|
|
C Form X = Phat*( p11*inv( v11 ) ).
|
|
C
|
|
TEMPR = DP(1)*ETA
|
|
TEMPI = -DP(2)*ETA
|
|
X11(1) = CSP(1)*ALPHA
|
|
X11(2) = CSP(2)*ALPHA
|
|
X21(1) = SNP*ALPHA
|
|
X12(1) = CSP(1)*DELTA(1) + CSP(2)*DELTA(2) - SNP*TEMPR
|
|
X12(2) = -CSP(1)*DELTA(2) + CSP(2)*DELTA(1) - SNP*TEMPI
|
|
X22(1) = CSP(1)*TEMPR + CSP(2)*TEMPI + SNP*DELTA(1)
|
|
X22(2) = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*DELTA(2)
|
|
C
|
|
C Finally form A = X*conjg( That' ).
|
|
C
|
|
A(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1)
|
|
A(2,1) = ZERO
|
|
A(1,2) = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1)
|
|
TEMPR = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1)
|
|
TEMPI = CST(1)*X22(2) - CST(2)*X22(1)
|
|
A(2,2) = DT(1)*TEMPR + DT(2)*TEMPI
|
|
END IF
|
|
C
|
|
IF( SCALE.NE.ONE ) THEN
|
|
A(1,1) = SCALE*A(1,1)
|
|
A(1,2) = SCALE*A(1,2)
|
|
A(2,2) = SCALE*A(2,2)
|
|
END IF
|
|
C
|
|
RETURN
|
|
C *** Last line of SB03OY ***
|
|
END
|