157 SUBROUTINE dlagv2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
167 DOUBLE PRECISION CSL, CSR, SNL, SNR
170 DOUBLE PRECISION A( lda, * ), ALPHAI( 2 ), ALPHAR( 2 ),
171 $ b( ldb, * ), beta( 2 )
177 DOUBLE PRECISION ZERO, ONE
178 parameter( zero = 0.0d+0, one = 1.0d+0 )
181 DOUBLE PRECISION ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ,
182 $ r, rr, safmin, scale1, scale2, t, ulp, wi, wr1,
189 DOUBLE PRECISION DLAMCH, DLAPY2
190 EXTERNAL dlamch, dlapy2
197 safmin = dlamch(
'S' )
202 anorm = max( abs( a( 1, 1 ) )+abs( a( 2, 1 ) ),
203 $ abs( a( 1, 2 ) )+abs( a( 2, 2 ) ), safmin )
205 a( 1, 1 ) = ascale*a( 1, 1 )
206 a( 1, 2 ) = ascale*a( 1, 2 )
207 a( 2, 1 ) = ascale*a( 2, 1 )
208 a( 2, 2 ) = ascale*a( 2, 2 )
212 bnorm = max( abs( b( 1, 1 ) ), abs( b( 1, 2 ) )+abs( b( 2, 2 ) ),
215 b( 1, 1 ) = bscale*b( 1, 1 )
216 b( 1, 2 ) = bscale*b( 1, 2 )
217 b( 2, 2 ) = bscale*b( 2, 2 )
221 IF( abs( a( 2, 1 ) ).LE.ulp )
THEN
232 ELSE IF( abs( b( 1, 1 ) ).LE.ulp )
THEN
233 CALL dlartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r )
236 CALL drot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl )
237 CALL drot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl )
243 ELSE IF( abs( b( 2, 2 ) ).LE.ulp )
THEN
244 CALL dlartg( a( 2, 2 ), a( 2, 1 ), csr, snr, t )
246 CALL drot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr )
247 CALL drot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr )
259 CALL dlag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2,
262 IF( wi.EQ.zero )
THEN
266 h1 = scale1*a( 1, 1 ) - wr1*b( 1, 1 )
267 h2 = scale1*a( 1, 2 ) - wr1*b( 1, 2 )
268 h3 = scale1*a( 2, 2 ) - wr1*b( 2, 2 )
270 rr = dlapy2( h1, h2 )
271 qq = dlapy2( scale1*a( 2, 1 ), h3 )
278 CALL dlartg( h2, h1, csr, snr, t )
285 CALL dlartg( h3, scale1*a( 2, 1 ), csr, snr, t )
290 CALL drot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr )
291 CALL drot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr )
295 h1 = max( abs( a( 1, 1 ) )+abs( a( 1, 2 ) ),
296 $ abs( a( 2, 1 ) )+abs( a( 2, 2 ) ) )
297 h2 = max( abs( b( 1, 1 ) )+abs( b( 1, 2 ) ),
298 $ abs( b( 2, 1 ) )+abs( b( 2, 2 ) ) )
300 IF( ( scale1*h1 ).GE.abs( wr1 )*h2 )
THEN
304 CALL dlartg( b( 1, 1 ), b( 2, 1 ), csl, snl, r )
310 CALL dlartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r )
314 CALL drot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl )
315 CALL drot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl )
325 CALL dlasv2( b( 1, 1 ), b( 1, 2 ), b( 2, 2 ), r, t, snr,
331 CALL drot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl )
332 CALL drot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl )
333 CALL drot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr )
334 CALL drot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr )
345 a( 1, 1 ) = anorm*a( 1, 1 )
346 a( 2, 1 ) = anorm*a( 2, 1 )
347 a( 1, 2 ) = anorm*a( 1, 2 )
348 a( 2, 2 ) = anorm*a( 2, 2 )
349 b( 1, 1 ) = bnorm*b( 1, 1 )
350 b( 2, 1 ) = bnorm*b( 2, 1 )
351 b( 1, 2 ) = bnorm*b( 1, 2 )
352 b( 2, 2 ) = bnorm*b( 2, 2 )
354 IF( wi.EQ.zero )
THEN
355 alphar( 1 ) = a( 1, 1 )
356 alphar( 2 ) = a( 2, 2 )
359 beta( 1 ) = b( 1, 1 )
360 beta( 2 ) = b( 2, 2 )
362 alphar( 1 ) = anorm*wr1 / scale1 / bnorm
363 alphai( 1 ) = anorm*wi / scale1 / bnorm
364 alphar( 2 ) = alphar( 1 )
365 alphai( 2 ) = -alphai( 1 )
subroutine dlasv2(F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL)
DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
subroutine dlartg(F, G, CS, SN, R)
DLARTG generates a plane rotation with real cosine and real sine.
subroutine dlag2(A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, WI)
DLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary ...
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
subroutine dlagv2(A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, CSR, SNR)
DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 matrix pencil (A...