LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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.
Date
November 2011

Definition at line 120 of file ddrvrf4.f.

120 *
121 * -- LAPACK test routine (version 3.4.0) --
122 * -- LAPACK is a software package provided by Univ. of Tennessee, --
123 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
124 * November 2011
125 *
126 * .. Scalar Arguments ..
127  INTEGER lda, ldc, nn, nout
128  DOUBLE PRECISION thresh
129 * ..
130 * .. Array Arguments ..
131  INTEGER nval( nn )
132  DOUBLE PRECISION a( lda, * ), c1( ldc, * ), c2( ldc, *),
133  + crf( * ), d_work_dlange( * )
134 * ..
135 *
136 * =====================================================================
137 * ..
138 * .. Parameters ..
139  DOUBLE PRECISION zero, one
140  parameter ( zero = 0.0d+0, one = 1.0d+0 )
141  INTEGER ntests
142  parameter ( ntests = 1 )
143 * ..
144 * .. Local Scalars ..
145  CHARACTER uplo, cform, trans
146  INTEGER i, iform, iik, iin, info, iuplo, j, k, n,
147  + nfail, nrun, ialpha, itrans
148  DOUBLE PRECISION alpha, beta, eps, norma, normc
149 * ..
150 * .. Local Arrays ..
151  CHARACTER uplos( 2 ), forms( 2 ), transs( 2 )
152  INTEGER iseed( 4 ), iseedy( 4 )
153  DOUBLE PRECISION result( ntests )
154 * ..
155 * .. External Functions ..
156  DOUBLE PRECISION dlamch, dlarnd, dlange
157  EXTERNAL dlamch, dlarnd, dlange
158 * ..
159 * .. External Subroutines ..
160  EXTERNAL dsyrk, dsfrk, dtfttr, dtrttf
161 * ..
162 * .. Intrinsic Functions ..
163  INTRINSIC abs, max
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 transs / 'N', 'T' /
176 * ..
177 * .. Executable Statements ..
178 *
179 * Initialize constants and the random number seed.
180 *
181  nrun = 0
182  nfail = 0
183  info = 0
184  DO 10 i = 1, 4
185  iseed( i ) = iseedy( i )
186  10 CONTINUE
187  eps = dlamch( 'Precision' )
188 *
189  DO 150 iin = 1, nn
190 *
191  n = nval( iin )
192 *
193  DO 140 iik = 1, nn
194 *
195  k = nval( iin )
196 *
197  DO 130 iform = 1, 2
198 *
199  cform = forms( iform )
200 *
201  DO 120 iuplo = 1, 2
202 *
203  uplo = uplos( iuplo )
204 *
205  DO 110 itrans = 1, 2
206 *
207  trans = transs( itrans )
208 *
209  DO 100 ialpha = 1, 4
210 *
211  IF ( ialpha.EQ. 1) THEN
212  alpha = zero
213  beta = zero
214  ELSE IF ( ialpha.EQ. 2) THEN
215  alpha = one
216  beta = zero
217  ELSE IF ( ialpha.EQ. 3) THEN
218  alpha = zero
219  beta = one
220  ELSE
221  alpha = dlarnd( 2, iseed )
222  beta = dlarnd( 2, iseed )
223  END IF
224 *
225 * All the parameters are set:
226 * CFORM, UPLO, TRANS, M, N,
227 * ALPHA, and BETA
228 * READY TO TEST!
229 *
230  nrun = nrun + 1
231 *
232  IF ( itrans.EQ.1 ) THEN
233 *
234 * In this case we are NOTRANS, so A is N-by-K
235 *
236  DO j = 1, k
237  DO i = 1, n
238  a( i, j) = dlarnd( 2, iseed )
239  END DO
240  END DO
241 *
242  norma = dlange( 'I', n, k, a, lda,
243  + d_work_dlange )
244 *
245 
246  ELSE
247 *
248 * In this case we are TRANS, so A is K-by-N
249 *
250  DO j = 1,n
251  DO i = 1, k
252  a( i, j) = dlarnd( 2, iseed )
253  END DO
254  END DO
255 *
256  norma = dlange( 'I', k, n, a, lda,
257  + d_work_dlange )
258 *
259  END IF
260 *
261 * Generate C1 our N--by--N symmetric matrix.
262 * Make sure C2 has the same upper/lower part,
263 * (the one that we do not touch), so
264 * copy the initial C1 in C2 in it.
265 *
266  DO j = 1, n
267  DO i = 1, n
268  c1( i, j) = dlarnd( 2, iseed )
269  c2(i,j) = c1(i,j)
270  END DO
271  END DO
272 *
273 * (See comment later on for why we use DLANGE and
274 * not DLANSY for C1.)
275 *
276  normc = dlange( 'I', n, n, c1, ldc,
277  + d_work_dlange )
278 *
279  srnamt = 'DTRTTF'
280  CALL dtrttf( cform, uplo, n, c1, ldc, crf,
281  + info )
282 *
283 * call dsyrk the BLAS routine -> gives C1
284 *
285  srnamt = 'DSYRK '
286  CALL dsyrk( uplo, trans, n, k, alpha, a, lda,
287  + beta, c1, ldc )
288 *
289 * call dsfrk the RFP routine -> gives CRF
290 *
291  srnamt = 'DSFRK '
292  CALL dsfrk( cform, uplo, trans, n, k, alpha, a,
293  + lda, beta, crf )
294 *
295 * convert CRF in full format -> gives C2
296 *
297  srnamt = 'DTFTTR'
298  CALL dtfttr( cform, uplo, n, crf, c2, ldc,
299  + info )
300 *
301 * compare C1 and C2
302 *
303  DO j = 1, n
304  DO i = 1, n
305  c1(i,j) = c1(i,j)-c2(i,j)
306  END DO
307  END DO
308 *
309 * Yes, C1 is symmetric so we could call DLANSY,
310 * but we want to check the upper part that is
311 * supposed to be unchanged and the diagonal that
312 * is supposed to be real -> DLANGE
313 *
314  result(1) = dlange( 'I', n, n, c1, ldc,
315  + d_work_dlange )
316  result(1) = result(1)
317  + / max( abs( alpha ) * norma
318  + + abs( beta ) , one )
319  + / max( n , 1 ) / eps
320 *
321  IF( result(1).GE.thresh ) THEN
322  IF( nfail.EQ.0 ) THEN
323  WRITE( nout, * )
324  WRITE( nout, fmt = 9999 )
325  END IF
326  WRITE( nout, fmt = 9997 ) 'DSFRK',
327  + cform, uplo, trans, n, k, result(1)
328  nfail = nfail + 1
329  END IF
330 *
331  100 CONTINUE
332  110 CONTINUE
333  120 CONTINUE
334  130 CONTINUE
335  140 CONTINUE
336  150 CONTINUE
337 *
338 * Print a summary of the results.
339 *
340  IF ( nfail.EQ.0 ) THEN
341  WRITE( nout, fmt = 9996 ) 'DSFRK', nrun
342  ELSE
343  WRITE( nout, fmt = 9995 ) 'DSFRK', nfail, nrun
344  END IF
345 *
346  9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing DSFRK
347  + ***')
348  9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
349  + ' UPLO=''',a1,''',',' TRANS=''',a1,''',', ' N=',i3,', K =', i3,
350  + ', test=',g12.5)
351  9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
352  + 'threshold ( ',i5,' tests run)')
353  9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
354  + ' tests failed to pass the threshold')
355 *
356  RETURN
357 *
358 * End of DDRVRF4
359 *
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:198
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
dsyrk
subroutine dsyrk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
DSYRK
Definition: dsyrk.f:171
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:116
dlarnd
double precision function dlarnd(IDIST, ISEED)
DLARND
Definition: dlarnd.f:75
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:196
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:168

Here is the call graph for this function:

Here is the caller graph for this function: