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