LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
sget33.f
Go to the documentation of this file.
1 *> \brief \b SGET33
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE SGET33( RMAX, LMAX, NINFO, KNT )
12 *
13 * .. Scalar Arguments ..
14 * INTEGER KNT, LMAX, NINFO
15 * REAL RMAX
16 * ..
17 *
18 *
19 *> \par Purpose:
20 * =============
21 *>
22 *> \verbatim
23 *>
24 *> SGET33 tests SLANV2, a routine for putting 2 by 2 blocks into
25 *> standard form. In other words, it computes a two by two rotation
26 *> [[C,S];[-S,C]] where in
27 *>
28 *> [ C S ][T(1,1) T(1,2)][ C -S ] = [ T11 T12 ]
29 *> [-S C ][T(2,1) T(2,2)][ S C ] [ T21 T22 ]
30 *>
31 *> either
32 *> 1) T21=0 (real eigenvalues), or
33 *> 2) T11=T22 and T21*T12<0 (complex conjugate eigenvalues).
34 *> We also verify that the residual is small.
35 *> \endverbatim
36 *
37 * Arguments:
38 * ==========
39 *
40 *> \param[out] RMAX
41 *> \verbatim
42 *> RMAX is REAL
43 *> Value of the largest test ratio.
44 *> \endverbatim
45 *>
46 *> \param[out] LMAX
47 *> \verbatim
48 *> LMAX is INTEGER
49 *> Example number where largest test ratio achieved.
50 *> \endverbatim
51 *>
52 *> \param[out] NINFO
53 *> \verbatim
54 *> NINFO is INTEGER
55 *> Number of examples returned with INFO .NE. 0.
56 *> \endverbatim
57 *>
58 *> \param[out] KNT
59 *> \verbatim
60 *> KNT is INTEGER
61 *> Total number of examples tested.
62 *> \endverbatim
63 *
64 * Authors:
65 * ========
66 *
67 *> \author Univ. of Tennessee
68 *> \author Univ. of California Berkeley
69 *> \author Univ. of Colorado Denver
70 *> \author NAG Ltd.
71 *
72 *> \ingroup single_eig
73 *
74 * =====================================================================
75  SUBROUTINE sget33( RMAX, LMAX, NINFO, KNT )
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 *
223  END
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
subroutine sget33(RMAX, LMAX, NINFO, KNT)
SGET33
Definition: sget33.f:76