LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
sget34.f
Go to the documentation of this file.
1*> \brief \b SGET34
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 SGET34( RMAX, LMAX, NINFO, KNT )
12*
13* .. Scalar Arguments ..
14* INTEGER KNT, LMAX
15* REAL RMAX
16* ..
17* .. Array Arguments ..
18* INTEGER NINFO( 2 )
19* ..
20*
21*
22*> \par Purpose:
23* =============
24*>
25*> \verbatim
26*>
27*> SGET34 tests SLAEXC, a routine for swapping adjacent blocks (either
28*> 1 by 1 or 2 by 2) on the diagonal of a matrix in real Schur form.
29*> Thus, SLAEXC computes an orthogonal matrix Q such that
30*>
31*> Q' * [ A B ] * Q = [ C1 B1 ]
32*> [ 0 C ] [ 0 A1 ]
33*>
34*> where C1 is similar to C and A1 is similar to A. Both A and C are
35*> assumed to be in standard form (equal diagonal entries and
36*> offdiagonal with differing signs) and A1 and C1 are returned with the
37*> same properties.
38*>
39*> The test code verifies these last last assertions, as well as that
40*> the residual in the above equation is small.
41*> \endverbatim
42*
43* Arguments:
44* ==========
45*
46*> \param[out] RMAX
47*> \verbatim
48*> RMAX is REAL
49*> Value of the largest test ratio.
50*> \endverbatim
51*>
52*> \param[out] LMAX
53*> \verbatim
54*> LMAX is INTEGER
55*> Example number where largest test ratio achieved.
56*> \endverbatim
57*>
58*> \param[out] NINFO
59*> \verbatim
60*> NINFO is INTEGER array, dimension (2)
61*> NINFO(J) is the number of examples where INFO=J occurred.
62*> \endverbatim
63*>
64*> \param[out] KNT
65*> \verbatim
66*> KNT is INTEGER
67*> Total number of examples tested.
68*> \endverbatim
69*
70* Authors:
71* ========
72*
73*> \author Univ. of Tennessee
74*> \author Univ. of California Berkeley
75*> \author Univ. of Colorado Denver
76*> \author NAG Ltd.
77*
78*> \ingroup single_eig
79*
80* =====================================================================
81 SUBROUTINE sget34( RMAX, LMAX, NINFO, KNT )
82*
83* -- LAPACK test routine --
84* -- LAPACK is a software package provided by Univ. of Tennessee, --
85* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
86*
87* .. Scalar Arguments ..
88 INTEGER KNT, LMAX
89 REAL RMAX
90* ..
91* .. Array Arguments ..
92 INTEGER NINFO( 2 )
93* ..
94*
95* =====================================================================
96*
97* .. Parameters ..
98 REAL ZERO, HALF, ONE
99 parameter( zero = 0.0e0, half = 0.5e0, one = 1.0e0 )
100 REAL TWO, THREE
101 parameter( two = 2.0e0, three = 3.0e0 )
102 INTEGER LWORK
103 parameter( lwork = 32 )
104* ..
105* .. Local Scalars ..
106 INTEGER I, IA, IA11, IA12, IA21, IA22, IAM, IB, IC,
107 $ IC11, IC12, IC21, IC22, ICM, INFO, J
108 REAL BIGNUM, EPS, RES, SMLNUM, TNRM
109* ..
110* .. Local Arrays ..
111 REAL Q( 4, 4 ), RESULT( 2 ), T( 4, 4 ), T1( 4, 4 ),
112 $ VAL( 9 ), VM( 2 ), WORK( LWORK )
113* ..
114* .. External Functions ..
115 REAL SLAMCH
116 EXTERNAL slamch
117* ..
118* .. External Subroutines ..
119 EXTERNAL scopy, slaexc
120* ..
121* .. Intrinsic Functions ..
122 INTRINSIC abs, max, real, sign, sqrt
123* ..
124* .. Executable Statements ..
125*
126* Get machine parameters
127*
128 eps = slamch( 'P' )
129 smlnum = slamch( 'S' ) / eps
130 bignum = one / smlnum
131*
132* Set up test case parameters
133*
134 val( 1 ) = zero
135 val( 2 ) = sqrt( smlnum )
136 val( 3 ) = one
137 val( 4 ) = two
138 val( 5 ) = sqrt( bignum )
139 val( 6 ) = -sqrt( smlnum )
140 val( 7 ) = -one
141 val( 8 ) = -two
142 val( 9 ) = -sqrt( bignum )
143 vm( 1 ) = one
144 vm( 2 ) = one + two*eps
145 CALL scopy( 16, val( 4 ), 0, t( 1, 1 ), 1 )
146*
147 ninfo( 1 ) = 0
148 ninfo( 2 ) = 0
149 knt = 0
150 lmax = 0
151 rmax = zero
152*
153* Begin test loop
154*
155 DO 40 ia = 1, 9
156 DO 30 iam = 1, 2
157 DO 20 ib = 1, 9
158 DO 10 ic = 1, 9
159 t( 1, 1 ) = val( ia )*vm( iam )
160 t( 2, 2 ) = val( ic )
161 t( 1, 2 ) = val( ib )
162 t( 2, 1 ) = zero
163 tnrm = max( abs( t( 1, 1 ) ), abs( t( 2, 2 ) ),
164 $ abs( t( 1, 2 ) ) )
165 CALL scopy( 16, t, 1, t1, 1 )
166 CALL scopy( 16, val( 1 ), 0, q, 1 )
167 CALL scopy( 4, val( 3 ), 0, q, 5 )
168 CALL slaexc( .true., 2, t, 4, q, 4, 1, 1, 1, work,
169 $ info )
170 IF( info.NE.0 )
171 $ ninfo( info ) = ninfo( info ) + 1
172 CALL shst01( 2, 1, 2, t1, 4, t, 4, q, 4, work, lwork,
173 $ result )
174 res = result( 1 ) + result( 2 )
175 IF( info.NE.0 )
176 $ res = res + one / eps
177 IF( t( 1, 1 ).NE.t1( 2, 2 ) )
178 $ res = res + one / eps
179 IF( t( 2, 2 ).NE.t1( 1, 1 ) )
180 $ res = res + one / eps
181 IF( t( 2, 1 ).NE.zero )
182 $ res = res + one / eps
183 knt = knt + 1
184 IF( res.GT.rmax ) THEN
185 lmax = knt
186 rmax = res
187 END IF
188 10 CONTINUE
189 20 CONTINUE
190 30 CONTINUE
191 40 CONTINUE
192*
193 DO 110 ia = 1, 5
194 DO 100 iam = 1, 2
195 DO 90 ib = 1, 5
196 DO 80 ic11 = 1, 5
197 DO 70 ic12 = 2, 5
198 DO 60 ic21 = 2, 4
199 DO 50 ic22 = -1, 1, 2
200 t( 1, 1 ) = val( ia )*vm( iam )
201 t( 1, 2 ) = val( ib )
202 t( 1, 3 ) = -two*val( ib )
203 t( 2, 1 ) = zero
204 t( 2, 2 ) = val( ic11 )
205 t( 2, 3 ) = val( ic12 )
206 t( 3, 1 ) = zero
207 t( 3, 2 ) = -val( ic21 )
208 t( 3, 3 ) = val( ic11 )*real( ic22 )
209 tnrm = max( abs( t( 1, 1 ) ),
210 $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
211 $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
212 $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
213 CALL scopy( 16, t, 1, t1, 1 )
214 CALL scopy( 16, val( 1 ), 0, q, 1 )
215 CALL scopy( 4, val( 3 ), 0, q, 5 )
216 CALL slaexc( .true., 3, t, 4, q, 4, 1, 1, 2,
217 $ work, info )
218 IF( info.NE.0 )
219 $ ninfo( info ) = ninfo( info ) + 1
220 CALL shst01( 3, 1, 3, t1, 4, t, 4, q, 4,
221 $ work, lwork, result )
222 res = result( 1 ) + result( 2 )
223 IF( info.EQ.0 ) THEN
224 IF( t1( 1, 1 ).NE.t( 3, 3 ) )
225 $ res = res + one / eps
226 IF( t( 3, 1 ).NE.zero )
227 $ res = res + one / eps
228 IF( t( 3, 2 ).NE.zero )
229 $ res = res + one / eps
230 IF( t( 2, 1 ).NE.0 .AND.
231 $ ( t( 1, 1 ).NE.t( 2,
232 $ 2 ) .OR. sign( one, t( 1,
233 $ 2 ) ).EQ.sign( one, t( 2, 1 ) ) ) )
234 $ res = res + one / eps
235 END IF
236 knt = knt + 1
237 IF( res.GT.rmax ) THEN
238 lmax = knt
239 rmax = res
240 END IF
241 50 CONTINUE
242 60 CONTINUE
243 70 CONTINUE
244 80 CONTINUE
245 90 CONTINUE
246 100 CONTINUE
247 110 CONTINUE
248*
249 DO 180 ia11 = 1, 5
250 DO 170 ia12 = 2, 5
251 DO 160 ia21 = 2, 4
252 DO 150 ia22 = -1, 1, 2
253 DO 140 icm = 1, 2
254 DO 130 ib = 1, 5
255 DO 120 ic = 1, 5
256 t( 1, 1 ) = val( ia11 )
257 t( 1, 2 ) = val( ia12 )
258 t( 1, 3 ) = -two*val( ib )
259 t( 2, 1 ) = -val( ia21 )
260 t( 2, 2 ) = val( ia11 )*real( ia22 )
261 t( 2, 3 ) = val( ib )
262 t( 3, 1 ) = zero
263 t( 3, 2 ) = zero
264 t( 3, 3 ) = val( ic )*vm( icm )
265 tnrm = max( abs( t( 1, 1 ) ),
266 $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
267 $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
268 $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
269 CALL scopy( 16, t, 1, t1, 1 )
270 CALL scopy( 16, val( 1 ), 0, q, 1 )
271 CALL scopy( 4, val( 3 ), 0, q, 5 )
272 CALL slaexc( .true., 3, t, 4, q, 4, 1, 2, 1,
273 $ work, info )
274 IF( info.NE.0 )
275 $ ninfo( info ) = ninfo( info ) + 1
276 CALL shst01( 3, 1, 3, t1, 4, t, 4, q, 4,
277 $ work, lwork, result )
278 res = result( 1 ) + result( 2 )
279 IF( info.EQ.0 ) THEN
280 IF( t1( 3, 3 ).NE.t( 1, 1 ) )
281 $ res = res + one / eps
282 IF( t( 2, 1 ).NE.zero )
283 $ res = res + one / eps
284 IF( t( 3, 1 ).NE.zero )
285 $ res = res + one / eps
286 IF( t( 3, 2 ).NE.0 .AND.
287 $ ( t( 2, 2 ).NE.t( 3,
288 $ 3 ) .OR. sign( one, t( 2,
289 $ 3 ) ).EQ.sign( one, t( 3, 2 ) ) ) )
290 $ res = res + one / eps
291 END IF
292 knt = knt + 1
293 IF( res.GT.rmax ) THEN
294 lmax = knt
295 rmax = res
296 END IF
297 120 CONTINUE
298 130 CONTINUE
299 140 CONTINUE
300 150 CONTINUE
301 160 CONTINUE
302 170 CONTINUE
303 180 CONTINUE
304*
305 DO 300 ia11 = 1, 5
306 DO 290 ia12 = 2, 5
307 DO 280 ia21 = 2, 4
308 DO 270 ia22 = -1, 1, 2
309 DO 260 ib = 1, 5
310 DO 250 ic11 = 3, 4
311 DO 240 ic12 = 3, 4
312 DO 230 ic21 = 3, 4
313 DO 220 ic22 = -1, 1, 2
314 DO 210 icm = 5, 7
315 iam = 1
316 t( 1, 1 ) = val( ia11 )*vm( iam )
317 t( 1, 2 ) = val( ia12 )*vm( iam )
318 t( 1, 3 ) = -two*val( ib )
319 t( 1, 4 ) = half*val( ib )
320 t( 2, 1 ) = -t( 1, 2 )*val( ia21 )
321 t( 2, 2 ) = val( ia11 )*
322 $ real( ia22 )*vm( iam )
323 t( 2, 3 ) = val( ib )
324 t( 2, 4 ) = three*val( ib )
325 t( 3, 1 ) = zero
326 t( 3, 2 ) = zero
327 t( 3, 3 ) = val( ic11 )*
328 $ abs( val( icm ) )
329 t( 3, 4 ) = val( ic12 )*
330 $ abs( val( icm ) )
331 t( 4, 1 ) = zero
332 t( 4, 2 ) = zero
333 t( 4, 3 ) = -t( 3, 4 )*val( ic21 )*
334 $ abs( val( icm ) )
335 t( 4, 4 ) = val( ic11 )*
336 $ real( ic22 )*
337 $ abs( val( icm ) )
338 tnrm = zero
339 DO 200 i = 1, 4
340 DO 190 j = 1, 4
341 tnrm = max( tnrm,
342 $ abs( t( i, j ) ) )
343 190 CONTINUE
344 200 CONTINUE
345 CALL scopy( 16, t, 1, t1, 1 )
346 CALL scopy( 16, val( 1 ), 0, q, 1 )
347 CALL scopy( 4, val( 3 ), 0, q, 5 )
348 CALL slaexc( .true., 4, t, 4, q, 4,
349 $ 1, 2, 2, work, info )
350 IF( info.NE.0 )
351 $ ninfo( info ) = ninfo( info ) + 1
352 CALL shst01( 4, 1, 4, t1, 4, t, 4,
353 $ q, 4, work, lwork,
354 $ result )
355 res = result( 1 ) + result( 2 )
356 IF( info.EQ.0 ) THEN
357 IF( t( 3, 1 ).NE.zero )
358 $ res = res + one / eps
359 IF( t( 4, 1 ).NE.zero )
360 $ res = res + one / eps
361 IF( t( 3, 2 ).NE.zero )
362 $ res = res + one / eps
363 IF( t( 4, 2 ).NE.zero )
364 $ res = res + one / eps
365 IF( t( 2, 1 ).NE.0 .AND.
366 $ ( t( 1, 1 ).NE.t( 2,
367 $ 2 ) .OR. sign( one, t( 1,
368 $ 2 ) ).EQ.sign( one, t( 2,
369 $ 1 ) ) ) )res = res +
370 $ one / eps
371 IF( t( 4, 3 ).NE.0 .AND.
372 $ ( t( 3, 3 ).NE.t( 4,
373 $ 4 ) .OR. sign( one, t( 3,
374 $ 4 ) ).EQ.sign( one, t( 4,
375 $ 3 ) ) ) )res = res +
376 $ one / eps
377 END IF
378 knt = knt + 1
379 IF( res.GT.rmax ) THEN
380 lmax = knt
381 rmax = res
382 END IF
383 210 CONTINUE
384 220 CONTINUE
385 230 CONTINUE
386 240 CONTINUE
387 250 CONTINUE
388 260 CONTINUE
389 270 CONTINUE
390 280 CONTINUE
391 290 CONTINUE
392 300 CONTINUE
393*
394 RETURN
395*
396* End of SGET34
397*
398 END
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
slaexc
subroutine slaexc(wantq, n, t, ldt, q, ldq, j1, n1, n2, work, info)
SLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form...
Definition slaexc.f:138
sget34
subroutine sget34(rmax, lmax, ninfo, knt)
SGET34
Definition sget34.f:82
shst01
subroutine shst01(n, ilo, ihi, a, lda, h, ldh, q, ldq, work, lwork, result)
SHST01
Definition shst01.f:134