LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
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 *> \date November 2011
73 *
74 *> \ingroup single_eig
75 *
76 * =====================================================================
77  SUBROUTINE sget33( RMAX, LMAX, NINFO, KNT )
78 *
79 * -- LAPACK test routine (version 3.4.0) --
80 * -- LAPACK is a software package provided by Univ. of Tennessee, --
81 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
82 * November 2011
83 *
84 * .. Scalar Arguments ..
85  INTEGER knt, lmax, ninfo
86  REAL rmax
87 * ..
88 *
89 * =====================================================================
90 *
91 * .. Parameters ..
92  REAL zero, one
93  parameter( zero = 0.0e0, one = 1.0e0 )
94  REAL two, four
95  parameter( two = 2.0e0, four = 4.0e0 )
96 * ..
97 * .. Local Scalars ..
98  INTEGER i1, i2, i3, i4, im1, im2, im3, im4, j1, j2, j3
99  REAL bignum, cs, eps, res, smlnum, sn, sum, tnrm,
100  $ wi1, wi2, wr1, wr2
101 * ..
102 * .. Local Arrays ..
103  REAL q( 2, 2 ), t( 2, 2 ), t1( 2, 2 ), t2( 2, 2 ),
104  $ val( 4 ), vm( 3 )
105 * ..
106 * .. External Functions ..
107  REAL slamch
108  EXTERNAL slamch
109 * ..
110 * .. External Subroutines ..
111  EXTERNAL slabad, slanv2
112 * ..
113 * .. Intrinsic Functions ..
114  INTRINSIC abs, max, sign
115 * ..
116 * .. Executable Statements ..
117 *
118 * Get machine parameters
119 *
120  eps = slamch( 'P' )
121  smlnum = slamch( 'S' ) / eps
122  bignum = one / smlnum
123  CALL slabad( smlnum, bignum )
124 *
125 * Set up test case parameters
126 *
127  val( 1 ) = one
128  val( 2 ) = one + two*eps
129  val( 3 ) = two
130  val( 4 ) = two - four*eps
131  vm( 1 ) = smlnum
132  vm( 2 ) = one
133  vm( 3 ) = bignum
134 *
135  knt = 0
136  ninfo = 0
137  lmax = 0
138  rmax = zero
139 *
140 * Begin test loop
141 *
142  DO 150 i1 = 1, 4
143  DO 140 i2 = 1, 4
144  DO 130 i3 = 1, 4
145  DO 120 i4 = 1, 4
146  DO 110 im1 = 1, 3
147  DO 100 im2 = 1, 3
148  DO 90 im3 = 1, 3
149  DO 80 im4 = 1, 3
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 ) ),
156  $ abs( t( 2, 2 ) ) )
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 )
161  q( 1, 1 ) = one
162  q( 1, 2 ) = zero
163  q( 2, 1 ) = zero
164  q( 2, 2 ) = one
165 *
166  CALL slanv2( t( 1, 1 ), t( 1, 2 ),
167  $ t( 2, 1 ), t( 2, 2 ), wr1,
168  $ wi1, wr2, wi2, cs, sn )
169  DO 10 j1 = 1, 2
170  res = q( j1, 1 )*cs + q( j1, 2 )*sn
171  q( j1, 2 ) = -q( j1, 1 )*sn +
172  $ q( j1, 2 )*cs
173  q( j1, 1 ) = res
174  10 continue
175 *
176  res = zero
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
183  DO 40 j1 = 1, 2
184  DO 30 j2 = 1, 2
185  t2( j1, j2 ) = zero
186  DO 20 j3 = 1, 2
187  t2( j1, j2 ) = t2( j1, j2 ) +
188  $ t1( j1, j3 )*
189  $ q( j3, j2 )
190  20 continue
191  30 continue
192  40 continue
193  DO 70 j1 = 1, 2
194  DO 60 j2 = 1, 2
195  sum = t( j1, j2 )
196  DO 50 j3 = 1, 2
197  sum = sum - q( j3, j1 )*
198  $ t2( j3, j2 )
199  50 continue
200  res = res + abs( sum ) / eps / tnrm
201  60 continue
202  70 continue
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
208  knt = knt + 1
209  IF( res.GT.rmax ) THEN
210  lmax = knt
211  rmax = res
212  END IF
213  80 continue
214  90 continue
215  100 continue
216  110 continue
217  120 continue
218  130 continue
219  140 continue
220  150 continue
221 *
222  return
223 *
224 * End of SGET33
225 *
226  END