LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
ddrvrf4.f
Go to the documentation of this file.
1 *> \brief \b DDRVRF4
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 DDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
12 * + LDA, D_WORK_DLANGE )
13 *
14 * .. Scalar Arguments ..
15 * INTEGER LDA, LDC, NN, NOUT
16 * DOUBLE PRECISION THRESH
17 * ..
18 * .. Array Arguments ..
19 * INTEGER NVAL( NN )
20 * DOUBLE PRECISION A( LDA, * ), C1( LDC, * ), C2( LDC, *),
21 * + CRF( * ), D_WORK_DLANGE( * )
22 * ..
23 *
24 *
25 *> \par Purpose:
26 * =============
27 *>
28 *> \verbatim
29 *>
30 *> DDRVRF4 tests the LAPACK RFP routines:
31 *> DSFRK
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 DOUBLE PRECISION
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 DOUBLE PRECISION array,
66 *> dimension (LDC,NMAX)
67 *> \endverbatim
68 *>
69 *> \param[out] C2
70 *> \verbatim
71 *> C2 is DOUBLE PRECISION 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 DOUBLE PRECISION array,
85 *> dimension ((NMAX*(NMAX+1))/2).
86 *> \endverbatim
87 *>
88 *> \param[out] A
89 *> \verbatim
90 *> A is DOUBLE PRECISION 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] D_WORK_DLANGE
101 *> \verbatim
102 *> D_WORK_DLANGE is DOUBLE PRECISION 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 *> \date November 2011
114 *
115 *> \ingroup double_lin
116 *
117 * =====================================================================
118  SUBROUTINE ddrvrf4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
119  + lda, d_work_dlange )
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,
347 ' *** Error(s) or Failure(s) while testing DSFRK + ***')
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 *
360  END