OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dget32.f
Go to the documentation of this file.
1*> \brief \b DGET32
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 DGET32( 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*> DGET32 tests DLASY2, 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 DOUBLE PRECISION
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 double_eig
79*
80* =====================================================================
81 SUBROUTINE dget32( 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 DOUBLE PRECISION RMAX
90* ..
91*
92* =====================================================================
93*
94* .. Parameters ..
95 DOUBLE PRECISION ZERO, ONE
96 parameter( zero = 0.0d0, one = 1.0d0 )
97 DOUBLE PRECISION TWO, FOUR, EIGHT
98 parameter( two = 2.0d0, four = 4.0d0, eight = 8.0d0 )
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 DOUBLE PRECISION BIGNUM, DEN, EPS, RES, SCALE, SGN, SMLNUM, TMP,
105 $ TNRM, XNORM, XNRM
106* ..
107* .. Local Arrays ..
108 INTEGER ITVAL( 2, 2, 8 )
109 DOUBLE PRECISION B( 2, 2 ), TL( 2, 2 ), TR( 2, 2 ), VAL( 3 ),
110 $ X( 2, 2 )
111* ..
112* .. External Functions ..
113 DOUBLE PRECISION DLAMCH
114 EXTERNAL dlamch
115* ..
116* .. External Subroutines ..
117 EXTERNAL dlabad, dlasy2
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 = dlamch( 'p' )
132 SMLNUM = DLAMCH( 's' ) / EPS
133 BIGNUM = ONE / SMLNUM
134 CALL DLABAD( 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.EQ. LTRANL = ITRANL1
154.EQ. LTRANR = ITRANR1
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 DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL,
166 $ 2, TR, 2, B, 2, SCALE, X, 2, XNORM,
167 $ INFO )
168.NE. IF( INFO0 )
169 $ NINFO = NINFO + 1
170 RES = ABS( ( TL( 1, 1 )+SGN*TR( 1, 1 ) )*
171 $ X( 1, 1 )-SCALE*B( 1, 1 ) )
172.EQ. IF( INFO0 ) 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.GT. IF( SCALEONE )
181 $ RES = RES + ONE / EPS
182 RES = RES + ABS( XNORM-ABS( X( 1, 1 ) ) ) /
183 $ MAX( SMLNUM, XNORM ) / EPS
184.NE..AND..NE. IF( INFO0 INFO1 )
185 $ RES = RES + ONE / EPS
186.GT. IF( RESRMAX ) 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 DLASY2( LTRANL, LTRANR, ISGN, N1, N2,
214 $ TL, 2, TR, 2, B, 2, SCALE, X,
215 $ 2, XNORM, INFO )
216.NE. IF( INFO0 )
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.GT. IF( SCALEONE )
240 $ RES = RES + ONE / EPS
241 RES = RES + ABS( XNORM-XNRM ) /
242 $ MAX( SMLNUM, XNORM ) / EPS
243.GT. IF( RESRMAX ) 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 DLASY2( LTRANL, LTRANR, ISGN, N1, N2,
273 $ TL, 2, TR, 2, B, 2, SCALE, X,
274 $ 2, XNORM, INFO )
275.NE. IF( INFO0 )
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.GT. IF( SCALEONE )
300 $ RES = RES + ONE / EPS
301 RES = RES + ABS( XNORM-XNRM ) /
302 $ MAX( SMLNUM, XNORM ) / EPS
303.GT. IF( RESRMAX ) 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 DLASY2( LTRANL, LTRANR, ISGN,
346 $ N1, N2, TL, 2, TR, 2,
347 $ B, 2, SCALE, X, 2,
348 $ XNORM, INFO )
349.NE. IF( INFO0 )
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.GT. IF( SCALEONE )
406 $ RES = RES + ONE / EPS
407 RES = RES + ABS( XNORM-XNRM ) /
408 $ MAX( SMLNUM, XNORM ) / EPS
409.GT. IF( RESRMAX ) 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 DGET32
427*
428 END
dlabad
subroutine dlabad(small, large)
DLABAD
Definition dlabad.f:74
dlasy2
subroutine dlasy2(ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr, ldtr, b, ldb, scale, x, ldx, xnorm, info)
DLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2.
Definition dlasy2.f:174
dget32
subroutine dget32(rmax, lmax, ninfo, knt)
DGET32
Definition dget32.f:82
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21