LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
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
zherk
subroutine zherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
ZHERK
Definition zherk.f:173
zhfrk
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
ztfttr
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
ztrttf
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
zdrvrf4
subroutine zdrvrf4(nout, nn, nval, thresh, c1, c2, ldc, crf, a, lda, d_work_zlange)
ZDRVRF4
Definition zdrvrf4.f:114