LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
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)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

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
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) = 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*
dlarnd
double precision function dlarnd(idist, iseed)
DLARND
Definition dlarnd.f:73
dsyrk
subroutine dsyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
DSYRK
Definition dsyrk.f:169
dsfrk
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
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
dlange
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
dtfttr
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
dtrttf
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
Here is the call graph for this function:
Here is the caller graph for this function: