LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
dget33.f
Go to the documentation of this file.
1*> \brief \b DGET33
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 DGET33( RMAX, LMAX, NINFO, KNT )
12*
13* .. Scalar Arguments ..
14* INTEGER KNT, LMAX, NINFO
15* DOUBLE PRECISION RMAX
16* ..
17*
18*
19*> \par Purpose:
20* =============
21*>
22*> \verbatim
23*>
24*> DGET33 tests DLANV2, 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 DOUBLE PRECISION
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 double_eig
73*
74* =====================================================================
75 SUBROUTINE dget33( 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 DOUBLE PRECISION RMAX
84* ..
85*
86* =====================================================================
87*
88* .. Parameters ..
89 DOUBLE PRECISION ZERO, ONE
90 parameter( zero = 0.0d0, one = 1.0d0 )
91 DOUBLE PRECISION TWO, FOUR
92 parameter( two = 2.0d0, four = 4.0d0 )
93* ..
94* .. Local Scalars ..
95 INTEGER I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3
96 DOUBLE PRECISION BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM,
97 $ WI1, WI2, WR1, WR2
98* ..
99* .. Local Arrays ..
100 DOUBLE PRECISION Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ),
101 $ VAL( 4 ), VM( 3 )
102* ..
103* .. External Functions ..
104 DOUBLE PRECISION DLAMCH
105 EXTERNAL dlamch
106* ..
107* .. External Subroutines ..
108 EXTERNAL dlabad, dlanv2
109* ..
110* .. Intrinsic Functions ..
111 INTRINSIC abs, max, sign
112* ..
113* .. Executable Statements ..
114*
115* Get machine parameters
116*
117 eps = dlamch( 'P' )
118 smlnum = dlamch( 'S' ) / eps
119 bignum = one / smlnum
120 CALL dlabad( 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 dlanv2( 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 DGET33
222*
223 END
subroutine dlabad(SMALL, LARGE)
DLABAD
Definition: dlabad.f:74
subroutine dget33(RMAX, LMAX, NINFO, KNT)
DGET33
Definition: dget33.f:76
subroutine dlanv2(A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN)
DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form.
Definition: dlanv2.f:127