LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cdrvrf4 ( integer  NOUT,
integer  NN,
integer, dimension( nn )  NVAL,
real  THRESH,
complex, dimension( ldc, * )  C1,
complex, dimension( ldc, *)  C2,
integer  LDC,
complex, dimension( * )  CRF,
complex, dimension( lda, * )  A,
integer  LDA,
real, dimension( * )  S_WORK_CLANGE 
)

CDRVRF4

Purpose: 
 CDRVRF4 tests the LAPACK RFP routines:
     CHFRK
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 REAL
                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 array, dimension (LDC,NMAX)
[out]C2
          C2 is COMPLEX 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 array, dimension ((NMAX*(NMAX+1))/2).
[out]A
          A is COMPLEX array, dimension (LDA,NMAX)
[in]LDA
          LDA is INTEGER
                The leading dimension of the array A.  LDA >= max(1,NMAX).
[out]S_WORK_CLANGE
          S_WORK_CLANGE is REAL 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 cdrvrf4.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  REAL thresh
125 * ..
126 * .. Array Arguments ..
127  INTEGER nval( nn )
128  REAL s_work_clange( * )
129  COMPLEX a( lda, * ), c1( ldc, * ), c2( ldc, *),
130  + crf( * )
131 * ..
132 *
133 * =====================================================================
134 * ..
135 * .. Parameters ..
136  REAL zero, one
137  parameter ( zero = 0.0e+0, one = 1.0e+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  REAL alpha, beta, eps, norma, normc
146 * ..
147 * .. Local Arrays ..
148  CHARACTER uplos( 2 ), forms( 2 ), transs( 2 )
149  INTEGER iseed( 4 ), iseedy( 4 )
150  REAL result( ntests )
151 * ..
152 * .. External Functions ..
153  REAL slamch, slarnd, clange
154  COMPLEX clarnd
155  EXTERNAL slamch, slarnd, clange, clarnd
156 * ..
157 * .. External Subroutines ..
158  EXTERNAL cherk, chfrk, ctfttr, ctrttf
159 * ..
160 * .. Intrinsic Functions ..
161  INTRINSIC abs, 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 = slamch( '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 = slarnd( 2, iseed )
220  beta = slarnd( 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) = clarnd( 4, iseed )
237  END DO
238  END DO
239 *
240  norma = clange( 'I', n, k, a, lda,
241  + s_work_clange )
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) = clarnd( 4, iseed )
250  END DO
251  END DO
252 *
253  norma = clange( 'I', k, n, a, lda,
254  + s_work_clange )
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) = clarnd( 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 CLANGE and
272 * not CLANHE for C1.)
273 *
274  normc = clange( 'I', n, n, c1, ldc,
275  + s_work_clange )
276 *
277  srnamt = 'CTRTTF'
278  CALL ctrttf( cform, uplo, n, c1, ldc, crf,
279  + info )
280 *
281 * call zherk the BLAS routine -> gives C1
282 *
283  srnamt = 'CHERK '
284  CALL cherk( uplo, trans, n, k, alpha, a, lda,
285  + beta, c1, ldc )
286 *
287 * call zhfrk the RFP routine -> gives CRF
288 *
289  srnamt = 'CHFRK '
290  CALL chfrk( cform, uplo, trans, n, k, alpha, a,
291  + lda, beta, crf )
292 *
293 * convert CRF in full format -> gives C2
294 *
295  srnamt = 'CTFTTR'
296  CALL ctfttr( 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 CLANHE,
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 -> CLANGE
311 *
312  result(1) = clange( 'I', n, n, c1, ldc,
313  + s_work_clange )
314  result(1) = result(1)
315  + / max( abs( alpha ) * norma * norma
316  + + abs( 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 ) 'CHFRK',
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 ) 'CHFRK', nrun
340  ELSE
341  WRITE( nout, fmt = 9995 ) 'CHFRK', nfail, nrun
342  END IF
343 *
344  9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing CHFRK
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 ( ',i5,' tests run)')
351  9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
352  + ' tests failed to pass the threshold')
353 *
354  RETURN
355 *
356 * End of CDRVRF4
357 *
clarnd
complex function clarnd(IDIST, ISEED)
CLARND
Definition: clarnd.f:77
cherk
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CHERK
Definition: cherk.f:175
clange
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: clange.f:117
ctfttr
subroutine ctfttr(TRANSR, UPLO, N, ARF, A, LDA, INFO)
CTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full f...
Definition: ctfttr.f:218
slarnd
real function slarnd(IDIST, ISEED)
SLARND
Definition: slarnd.f:75
chfrk
subroutine chfrk(TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C)
CHFRK performs a Hermitian rank-k operation for matrix in RFP format.
Definition: chfrk.f:170
slamch
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
ctrttf
subroutine ctrttf(TRANSR, UPLO, N, A, LDA, ARF, INFO)
CTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
Definition: ctrttf.f:218

Here is the call graph for this function:

Here is the caller graph for this function: