LAPACK  3.8.0 LAPACK: Linear Algebra PACKage

## ◆ 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)`
Date
June 2017

Definition at line 116 of file zdrvrf4.f.

116 *
117 * -- LAPACK test routine (version 3.7.1) --
118 * -- LAPACK is a software package provided by Univ. of Tennessee, --
119 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
120 * June 2017
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. 2) THEN
213  alpha = one
214  beta = zero
215  ELSE IF ( ialpha.EQ. 3) 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
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, ' *** Error(s) or Failure(s) while testing ZHFRK
345  + ***')
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 *
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
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:170
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:218
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:218
double precision function dlarnd(IDIST, ISEED)
DLARND
Definition: dlarnd.f:75
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:117
subroutine zherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
ZHERK
Definition: zherk.f:175
complex *16 function zlarnd(IDIST, ISEED)
ZLARND
Definition: zlarnd.f:77
Here is the call graph for this function:
Here is the caller graph for this function: