LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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: