1 SUBROUTINE CDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
2 + LDA, S_WORK_CLANGE )
3 *
4 * -- LAPACK test routine (version 3.2.0) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * November 2008
7 *
8 * .. Scalar Arguments ..
9 INTEGER LDA, LDC, NN, NOUT
10 REAL THRESH
11 * ..
12 * .. Array Arguments ..
13 INTEGER NVAL( NN )
14 REAL S_WORK_CLANGE( * )
15 COMPLEX A( LDA, * ), C1( LDC, * ), C2( LDC, *),
16 + CRF( * )
17 * ..
18 *
19 * Purpose
20 * =======
21 *
22 * CDRVRF4 tests the LAPACK RFP routines:
23 * CHFRK
24 *
25 * Arguments
26 * =========
27 *
28 * NOUT (input) INTEGER
29 * The unit number for output.
30 *
31 * NN (input) INTEGER
32 * The number of values of N contained in the vector NVAL.
33 *
34 * NVAL (input) INTEGER array, dimension (NN)
35 * The values of the matrix dimension N.
36 *
37 * THRESH (input) REAL
38 * The threshold value for the test ratios. A result is
39 * included in the output file if RESULT >= THRESH. To have
40 * every test ratio printed, use THRESH = 0.
41 *
42 * C1 (workspace) COMPLEX array, dimension (LDC,NMAX)
43 *
44 * C2 (workspace) COMPLEX array, dimension (LDC,NMAX)
45 *
46 * LDC (input) INTEGER
47 * The leading dimension of the array A. LDA >= max(1,NMAX).
48 *
49 * CRF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2).
50 *
51 * A (workspace) COMPLEX array, dimension (LDA,NMAX)
52 *
53 * LDA (input) INTEGER
54 * The leading dimension of the array A. LDA >= max(1,NMAX).
55 *
56 * S_WORK_CLANGE (workspace) REAL array, dimension (NMAX)
57 *
58 * =====================================================================
59 * ..
60 * .. Parameters ..
61 REAL ZERO, ONE
62 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
63 INTEGER NTESTS
64 PARAMETER ( NTESTS = 1 )
65 * ..
66 * .. Local Scalars ..
67 CHARACTER UPLO, CFORM, TRANS
68 INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
69 + NFAIL, NRUN, IALPHA, ITRANS
70 REAL ALPHA, BETA, EPS, NORMA, NORMC
71 * ..
72 * .. Local Arrays ..
73 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
74 INTEGER ISEED( 4 ), ISEEDY( 4 )
75 REAL RESULT( NTESTS )
76 * ..
77 * .. External Functions ..
78 REAL SLAMCH, SLARND, CLANGE
79 COMPLEX CLARND
80 EXTERNAL SLAMCH, SLARND, CLANGE, CLARND
81 * ..
82 * .. External Subroutines ..
83 EXTERNAL CHERK, CHFRK, CTFTTR, CTRTTF
84 * ..
85 * .. Intrinsic Functions ..
86 INTRINSIC ABS, MAX
87 * ..
88 * .. Scalars in Common ..
89 CHARACTER*32 SRNAMT
90 * ..
91 * .. Common blocks ..
92 COMMON / SRNAMC / SRNAMT
93 * ..
94 * .. Data statements ..
95 DATA ISEEDY / 1988, 1989, 1990, 1991 /
96 DATA UPLOS / 'U', 'L' /
97 DATA FORMS / 'N', 'C' /
98 DATA TRANSS / 'N', 'C' /
99 * ..
100 * .. Executable Statements ..
101 *
102 * Initialize constants and the random number seed.
103 *
104 NRUN = 0
105 NFAIL = 0
106 INFO = 0
107 DO 10 I = 1, 4
108 ISEED( I ) = ISEEDY( I )
109 10 CONTINUE
110 EPS = SLAMCH( 'Precision' )
111 *
112 DO 150 IIN = 1, NN
113 *
114 N = NVAL( IIN )
115 *
116 DO 140 IIK = 1, NN
117 *
118 K = NVAL( IIN )
119 *
120 DO 130 IFORM = 1, 2
121 *
122 CFORM = FORMS( IFORM )
123 *
124 DO 120 IUPLO = 1, 2
125 *
126 UPLO = UPLOS( IUPLO )
127 *
128 DO 110 ITRANS = 1, 2
129 *
130 TRANS = TRANSS( ITRANS )
131 *
132 DO 100 IALPHA = 1, 4
133 *
134 IF ( IALPHA.EQ. 1) THEN
135 ALPHA = ZERO
136 BETA = ZERO
137 ELSE IF ( IALPHA.EQ. 1) THEN
138 ALPHA = ONE
139 BETA = ZERO
140 ELSE IF ( IALPHA.EQ. 1) THEN
141 ALPHA = ZERO
142 BETA = ONE
143 ELSE
144 ALPHA = SLARND( 2, ISEED )
145 BETA = SLARND( 2, ISEED )
146 END IF
147 *
148 * All the parameters are set:
149 * CFORM, UPLO, TRANS, M, N,
150 * ALPHA, and BETA
151 * READY TO TEST!
152 *
153 NRUN = NRUN + 1
154 *
155 IF ( ITRANS.EQ.1 ) THEN
156 *
157 * In this case we are NOTRANS, so A is N-by-K
158 *
159 DO J = 1, K
160 DO I = 1, N
161 A( I, J) = CLARND( 4, ISEED )
162 END DO
163 END DO
164 *
165 NORMA = CLANGE( 'I', N, K, A, LDA,
166 + S_WORK_CLANGE )
167 *
168 ELSE
169 *
170 * In this case we are TRANS, so A is K-by-N
171 *
172 DO J = 1,N
173 DO I = 1, K
174 A( I, J) = CLARND( 4, ISEED )
175 END DO
176 END DO
177 *
178 NORMA = CLANGE( 'I', K, N, A, LDA,
179 + S_WORK_CLANGE )
180 *
181 END IF
182 *
183 *
184 * Generate C1 our N--by--N Hermitian matrix.
185 * Make sure C2 has the same upper/lower part,
186 * (the one that we do not touch), so
187 * copy the initial C1 in C2 in it.
188 *
189 DO J = 1, N
190 DO I = 1, N
191 C1( I, J) = CLARND( 4, ISEED )
192 C2(I,J) = C1(I,J)
193 END DO
194 END DO
195 *
196 * (See comment later on for why we use CLANGE and
197 * not CLANHE for C1.)
198 *
199 NORMC = CLANGE( 'I', N, N, C1, LDC,
200 + S_WORK_CLANGE )
201 *
202 SRNAMT = 'CTRTTF'
203 CALL CTRTTF( CFORM, UPLO, N, C1, LDC, CRF,
204 + INFO )
205 *
206 * call zherk the BLAS routine -> gives C1
207 *
208 SRNAMT = 'CHERK '
209 CALL CHERK( UPLO, TRANS, N, K, ALPHA, A, LDA,
210 + BETA, C1, LDC )
211 *
212 * call zhfrk the RFP routine -> gives CRF
213 *
214 SRNAMT = 'CHFRK '
215 CALL CHFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A,
216 + LDA, BETA, CRF )
217 *
218 * convert CRF in full format -> gives C2
219 *
220 SRNAMT = 'CTFTTR'
221 CALL CTFTTR( CFORM, UPLO, N, CRF, C2, LDC,
222 + INFO )
223 *
224 * compare C1 and C2
225 *
226 DO J = 1, N
227 DO I = 1, N
228 C1(I,J) = C1(I,J)-C2(I,J)
229 END DO
230 END DO
231 *
232 * Yes, C1 is Hermitian so we could call CLANHE,
233 * but we want to check the upper part that is
234 * supposed to be unchanged and the diagonal that
235 * is supposed to be real -> CLANGE
236 *
237 RESULT(1) = CLANGE( 'I', N, N, C1, LDC,
238 + S_WORK_CLANGE )
239 RESULT(1) = RESULT(1)
240 + / MAX( ABS( ALPHA ) * NORMA * NORMA
241 + + ABS( BETA ) * NORMC, ONE )
242 + / MAX( N , 1 ) / EPS
243 *
244 IF( RESULT(1).GE.THRESH ) THEN
245 IF( NFAIL.EQ.0 ) THEN
246 WRITE( NOUT, * )
247 WRITE( NOUT, FMT = 9999 )
248 END IF
249 WRITE( NOUT, FMT = 9997 ) 'CHFRK',
250 + CFORM, UPLO, TRANS, N, K, RESULT(1)
251 NFAIL = NFAIL + 1
252 END IF
253 *
254 100 CONTINUE
255 110 CONTINUE
256 120 CONTINUE
257 130 CONTINUE
258 140 CONTINUE
259 150 CONTINUE
260 *
261 * Print a summary of the results.
262 *
263 IF ( NFAIL.EQ.0 ) THEN
264 WRITE( NOUT, FMT = 9996 ) 'CHFRK', NRUN
265 ELSE
266 WRITE( NOUT, FMT = 9995 ) 'CHFRK', NFAIL, NRUN
267 END IF
268 *
269 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CHFRK
270 + ***')
271 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',',
272 + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3,
273 + ', test=',G12.5)
274 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ',
275 + 'threshold (',I5,' tests run)')
276 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5,
277 + ' tests failed to pass the threshold')
278 *
279 RETURN
280 *
281 * End of CDRVRF4
282 *
283 END
2 + LDA, S_WORK_CLANGE )
3 *
4 * -- LAPACK test routine (version 3.2.0) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * November 2008
7 *
8 * .. Scalar Arguments ..
9 INTEGER LDA, LDC, NN, NOUT
10 REAL THRESH
11 * ..
12 * .. Array Arguments ..
13 INTEGER NVAL( NN )
14 REAL S_WORK_CLANGE( * )
15 COMPLEX A( LDA, * ), C1( LDC, * ), C2( LDC, *),
16 + CRF( * )
17 * ..
18 *
19 * Purpose
20 * =======
21 *
22 * CDRVRF4 tests the LAPACK RFP routines:
23 * CHFRK
24 *
25 * Arguments
26 * =========
27 *
28 * NOUT (input) INTEGER
29 * The unit number for output.
30 *
31 * NN (input) INTEGER
32 * The number of values of N contained in the vector NVAL.
33 *
34 * NVAL (input) INTEGER array, dimension (NN)
35 * The values of the matrix dimension N.
36 *
37 * THRESH (input) REAL
38 * The threshold value for the test ratios. A result is
39 * included in the output file if RESULT >= THRESH. To have
40 * every test ratio printed, use THRESH = 0.
41 *
42 * C1 (workspace) COMPLEX array, dimension (LDC,NMAX)
43 *
44 * C2 (workspace) COMPLEX array, dimension (LDC,NMAX)
45 *
46 * LDC (input) INTEGER
47 * The leading dimension of the array A. LDA >= max(1,NMAX).
48 *
49 * CRF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2).
50 *
51 * A (workspace) COMPLEX array, dimension (LDA,NMAX)
52 *
53 * LDA (input) INTEGER
54 * The leading dimension of the array A. LDA >= max(1,NMAX).
55 *
56 * S_WORK_CLANGE (workspace) REAL array, dimension (NMAX)
57 *
58 * =====================================================================
59 * ..
60 * .. Parameters ..
61 REAL ZERO, ONE
62 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
63 INTEGER NTESTS
64 PARAMETER ( NTESTS = 1 )
65 * ..
66 * .. Local Scalars ..
67 CHARACTER UPLO, CFORM, TRANS
68 INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
69 + NFAIL, NRUN, IALPHA, ITRANS
70 REAL ALPHA, BETA, EPS, NORMA, NORMC
71 * ..
72 * .. Local Arrays ..
73 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
74 INTEGER ISEED( 4 ), ISEEDY( 4 )
75 REAL RESULT( NTESTS )
76 * ..
77 * .. External Functions ..
78 REAL SLAMCH, SLARND, CLANGE
79 COMPLEX CLARND
80 EXTERNAL SLAMCH, SLARND, CLANGE, CLARND
81 * ..
82 * .. External Subroutines ..
83 EXTERNAL CHERK, CHFRK, CTFTTR, CTRTTF
84 * ..
85 * .. Intrinsic Functions ..
86 INTRINSIC ABS, MAX
87 * ..
88 * .. Scalars in Common ..
89 CHARACTER*32 SRNAMT
90 * ..
91 * .. Common blocks ..
92 COMMON / SRNAMC / SRNAMT
93 * ..
94 * .. Data statements ..
95 DATA ISEEDY / 1988, 1989, 1990, 1991 /
96 DATA UPLOS / 'U', 'L' /
97 DATA FORMS / 'N', 'C' /
98 DATA TRANSS / 'N', 'C' /
99 * ..
100 * .. Executable Statements ..
101 *
102 * Initialize constants and the random number seed.
103 *
104 NRUN = 0
105 NFAIL = 0
106 INFO = 0
107 DO 10 I = 1, 4
108 ISEED( I ) = ISEEDY( I )
109 10 CONTINUE
110 EPS = SLAMCH( 'Precision' )
111 *
112 DO 150 IIN = 1, NN
113 *
114 N = NVAL( IIN )
115 *
116 DO 140 IIK = 1, NN
117 *
118 K = NVAL( IIN )
119 *
120 DO 130 IFORM = 1, 2
121 *
122 CFORM = FORMS( IFORM )
123 *
124 DO 120 IUPLO = 1, 2
125 *
126 UPLO = UPLOS( IUPLO )
127 *
128 DO 110 ITRANS = 1, 2
129 *
130 TRANS = TRANSS( ITRANS )
131 *
132 DO 100 IALPHA = 1, 4
133 *
134 IF ( IALPHA.EQ. 1) THEN
135 ALPHA = ZERO
136 BETA = ZERO
137 ELSE IF ( IALPHA.EQ. 1) THEN
138 ALPHA = ONE
139 BETA = ZERO
140 ELSE IF ( IALPHA.EQ. 1) THEN
141 ALPHA = ZERO
142 BETA = ONE
143 ELSE
144 ALPHA = SLARND( 2, ISEED )
145 BETA = SLARND( 2, ISEED )
146 END IF
147 *
148 * All the parameters are set:
149 * CFORM, UPLO, TRANS, M, N,
150 * ALPHA, and BETA
151 * READY TO TEST!
152 *
153 NRUN = NRUN + 1
154 *
155 IF ( ITRANS.EQ.1 ) THEN
156 *
157 * In this case we are NOTRANS, so A is N-by-K
158 *
159 DO J = 1, K
160 DO I = 1, N
161 A( I, J) = CLARND( 4, ISEED )
162 END DO
163 END DO
164 *
165 NORMA = CLANGE( 'I', N, K, A, LDA,
166 + S_WORK_CLANGE )
167 *
168 ELSE
169 *
170 * In this case we are TRANS, so A is K-by-N
171 *
172 DO J = 1,N
173 DO I = 1, K
174 A( I, J) = CLARND( 4, ISEED )
175 END DO
176 END DO
177 *
178 NORMA = CLANGE( 'I', K, N, A, LDA,
179 + S_WORK_CLANGE )
180 *
181 END IF
182 *
183 *
184 * Generate C1 our N--by--N Hermitian matrix.
185 * Make sure C2 has the same upper/lower part,
186 * (the one that we do not touch), so
187 * copy the initial C1 in C2 in it.
188 *
189 DO J = 1, N
190 DO I = 1, N
191 C1( I, J) = CLARND( 4, ISEED )
192 C2(I,J) = C1(I,J)
193 END DO
194 END DO
195 *
196 * (See comment later on for why we use CLANGE and
197 * not CLANHE for C1.)
198 *
199 NORMC = CLANGE( 'I', N, N, C1, LDC,
200 + S_WORK_CLANGE )
201 *
202 SRNAMT = 'CTRTTF'
203 CALL CTRTTF( CFORM, UPLO, N, C1, LDC, CRF,
204 + INFO )
205 *
206 * call zherk the BLAS routine -> gives C1
207 *
208 SRNAMT = 'CHERK '
209 CALL CHERK( UPLO, TRANS, N, K, ALPHA, A, LDA,
210 + BETA, C1, LDC )
211 *
212 * call zhfrk the RFP routine -> gives CRF
213 *
214 SRNAMT = 'CHFRK '
215 CALL CHFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A,
216 + LDA, BETA, CRF )
217 *
218 * convert CRF in full format -> gives C2
219 *
220 SRNAMT = 'CTFTTR'
221 CALL CTFTTR( CFORM, UPLO, N, CRF, C2, LDC,
222 + INFO )
223 *
224 * compare C1 and C2
225 *
226 DO J = 1, N
227 DO I = 1, N
228 C1(I,J) = C1(I,J)-C2(I,J)
229 END DO
230 END DO
231 *
232 * Yes, C1 is Hermitian so we could call CLANHE,
233 * but we want to check the upper part that is
234 * supposed to be unchanged and the diagonal that
235 * is supposed to be real -> CLANGE
236 *
237 RESULT(1) = CLANGE( 'I', N, N, C1, LDC,
238 + S_WORK_CLANGE )
239 RESULT(1) = RESULT(1)
240 + / MAX( ABS( ALPHA ) * NORMA * NORMA
241 + + ABS( BETA ) * NORMC, ONE )
242 + / MAX( N , 1 ) / EPS
243 *
244 IF( RESULT(1).GE.THRESH ) THEN
245 IF( NFAIL.EQ.0 ) THEN
246 WRITE( NOUT, * )
247 WRITE( NOUT, FMT = 9999 )
248 END IF
249 WRITE( NOUT, FMT = 9997 ) 'CHFRK',
250 + CFORM, UPLO, TRANS, N, K, RESULT(1)
251 NFAIL = NFAIL + 1
252 END IF
253 *
254 100 CONTINUE
255 110 CONTINUE
256 120 CONTINUE
257 130 CONTINUE
258 140 CONTINUE
259 150 CONTINUE
260 *
261 * Print a summary of the results.
262 *
263 IF ( NFAIL.EQ.0 ) THEN
264 WRITE( NOUT, FMT = 9996 ) 'CHFRK', NRUN
265 ELSE
266 WRITE( NOUT, FMT = 9995 ) 'CHFRK', NFAIL, NRUN
267 END IF
268 *
269 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CHFRK
270 + ***')
271 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',',
272 + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3,
273 + ', test=',G12.5)
274 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ',
275 + 'threshold (',I5,' tests run)')
276 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5,
277 + ' tests failed to pass the threshold')
278 *
279 RETURN
280 *
281 * End of CDRVRF4
282 *
283 END