LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ cdrvrf4()

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.

Definition at line 112 of file cdrvrf4.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  REAL THRESH
122 * ..
123 * .. Array Arguments ..
124  INTEGER NVAL( NN )
125  REAL S_WORK_CLANGE( * )
126  COMPLEX A( LDA, * ), C1( LDC, * ), C2( LDC, *),
127  + CRF( * )
128 * ..
129 *
130 * =====================================================================
131 * ..
132 * .. Parameters ..
133  REAL ZERO, ONE
134  parameter( zero = 0.0e+0, one = 1.0e+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  REAL ALPHA, BETA, EPS, NORMA, NORMC
143 * ..
144 * .. Local Arrays ..
145  CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
146  INTEGER ISEED( 4 ), ISEEDY( 4 )
147  REAL RESULT( NTESTS )
148 * ..
149 * .. External Functions ..
150  REAL SLAMCH, SLARND, CLANGE
151  COMPLEX CLARND
152  EXTERNAL slamch, slarnd, clange, clarnd
153 * ..
154 * .. External Subroutines ..
155  EXTERNAL cherk, chfrk, ctfttr, ctrttf
156 * ..
157 * .. Intrinsic Functions ..
158  INTRINSIC abs, 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 = slamch( '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 = slarnd( 2, iseed )
217  beta = slarnd( 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) = clarnd( 4, iseed )
234  END DO
235  END DO
236 *
237  norma = clange( 'I', n, k, a, lda,
238  + s_work_clange )
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) = clarnd( 4, iseed )
247  END DO
248  END DO
249 *
250  norma = clange( 'I', k, n, a, lda,
251  + s_work_clange )
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) = clarnd( 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 CLANGE and
269 * not CLANHE for C1.)
270 *
271  normc = clange( 'I', n, n, c1, ldc,
272  + s_work_clange )
273 *
274  srnamt = 'CTRTTF'
275  CALL ctrttf( cform, uplo, n, c1, ldc, crf,
276  + info )
277 *
278 * call zherk the BLAS routine -> gives C1
279 *
280  srnamt = 'CHERK '
281  CALL cherk( uplo, trans, n, k, alpha, a, lda,
282  + beta, c1, ldc )
283 *
284 * call zhfrk the RFP routine -> gives CRF
285 *
286  srnamt = 'CHFRK '
287  CALL chfrk( cform, uplo, trans, n, k, alpha, a,
288  + lda, beta, crf )
289 *
290 * convert CRF in full format -> gives C2
291 *
292  srnamt = 'CTFTTR'
293  CALL ctfttr( 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 CLANHE,
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 -> CLANGE
308 *
309  result(1) = clange( 'I', n, n, c1, ldc,
310  + s_work_clange )
311  result(1) = result(1)
312  + / max( abs( alpha ) * norma * norma
313  + + abs( 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 ) 'CHFRK',
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 ) 'CHFRK', nrun
337  ELSE
338  WRITE( nout, fmt = 9995 ) 'CHFRK', nfail, nrun
339  END IF
340 *
341  9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing CHFRK
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 ( ',i5,' tests run)')
348  9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
349  + ' tests failed to pass the threshold')
350 *
351  RETURN
352 *
353 * End of CDRVRF4
354 *
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CHERK
Definition: cherk.f:173
complex function clarnd(IDIST, ISEED)
CLARND
Definition: clarnd.f:75
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:115
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:216
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:168
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:216
real function slarnd(IDIST, ISEED)
SLARND
Definition: slarnd.f:73
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:68
Here is the call graph for this function:
Here is the caller graph for this function: