OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sget32.f
Go to the documentation of this file.
1*> \brief \b SGET32
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 SGET32( 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*> SGET32 tests SLASY2, a routine for solving
25*>
26*> op(TL)*X + ISGN*X*op(TR) = SCALE*B
27*>
28*> where TL is N1 by N1, TR is N2 by N2, and N1,N2 =1 or 2 only.
29*> X and B are N1 by N2, op() is an optional transpose, an
30*> ISGN = 1 or -1. SCALE is chosen less than or equal to 1 to
31*> avoid overflow in X.
32*>
33*> The test condition is that the scaled residual
34*>
35*> norm( op(TL)*X + ISGN*X*op(TR) = SCALE*B )
36*> / ( max( ulp*norm(TL), ulp*norm(TR)) * norm(X), SMLNUM )
37*>
38*> should be on the order of 1. Here, ulp is the machine precision.
39*> Also, it is verified that SCALE is less than or equal to 1, and
40*> that XNORM = infinity-norm(X).
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
61*> Number of examples returned with INFO.NE.0.
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 sget32( 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, NINFO
89 REAL RMAX
90* ..
91*
92* =====================================================================
93*
94* .. Parameters ..
95 REAL ZERO, ONE
96 parameter( zero = 0.0e0, one = 1.0e0 )
97 REAL TWO, FOUR, EIGHT
98 parameter( two = 2.0e0, four = 4.0e0, eight = 8.0e0 )
99* ..
100* .. Local Scalars ..
101 LOGICAL LTRANL, LTRANR
102 INTEGER IB, IB1, IB2, IB3, INFO, ISGN, ITL, ITLSCL,
103 $ ITR, ITRANL, ITRANR, ITRSCL, N1, N2
104 REAL BIGNUM, DEN, EPS, RES, SCALE, SGN, SMLNUM, TMP,
105 $ TNRM, XNORM, XNRM
106* ..
107* .. Local Arrays ..
108 INTEGER ITVAL( 2, 2, 8 )
109 REAL B( 2, 2 ), TL( 2, 2 ), TR( 2, 2 ), VAL( 3 ),
110 $ X( 2, 2 )
111* ..
112* .. External Functions ..
113 REAL SLAMCH
114 EXTERNAL slamch
115* ..
116* .. External Subroutines ..
117 EXTERNAL slabad, slasy2
118* ..
119* .. Intrinsic Functions ..
120 INTRINSIC abs, max, min, sqrt
121* ..
122* .. Data statements ..
123 DATA itval / 8, 4, 2, 1, 4, 8, 1, 2, 2, 1, 8, 4, 1,
124 $ 2, 4, 8, 9, 4, 2, 1, 4, 9, 1, 2, 2, 1, 9, 4, 1,
125 $ 2, 4, 9 /
126* ..
127* .. Executable Statements ..
128*
129* Get machine parameters
130*
131 eps = slamch( 'P' )
132 smlnum = slamch( 'S' ) / eps
133 bignum = one / smlnum
134 CALL slabad( smlnum, bignum )
135*
136* Set up test case parameters
137*
138 val( 1 ) = sqrt( smlnum )
139 val( 2 ) = one
140 val( 3 ) = sqrt( bignum )
141*
142 knt = 0
143 ninfo = 0
144 lmax = 0
145 rmax = zero
146*
147* Begin test loop
148*
149 DO 230 itranl = 0, 1
150 DO 220 itranr = 0, 1
151 DO 210 isgn = -1, 1, 2
152 sgn = isgn
153 ltranl = itranl.EQ.1
154 ltranr = itranr.EQ.1
155*
156 n1 = 1
157 n2 = 1
158 DO 30 itl = 1, 3
159 DO 20 itr = 1, 3
160 DO 10 ib = 1, 3
161 tl( 1, 1 ) = val( itl )
162 tr( 1, 1 ) = val( itr )
163 b( 1, 1 ) = val( ib )
164 knt = knt + 1
165 CALL slasy2( ltranl, ltranr, isgn, n1, n2, tl,
166 $ 2, tr, 2, b, 2, scale, x, 2, xnorm,
167 $ info )
168 IF( info.NE.0 )
169 $ ninfo = ninfo + 1
170 res = abs( ( tl( 1, 1 )+sgn*tr( 1, 1 ) )*
171 $ x( 1, 1 )-scale*b( 1, 1 ) )
172 IF( info.EQ.0 ) THEN
173 den = max( eps*( ( abs( tr( 1,
174 $ 1 ) )+abs( tl( 1, 1 ) ) )*abs( x( 1,
175 $ 1 ) ) ), smlnum )
176 ELSE
177 den = smlnum*max( abs( x( 1, 1 ) ), one )
178 END IF
179 res = res / den
180 IF( scale.GT.one )
181 $ res = res + one / eps
182 res = res + abs( xnorm-abs( x( 1, 1 ) ) ) /
183 $ max( smlnum, xnorm ) / eps
184 IF( info.NE.0 .AND. info.NE.1 )
185 $ res = res + one / eps
186 IF( res.GT.rmax ) THEN
187 lmax = knt
188 rmax = res
189 END IF
190 10 CONTINUE
191 20 CONTINUE
192 30 CONTINUE
193*
194 n1 = 2
195 n2 = 1
196 DO 80 itl = 1, 8
197 DO 70 itlscl = 1, 3
198 DO 60 itr = 1, 3
199 DO 50 ib1 = 1, 3
200 DO 40 ib2 = 1, 3
201 b( 1, 1 ) = val( ib1 )
202 b( 2, 1 ) = -four*val( ib2 )
203 tl( 1, 1 ) = itval( 1, 1, itl )*
204 $ val( itlscl )
205 tl( 2, 1 ) = itval( 2, 1, itl )*
206 $ val( itlscl )
207 tl( 1, 2 ) = itval( 1, 2, itl )*
208 $ val( itlscl )
209 tl( 2, 2 ) = itval( 2, 2, itl )*
210 $ val( itlscl )
211 tr( 1, 1 ) = val( itr )
212 knt = knt + 1
213 CALL slasy2( ltranl, ltranr, isgn, n1, n2,
214 $ tl, 2, tr, 2, b, 2, scale, x,
215 $ 2, xnorm, info )
216 IF( info.NE.0 )
217 $ ninfo = ninfo + 1
218 IF( ltranl ) THEN
219 tmp = tl( 1, 2 )
220 tl( 1, 2 ) = tl( 2, 1 )
221 tl( 2, 1 ) = tmp
222 END IF
223 res = abs( ( tl( 1, 1 )+sgn*tr( 1, 1 ) )*
224 $ x( 1, 1 )+tl( 1, 2 )*x( 2, 1 )-
225 $ scale*b( 1, 1 ) )
226 res = res + abs( ( tl( 2, 2 )+sgn*tr( 1,
227 $ 1 ) )*x( 2, 1 )+tl( 2, 1 )*
228 $ x( 1, 1 )-scale*b( 2, 1 ) )
229 tnrm = abs( tr( 1, 1 ) ) +
230 $ abs( tl( 1, 1 ) ) +
231 $ abs( tl( 1, 2 ) ) +
232 $ abs( tl( 2, 1 ) ) +
233 $ abs( tl( 2, 2 ) )
234 xnrm = max( abs( x( 1, 1 ) ),
235 $ abs( x( 2, 1 ) ) )
236 den = max( smlnum, smlnum*xnrm,
237 $ ( tnrm*eps )*xnrm )
238 res = res / den
239 IF( scale.GT.one )
240 $ res = res + one / eps
241 res = res + abs( xnorm-xnrm ) /
242 $ max( smlnum, xnorm ) / eps
243 IF( res.GT.rmax ) THEN
244 lmax = knt
245 rmax = res
246 END IF
247 40 CONTINUE
248 50 CONTINUE
249 60 CONTINUE
250 70 CONTINUE
251 80 CONTINUE
252*
253 n1 = 1
254 n2 = 2
255 DO 130 itr = 1, 8
256 DO 120 itrscl = 1, 3
257 DO 110 itl = 1, 3
258 DO 100 ib1 = 1, 3
259 DO 90 ib2 = 1, 3
260 b( 1, 1 ) = val( ib1 )
261 b( 1, 2 ) = -two*val( ib2 )
262 tr( 1, 1 ) = itval( 1, 1, itr )*
263 $ val( itrscl )
264 tr( 2, 1 ) = itval( 2, 1, itr )*
265 $ val( itrscl )
266 tr( 1, 2 ) = itval( 1, 2, itr )*
267 $ val( itrscl )
268 tr( 2, 2 ) = itval( 2, 2, itr )*
269 $ val( itrscl )
270 tl( 1, 1 ) = val( itl )
271 knt = knt + 1
272 CALL slasy2( ltranl, ltranr, isgn, n1, n2,
273 $ tl, 2, tr, 2, b, 2, scale, x,
274 $ 2, xnorm, info )
275 IF( info.NE.0 )
276 $ ninfo = ninfo + 1
277 IF( ltranr ) THEN
278 tmp = tr( 1, 2 )
279 tr( 1, 2 ) = tr( 2, 1 )
280 tr( 2, 1 ) = tmp
281 END IF
282 tnrm = abs( tl( 1, 1 ) ) +
283 $ abs( tr( 1, 1 ) ) +
284 $ abs( tr( 1, 2 ) ) +
285 $ abs( tr( 2, 2 ) ) +
286 $ abs( tr( 2, 1 ) )
287 xnrm = abs( x( 1, 1 ) ) + abs( x( 1, 2 ) )
288 res = abs( ( ( tl( 1, 1 )+sgn*tr( 1,
289 $ 1 ) ) )*( x( 1, 1 ) )+
290 $ ( sgn*tr( 2, 1 ) )*( x( 1, 2 ) )-
291 $ ( scale*b( 1, 1 ) ) )
292 res = res + abs( ( ( tl( 1, 1 )+sgn*tr( 2,
293 $ 2 ) ) )*( x( 1, 2 ) )+
294 $ ( sgn*tr( 1, 2 ) )*( x( 1, 1 ) )-
295 $ ( scale*b( 1, 2 ) ) )
296 den = max( smlnum, smlnum*xnrm,
297 $ ( tnrm*eps )*xnrm )
298 res = res / den
299 IF( scale.GT.one )
300 $ res = res + one / eps
301 res = res + abs( xnorm-xnrm ) /
302 $ max( smlnum, xnorm ) / eps
303 IF( res.GT.rmax ) THEN
304 lmax = knt
305 rmax = res
306 END IF
307 90 CONTINUE
308 100 CONTINUE
309 110 CONTINUE
310 120 CONTINUE
311 130 CONTINUE
312*
313 n1 = 2
314 n2 = 2
315 DO 200 itr = 1, 8
316 DO 190 itrscl = 1, 3
317 DO 180 itl = 1, 8
318 DO 170 itlscl = 1, 3
319 DO 160 ib1 = 1, 3
320 DO 150 ib2 = 1, 3
321 DO 140 ib3 = 1, 3
322 b( 1, 1 ) = val( ib1 )
323 b( 2, 1 ) = -four*val( ib2 )
324 b( 1, 2 ) = -two*val( ib3 )
325 b( 2, 2 ) = eight*
326 $ min( val( ib1 ), val
327 $ ( ib2 ), val( ib3 ) )
328 tr( 1, 1 ) = itval( 1, 1, itr )*
329 $ val( itrscl )
330 tr( 2, 1 ) = itval( 2, 1, itr )*
331 $ val( itrscl )
332 tr( 1, 2 ) = itval( 1, 2, itr )*
333 $ val( itrscl )
334 tr( 2, 2 ) = itval( 2, 2, itr )*
335 $ val( itrscl )
336 tl( 1, 1 ) = itval( 1, 1, itl )*
337 $ val( itlscl )
338 tl( 2, 1 ) = itval( 2, 1, itl )*
339 $ val( itlscl )
340 tl( 1, 2 ) = itval( 1, 2, itl )*
341 $ val( itlscl )
342 tl( 2, 2 ) = itval( 2, 2, itl )*
343 $ val( itlscl )
344 knt = knt + 1
345 CALL slasy2( ltranl, ltranr, isgn,
346 $ n1, n2, tl, 2, tr, 2,
347 $ b, 2, scale, x, 2,
348 $ xnorm, info )
349 IF( info.NE.0 )
350 $ ninfo = ninfo + 1
351 IF( ltranr ) THEN
352 tmp = tr( 1, 2 )
353 tr( 1, 2 ) = tr( 2, 1 )
354 tr( 2, 1 ) = tmp
355 END IF
356 IF( ltranl ) THEN
357 tmp = tl( 1, 2 )
358 tl( 1, 2 ) = tl( 2, 1 )
359 tl( 2, 1 ) = tmp
360 END IF
361 tnrm = abs( tr( 1, 1 ) ) +
362 $ abs( tr( 2, 1 ) ) +
363 $ abs( tr( 1, 2 ) ) +
364 $ abs( tr( 2, 2 ) ) +
365 $ abs( tl( 1, 1 ) ) +
366 $ abs( tl( 2, 1 ) ) +
367 $ abs( tl( 1, 2 ) ) +
368 $ abs( tl( 2, 2 ) )
369 xnrm = max( abs( x( 1, 1 ) )+
370 $ abs( x( 1, 2 ) ),
371 $ abs( x( 2, 1 ) )+
372 $ abs( x( 2, 2 ) ) )
373 res = abs( ( ( tl( 1, 1 )+sgn*tr( 1,
374 $ 1 ) ) )*( x( 1, 1 ) )+
375 $ ( sgn*tr( 2, 1 ) )*
376 $ ( x( 1, 2 ) )+( tl( 1, 2 ) )*
377 $ ( x( 2, 1 ) )-
378 $ ( scale*b( 1, 1 ) ) )
379 res = res + abs( ( tl( 1, 1 ) )*
380 $ ( x( 1, 2 ) )+
381 $ ( sgn*tr( 1, 2 ) )*
382 $ ( x( 1, 1 ) )+
383 $ ( sgn*tr( 2, 2 ) )*
384 $ ( x( 1, 2 ) )+( tl( 1, 2 ) )*
385 $ ( x( 2, 2 ) )-
386 $ ( scale*b( 1, 2 ) ) )
387 res = res + abs( ( tl( 2, 1 ) )*
388 $ ( x( 1, 1 ) )+
389 $ ( sgn*tr( 1, 1 ) )*
390 $ ( x( 2, 1 ) )+
391 $ ( sgn*tr( 2, 1 ) )*
392 $ ( x( 2, 2 ) )+( tl( 2, 2 ) )*
393 $ ( x( 2, 1 ) )-
394 $ ( scale*b( 2, 1 ) ) )
395 res = res + abs( ( ( tl( 2,
396 $ 2 )+sgn*tr( 2, 2 ) ) )*
397 $ ( x( 2, 2 ) )+
398 $ ( sgn*tr( 1, 2 ) )*
399 $ ( x( 2, 1 ) )+( tl( 2, 1 ) )*
400 $ ( x( 1, 2 ) )-
401 $ ( scale*b( 2, 2 ) ) )
402 den = max( smlnum, smlnum*xnrm,
403 $ ( tnrm*eps )*xnrm )
404 res = res / den
405 IF( scale.GT.one )
406 $ res = res + one / eps
407 res = res + abs( xnorm-xnrm ) /
408 $ max( smlnum, xnorm ) / eps
409 IF( res.GT.rmax ) THEN
410 lmax = knt
411 rmax = res
412 END IF
413 140 CONTINUE
414 150 CONTINUE
415 160 CONTINUE
416 170 CONTINUE
417 180 CONTINUE
418 190 CONTINUE
419 200 CONTINUE
420 210 CONTINUE
421 220 CONTINUE
422 230 CONTINUE
423*
424 RETURN
425*
426* End of SGET32
427*
428 END
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74
slasy2
subroutine slasy2(ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr, ldtr, b, ldb, scale, x, ldx, xnorm, info)
SLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2.
Definition slasy2.f:174
sget32
subroutine sget32(rmax, lmax, ninfo, knt)
SGET32
Definition sget32.f:82
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21