LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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.
Date
November 2011

Definition at line 78 of file sget33.f.

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 *
slabad
subroutine slabad(SMALL, LARGE)
SLABAD
Definition: slabad.f:76
slanv2
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:129
slamch
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69

Here is the call graph for this function:

Here is the caller graph for this function: