OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
dget35.f
Go to the documentation of this file.
1*> \brief \b DGET35
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 DGET35( 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*> DGET35 tests DTRSYL, a routine for solving the Sylvester matrix
25*> equation
26*>
27*> op(A)*X + ISGN*X*op(B) = scale*C,
28*>
29*> A and B are assumed to be in Schur canonical form, op() represents an
30*> optional transpose, and ISGN can be -1 or +1. Scale is an output
31*> less than or equal to 1, chosen to avoid overflow in X.
32*>
33*> The test code verifies that the following residual is order 1:
34*>
35*> norm(op(A)*X + ISGN*X*op(B) - scale*C) /
36*> (EPS*max(norm(A),norm(B))*norm(X))
37*> \endverbatim
38*
39* Arguments:
40* ==========
41*
42*> \param[out] RMAX
43*> \verbatim
44*> RMAX is DOUBLE PRECISION
45*> Value of the largest test ratio.
46*> \endverbatim
47*>
48*> \param[out] LMAX
49*> \verbatim
50*> LMAX is INTEGER
51*> Example number where largest test ratio achieved.
52*> \endverbatim
53*>
54*> \param[out] NINFO
55*> \verbatim
56*> NINFO is INTEGER
57*> Number of examples where INFO is nonzero.
58*> \endverbatim
59*>
60*> \param[out] KNT
61*> \verbatim
62*> KNT is INTEGER
63*> Total number of examples tested.
64*> \endverbatim
65*
66* Authors:
67* ========
68*
69*> \author Univ. of Tennessee
70*> \author Univ. of California Berkeley
71*> \author Univ. of Colorado Denver
72*> \author NAG Ltd.
73*
74*> \ingroup double_eig
75*
76* =====================================================================
77 SUBROUTINE dget35( RMAX, LMAX, NINFO, KNT )
78*
79* -- LAPACK test routine --
80* -- LAPACK is a software package provided by Univ. of Tennessee, --
81* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
82*
83* .. Scalar Arguments ..
84 INTEGER KNT, LMAX, NINFO
85 DOUBLE PRECISION RMAX
86* ..
87*
88* =====================================================================
89*
90* .. Parameters ..
91 DOUBLE PRECISION ZERO, ONE
92 parameter( zero = 0.0d0, one = 1.0d0 )
93 DOUBLE PRECISION TWO, FOUR
94 parameter( two = 2.0d0, four = 4.0d0 )
95* ..
96* .. Local Scalars ..
97 CHARACTER TRANA, TRANB
98 INTEGER I, IMA, IMB, IMLDA1, IMLDA2, IMLDB1, IMLOFF,
99 $ INFO, ISGN, ITRANA, ITRANB, J, M, N
100 DOUBLE PRECISION BIGNUM, CNRM, EPS, RES, RES1, RMUL, SCALE,
101 $ SMLNUM, TNRM, XNRM
102* ..
103* .. Local Arrays ..
104 INTEGER IDIM( 8 ), IVAL( 6, 6, 8 )
105 DOUBLE PRECISION A( 6, 6 ), B( 6, 6 ), C( 6, 6 ), CC( 6, 6 ),
106 $ DUM( 1 ), VM1( 3 ), VM2( 3 )
107* ..
108* .. External Functions ..
109 DOUBLE PRECISION DLAMCH, DLANGE
110 EXTERNAL dlamch, dlange
111* ..
112* .. External Subroutines ..
113 EXTERNAL dgemm, dlabad, dtrsyl
114* ..
115* .. Intrinsic Functions ..
116 INTRINSIC abs, dble, max, sin, sqrt
117* ..
118* .. Data statements ..
119 DATA idim / 1, 2, 3, 4, 3, 3, 6, 4 /
120 DATA ival / 1, 35*0, 1, 2, 4*0, -2, 0, 28*0, 1, 5*0,
121 $ 5, 1, 2, 3*0, -8, -2, 1, 21*0, 3, 4, 4*0, -5,
122 $ 3, 4*0, 1, 2, 1, 4, 2*0, -3, -9, -1, 1, 14*0,
123 $ 1, 5*0, 2, 3, 4*0, 5, 6, 7, 21*0, 1, 5*0, 1, 3,
124 $ -4, 3*0, 2, 5, 2, 21*0, 1, 2, 4*0, -2, 0, 4*0,
125 $ 5, 6, 3, 4, 2*0, -1, -9, -5, 2, 2*0, 4*8, 5, 6,
126 $ 4*9, -7, 5, 1, 5*0, 1, 5, 2, 3*0, 2, -21, 5,
127 $ 3*0, 1, 2, 3, 4, 14*0 /
128* ..
129* .. Executable Statements ..
130*
131* Get machine parameters
132*
133 eps = dlamch( 'P' )
134 smlnum = dlamch( 'S' )*four / eps
135 bignum = one / smlnum
136 CALL dlabad( smlnum, bignum )
137*
138* Set up test case parameters
139*
140 vm1( 1 ) = sqrt( smlnum )
141 vm1( 2 ) = one
142 vm1( 3 ) = sqrt( bignum )
143 vm2( 1 ) = one
144 vm2( 2 ) = one + two*eps
145 vm2( 3 ) = two
146*
147 knt = 0
148 ninfo = 0
149 lmax = 0
150 rmax = zero
151*
152* Begin test loop
153*
154 DO 150 itrana = 1, 2
155 DO 140 itranb = 1, 2
156 DO 130 isgn = -1, 1, 2
157 DO 120 ima = 1, 8
158 DO 110 imlda1 = 1, 3
159 DO 100 imlda2 = 1, 3
160 DO 90 imloff = 1, 2
161 DO 80 imb = 1, 8
162 DO 70 imldb1 = 1, 3
163 IF( itrana.EQ.1 )
164 $ trana = 'N'
165 IF( itrana.EQ.2 )
166 $ trana = 'T'
167 IF( itranb.EQ.1 )
168 $ tranb = 'N'
169 IF( itranb.EQ.2 )
170 $ tranb = 'T'
171 m = idim( ima )
172 n = idim( imb )
173 tnrm = zero
174 DO 20 i = 1, m
175 DO 10 j = 1, m
176 a( i, j ) = ival( i, j, ima )
177 IF( abs( i-j ).LE.1 ) THEN
178 a( i, j ) = a( i, j )*
179 $ vm1( imlda1 )
180 a( i, j ) = a( i, j )*
181 $ vm2( imlda2 )
182 ELSE
183 a( i, j ) = a( i, j )*
184 $ vm1( imloff )
185 END IF
186 tnrm = max( tnrm,
187 $ abs( a( i, j ) ) )
188 10 CONTINUE
189 20 CONTINUE
190 DO 40 i = 1, n
191 DO 30 j = 1, n
192 b( i, j ) = ival( i, j, imb )
193 IF( abs( i-j ).LE.1 ) THEN
194 b( i, j ) = b( i, j )*
195 $ vm1( imldb1 )
196 ELSE
197 b( i, j ) = b( i, j )*
198 $ vm1( imloff )
199 END IF
200 tnrm = max( tnrm,
201 $ abs( b( i, j ) ) )
202 30 CONTINUE
203 40 CONTINUE
204 cnrm = zero
205 DO 60 i = 1, m
206 DO 50 j = 1, n
207 c( i, j ) = sin( dble( i*j ) )
208 cnrm = max( cnrm, c( i, j ) )
209 cc( i, j ) = c( i, j )
210 50 CONTINUE
211 60 CONTINUE
212 knt = knt + 1
213 CALL dtrsyl( trana, tranb, isgn, m, n,
214 $ a, 6, b, 6, c, 6, scale,
215 $ info )
216 IF( info.NE.0 )
217 $ ninfo = ninfo + 1
218 xnrm = dlange( 'M', m, n, c, 6, dum )
219 rmul = one
220 IF( xnrm.GT.one .AND. tnrm.GT.one )
221 $ THEN
222 IF( xnrm.GT.bignum / tnrm ) THEN
223 rmul = one / max( xnrm, tnrm )
224 END IF
225 END IF
226 CALL dgemm( trana, 'N', m, n, m, rmul,
227 $ a, 6, c, 6, -scale*rmul,
228 $ cc, 6 )
229 CALL dgemm( 'N', tranb, m, n, n,
230 $ dble( isgn )*rmul, c, 6, b,
231 $ 6, one, cc, 6 )
232 res1 = dlange( 'M', m, n, cc, 6, dum )
233 res = res1 / max( smlnum, smlnum*xnrm,
234 $ ( ( rmul*tnrm )*eps )*xnrm )
235 IF( res.GT.rmax ) THEN
236 lmax = knt
237 rmax = res
238 END IF
239 70 CONTINUE
240 80 CONTINUE
241 90 CONTINUE
242 100 CONTINUE
243 110 CONTINUE
244 120 CONTINUE
245 130 CONTINUE
246 140 CONTINUE
247 150 CONTINUE
248*
249 RETURN
250*
251* End of DGET35
252*
253 END
dlabad
subroutine dlabad(small, large)
DLABAD
Definition dlabad.f:74
dtrsyl
subroutine dtrsyl(trana, tranb, isgn, m, n, a, lda, b, ldb, c, ldc, scale, info)
DTRSYL
Definition dtrsyl.f:164
dgemm
subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
DGEMM
Definition dgemm.f:187
dget35
subroutine dget35(rmax, lmax, ninfo, knt)
DGET35
Definition dget35.f:78
max
#define max(a, b)
Definition macros.h:21