157 SUBROUTINE slagv2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
167 REAL csl, csr, snl, snr
170 REAL a( lda, * ), alphai( 2 ), alphar( 2 ),
171 $
b( ldb, * ), beta( 2 )
178 parameter( zero = 0.0e+0, one = 1.0e+0 )
181 REAL 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
slartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r )
236 CALL
srot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl )
237 CALL
srot( 2,
b( 1, 1 ), ldb,
b( 2, 1 ), ldb, csl, snl )
243 ELSE IF( abs(
b( 2, 2 ) ).LE.ulp )
THEN
244 CALL
slartg( a( 2, 2 ), a( 2, 1 ), csr, snr, t )
246 CALL
srot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr )
247 CALL
srot( 2,
b( 1, 1 ), 1,
b( 1, 2 ), 1, csr, snr )
259 CALL
slag2( 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 =
slapy2( scale1*a( 2, 1 ), h3 )
278 CALL
slartg( h2, h1, csr, snr, t )
285 CALL
slartg( h3, scale1*a( 2, 1 ), csr, snr, t )
290 CALL
srot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr )
291 CALL
srot( 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
slartg(
b( 1, 1 ),
b( 2, 1 ), csl, snl, r )
310 CALL
slartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r )
314 CALL
srot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl )
315 CALL
srot( 2,
b( 1, 1 ), ldb,
b( 2, 1 ), ldb, csl, snl )
325 CALL
slasv2(
b( 1, 1 ),
b( 1, 2 ),
b( 2, 2 ), r, t, snr,
331 CALL
srot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl )
332 CALL
srot( 2,
b( 1, 1 ), ldb,
b( 2, 1 ), ldb, csl, snl )
333 CALL
srot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr )
334 CALL
srot( 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 slasv2(F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL)
SLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
subroutine slag2(A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, WI)
SLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary ...
REAL function slamch(CMACH)
SLAMCH
REAL function slapy2(X, Y)
SLAPY2 returns sqrt(x2+y2).
subroutine slagv2(A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, CSR, SNR)
SLAGV2 computes the Generalized Schur factorization of a real 2-by-2 matrix pencil (A...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT