OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sdrvrf3.f
Go to the documentation of this file.
1*> \brief \b SDRVRF3
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 SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
12* + S_WORK_SLANGE, S_WORK_SGEQRF, TAU )
13*
14* .. Scalar Arguments ..
15* INTEGER LDA, NN, NOUT
16* REAL THRESH
17* ..
18* .. Array Arguments ..
19* INTEGER NVAL( NN )
20* REAL A( LDA, * ), ARF( * ), B1( LDA, * ),
21* + B2( LDA, * ), S_WORK_SGEQRF( * ),
22* + S_WORK_SLANGE( * ), TAU( * )
23* ..
24*
25*
26*> \par Purpose:
27* =============
28*>
29*> \verbatim
30*>
31*> SDRVRF3 tests the LAPACK RFP routines:
32*> STFSM
33*> \endverbatim
34*
35* Arguments:
36* ==========
37*
38*> \param[in] NOUT
39*> \verbatim
40*> NOUT is INTEGER
41*> The unit number for output.
42*> \endverbatim
43*>
44*> \param[in] NN
45*> \verbatim
46*> NN is INTEGER
47*> The number of values of N contained in the vector NVAL.
48*> \endverbatim
49*>
50*> \param[in] NVAL
51*> \verbatim
52*> NVAL is INTEGER array, dimension (NN)
53*> The values of the matrix dimension N.
54*> \endverbatim
55*>
56*> \param[in] THRESH
57*> \verbatim
58*> THRESH is REAL
59*> The threshold value for the test ratios. A result is
60*> included in the output file if RESULT >= THRESH. To have
61*> every test ratio printed, use THRESH = 0.
62*> \endverbatim
63*>
64*> \param[out] A
65*> \verbatim
66*> A is REAL array, dimension (LDA,NMAX)
67*> \endverbatim
68*>
69*> \param[in] LDA
70*> \verbatim
71*> LDA is INTEGER
72*> The leading dimension of the array A. LDA >= max(1,NMAX).
73*> \endverbatim
74*>
75*> \param[out] ARF
76*> \verbatim
77*> ARF is REAL array, dimension ((NMAX*(NMAX+1))/2).
78*> \endverbatim
79*>
80*> \param[out] B1
81*> \verbatim
82*> B1 is REAL array, dimension (LDA,NMAX)
83*> \endverbatim
84*>
85*> \param[out] B2
86*> \verbatim
87*> B2 is REAL array, dimension (LDA,NMAX)
88*> \endverbatim
89*>
90*> \param[out] S_WORK_SLANGE
91*> \verbatim
92*> S_WORK_SLANGE is REAL array, dimension (NMAX)
93*> \endverbatim
94*>
95*> \param[out] S_WORK_SGEQRF
96*> \verbatim
97*> S_WORK_SGEQRF is REAL array, dimension (NMAX)
98*> \endverbatim
99*>
100*> \param[out] TAU
101*> \verbatim
102*> TAU is REAL array, dimension (NMAX)
103*> \endverbatim
104*
105* Authors:
106* ========
107*
108*> \author Univ. of Tennessee
109*> \author Univ. of California Berkeley
110*> \author Univ. of Colorado Denver
111*> \author NAG Ltd.
112*
113*> \ingroup single_lin
114*
115* =====================================================================
116 SUBROUTINE sdrvrf3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
117 + S_WORK_SLANGE, S_WORK_SGEQRF, TAU )
118*
119* -- LAPACK test routine --
120* -- LAPACK is a software package provided by Univ. of Tennessee, --
121* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
122*
123* .. Scalar Arguments ..
124 INTEGER LDA, NN, NOUT
125 REAL THRESH
126* ..
127* .. Array Arguments ..
128 INTEGER NVAL( NN )
129 REAL A( LDA, * ), ARF( * ), B1( LDA, * ),
130 + b2( lda, * ), s_work_sgeqrf( * ),
131 + s_work_slange( * ), tau( * )
132* ..
133*
134* =====================================================================
135* ..
136* .. Parameters ..
137 REAL ZERO, ONE
138 parameter( zero = ( 0.0e+0, 0.0e+0 ) ,
139 + one = ( 1.0e+0, 0.0e+0 ) )
140 INTEGER NTESTS
141 parameter( ntests = 1 )
142* ..
143* .. Local Scalars ..
144 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE
145 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
146 + nfail, nrun, iside, idiag, ialpha, itrans
147 REAL EPS, ALPHA
148* ..
149* .. Local Arrays ..
150 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
151 + diags( 2 ), sides( 2 )
152 INTEGER ISEED( 4 ), ISEEDY( 4 )
153 REAL RESULT( NTESTS )
154* ..
155* .. External Functions ..
156 REAL SLAMCH, SLANGE, SLARND
157 EXTERNAL slamch, slange, slarnd
158* ..
159* .. External Subroutines ..
160 EXTERNAL strttf, sgeqrf, sgeqlf, stfsm, strsm
161* ..
162* .. Intrinsic Functions ..
163 INTRINSIC max, sqrt
164* ..
165* .. Scalars in Common ..
166 CHARACTER*32 SRNAMT
167* ..
168* .. Common blocks ..
169 COMMON / srnamc / srnamt
170* ..
171* .. Data statements ..
172 DATA iseedy / 1988, 1989, 1990, 1991 /
173 DATA uplos / 'U', 'L' /
174 DATA forms / 'n', 't' /
175 DATA SIDES / 'l', 'r' /
176 DATA TRANSS / 'n', 't' /
177 DATA DIAGS / 'n', 'u' /
178* ..
179* .. Executable Statements ..
180*
181* Initialize constants and the random number seed.
182*
183 NRUN = 0
184 NFAIL = 0
185 INFO = 0
186 DO 10 I = 1, 4
187 ISEED( I ) = ISEEDY( I )
188 10 CONTINUE
189 EPS = SLAMCH( 'precision' )
190*
191 DO 170 IIM = 1, NN
192*
193 M = NVAL( IIM )
194*
195 DO 160 IIN = 1, NN
196*
197 N = NVAL( IIN )
198*
199 DO 150 IFORM = 1, 2
200*
201 CFORM = FORMS( IFORM )
202*
203 DO 140 IUPLO = 1, 2
204*
205 UPLO = UPLOS( IUPLO )
206*
207 DO 130 ISIDE = 1, 2
208*
209 SIDE = SIDES( ISIDE )
210*
211 DO 120 ITRANS = 1, 2
212*
213 TRANS = TRANSS( ITRANS )
214*
215 DO 110 IDIAG = 1, 2
216*
217 DIAG = DIAGS( IDIAG )
218*
219 DO 100 IALPHA = 1, 3
220*
221.EQ. IF ( IALPHA 1) THEN
222 ALPHA = ZERO
223.EQ. ELSE IF ( IALPHA 2) THEN
224 ALPHA = ONE
225 ELSE
226 ALPHA = SLARND( 2, ISEED )
227 END IF
228*
229* All the parameters are set:
230* CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
231* and ALPHA
232* READY TO TEST!
233*
234 NRUN = NRUN + 1
235*
236.EQ. IF ( ISIDE1 ) THEN
237*
238* The case ISIDE.EQ.1 is when SIDE.EQ.'L'
239* -> A is M-by-M ( B is M-by-N )
240*
241 NA = M
242*
243 ELSE
244*
245* The case ISIDE.EQ.2 is when SIDE.EQ.'R'
246* -> A is N-by-N ( B is M-by-N )
247*
248 NA = N
249*
250 END IF
251*
252* Generate A our NA--by--NA triangular
253* matrix.
254* Our test is based on forward error so we
255* do want A to be well conditioned! To get
256* a well-conditioned triangular matrix, we
257* take the R factor of the QR/LQ factorization
258* of a random matrix.
259*
260 DO J = 1, NA
261 DO I = 1, NA
262 A( I, J) = SLARND( 2, ISEED )
263 END DO
264 END DO
265*
266.EQ. IF ( IUPLO1 ) THEN
267*
268* The case IUPLO.EQ.1 is when SIDE.EQ.'U'
269* -> QR factorization.
270*
271 SRNAMT = 'sgeqrf'
272 CALL SGEQRF( NA, NA, A, LDA, TAU,
273 + S_WORK_SGEQRF, LDA,
274 + INFO )
275 ELSE
276*
277* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
278* -> QL factorization.
279*
280 SRNAMT = 'sgelqf'
281 CALL SGELQF( NA, NA, A, LDA, TAU,
282 + S_WORK_SGEQRF, LDA,
283 + INFO )
284 END IF
285*
286* Store a copy of A in RFP format (in ARF).
287*
288 SRNAMT = 'strttf'
289 CALL STRTTF( CFORM, UPLO, NA, A, LDA, ARF,
290 + INFO )
291*
292* Generate B1 our M--by--N right-hand side
293* and store a copy in B2.
294*
295 DO J = 1, N
296 DO I = 1, M
297 B1( I, J) = SLARND( 2, ISEED )
298 B2( I, J) = B1( I, J)
299 END DO
300 END DO
301*
302* Solve op( A ) X = B or X op( A ) = B
303* with STRSM
304*
305 SRNAMT = 'strsm'
306 CALL STRSM( SIDE, UPLO, TRANS, DIAG, M, N,
307 + ALPHA, A, LDA, B1, LDA )
308*
309* Solve op( A ) X = B or X op( A ) = B
310* with STFSM
311*
312 SRNAMT = 'stfsm'
313 CALL STFSM( CFORM, SIDE, UPLO, TRANS,
314 + DIAG, M, N, ALPHA, ARF, B2,
315 + LDA )
316*
317* Check that the result agrees.
318*
319 DO J = 1, N
320 DO I = 1, M
321 B1( I, J) = B2( I, J ) - B1( I, J )
322 END DO
323 END DO
324*
325 RESULT(1) = SLANGE( 'i', M, N, B1, LDA,
326 + S_WORK_SLANGE )
327*
328 RESULT(1) = RESULT(1) / SQRT( EPS )
329 + / MAX ( MAX( M, N), 1 )
330*
331.GE. IF( RESULT(1)THRESH ) THEN
332.EQ. IF( NFAIL0 ) THEN
333 WRITE( NOUT, * )
334 WRITE( NOUT, FMT = 9999 )
335 END IF
336 WRITE( NOUT, FMT = 9997 ) 'stfsm',
337 + CFORM, SIDE, UPLO, TRANS, DIAG, M,
338 + N, RESULT(1)
339 NFAIL = NFAIL + 1
340 END IF
341*
342 100 CONTINUE
343 110 CONTINUE
344 120 CONTINUE
345 130 CONTINUE
346 140 CONTINUE
347 150 CONTINUE
348 160 CONTINUE
349 170 CONTINUE
350*
351* Print a summary of the results.
352*
353.EQ. IF ( NFAIL0 ) THEN
354 WRITE( NOUT, FMT = 9996 ) 'stfsm', NRUN
355 ELSE
356 WRITE( NOUT, FMT = 9995 ) 'stfsm', NFAIL, NRUN
357 END IF
358*
359 9999 FORMAT( 1X, ' *** error(s) or failure(s) while testing stfsm
360 + ***')
361 9997 FORMAT( 1X, ' failure in ',A5,', cform=''',A1,''',',
362 + ' side=''',A1,''',',' uplo=''',A1,''',',' trans=''',A1,''',',
363 + ' diag=''',A1,''',',' m=',I3,', n =', I3,', test=',G12.5)
364 9996 FORMAT( 1X, 'all tests for ',A5,' auxiliary routine passed the ',
365 + 'threshold( ',I5,' tests run)')
366 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I5,' out of ',i5,
367 + ' tests failed to pass the threshold')
368*
369 RETURN
370*
371* End of SDRVRF3
372*
373 END
the
end diagonal values have been computed in the(sparse) matrix id.SOL
sgeqrf
subroutine sgeqrf(m, n, a, lda, tau, work, lwork, info)
SGEQRF
Definition sgeqrf.f:146
sgelqf
subroutine sgelqf(m, n, a, lda, tau, work, lwork, info)
SGELQF
Definition sgelqf.f:143
sgeqlf
subroutine sgeqlf(m, n, a, lda, tau, work, lwork, info)
SGEQLF
Definition sgeqlf.f:138
strttf
subroutine strttf(transr, uplo, n, a, lda, arf, info)
STRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
Definition strttf.f:194
stfsm
subroutine stfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
STFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition stfsm.f:277
strsm
subroutine strsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRSM
Definition strsm.f:181
sdrvrf3
subroutine sdrvrf3(nout, nn, nval, thresh, a, lda, arf, b1, b2, s_work_slange, s_work_sgeqrf, tau)
SDRVRF3
Definition sdrvrf3.f:118
max
#define max(a, b)
Definition macros.h:21
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91