LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
zdrvrf4.f
Go to the documentation of this file.
1 *> \brief \b ZDRVRF4
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 ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
12 * + LDA, D_WORK_ZLANGE )
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 D_WORK_ZLANGE( * )
21 * COMPLEX*16 A( LDA, * ), C1( LDC, * ), C2( LDC, *),
22 * + CRF( * )
23 * ..
24 *
25 *
26 *> \par Purpose:
27 * =============
28 *>
29 *> \verbatim
30 *>
31 *> ZDRVRF4 tests the LAPACK RFP routines:
32 *> ZHFRK
33 *> \endverbatim
34 *
35 * Arguments:
36 * ==========
37 *
38 *> \param[in] NOUT
39 *> \verbatim
40 *> NOUT is INTEGER
41 *> The unit number for output.
42 *> \endverbatim
43 *>
44 *> \param[in] NN
45 *> \verbatim
46 *> NN is INTEGER
47 *> The number of values of N contained in the vector NVAL.
48 *> \endverbatim
49 *>
50 *> \param[in] NVAL
51 *> \verbatim
52 *> NVAL is INTEGER array, dimension (NN)
53 *> The values of the matrix dimension N.
54 *> \endverbatim
55 *>
56 *> \param[in] THRESH
57 *> \verbatim
58 *> THRESH is DOUBLE PRECISION
59 *> The threshold value for the test ratios. A result is
60 *> included in the output file if RESULT >= THRESH. To have
61 *> every test ratio printed, use THRESH = 0.
62 *> \endverbatim
63 *>
64 *> \param[out] C1
65 *> \verbatim
66 *> C1 is COMPLEX*16 array, dimension (LDC,NMAX)
67 *> \endverbatim
68 *>
69 *> \param[out] C2
70 *> \verbatim
71 *> C2 is COMPLEX*16 array, dimension (LDC,NMAX)
72 *> \endverbatim
73 *>
74 *> \param[in] LDC
75 *> \verbatim
76 *> LDC is INTEGER
77 *> The leading dimension of the array A. LDA >= max(1,NMAX).
78 *> \endverbatim
79 *>
80 *> \param[out] CRF
81 *> \verbatim
82 *> CRF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
83 *> \endverbatim
84 *>
85 *> \param[out] A
86 *> \verbatim
87 *> A is COMPLEX*16 array, dimension (LDA,NMAX)
88 *> \endverbatim
89 *>
90 *> \param[in] LDA
91 *> \verbatim
92 *> LDA is INTEGER
93 *> The leading dimension of the array A. LDA >= max(1,NMAX).
94 *> \endverbatim
95 *>
96 *> \param[out] D_WORK_ZLANGE
97 *> \verbatim
98 *> D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX)
99 *> \endverbatim
100 *
101 * Authors:
102 * ========
103 *
104 *> \author Univ. of Tennessee
105 *> \author Univ. of California Berkeley
106 *> \author Univ. of Colorado Denver
107 *> \author NAG Ltd.
108 *
109 *> \date November 2011
110 *
111 *> \ingroup complex16_lin
112 *
113 * =====================================================================
114  SUBROUTINE zdrvrf4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
115  + lda, d_work_zlange )
116 *
117 * -- LAPACK test routine (version 3.4.0) --
118 * -- LAPACK is a software package provided by Univ. of Tennessee, --
119 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
120 * November 2011
121 *
122 * .. Scalar Arguments ..
123  INTEGER lda, ldc, nn, nout
124  DOUBLE PRECISION thresh
125 * ..
126 * .. Array Arguments ..
127  INTEGER nval( nn )
128  DOUBLE PRECISION d_work_zlange( * )
129  COMPLEX*16 a( lda, * ), c1( ldc, * ), c2( ldc, *),
130  + crf( * )
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, zlange
154  COMPLEX*16 zlarnd
155  EXTERNAL dlamch, dlarnd, zlange, zlarnd
156 * ..
157 * .. External Subroutines ..
158  EXTERNAL zherk, zhfrk, ztfttr, ztrttf
159 * ..
160 * .. Intrinsic Functions ..
161  INTRINSIC dabs, max
162 * ..
163 * .. Scalars in Common ..
164  CHARACTER*32 srnamt
165 * ..
166 * .. Common blocks ..
167  common / srnamc / srnamt
168 * ..
169 * .. Data statements ..
170  DATA iseedy / 1988, 1989, 1990, 1991 /
171  DATA uplos / 'U', 'L' /
172  DATA forms / 'N', 'C' /
173  DATA transs / 'N', 'C' /
174 * ..
175 * .. Executable Statements ..
176 *
177 * Initialize constants and the random number seed.
178 *
179  nrun = 0
180  nfail = 0
181  info = 0
182  DO 10 i = 1, 4
183  iseed( i ) = iseedy( i )
184  10 continue
185  eps = dlamch( 'Precision' )
186 *
187  DO 150 iin = 1, nn
188 *
189  n = nval( iin )
190 *
191  DO 140 iik = 1, nn
192 *
193  k = nval( iin )
194 *
195  DO 130 iform = 1, 2
196 *
197  cform = forms( iform )
198 *
199  DO 120 iuplo = 1, 2
200 *
201  uplo = uplos( iuplo )
202 *
203  DO 110 itrans = 1, 2
204 *
205  trans = transs( itrans )
206 *
207  DO 100 ialpha = 1, 4
208 *
209  IF ( ialpha.EQ. 1) THEN
210  alpha = zero
211  beta = zero
212  ELSE IF ( ialpha.EQ. 1) THEN
213  alpha = one
214  beta = zero
215  ELSE IF ( ialpha.EQ. 1) THEN
216  alpha = zero
217  beta = one
218  ELSE
219  alpha = dlarnd( 2, iseed )
220  beta = dlarnd( 2, iseed )
221  END IF
222 *
223 * All the parameters are set:
224 * CFORM, UPLO, TRANS, M, N,
225 * ALPHA, and BETA
226 * READY TO TEST!
227 *
228  nrun = nrun + 1
229 *
230  IF ( itrans.EQ.1 ) THEN
231 *
232 * In this case we are NOTRANS, so A is N-by-K
233 *
234  DO j = 1, k
235  DO i = 1, n
236  a( i, j) = zlarnd( 4, iseed )
237  END DO
238  END DO
239 *
240  norma = zlange( 'I', n, k, a, lda,
241  + d_work_zlange )
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) = zlarnd( 4, iseed )
250  END DO
251  END DO
252 *
253  norma = zlange( 'I', k, n, a, lda,
254  + d_work_zlange )
255 *
256  END IF
257 *
258 *
259 * Generate C1 our N--by--N Hermitian matrix.
260 * Make sure C2 has the same upper/lower part,
261 * (the one that we do not touch), so
262 * copy the initial C1 in C2 in it.
263 *
264  DO j = 1, n
265  DO i = 1, n
266  c1( i, j) = zlarnd( 4, iseed )
267  c2(i,j) = c1(i,j)
268  END DO
269  END DO
270 *
271 * (See comment later on for why we use ZLANGE and
272 * not ZLANHE for C1.)
273 *
274  normc = zlange( 'I', n, n, c1, ldc,
275  + d_work_zlange )
276 *
277  srnamt = 'ZTRTTF'
278  CALL ztrttf( cform, uplo, n, c1, ldc, crf,
279  + info )
280 *
281 * call zherk the BLAS routine -> gives C1
282 *
283  srnamt = 'ZHERK '
284  CALL zherk( uplo, trans, n, k, alpha, a, lda,
285  + beta, c1, ldc )
286 *
287 * call zhfrk the RFP routine -> gives CRF
288 *
289  srnamt = 'ZHFRK '
290  CALL zhfrk( cform, uplo, trans, n, k, alpha, a,
291  + lda, beta, crf )
292 *
293 * convert CRF in full format -> gives C2
294 *
295  srnamt = 'ZTFTTR'
296  CALL ztfttr( cform, uplo, n, crf, c2, ldc,
297  + info )
298 *
299 * compare C1 and C2
300 *
301  DO j = 1, n
302  DO i = 1, n
303  c1(i,j) = c1(i,j)-c2(i,j)
304  END DO
305  END DO
306 *
307 * Yes, C1 is Hermitian so we could call ZLANHE,
308 * but we want to check the upper part that is
309 * supposed to be unchanged and the diagonal that
310 * is supposed to be real -> ZLANGE
311 *
312  result(1) = zlange( 'I', n, n, c1, ldc,
313  + d_work_zlange )
314  result(1) = result(1)
315  + / max( dabs( alpha ) * norma * norma
316  + + dabs( beta ) * normc, one )
317  + / max( n , 1 ) / eps
318 *
319  IF( result(1).GE.thresh ) THEN
320  IF( nfail.EQ.0 ) THEN
321  WRITE( nout, * )
322  WRITE( nout, fmt = 9999 )
323  END IF
324  WRITE( nout, fmt = 9997 ) 'ZHFRK',
325  + cform, uplo, trans, n, k, result(1)
326  nfail = nfail + 1
327  END IF
328 *
329  100 continue
330  110 continue
331  120 continue
332  130 continue
333  140 continue
334  150 continue
335 *
336 * Print a summary of the results.
337 *
338  IF ( nfail.EQ.0 ) THEN
339  WRITE( nout, fmt = 9996 ) 'ZHFRK', nrun
340  ELSE
341  WRITE( nout, fmt = 9995 ) 'ZHFRK', nfail, nrun
342  END IF
343 *
344  9999 format( 1x,
345 ' *** Error(s) or Failure(s) while testing ZHFRK + ***')
346  9997 format( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
347  + ' UPLO=''',a1,''',',' TRANS=''',a1,''',', ' N=',i3,', K =', i3,
348  + ', test=',g12.5)
349  9996 format( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
350  + 'threshold ( ',i6,' tests run)')
351  9995 format( 1x, a6, ' auxiliary routine: ',i6,' out of ',i6,
352  + ' tests failed to pass the threshold')
353 *
354  return
355 *
356 * End of ZDRVRF4
357 *
358  END