001:       SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
002:      $                   CSR, SNR )
003: *
004: *  -- LAPACK auxiliary routine (version 3.2) --
005: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
006: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
007: *     November 2006
008: *
009: *     .. Scalar Arguments ..
010:       INTEGER            LDA, LDB
011:       DOUBLE PRECISION   CSL, CSR, SNL, SNR
012: *     ..
013: *     .. Array Arguments ..
014:       DOUBLE PRECISION   A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ),
015:      $                   B( LDB, * ), BETA( 2 )
016: *     ..
017: *
018: *  Purpose
019: *  =======
020: *
021: *  DLAGV2 computes the Generalized Schur factorization of a real 2-by-2
022: *  matrix pencil (A,B) where B is upper triangular. This routine
023: *  computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
024: *  SNR such that
025: *
026: *  1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
027: *     types), then
028: *
029: *     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
030: *     [  0  a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
031: *
032: *     [ b11 b12 ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]
033: *     [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ],
034: *
035: *  2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
036: *     then
037: *
038: *     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
039: *     [ a21 a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
040: *
041: *     [ b11  0  ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]
042: *     [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ]
043: *
044: *     where b11 >= b22 > 0.
045: *
046: *
047: *  Arguments
048: *  =========
049: *
050: *  A       (input/output) DOUBLE PRECISION array, dimension (LDA, 2)
051: *          On entry, the 2 x 2 matrix A.
052: *          On exit, A is overwritten by the ``A-part'' of the
053: *          generalized Schur form.
054: *
055: *  LDA     (input) INTEGER
056: *          THe leading dimension of the array A.  LDA >= 2.
057: *
058: *  B       (input/output) DOUBLE PRECISION array, dimension (LDB, 2)
059: *          On entry, the upper triangular 2 x 2 matrix B.
060: *          On exit, B is overwritten by the ``B-part'' of the
061: *          generalized Schur form.
062: *
063: *  LDB     (input) INTEGER
064: *          THe leading dimension of the array B.  LDB >= 2.
065: *
066: *  ALPHAR  (output) DOUBLE PRECISION array, dimension (2)
067: *  ALPHAI  (output) DOUBLE PRECISION array, dimension (2)
068: *  BETA    (output) DOUBLE PRECISION array, dimension (2)
069: *          (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
070: *          pencil (A,B), k=1,2, i = sqrt(-1).  Note that BETA(k) may
071: *          be zero.
072: *
073: *  CSL     (output) DOUBLE PRECISION
074: *          The cosine of the left rotation matrix.
075: *
076: *  SNL     (output) DOUBLE PRECISION
077: *          The sine of the left rotation matrix.
078: *
079: *  CSR     (output) DOUBLE PRECISION
080: *          The cosine of the right rotation matrix.
081: *
082: *  SNR     (output) DOUBLE PRECISION
083: *          The sine of the right rotation matrix.
084: *
085: *  Further Details
086: *  ===============
087: *
088: *  Based on contributions by
089: *     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
090: *
091: *  =====================================================================
092: *
093: *     .. Parameters ..
094:       DOUBLE PRECISION   ZERO, ONE
095:       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
096: *     ..
097: *     .. Local Scalars ..
098:       DOUBLE PRECISION   ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ,
099:      $                   R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1,
100:      $                   WR2
101: *     ..
102: *     .. External Subroutines ..
103:       EXTERNAL           DLAG2, DLARTG, DLASV2, DROT
104: *     ..
105: *     .. External Functions ..
106:       DOUBLE PRECISION   DLAMCH, DLAPY2
107:       EXTERNAL           DLAMCH, DLAPY2
108: *     ..
109: *     .. Intrinsic Functions ..
110:       INTRINSIC          ABS, MAX
111: *     ..
112: *     .. Executable Statements ..
113: *
114:       SAFMIN = DLAMCH( 'S' )
115:       ULP = DLAMCH( 'P' )
116: *
117: *     Scale A
118: *
119:       ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
120:      $        ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
121:       ASCALE = ONE / ANORM
122:       A( 1, 1 ) = ASCALE*A( 1, 1 )
123:       A( 1, 2 ) = ASCALE*A( 1, 2 )
124:       A( 2, 1 ) = ASCALE*A( 2, 1 )
125:       A( 2, 2 ) = ASCALE*A( 2, 2 )
126: *
127: *     Scale B
128: *
129:       BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ),
130:      $        SAFMIN )
131:       BSCALE = ONE / BNORM
132:       B( 1, 1 ) = BSCALE*B( 1, 1 )
133:       B( 1, 2 ) = BSCALE*B( 1, 2 )
134:       B( 2, 2 ) = BSCALE*B( 2, 2 )
135: *
136: *     Check if A can be deflated
137: *
138:       IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN
139:          CSL = ONE
140:          SNL = ZERO
141:          CSR = ONE
142:          SNR = ZERO
143:          A( 2, 1 ) = ZERO
144:          B( 2, 1 ) = ZERO
145: *
146: *     Check if B is singular
147: *
148:       ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN
149:          CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
150:          CSR = ONE
151:          SNR = ZERO
152:          CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
153:          CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
154:          A( 2, 1 ) = ZERO
155:          B( 1, 1 ) = ZERO
156:          B( 2, 1 ) = ZERO
157: *
158:       ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN
159:          CALL DLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T )
160:          SNR = -SNR
161:          CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
162:          CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
163:          CSL = ONE
164:          SNL = ZERO
165:          A( 2, 1 ) = ZERO
166:          B( 2, 1 ) = ZERO
167:          B( 2, 2 ) = ZERO
168: *
169:       ELSE
170: *
171: *        B is nonsingular, first compute the eigenvalues of (A,B)
172: *
173:          CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2,
174:      $               WI )
175: *
176:          IF( WI.EQ.ZERO ) THEN
177: *
178: *           two real eigenvalues, compute s*A-w*B
179: *
180:             H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 )
181:             H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 )
182:             H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 )
183: *
184:             RR = DLAPY2( H1, H2 )
185:             QQ = DLAPY2( SCALE1*A( 2, 1 ), H3 )
186: *
187:             IF( RR.GT.QQ ) THEN
188: *
189: *              find right rotation matrix to zero 1,1 element of
190: *              (sA - wB)
191: *
192:                CALL DLARTG( H2, H1, CSR, SNR, T )
193: *
194:             ELSE
195: *
196: *              find right rotation matrix to zero 2,1 element of
197: *              (sA - wB)
198: *
199:                CALL DLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T )
200: *
201:             END IF
202: *
203:             SNR = -SNR
204:             CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
205:             CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
206: *
207: *           compute inf norms of A and B
208: *
209:             H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ),
210:      $           ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) )
211:             H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
212:      $           ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
213: *
214:             IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN
215: *
216: *              find left rotation matrix Q to zero out B(2,1)
217: *
218:                CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R )
219: *
220:             ELSE
221: *
222: *              find left rotation matrix Q to zero out A(2,1)
223: *
224:                CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
225: *
226:             END IF
227: *
228:             CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
229:             CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
230: *
231:             A( 2, 1 ) = ZERO
232:             B( 2, 1 ) = ZERO
233: *
234:          ELSE
235: *
236: *           a pair of complex conjugate eigenvalues
237: *           first compute the SVD of the matrix B
238: *
239:             CALL DLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR,
240:      $                   CSR, SNL, CSL )
241: *
242: *           Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and
243: *           Z is right rotation matrix computed from DLASV2
244: *
245:             CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
246:             CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
247:             CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
248:             CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
249: *
250:             B( 2, 1 ) = ZERO
251:             B( 1, 2 ) = ZERO
252: *
253:          END IF
254: *
255:       END IF
256: *
257: *     Unscaling
258: *
259:       A( 1, 1 ) = ANORM*A( 1, 1 )
260:       A( 2, 1 ) = ANORM*A( 2, 1 )
261:       A( 1, 2 ) = ANORM*A( 1, 2 )
262:       A( 2, 2 ) = ANORM*A( 2, 2 )
263:       B( 1, 1 ) = BNORM*B( 1, 1 )
264:       B( 2, 1 ) = BNORM*B( 2, 1 )
265:       B( 1, 2 ) = BNORM*B( 1, 2 )
266:       B( 2, 2 ) = BNORM*B( 2, 2 )
267: *
268:       IF( WI.EQ.ZERO ) THEN
269:          ALPHAR( 1 ) = A( 1, 1 )
270:          ALPHAR( 2 ) = A( 2, 2 )
271:          ALPHAI( 1 ) = ZERO
272:          ALPHAI( 2 ) = ZERO
273:          BETA( 1 ) = B( 1, 1 )
274:          BETA( 2 ) = B( 2, 2 )
275:       ELSE
276:          ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM
277:          ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM
278:          ALPHAR( 2 ) = ALPHAR( 1 )
279:          ALPHAI( 2 ) = -ALPHAI( 1 )
280:          BETA( 1 ) = ONE
281:          BETA( 2 ) = ONE
282:       END IF
283: *
284:       RETURN
285: *
286: *     End of DLAGV2
287: *
288:       END
289: