82 INTEGER KNT, LMAX, NINFO
89 DOUBLE PRECISION ZERO, ONE
90 parameter( zero = 0.0d0, one = 1.0d0 )
91 DOUBLE PRECISION TWO, FOUR
92 parameter( two = 2.0d0, four = 4.0d0 )
95 INTEGER I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3
96 DOUBLE PRECISION BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM,
100 DOUBLE PRECISION Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ),
104 DOUBLE PRECISION DLAMCH
111 INTRINSIC abs, max, sign
118 smlnum =
dlamch(
'S' ) / eps
119 bignum = one / smlnum
120 CALL dlabad( smlnum, bignum )
125 val( 2 ) = one + two*eps
127 val( 4 ) = two - four*eps
147 t( 1, 1 ) = val( i1 )*vm( im1 )
148 t( 1, 2 ) = val( i2 )*vm( im2 )
149 t( 2, 1 ) = -val( i3 )*vm( im3 )
150 t( 2, 2 ) = val( i4 )*vm( im4 )
151 tnrm = max( abs( t( 1, 1 ) ),
152 $ abs( t( 1, 2 ) ), abs( t( 2, 1 ) ),
154 t1( 1, 1 ) = t( 1, 1 )
155 t1( 1, 2 ) = t( 1, 2 )
156 t1( 2, 1 ) = t( 2, 1 )
157 t1( 2, 2 ) = t( 2, 2 )
163 CALL dlanv2( t( 1, 1 ), t( 1, 2 ),
164 $ t( 2, 1 ), t( 2, 2 ), wr1,
165 $ wi1, wr2, wi2, cs, sn )
167 res = q( j1, 1 )*cs + q( j1, 2 )*sn
168 q( j1, 2 ) = -q( j1, 1 )*sn +
174 res = res + abs( q( 1, 1 )**2+
175 $ q( 1, 2 )**2-one ) / eps
176 res = res + abs( q( 2, 2 )**2+
177 $ q( 2, 1 )**2-one ) / eps
178 res = res + abs( q( 1, 1 )*q( 2, 1 )+
179 $ q( 1, 2 )*q( 2, 2 ) ) / eps
184 t2( j1, j2 ) = t2( j1, j2 ) +
194 sum = sum - q( j3, j1 )*
197 res = res + abs( sum ) / eps / tnrm
200 IF( t( 2, 1 ).NE.zero .AND.
201 $ ( t( 1, 1 ).NE.t( 2,
202 $ 2 ) .OR. sign( one, t( 1,
203 $ 2 ) )*sign( one, t( 2,
204 $ 1 ) ).GT.zero ) )res = res + one / eps
206 IF( res.GT.rmax )
THEN
double precision function dlamch(CMACH)
DLAMCH
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlanv2(A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN)
DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form.