LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
sdrvrf4.f
Go to the documentation of this file.
1*> \brief \b SDRVRF4
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 SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
12* + LDA, S_WORK_SLANGE )
13*
14* .. Scalar Arguments ..
15* INTEGER LDA, LDC, NN, NOUT
16* REAL THRESH
17* ..
18* .. Array Arguments ..
19* INTEGER NVAL( NN )
20* REAL A( LDA, * ), C1( LDC, * ), C2( LDC, *),
21* + CRF( * ), S_WORK_SLANGE( * )
22* ..
23*
24*
25*> \par Purpose:
26* =============
27*>
28*> \verbatim
29*>
30*> SDRVRF4 tests the LAPACK RFP routines:
31*> SSFRK
32*> \endverbatim
33*
34* Arguments:
35* ==========
36*
37*> \param[in] NOUT
38*> \verbatim
39*> NOUT is INTEGER
40*> The unit number for output.
41*> \endverbatim
42*>
43*> \param[in] NN
44*> \verbatim
45*> NN is INTEGER
46*> The number of values of N contained in the vector NVAL.
47*> \endverbatim
48*>
49*> \param[in] NVAL
50*> \verbatim
51*> NVAL is INTEGER array, dimension (NN)
52*> The values of the matrix dimension N.
53*> \endverbatim
54*>
55*> \param[in] THRESH
56*> \verbatim
57*> THRESH is REAL
58*> The threshold value for the test ratios. A result is
59*> included in the output file if RESULT >= THRESH. To
60*> have every test ratio printed, use THRESH = 0.
61*> \endverbatim
62*>
63*> \param[out] C1
64*> \verbatim
65*> C1 is REAL array,
66*> dimension (LDC,NMAX)
67*> \endverbatim
68*>
69*> \param[out] C2
70*> \verbatim
71*> C2 is REAL array,
72*> dimension (LDC,NMAX)
73*> \endverbatim
74*>
75*> \param[in] LDC
76*> \verbatim
77*> LDC is INTEGER
78*> The leading dimension of the array A.
79*> LDA >= max(1,NMAX).
80*> \endverbatim
81*>
82*> \param[out] CRF
83*> \verbatim
84*> CRF is REAL array,
85*> dimension ((NMAX*(NMAX+1))/2).
86*> \endverbatim
87*>
88*> \param[out] A
89*> \verbatim
90*> A is REAL array,
91*> dimension (LDA,NMAX)
92*> \endverbatim
93*>
94*> \param[in] LDA
95*> \verbatim
96*> LDA is INTEGER
97*> The leading dimension of the array A. LDA >= max(1,NMAX).
98*> \endverbatim
99*>
100*> \param[out] S_WORK_SLANGE
101*> \verbatim
102*> S_WORK_SLANGE 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 sdrvrf4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
117 + LDA, S_WORK_SLANGE )
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, LDC, NN, NOUT
125 REAL THRESH
126* ..
127* .. Array Arguments ..
128 INTEGER NVAL( NN )
129 REAL A( LDA, * ), C1( LDC, * ), C2( LDC, *),
130 + crf( * ), s_work_slange( * )
131* ..
132*
133* =====================================================================
134* ..
135* .. Parameters ..
136 REAL ZERO, ONE
137 parameter( zero = 0.0e+0, one = 1.0e+0 )
138 INTEGER NTESTS
139 parameter( ntests = 1 )
140* ..
141* .. Local Scalars ..
142 CHARACTER UPLO, CFORM, TRANS
143 INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
144 + nfail, nrun, ialpha, itrans
145 REAL ALPHA, BETA, EPS, NORMA, NORMC
146* ..
147* .. Local Arrays ..
148 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
149 INTEGER ISEED( 4 ), ISEEDY( 4 )
150 REAL RESULT( NTESTS )
151* ..
152* .. External Functions ..
153 REAL SLAMCH, SLARND, SLANGE
154 EXTERNAL slamch, slarnd, slange
155* ..
156* .. External Subroutines ..
157 EXTERNAL ssyrk, ssfrk, stfttr, strttf
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC abs, max
161* ..
162* .. Scalars in Common ..
163 CHARACTER*32 SRNAMT
164* ..
165* .. Common blocks ..
166 COMMON / srnamc / srnamt
167* ..
168* .. Data statements ..
169 DATA iseedy / 1988, 1989, 1990, 1991 /
170 DATA uplos / 'U', 'L' /
171 DATA forms / 'N', 'T' /
172 DATA transs / 'N', 'T' /
173* ..
174* .. Executable Statements ..
175*
176* Initialize constants and the random number seed.
177*
178 nrun = 0
179 nfail = 0
180 info = 0
181 DO 10 i = 1, 4
182 iseed( i ) = iseedy( i )
183 10 CONTINUE
184 eps = slamch( 'Precision' )
185*
186 DO 150 iin = 1, nn
187*
188 n = nval( iin )
189*
190 DO 140 iik = 1, nn
191*
192 k = nval( iin )
193*
194 DO 130 iform = 1, 2
195*
196 cform = forms( iform )
197*
198 DO 120 iuplo = 1, 2
199*
200 uplo = uplos( iuplo )
201*
202 DO 110 itrans = 1, 2
203*
204 trans = transs( itrans )
205*
206 DO 100 ialpha = 1, 4
207*
208 IF ( ialpha.EQ. 1) THEN
209 alpha = zero
210 beta = zero
211 ELSE IF ( ialpha.EQ. 2) THEN
212 alpha = one
213 beta = zero
214 ELSE IF ( ialpha.EQ. 3) THEN
215 alpha = zero
216 beta = one
217 ELSE
218 alpha = slarnd( 2, iseed )
219 beta = slarnd( 2, iseed )
220 END IF
221*
222* All the parameters are set:
223* CFORM, UPLO, TRANS, M, N,
224* ALPHA, and BETA
225* READY TO TEST!
226*
227 nrun = nrun + 1
228*
229 IF ( itrans.EQ.1 ) THEN
230*
231* In this case we are NOTRANS, so A is N-by-K
232*
233 DO j = 1, k
234 DO i = 1, n
235 a( i, j) = slarnd( 2, iseed )
236 END DO
237 END DO
238*
239 norma = slange( 'I', n, k, a, lda,
240 + s_work_slange )
241*
242
243 ELSE
244*
245* In this case we are TRANS, so A is K-by-N
246*
247 DO j = 1,n
248 DO i = 1, k
249 a( i, j) = slarnd( 2, iseed )
250 END DO
251 END DO
252*
253 norma = slange( 'I', k, n, a, lda,
254 + s_work_slange )
255*
256 END IF
257*
258* Generate C1 our N--by--N symmetric matrix.
259* Make sure C2 has the same upper/lower part,
260* (the one that we do not touch), so
261* copy the initial C1 in C2 in it.
262*
263 DO j = 1, n
264 DO i = 1, n
265 c1( i, j) = slarnd( 2, iseed )
266 c2(i,j) = c1(i,j)
267 END DO
268 END DO
269*
270* (See comment later on for why we use SLANGE and
271* not SLANSY for C1.)
272*
273 normc = slange( 'I', n, n, c1, ldc,
274 + s_work_slange )
275*
276 srnamt = 'STRTTF'
277 CALL strttf( cform, uplo, n, c1, ldc, crf,
278 + info )
279*
280* call ssyrk the BLAS routine -> gives C1
281*
282 srnamt = 'SSYRK '
283 CALL ssyrk( uplo, trans, n, k, alpha, a, lda,
284 + beta, c1, ldc )
285*
286* call ssfrk the RFP routine -> gives CRF
287*
288 srnamt = 'SSFRK '
289 CALL ssfrk( cform, uplo, trans, n, k, alpha, a,
290 + lda, beta, crf )
291*
292* convert CRF in full format -> gives C2
293*
294 srnamt = 'STFTTR'
295 CALL stfttr( cform, uplo, n, crf, c2, ldc,
296 + info )
297*
298* compare C1 and C2
299*
300 DO j = 1, n
301 DO i = 1, n
302 c1(i,j) = c1(i,j)-c2(i,j)
303 END DO
304 END DO
305*
306* Yes, C1 is symmetric so we could call SLANSY,
307* but we want to check the upper part that is
308* supposed to be unchanged and the diagonal that
309* is supposed to be real -> SLANGE
310*
311 result(1) = slange( 'I', n, n, c1, ldc,
312 + s_work_slange )
313 result(1) = result(1)
314 + / max( abs( alpha ) * norma
315 + + abs( beta ) , one )
316 + / max( n , 1 ) / eps
317*
318 IF( result(1).GE.thresh ) THEN
319 IF( nfail.EQ.0 ) THEN
320 WRITE( nout, * )
321 WRITE( nout, fmt = 9999 )
322 END IF
323 WRITE( nout, fmt = 9997 ) 'SSFRK',
324 + cform, uplo, trans, n, k, result(1)
325 nfail = nfail + 1
326 END IF
327*
328 100 CONTINUE
329 110 CONTINUE
330 120 CONTINUE
331 130 CONTINUE
332 140 CONTINUE
333 150 CONTINUE
334*
335* Print a summary of the results.
336*
337 IF ( nfail.EQ.0 ) THEN
338 WRITE( nout, fmt = 9996 ) 'SSFRK', nrun
339 ELSE
340 WRITE( nout, fmt = 9995 ) 'SSFRK', nfail, nrun
341 END IF
342*
343 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing SSFRK
344 + ***')
345 9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
346 + ' UPLO=''',a1,''',',' TRANS=''',a1,''',', ' N=',i3,', K =', i3,
347 + ', test=',g12.5)
348 9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
349 + 'threshold ( ',i5,' tests run)')
350 9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
351 + ' tests failed to pass the threshold')
352*
353 RETURN
354*
355* End of SDRVRF4
356*
357 END
subroutine ssyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
SSYRK
Definition ssyrk.f:169
subroutine ssfrk(transr, uplo, trans, n, k, alpha, a, lda, beta, c)
SSFRK performs a symmetric rank-k operation for matrix in RFP format.
Definition ssfrk.f:166
subroutine stfttr(transr, uplo, n, arf, a, lda, info)
STFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full f...
Definition stfttr.f:196
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
subroutine sdrvrf4(nout, nn, nval, thresh, c1, c2, ldc, crf, a, lda, s_work_slange)
SDRVRF4
Definition sdrvrf4.f:118