LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ sget33()

subroutine sget33 ( real  RMAX,
integer  LMAX,
integer  NINFO,
integer  KNT 
)

SGET33

Purpose:
 SGET33 tests SLANV2, a routine for putting 2 by 2 blocks into
 standard form.  In other words, it computes a two by two rotation
 [[C,S];[-S,C]] where in

    [ C S ][T(1,1) T(1,2)][ C -S ] = [ T11 T12 ]
    [-S C ][T(2,1) T(2,2)][ S  C ]   [ T21 T22 ]

 either
    1) T21=0 (real eigenvalues), or
    2) T11=T22 and T21*T12<0 (complex conjugate eigenvalues).
 We also  verify that the residual is small.
Parameters
[out]RMAX
          RMAX is REAL
          Value of the largest test ratio.
[out]LMAX
          LMAX is INTEGER
          Example number where largest test ratio achieved.
[out]NINFO
          NINFO is INTEGER
          Number of examples returned with INFO .NE. 0.
[out]KNT
          KNT is INTEGER
          Total number of examples tested.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 75 of file sget33.f.

76*
77* -- LAPACK test routine --
78* -- LAPACK is a software package provided by Univ. of Tennessee, --
79* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
80*
81* .. Scalar Arguments ..
82 INTEGER KNT, LMAX, NINFO
83 REAL RMAX
84* ..
85*
86* =====================================================================
87*
88* .. Parameters ..
89 REAL ZERO, ONE
90 parameter( zero = 0.0e0, one = 1.0e0 )
91 REAL TWO, FOUR
92 parameter( two = 2.0e0, four = 4.0e0 )
93* ..
94* .. Local Scalars ..
95 INTEGER I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3
96 REAL BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM,
97 $ WI1, WI2, WR1, WR2
98* ..
99* .. Local Arrays ..
100 REAL Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ),
101 $ VAL( 4 ), VM( 3 )
102* ..
103* .. External Functions ..
104 REAL SLAMCH
105 EXTERNAL slamch
106* ..
107* .. External Subroutines ..
108 EXTERNAL slabad, slanv2
109* ..
110* .. Intrinsic Functions ..
111 INTRINSIC abs, max, sign
112* ..
113* .. Executable Statements ..
114*
115* Get machine parameters
116*
117 eps = slamch( 'P' )
118 smlnum = slamch( 'S' ) / eps
119 bignum = one / smlnum
120 CALL slabad( smlnum, bignum )
121*
122* Set up test case parameters
123*
124 val( 1 ) = one
125 val( 2 ) = one + two*eps
126 val( 3 ) = two
127 val( 4 ) = two - four*eps
128 vm( 1 ) = smlnum
129 vm( 2 ) = one
130 vm( 3 ) = bignum
131*
132 knt = 0
133 ninfo = 0
134 lmax = 0
135 rmax = zero
136*
137* Begin test loop
138*
139 DO 150 i1 = 1, 4
140 DO 140 i2 = 1, 4
141 DO 130 i3 = 1, 4
142 DO 120 i4 = 1, 4
143 DO 110 im1 = 1, 3
144 DO 100 im2 = 1, 3
145 DO 90 im3 = 1, 3
146 DO 80 im4 = 1, 3
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 ) ),
153 $ abs( t( 2, 2 ) ) )
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 )
158 q( 1, 1 ) = one
159 q( 1, 2 ) = zero
160 q( 2, 1 ) = zero
161 q( 2, 2 ) = one
162*
163 CALL slanv2( t( 1, 1 ), t( 1, 2 ),
164 $ t( 2, 1 ), t( 2, 2 ), wr1,
165 $ wi1, wr2, wi2, cs, sn )
166 DO 10 j1 = 1, 2
167 res = q( j1, 1 )*cs + q( j1, 2 )*sn
168 q( j1, 2 ) = -q( j1, 1 )*sn +
169 $ q( j1, 2 )*cs
170 q( j1, 1 ) = res
171 10 CONTINUE
172*
173 res = zero
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
180 DO 40 j1 = 1, 2
181 DO 30 j2 = 1, 2
182 t2( j1, j2 ) = zero
183 DO 20 j3 = 1, 2
184 t2( j1, j2 ) = t2( j1, j2 ) +
185 $ t1( j1, j3 )*
186 $ q( j3, j2 )
187 20 CONTINUE
188 30 CONTINUE
189 40 CONTINUE
190 DO 70 j1 = 1, 2
191 DO 60 j2 = 1, 2
192 sum = t( j1, j2 )
193 DO 50 j3 = 1, 2
194 sum = sum - q( j3, j1 )*
195 $ t2( j3, j2 )
196 50 CONTINUE
197 res = res + abs( sum ) / eps / tnrm
198 60 CONTINUE
199 70 CONTINUE
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
205 knt = knt + 1
206 IF( res.GT.rmax ) THEN
207 lmax = knt
208 rmax = res
209 END IF
210 80 CONTINUE
211 90 CONTINUE
212 100 CONTINUE
213 110 CONTINUE
214 120 CONTINUE
215 130 CONTINUE
216 140 CONTINUE
217 150 CONTINUE
218*
219 RETURN
220*
221* End of SGET33
222*
subroutine slabad(SMALL, LARGE)
SLABAD
Definition: slabad.f:74
subroutine slanv2(A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN)
SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form.
Definition: slanv2.f:127
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:68
Here is the call graph for this function:
Here is the caller graph for this function: