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

◆ 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: