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