LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
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 LOGICAL LSAME
157 REAL SLAMCH, SLANGE, SLARND
158 EXTERNAL slamch, slange, slarnd, lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL strttf, sgeqrf, sgeqlf, stfsm, strsm
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC max, sqrt
165* ..
166* .. Scalars in Common ..
167 CHARACTER*32 SRNAMT
168* ..
169* .. Common blocks ..
170 COMMON / srnamc / srnamt
171* ..
172* .. Data statements ..
173 DATA iseedy / 1988, 1989, 1990, 1991 /
174 DATA uplos / 'U', 'L' /
175 DATA forms / 'N', 'T' /
176 DATA sides / 'L', 'R' /
177 DATA transs / 'N', 'T' /
178 DATA diags / 'N', 'U' /
179* ..
180* .. Executable Statements ..
181*
182* Initialize constants and the random number seed.
183*
184 nrun = 0
185 nfail = 0
186 info = 0
187 DO 10 i = 1, 4
188 iseed( i ) = iseedy( i )
189 10 CONTINUE
190 eps = slamch( 'Precision' )
191*
192 DO 170 iim = 1, nn
193*
194 m = nval( iim )
195*
196 DO 160 iin = 1, nn
197*
198 n = nval( iin )
199*
200 DO 150 iform = 1, 2
201*
202 cform = forms( iform )
203*
204 DO 140 iuplo = 1, 2
205*
206 uplo = uplos( iuplo )
207*
208 DO 130 iside = 1, 2
209*
210 side = sides( iside )
211*
212 DO 120 itrans = 1, 2
213*
214 trans = transs( itrans )
215*
216 DO 110 idiag = 1, 2
217*
218 diag = diags( idiag )
219*
220 DO 100 ialpha = 1, 3
221*
222 IF ( ialpha.EQ.1 ) THEN
223 alpha = zero
224 ELSE IF ( ialpha.EQ.2 ) THEN
225 alpha = one
226 ELSE
227 alpha = slarnd( 2, iseed )
228 END IF
229*
230* All the parameters are set:
231* CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
232* and ALPHA
233* READY TO TEST!
234*
235 nrun = nrun + 1
236*
237 IF ( iside.EQ.1 ) THEN
238*
239* The case ISIDE.EQ.1 is when SIDE.EQ.'L'
240* -> A is M-by-M ( B is M-by-N )
241*
242 na = m
243*
244 ELSE
245*
246* The case ISIDE.EQ.2 is when SIDE.EQ.'R'
247* -> A is N-by-N ( B is M-by-N )
248*
249 na = n
250*
251 END IF
252*
253* Generate A our NA--by--NA triangular
254* matrix.
255* Our test is based on forward error so we
256* do want A to be well conditioned! To get
257* a well-conditioned triangular matrix, we
258* take the R factor of the QR/LQ factorization
259* of a random matrix.
260*
261 DO j = 1, na
262 DO i = 1, na
263 a( i, j ) = slarnd( 2, iseed )
264 END DO
265 END DO
266*
267 IF ( iuplo.EQ.1 ) THEN
268*
269* The case IUPLO.EQ.1 is when SIDE.EQ.'U'
270* -> QR factorization.
271*
272 srnamt = 'SGEQRF'
273 CALL sgeqrf( na, na, a, lda, tau,
274 + s_work_sgeqrf, lda,
275 + info )
276*
277* Forcing main diagonal of test matrix to
278* be unit makes it ill-conditioned for
279* some test cases
280*
281 IF ( lsame( diag, 'U' ) ) THEN
282 DO j = 1, na
283 DO i = 1, j
284 a( i, j ) = a( i, j ) /
285 + ( 2.0 * a( j, j ) )
286 END DO
287 END DO
288 END IF
289*
290 ELSE
291*
292* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
293* -> QL factorization.
294*
295 srnamt = 'SGELQF'
296 CALL sgelqf( na, na, a, lda, tau,
297 + s_work_sgeqrf, lda,
298 + info )
299*
300* Forcing main diagonal of test matrix to
301* be unit makes it ill-conditioned for
302* some test cases
303*
304 IF ( lsame( diag, 'U' ) ) THEN
305 DO i = 1, na
306 DO j = 1, i
307 a( i, j ) = a( i, j ) /
308 + ( 2.0 * a( i, i ) )
309 END DO
310 END DO
311 END IF
312*
313 END IF
314*
315* Store a copy of A in RFP format (in ARF).
316*
317 srnamt = 'STRTTF'
318 CALL strttf( cform, uplo, na, a, lda, arf,
319 + info )
320*
321* Generate B1 our M--by--N right-hand side
322* and store a copy in B2.
323*
324 DO j = 1, n
325 DO i = 1, m
326 b1( i, j ) = slarnd( 2, iseed )
327 b2( i, j ) = b1( i, j )
328 END DO
329 END DO
330*
331* Solve op( A ) X = B or X op( A ) = B
332* with STRSM
333*
334 srnamt = 'STRSM'
335 CALL strsm( side, uplo, trans, diag, m, n,
336 + alpha, a, lda, b1, lda )
337*
338* Solve op( A ) X = B or X op( A ) = B
339* with STFSM
340*
341 srnamt = 'STFSM'
342 CALL stfsm( cform, side, uplo, trans,
343 + diag, m, n, alpha, arf, b2,
344 + lda )
345*
346* Check that the result agrees.
347*
348 DO j = 1, n
349 DO i = 1, m
350 b1( i, j ) = b2( i, j ) - b1( i, j )
351 END DO
352 END DO
353*
354 result( 1 ) = slange( 'I', m, n, b1, lda,
355 + s_work_slange )
356*
357 result( 1 ) = result( 1 ) / sqrt( eps )
358 + / max( max( m, n ), 1 )
359*
360 IF( result( 1 ).GE.thresh ) THEN
361 IF( nfail.EQ.0 ) THEN
362 WRITE( nout, * )
363 WRITE( nout, fmt = 9999 )
364 END IF
365 WRITE( nout, fmt = 9997 ) 'STFSM',
366 + cform, side, uplo, trans, diag, m,
367 + n, result( 1 )
368 nfail = nfail + 1
369 END IF
370*
371 100 CONTINUE
372 110 CONTINUE
373 120 CONTINUE
374 130 CONTINUE
375 140 CONTINUE
376 150 CONTINUE
377 160 CONTINUE
378 170 CONTINUE
379*
380* Print a summary of the results.
381*
382 IF ( nfail.EQ.0 ) THEN
383 WRITE( nout, fmt = 9996 ) 'STFSM', nrun
384 ELSE
385 WRITE( nout, fmt = 9995 ) 'STFSM', nfail, nrun
386 END IF
387*
388 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing STFSM
389 + ***')
390 9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
391 + ' SIDE=''',a1,''',',' UPLO=''',a1,''',',' TRANS=''',a1,''',',
392 + ' DIAG=''',a1,''',',' M=',i3,', N =', i3,', test=',g12.5)
393 9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
394 + 'threshold ( ',i5,' tests run)')
395 9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
396 + ' tests failed to pass the threshold')
397*
398 RETURN
399*
400* End of SDRVRF3
401*
402 END
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
sgeqrf
subroutine sgeqrf(m, n, a, lda, tau, work, lwork, info)
SGEQRF
Definition sgeqrf.f:146
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
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
sdrvrf3
subroutine sdrvrf3(nout, nn, nval, thresh, a, lda, arf, b1, b2, s_work_slange, s_work_sgeqrf, tau)
SDRVRF3
Definition sdrvrf3.f:118