77 SUBROUTINE dget33( RMAX, LMAX, NINFO, KNT )
85 INTEGER KNT, LMAX, NINFO
92 DOUBLE PRECISION ZERO, ONE
93 parameter ( zero = 0.0d0, one = 1.0d0 )
94 DOUBLE PRECISION TWO, FOUR
95 parameter ( two = 2.0d0, four = 4.0d0 )
98 INTEGER I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3
99 DOUBLE PRECISION BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM,
103 DOUBLE PRECISION Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ),
107 DOUBLE PRECISION DLAMCH
114 INTRINSIC abs, max, sign
121 smlnum = dlamch(
'S' ) / eps
122 bignum = one / smlnum
123 CALL dlabad( smlnum, bignum )
128 val( 2 ) = one + two*eps
130 val( 4 ) = two - four*eps
150 t( 1, 1 ) = val( i1 )*vm( im1 )
151 t( 1, 2 ) = val( i2 )*vm( im2 )
152 t( 2, 1 ) = -val( i3 )*vm( im3 )
153 t( 2, 2 ) = val( i4 )*vm( im4 )
154 tnrm = max( abs( t( 1, 1 ) ),
155 $ abs( t( 1, 2 ) ), abs( t( 2, 1 ) ),
157 t1( 1, 1 ) = t( 1, 1 )
158 t1( 1, 2 ) = t( 1, 2 )
159 t1( 2, 1 ) = t( 2, 1 )
160 t1( 2, 2 ) = t( 2, 2 )
166 CALL dlanv2( t( 1, 1 ), t( 1, 2 ),
167 $ t( 2, 1 ), t( 2, 2 ), wr1,
168 $ wi1, wr2, wi2, cs, sn )
170 res = q( j1, 1 )*cs + q( j1, 2 )*sn
171 q( j1, 2 ) = -q( j1, 1 )*sn +
177 res = res + abs( q( 1, 1 )**2+
178 $ q( 1, 2 )**2-one ) / eps
179 res = res + abs( q( 2, 2 )**2+
180 $ q( 2, 1 )**2-one ) / eps
181 res = res + abs( q( 1, 1 )*q( 2, 1 )+
182 $ q( 1, 2 )*q( 2, 2 ) ) / eps
187 t2( j1, j2 ) = t2( j1, j2 ) +
197 sum = sum - q( j3, j1 )*
200 res = res + abs( sum ) / eps / tnrm
203 IF( t( 2, 1 ).NE.zero .AND.
204 $ ( t( 1, 1 ).NE.t( 2,
205 $ 2 ) .OR. sign( one, t( 1,
206 $ 2 ) )*sign( one, t( 2,
207 $ 1 ) ).GT.zero ) )res = res + one / eps
209 IF( res.GT.rmax )
THEN
subroutine dget33(RMAX, LMAX, NINFO, KNT)
DGET33
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...
subroutine dlabad(SMALL, LARGE)
DLABAD