LAPACK  3.10.1
LAPACK: Linear Algebra PACKage
cdrvrf4.f
Go to the documentation of this file.
1 *> \brief \b CDRVRF4
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE CDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
12 * + LDA, S_WORK_CLANGE )
13 *
14 * .. Scalar Arguments ..
15 * INTEGER LDA, LDC, NN, NOUT
16 * REAL THRESH
17 * ..
18 * .. Array Arguments ..
19 * INTEGER NVAL( NN )
20 * REAL S_WORK_CLANGE( * )
21 * COMPLEX A( LDA, * ), C1( LDC, * ), C2( LDC, *),
22 * + CRF( * )
23 * ..
24 *
25 *
26 *> \par Purpose:
27 * =============
28 *>
29 *> \verbatim
30 *>
31 *> CDRVRF4 tests the LAPACK RFP routines:
32 *> CHFRK
33 *> \endverbatim
34 *
35 * Arguments:
36 * ==========
37 *
38 *> \param[in] NOUT
39 *> \verbatim
40 *> NOUT is INTEGER
41 *> The unit number for output.
42 *> \endverbatim
43 *>
44 *> \param[in] NN
45 *> \verbatim
46 *> NN is INTEGER
47 *> The number of values of N contained in the vector NVAL.
48 *> \endverbatim
49 *>
50 *> \param[in] NVAL
51 *> \verbatim
52 *> NVAL is INTEGER array, dimension (NN)
53 *> The values of the matrix dimension N.
54 *> \endverbatim
55 *>
56 *> \param[in] THRESH
57 *> \verbatim
58 *> THRESH is REAL
59 *> The threshold value for the test ratios. A result is
60 *> included in the output file if RESULT >= THRESH. To have
61 *> every test ratio printed, use THRESH = 0.
62 *> \endverbatim
63 *>
64 *> \param[out] C1
65 *> \verbatim
66 *> C1 is COMPLEX array, dimension (LDC,NMAX)
67 *> \endverbatim
68 *>
69 *> \param[out] C2
70 *> \verbatim
71 *> C2 is COMPLEX array, dimension (LDC,NMAX)
72 *> \endverbatim
73 *>
74 *> \param[in] LDC
75 *> \verbatim
76 *> LDC is INTEGER
77 *> The leading dimension of the array A. LDA >= max(1,NMAX).
78 *> \endverbatim
79 *>
80 *> \param[out] CRF
81 *> \verbatim
82 *> CRF is COMPLEX array, dimension ((NMAX*(NMAX+1))/2).
83 *> \endverbatim
84 *>
85 *> \param[out] A
86 *> \verbatim
87 *> A is COMPLEX array, dimension (LDA,NMAX)
88 *> \endverbatim
89 *>
90 *> \param[in] LDA
91 *> \verbatim
92 *> LDA is INTEGER
93 *> The leading dimension of the array A. LDA >= max(1,NMAX).
94 *> \endverbatim
95 *>
96 *> \param[out] S_WORK_CLANGE
97 *> \verbatim
98 *> S_WORK_CLANGE is REAL array, dimension (NMAX)
99 *> \endverbatim
100 *
101 * Authors:
102 * ========
103 *
104 *> \author Univ. of Tennessee
105 *> \author Univ. of California Berkeley
106 *> \author Univ. of Colorado Denver
107 *> \author NAG Ltd.
108 *
109 *> \ingroup complex_lin
110 *
111 * =====================================================================
112  SUBROUTINE cdrvrf4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
113  + LDA, S_WORK_CLANGE )
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 *
355  END
subroutine cherk(UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC)
CHERK
Definition: cherk.f:173
subroutine cdrvrf4(NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, LDA, S_WORK_CLANGE)
CDRVRF4
Definition: cdrvrf4.f:114
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