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,
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 )
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 ...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
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...
DOUBLE PRECISION function dlapy2(X, Y)
DLAPY2 returns sqrt(x2+y2).