LAPACK  3.10.1
LAPACK: Linear Algebra PACKage
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 *> \ingroup complex16_lin
110 *
111 * =====================================================================
112  SUBROUTINE zdrvrf4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
113  + LDA, D_WORK_ZLANGE )
114 *
115 * -- LAPACK test routine --
116 * -- LAPACK is a software package provided by Univ. of Tennessee, --
117 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
118 *
119 * .. Scalar Arguments ..
120  INTEGER LDA, LDC, NN, NOUT
121  DOUBLE PRECISION THRESH
122 * ..
123 * .. Array Arguments ..
124  INTEGER NVAL( NN )
125  DOUBLE PRECISION D_WORK_ZLANGE( * )
126  COMPLEX*16 A( LDA, * ), C1( LDC, * ), C2( LDC, *),
127  + crf( * )
128 * ..
129 *
130 * =====================================================================
131 * ..
132 * .. Parameters ..
133  DOUBLE PRECISION ZERO, ONE
134  parameter( zero = 0.0d+0, one = 1.0d+0 )
135  INTEGER NTESTS
136  parameter( ntests = 1 )
137 * ..
138 * .. Local Scalars ..
139  CHARACTER UPLO, CFORM, TRANS
140  INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
141  + nfail, nrun, ialpha, itrans
142  DOUBLE PRECISION ALPHA, BETA, EPS, NORMA, NORMC
143 * ..
144 * .. Local Arrays ..
145  CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
146  INTEGER ISEED( 4 ), ISEEDY( 4 )
147  DOUBLE PRECISION RESULT( NTESTS )
148 * ..
149 * .. External Functions ..
150  DOUBLE PRECISION DLAMCH, DLARND, ZLANGE
151  COMPLEX*16 ZLARND
152  EXTERNAL dlamch, dlarnd, zlange, zlarnd
153 * ..
154 * .. External Subroutines ..
155  EXTERNAL zherk, zhfrk, ztfttr, ztrttf
156 * ..
157 * .. Intrinsic Functions ..
158  INTRINSIC dabs, max
159 * ..
160 * .. Scalars in Common ..
161  CHARACTER*32 SRNAMT
162 * ..
163 * .. Common blocks ..
164  COMMON / srnamc / srnamt
165 * ..
166 * .. Data statements ..
167  DATA iseedy / 1988, 1989, 1990, 1991 /
168  DATA uplos / 'U', 'L' /
169  DATA forms / 'N', 'C' /
170  DATA transs / 'N', 'C' /
171 * ..
172 * .. Executable Statements ..
173 *
174 * Initialize constants and the random number seed.
175 *
176  nrun = 0
177  nfail = 0
178  info = 0
179  DO 10 i = 1, 4
180  iseed( i ) = iseedy( i )
181  10 CONTINUE
182  eps = dlamch( 'Precision' )
183 *
184  DO 150 iin = 1, nn
185 *
186  n = nval( iin )
187 *
188  DO 140 iik = 1, nn
189 *
190  k = nval( iin )
191 *
192  DO 130 iform = 1, 2
193 *
194  cform = forms( iform )
195 *
196  DO 120 iuplo = 1, 2
197 *
198  uplo = uplos( iuplo )
199 *
200  DO 110 itrans = 1, 2
201 *
202  trans = transs( itrans )
203 *
204  DO 100 ialpha = 1, 4
205 *
206  IF ( ialpha.EQ. 1) THEN
207  alpha = zero
208  beta = zero
209  ELSE IF ( ialpha.EQ. 2) THEN
210  alpha = one
211  beta = zero
212  ELSE IF ( ialpha.EQ. 3) THEN
213  alpha = zero
214  beta = one
215  ELSE
216  alpha = dlarnd( 2, iseed )
217  beta = dlarnd( 2, iseed )
218  END IF
219 *
220 * All the parameters are set:
221 * CFORM, UPLO, TRANS, M, N,
222 * ALPHA, and BETA
223 * READY TO TEST!
224 *
225  nrun = nrun + 1
226 *
227  IF ( itrans.EQ.1 ) THEN
228 *
229 * In this case we are NOTRANS, so A is N-by-K
230 *
231  DO j = 1, k
232  DO i = 1, n
233  a( i, j) = zlarnd( 4, iseed )
234  END DO
235  END DO
236 *
237  norma = zlange( 'I', n, k, a, lda,
238  + d_work_zlange )
239 *
240  ELSE
241 *
242 * In this case we are TRANS, so A is K-by-N
243 *
244  DO j = 1,n
245  DO i = 1, k
246  a( i, j) = zlarnd( 4, iseed )
247  END DO
248  END DO
249 *
250  norma = zlange( 'I', k, n, a, lda,
251  + d_work_zlange )
252 *
253  END IF
254 *
255 *
256 * Generate C1 our N--by--N Hermitian matrix.
257 * Make sure C2 has the same upper/lower part,
258 * (the one that we do not touch), so
259 * copy the initial C1 in C2 in it.
260 *
261  DO j = 1, n
262  DO i = 1, n
263  c1( i, j) = zlarnd( 4, iseed )
264  c2(i,j) = c1(i,j)
265  END DO
266  END DO
267 *
268 * (See comment later on for why we use ZLANGE and
269 * not ZLANHE for C1.)
270 *
271  normc = zlange( 'I', n, n, c1, ldc,
272  + d_work_zlange )
273 *
274  srnamt = 'ZTRTTF'
275  CALL ztrttf( cform, uplo, n, c1, ldc, crf,
276  + info )
277 *
278 * call zherk the BLAS routine -> gives C1
279 *
280  srnamt = 'ZHERK '
281  CALL zherk( uplo, trans, n, k, alpha, a, lda,
282  + beta, c1, ldc )
283 *
284 * call zhfrk the RFP routine -> gives CRF
285 *
286  srnamt = 'ZHFRK '
287  CALL zhfrk( cform, uplo, trans, n, k, alpha, a,
288  + lda, beta, crf )
289 *
290 * convert CRF in full format -> gives C2
291 *
292  srnamt = 'ZTFTTR'
293  CALL ztfttr( cform, uplo, n, crf, c2, ldc,
294  + info )
295 *
296 * compare C1 and C2
297 *
298  DO j = 1, n
299  DO i = 1, n
300  c1(i,j) = c1(i,j)-c2(i,j)
301  END DO
302  END DO
303 *
304 * Yes, C1 is Hermitian so we could call ZLANHE,
305 * but we want to check the upper part that is
306 * supposed to be unchanged and the diagonal that
307 * is supposed to be real -> ZLANGE
308 *
309  result(1) = zlange( 'I', n, n, c1, ldc,
310  + d_work_zlange )
311  result(1) = result(1)
312  + / max( dabs( alpha ) * norma * norma
313  + + dabs( beta ) * normc, one )
314  + / max( n , 1 ) / eps
315 *
316  IF( result(1).GE.thresh ) THEN
317  IF( nfail.EQ.0 ) THEN
318  WRITE( nout, * )
319  WRITE( nout, fmt = 9999 )
320  END IF
321  WRITE( nout, fmt = 9997 ) 'ZHFRK',
322  + cform, uplo, trans, n, k, result(1)
323  nfail = nfail + 1
324  END IF
325 *
326  100 CONTINUE
327  110 CONTINUE
328  120 CONTINUE
329  130 CONTINUE
330  140 CONTINUE
331  150 CONTINUE
332 *
333 * Print a summary of the results.
334 *
335  IF ( nfail.EQ.0 ) THEN
336  WRITE( nout, fmt = 9996 ) 'ZHFRK', nrun
337  ELSE
338  WRITE( nout, fmt = 9995 ) 'ZHFRK', nfail, nrun
339  END IF
340 *
341  9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing ZHFRK
342  + ***')
343  9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
344  + ' UPLO=''',a1,''',',' TRANS=''',a1,''',', ' N=',i3,', K =', i3,
345  + ', test=',g12.5)
346  9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
347  + 'threshold ( ',i6,' tests run)')
348  9995 FORMAT( 1x, a6, ' auxiliary routine: ',i6,' out of ',i6,
349  + ' tests failed to pass the threshold')
350 *
351  RETURN
352 *
353 * End of ZDRVRF4
354 *
355  END
subroutine zherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
ZHERK
Definition: zherk.f:173
subroutine zdrvrf4(NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, LDA, D_WORK_ZLANGE)
ZDRVRF4
Definition: zdrvrf4.f:114
subroutine zhfrk(TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C)
ZHFRK performs a Hermitian rank-k operation for matrix in RFP format.
Definition: zhfrk.f:168
subroutine ztrttf(TRANSR, UPLO, N, A, LDA, ARF, INFO)
ZTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
Definition: ztrttf.f:216
subroutine ztfttr(TRANSR, UPLO, N, ARF, A, LDA, INFO)
ZTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full f...
Definition: ztfttr.f:216