OpenRadioss 2025.1.11
OpenRadioss project
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 CALL slabad( smlnum, bignum )
132*
133* Set up test case parameters
134*
135 val( 1 ) = zero
136 val( 2 ) = sqrt( smlnum )
137 val( 3 ) = one
138 val( 4 ) = two
139 val( 5 ) = sqrt( bignum )
140 val( 6 ) = -sqrt( smlnum )
141 val( 7 ) = -one
142 val( 8 ) = -two
143 val( 9 ) = -sqrt( bignum )
144 vm( 1 ) = one
145 vm( 2 ) = one + two*eps
146 CALL scopy( 16, val( 4 ), 0, t( 1, 1 ), 1 )
147*
148 ninfo( 1 ) = 0
149 ninfo( 2 ) = 0
150 knt = 0
151 lmax = 0
152 rmax = zero
153*
154* Begin test loop
155*
156 DO 40 ia = 1, 9
157 DO 30 iam = 1, 2
158 DO 20 ib = 1, 9
159 DO 10 ic = 1, 9
160 t( 1, 1 ) = val( ia )*vm( iam )
161 t( 2, 2 ) = val( ic )
162 t( 1, 2 ) = val( ib )
163 t( 2, 1 ) = zero
164 tnrm = max( abs( t( 1, 1 ) ), abs( t( 2, 2 ) ),
165 $ abs( t( 1, 2 ) ) )
166 CALL scopy( 16, t, 1, t1, 1 )
167 CALL scopy( 16, val( 1 ), 0, q, 1 )
168 CALL scopy( 4, val( 3 ), 0, q, 5 )
169 CALL slaexc( .true., 2, t, 4, q, 4, 1, 1, 1, work,
170 $ info )
171 IF( info.NE.0 )
172 $ ninfo( info ) = ninfo( info ) + 1
173 CALL shst01( 2, 1, 2, t1, 4, t, 4, q, 4, work, lwork,
174 $ result )
175 res = result( 1 ) + result( 2 )
176 IF( info.NE.0 )
177 $ res = res + one / eps
178 IF( t( 1, 1 ).NE.t1( 2, 2 ) )
179 $ res = res + one / eps
180 IF( t( 2, 2 ).NE.t1( 1, 1 ) )
181 $ res = res + one / eps
182 IF( t( 2, 1 ).NE.zero )
183 $ res = res + one / eps
184 knt = knt + 1
185 IF( res.GT.rmax ) THEN
186 lmax = knt
187 rmax = res
188 END IF
189 10 CONTINUE
190 20 CONTINUE
191 30 CONTINUE
192 40 CONTINUE
193*
194 DO 110 ia = 1, 5
195 DO 100 iam = 1, 2
196 DO 90 ib = 1, 5
197 DO 80 ic11 = 1, 5
198 DO 70 ic12 = 2, 5
199 DO 60 ic21 = 2, 4
200 DO 50 ic22 = -1, 1, 2
201 t( 1, 1 ) = val( ia )*vm( iam )
202 t( 1, 2 ) = val( ib )
203 t( 1, 3 ) = -two*val( ib )
204 t( 2, 1 ) = zero
205 t( 2, 2 ) = val( ic11 )
206 t( 2, 3 ) = val( ic12 )
207 t( 3, 1 ) = zero
208 t( 3, 2 ) = -val( ic21 )
209 t( 3, 3 ) = val( ic11 )*real( ic22 )
210 tnrm = max( abs( t( 1, 1 ) ),
211 $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
212 $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
213 $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
214 CALL scopy( 16, t, 1, t1, 1 )
215 CALL scopy( 16, val( 1 ), 0, q, 1 )
216 CALL scopy( 4, val( 3 ), 0, q, 5 )
217 CALL slaexc( .true., 3, t, 4, q, 4, 1, 1, 2,
218 $ work, info )
219 IF( info.NE.0 )
220 $ ninfo( info ) = ninfo( info ) + 1
221 CALL shst01( 3, 1, 3, t1, 4, t, 4, q, 4,
222 $ work, lwork, result )
223 res = result( 1 ) + result( 2 )
224 IF( info.EQ.0 ) THEN
225 IF( t1( 1, 1 ).NE.t( 3, 3 ) )
226 $ res = res + one / eps
227 IF( t( 3, 1 ).NE.zero )
228 $ res = res + one / eps
229 IF( t( 3, 2 ).NE.zero )
230 $ res = res + one / eps
231 IF( t( 2, 1 ).NE.0 .AND.
232 $ ( t( 1, 1 ).NE.t( 2,
233 $ 2 ) .OR. sign( one, t( 1,
234 $ 2 ) ).EQ.sign( one, t( 2, 1 ) ) ) )
235 $ res = res + one / eps
236 END IF
237 knt = knt + 1
238 IF( res.GT.rmax ) THEN
239 lmax = knt
240 rmax = res
241 END IF
242 50 CONTINUE
243 60 CONTINUE
244 70 CONTINUE
245 80 CONTINUE
246 90 CONTINUE
247 100 CONTINUE
248 110 CONTINUE
249*
250 DO 180 ia11 = 1, 5
251 DO 170 ia12 = 2, 5
252 DO 160 ia21 = 2, 4
253 DO 150 ia22 = -1, 1, 2
254 DO 140 icm = 1, 2
255 DO 130 ib = 1, 5
256 DO 120 ic = 1, 5
257 t( 1, 1 ) = val( ia11 )
258 t( 1, 2 ) = val( ia12 )
259 t( 1, 3 ) = -two*val( ib )
260 t( 2, 1 ) = -val( ia21 )
261 t( 2, 2 ) = val( ia11 )*real( ia22 )
262 t( 2, 3 ) = val( ib )
263 t( 3, 1 ) = zero
264 t( 3, 2 ) = zero
265 t( 3, 3 ) = val( ic )*vm( icm )
266 tnrm = max( abs( t( 1, 1 ) ),
267 $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
268 $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
269 $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
270 CALL scopy( 16, t, 1, t1, 1 )
271 CALL scopy( 16, val( 1 ), 0, q, 1 )
272 CALL scopy( 4, val( 3 ), 0, q, 5 )
273 CALL slaexc( .true., 3, t, 4, q, 4, 1, 2, 1,
274 $ work, info )
275 IF( info.NE.0 )
276 $ ninfo( info ) = ninfo( info ) + 1
277 CALL shst01( 3, 1, 3, t1, 4, t, 4, q, 4,
278 $ work, lwork, result )
279 res = result( 1 ) + result( 2 )
280 IF( info.EQ.0 ) THEN
281 IF( t1( 3, 3 ).NE.t( 1, 1 ) )
282 $ res = res + one / eps
283 IF( t( 2, 1 ).NE.zero )
284 $ res = res + one / eps
285 IF( t( 3, 1 ).NE.zero )
286 $ res = res + one / eps
287 IF( t( 3, 2 ).NE.0 .AND.
288 $ ( t( 2, 2 ).NE.t( 3,
289 $ 3 ) .OR. sign( one, t( 2,
290 $ 3 ) ).EQ.sign( one, t( 3, 2 ) ) ) )
291 $ res = res + one / eps
292 END IF
293 knt = knt + 1
294 IF( res.GT.rmax ) THEN
295 lmax = knt
296 rmax = res
297 END IF
298 120 CONTINUE
299 130 CONTINUE
300 140 CONTINUE
301 150 CONTINUE
302 160 CONTINUE
303 170 CONTINUE
304 180 CONTINUE
305*
306 DO 300 ia11 = 1, 5
307 DO 290 ia12 = 2, 5
308 DO 280 ia21 = 2, 4
309 DO 270 ia22 = -1, 1, 2
310 DO 260 ib = 1, 5
311 DO 250 ic11 = 3, 4
312 DO 240 ic12 = 3, 4
313 DO 230 ic21 = 3, 4
314 DO 220 ic22 = -1, 1, 2
315 DO 210 icm = 5, 7
316 iam = 1
317 t( 1, 1 ) = val( ia11 )*vm( iam )
318 t( 1, 2 ) = val( ia12 )*vm( iam )
319 t( 1, 3 ) = -two*val( ib )
320 t( 1, 4 ) = half*val( ib )
321 t( 2, 1 ) = -t( 1, 2 )*val( ia21 )
322 t( 2, 2 ) = val( ia11 )*
323 $ real( ia22 )*vm( iam )
324 t( 2, 3 ) = val( ib )
325 t( 2, 4 ) = three*val( ib )
326 t( 3, 1 ) = zero
327 t( 3, 2 ) = zero
328 t( 3, 3 ) = val( ic11 )*
329 $ abs( val( icm ) )
330 t( 3, 4 ) = val( ic12 )*
331 $ abs( val( icm ) )
332 t( 4, 1 ) = zero
333 t( 4, 2 ) = zero
334 t( 4, 3 ) = -t( 3, 4 )*val( ic21 )*
335 $ abs( val( icm ) )
336 t( 4, 4 ) = val( ic11 )*
337 $ real( ic22 )*
338 $ abs( val( icm ) )
339 tnrm = zero
340 DO 200 i = 1, 4
341 DO 190 j = 1, 4
342 tnrm = max( tnrm,
343 $ abs( t( i, j ) ) )
344 190 CONTINUE
345 200 CONTINUE
346 CALL scopy( 16, t, 1, t1, 1 )
347 CALL scopy( 16, val( 1 ), 0, q, 1 )
348 CALL scopy( 4, val( 3 ), 0, q, 5 )
349 CALL slaexc( .true., 4, t, 4, q, 4,
350 $ 1, 2, 2, work, info )
351 IF( info.NE.0 )
352 $ ninfo( info ) = ninfo( info ) + 1
353 CALL shst01( 4, 1, 4, t1, 4, t, 4,
354 $ q, 4, work, lwork,
355 $ result )
356 res = result( 1 ) + result( 2 )
357 IF( info.EQ.0 ) THEN
358 IF( t( 3, 1 ).NE.zero )
359 $ res = res + one / eps
360 IF( t( 4, 1 ).NE.zero )
361 $ res = res + one / eps
362 IF( t( 3, 2 ).NE.zero )
363 $ res = res + one / eps
364 IF( t( 4, 2 ).NE.zero )
365 $ res = res + one / eps
366 IF( t( 2, 1 ).NE.0 .AND.
367 $ ( t( 1, 1 ).NE.t( 2,
368 $ 2 ) .OR. sign( one, t( 1,
369 $ 2 ) ).EQ.sign( one, t( 2,
370 $ 1 ) ) ) )res = res +
371 $ one / eps
372 IF( t( 4, 3 ).NE.0 .AND.
373 $ ( t( 3, 3 ).NE.t( 4,
374 $ 4 ) .OR. sign( one, t( 3,
375 $ 4 ) ).EQ.sign( one, t( 4,
376 $ 3 ) ) ) )res = res +
377 $ one / eps
378 END IF
379 knt = knt + 1
380 IF( res.GT.rmax ) THEN
381 lmax = knt
382 rmax = res
383 END IF
384 210 CONTINUE
385 220 CONTINUE
386 230 CONTINUE
387 240 CONTINUE
388 250 CONTINUE
389 260 CONTINUE
390 270 CONTINUE
391 280 CONTINUE
392 290 CONTINUE
393 300 CONTINUE
394*
395 RETURN
396*
397* End of SGET34
398*
399 END
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74
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
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
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
max
#define max(a, b)
Definition macros.h:21