LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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.
Date
November 2011

Definition at line 116 of file zdrvrf4.f.

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, ' *** 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 *
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
dlarnd
double precision function dlarnd(IDIST, ISEED)
DLARND
Definition: dlarnd.f:75
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:218
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:117
zherk
subroutine zherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
ZHERK
Definition: zherk.f:175
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:218
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:170
zlarnd
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: