LAPACK 3.11.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches

## ◆ ddrvrf4()

 subroutine ddrvrf4 ( integer NOUT, integer NN, integer, dimension( nn ) NVAL, double precision THRESH, double precision, dimension( ldc, * ) C1, double precision, dimension( ldc, *) C2, integer LDC, double precision, dimension( * ) CRF, double precision, dimension( lda, * ) A, integer LDA, double precision, dimension( * ) D_WORK_DLANGE )

DDRVRF4

Purpose:
``` DDRVRF4 tests the LAPACK RFP routines:
DSFRK```
Parameters
 [in] NOUT ``` NOUT is INTEGER The unit number for output.``` [in] NN ``` NN is INTEGER The number of values of N contained in the vector NVAL.``` [in] NVAL ``` NVAL is INTEGER array, dimension (NN) The values of the matrix dimension N.``` [in] THRESH ``` THRESH is DOUBLE PRECISION The threshold value for the test ratios. A result is included in the output file if RESULT >= THRESH. To have every test ratio printed, use THRESH = 0.``` [out] C1 ``` C1 is DOUBLE PRECISION array, dimension (LDC,NMAX)``` [out] C2 ``` C2 is DOUBLE PRECISION array, dimension (LDC,NMAX)``` [in] LDC ``` LDC is INTEGER The leading dimension of the array A. LDA >= max(1,NMAX).``` [out] CRF ``` CRF is DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2).``` [out] A ``` A is DOUBLE PRECISION array, dimension (LDA,NMAX)``` [in] LDA ``` LDA is INTEGER The leading dimension of the array A. LDA >= max(1,NMAX).``` [out] D_WORK_DLANGE ` D_WORK_DLANGE is DOUBLE PRECISION array, dimension (NMAX)`

Definition at line 116 of file ddrvrf4.f.

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 DOUBLE PRECISION THRESH
126* ..
127* .. Array Arguments ..
128 INTEGER NVAL( NN )
129 DOUBLE PRECISION A( LDA, * ), C1( LDC, * ), C2( LDC, *),
130 + CRF( * ), D_WORK_DLANGE( * )
131* ..
132*
133* =====================================================================
134* ..
135* .. Parameters ..
136 DOUBLE PRECISION ZERO, ONE
137 parameter( zero = 0.0d+0, one = 1.0d+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 DOUBLE PRECISION ALPHA, BETA, EPS, NORMA, NORMC
146* ..
147* .. Local Arrays ..
148 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
149 INTEGER ISEED( 4 ), ISEEDY( 4 )
150 DOUBLE PRECISION RESULT( NTESTS )
151* ..
152* .. External Functions ..
153 DOUBLE PRECISION DLAMCH, DLARND, DLANGE
154 EXTERNAL dlamch, dlarnd, dlange
155* ..
156* .. External Subroutines ..
157 EXTERNAL dsyrk, dsfrk, dtfttr, dtrttf
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 = dlamch( '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 = dlarnd( 2, iseed )
219 beta = dlarnd( 2, iseed )
220 END IF
221*
222* All the parameters are set:
223* CFORM, UPLO, TRANS, M, N,
224* ALPHA, and BETA
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) = dlarnd( 2, iseed )
236 END DO
237 END DO
238*
239 norma = dlange( 'I', n, k, a, lda,
240 + d_work_dlange )
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) = dlarnd( 2, iseed )
250 END DO
251 END DO
252*
253 norma = dlange( 'I', k, n, a, lda,
254 + d_work_dlange )
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) = dlarnd( 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 DLANGE and
271* not DLANSY for C1.)
272*
273 normc = dlange( 'I', n, n, c1, ldc,
274 + d_work_dlange )
275*
276 srnamt = 'DTRTTF'
277 CALL dtrttf( cform, uplo, n, c1, ldc, crf,
278 + info )
279*
280* call dsyrk the BLAS routine -> gives C1
281*
282 srnamt = 'DSYRK '
283 CALL dsyrk( uplo, trans, n, k, alpha, a, lda,
284 + beta, c1, ldc )
285*
286* call dsfrk the RFP routine -> gives CRF
287*
288 srnamt = 'DSFRK '
289 CALL dsfrk( cform, uplo, trans, n, k, alpha, a,
290 + lda, beta, crf )
291*
292* convert CRF in full format -> gives C2
293*
294 srnamt = 'DTFTTR'
295 CALL dtfttr( 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 DLANSY,
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 -> DLANGE
310*
311 result(1) = dlange( 'I', n, n, c1, ldc,
312 + d_work_dlange )
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 ) 'DSFRK',
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 ) 'DSFRK', nrun
339 ELSE
340 WRITE( nout, fmt = 9995 ) 'DSFRK', nfail, nrun
341 END IF
342*
343 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing DSFRK
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 DDRVRF4
356*
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:69
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
Definition: dsyrk.f:169
double precision function dlarnd(IDIST, ISEED)
DLARND
Definition: dlarnd.f:73
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: dlange.f:114
subroutine dtrttf(TRANSR, UPLO, N, A, LDA, ARF, INFO)
DTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
Definition: dtrttf.f:194
subroutine dsfrk(TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C)
DSFRK performs a symmetric rank-k operation for matrix in RFP format.
Definition: dsfrk.f:166
subroutine dtfttr(TRANSR, UPLO, N, ARF, A, LDA, INFO)
DTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full f...
Definition: dtfttr.f:196
Here is the call graph for this function:
Here is the caller graph for this function: