LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ zdrvrf4()

subroutine zdrvrf4 ( integer  nout,
integer  nn,
integer, dimension( nn )  nval,
double precision  thresh,
complex*16, dimension( ldc, * )  c1,
complex*16, dimension( ldc, *)  c2,
integer  ldc,
complex*16, dimension( * )  crf,
complex*16, dimension( lda, * )  a,
integer  lda,
double precision, dimension( * )  d_work_zlange 
)

ZDRVRF4

Purpose:
 ZDRVRF4 tests the LAPACK RFP routines:
     ZHFRK
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 COMPLEX*16 array, dimension (LDC,NMAX)
[out]C2
          C2 is COMPLEX*16 array, dimension (LDC,NMAX)
[in]LDC
          LDC is INTEGER
                The leading dimension of the array A.  LDA >= max(1,NMAX).
[out]CRF
          CRF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
[out]A
          A is COMPLEX*16 array, dimension (LDA,NMAX)
[in]LDA
          LDA is INTEGER
                The leading dimension of the array A.  LDA >= max(1,NMAX).
[out]D_WORK_ZLANGE
          D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 112 of file zdrvrf4.f.

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*
dlarnd
double precision function dlarnd(idist, iseed)
DLARND
Definition dlarnd.f:73
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
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
zlange
double precision function zlange(norm, m, n, a, lda, work)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlange.f:115
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
zlarnd
complex *16 function zlarnd(idist, iseed)
ZLARND
Definition zlarnd.f:75
Here is the call graph for this function:
Here is the caller graph for this function: