1 SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2,
2 + S_WORK_CLANGE, C_WORK_CGEQRF, TAU )
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, NN, NOUT
10 REAL THRESH
11 * ..
12 * .. Array Arguments ..
13 INTEGER NVAL( NN )
14 REAL S_WORK_CLANGE( * )
15 COMPLEX A( LDA, * ), ARF( * ), B1( LDA, * ),
16 + B2( LDA, * )
17 COMPLEX C_WORK_CGEQRF( * ), TAU( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * CDRVRF3 tests the LAPACK RFP routines:
24 * CTFSM
25 *
26 * Arguments
27 * =========
28 *
29 * NOUT (input) INTEGER
30 * The unit number for output.
31 *
32 * NN (input) INTEGER
33 * The number of values of N contained in the vector NVAL.
34 *
35 * NVAL (input) INTEGER array, dimension (NN)
36 * The values of the matrix dimension N.
37 *
38 * THRESH (input) DOUBLE PRECISION
39 * The threshold value for the test ratios. A result is
40 * included in the output file if RESULT >= THRESH. To have
41 * every test ratio printed, use THRESH = 0.
42 *
43 * A (workspace) COMPLEX*16 array, dimension (LDA,NMAX)
44 *
45 * LDA (input) INTEGER
46 * The leading dimension of the array A. LDA >= max(1,NMAX).
47 *
48 * ARF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2).
49 *
50 * B1 (workspace) COMPLEX array, dimension (LDA,NMAX)
51 *
52 * B2 (workspace) COMPLEX array, dimension (LDA,NMAX)
53 *
54 * S_WORK_CLANGE (workspace) REAL array, dimension (NMAX)
55 *
56 * C_WORK_CGEQRF (workspace) COMPLEX array, dimension (NMAX)
57 *
58 * TAU (workspace) COMPLEX array, dimension (NMAX)
59 *
60 * =====================================================================
61 * ..
62 * .. Parameters ..
63 COMPLEX ZERO, ONE
64 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ,
65 + ONE = ( 1.0E+0, 0.0E+0 ) )
66 INTEGER NTESTS
67 PARAMETER ( NTESTS = 1 )
68 * ..
69 * .. Local Scalars ..
70 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE
71 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
72 + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS
73 COMPLEX ALPHA
74 REAL EPS
75 * ..
76 * .. Local Arrays ..
77 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
78 + DIAGS( 2 ), SIDES( 2 )
79 INTEGER ISEED( 4 ), ISEEDY( 4 )
80 REAL RESULT( NTESTS )
81 * ..
82 * .. External Functions ..
83 REAL SLAMCH, CLANGE
84 COMPLEX CLARND
85 EXTERNAL SLAMCH, CLARND, CLANGE
86 * ..
87 * .. External Subroutines ..
88 EXTERNAL CTRTTF, CGEQRF, CGEQLF, CTFSM, CTRSM
89 * ..
90 * .. Intrinsic Functions ..
91 INTRINSIC MAX, SQRT
92 * ..
93 * .. Scalars in Common ..
94 CHARACTER*32 SRNAMT
95 * ..
96 * .. Common blocks ..
97 COMMON / SRNAMC / SRNAMT
98 * ..
99 * .. Data statements ..
100 DATA ISEEDY / 1988, 1989, 1990, 1991 /
101 DATA UPLOS / 'U', 'L' /
102 DATA FORMS / 'N', 'C' /
103 DATA SIDES / 'L', 'R' /
104 DATA TRANSS / 'N', 'C' /
105 DATA DIAGS / 'N', 'U' /
106 * ..
107 * .. Executable Statements ..
108 *
109 * Initialize constants and the random number seed.
110 *
111 NRUN = 0
112 NFAIL = 0
113 INFO = 0
114 DO 10 I = 1, 4
115 ISEED( I ) = ISEEDY( I )
116 10 CONTINUE
117 EPS = SLAMCH( 'Precision' )
118 *
119 DO 170 IIM = 1, NN
120 *
121 M = NVAL( IIM )
122 *
123 DO 160 IIN = 1, NN
124 *
125 N = NVAL( IIN )
126 *
127 DO 150 IFORM = 1, 2
128 *
129 CFORM = FORMS( IFORM )
130 *
131 DO 140 IUPLO = 1, 2
132 *
133 UPLO = UPLOS( IUPLO )
134 *
135 DO 130 ISIDE = 1, 2
136 *
137 SIDE = SIDES( ISIDE )
138 *
139 DO 120 ITRANS = 1, 2
140 *
141 TRANS = TRANSS( ITRANS )
142 *
143 DO 110 IDIAG = 1, 2
144 *
145 DIAG = DIAGS( IDIAG )
146 *
147 DO 100 IALPHA = 1, 3
148 *
149 IF ( IALPHA.EQ. 1) THEN
150 ALPHA = ZERO
151 ELSE IF ( IALPHA.EQ. 1) THEN
152 ALPHA = ONE
153 ELSE
154 ALPHA = CLARND( 4, ISEED )
155 END IF
156 *
157 * All the parameters are set:
158 * CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
159 * and ALPHA
160 * READY TO TEST!
161 *
162 NRUN = NRUN + 1
163 *
164 IF ( ISIDE.EQ.1 ) THEN
165 *
166 * The case ISIDE.EQ.1 is when SIDE.EQ.'L'
167 * -> A is M-by-M ( B is M-by-N )
168 *
169 NA = M
170 *
171 ELSE
172 *
173 * The case ISIDE.EQ.2 is when SIDE.EQ.'R'
174 * -> A is N-by-N ( B is M-by-N )
175 *
176 NA = N
177 *
178 END IF
179 *
180 * Generate A our NA--by--NA triangular
181 * matrix.
182 * Our test is based on forward error so we
183 * do want A to be well conditionned! To get
184 * a well-conditionned triangular matrix, we
185 * take the R factor of the QR/LQ factorization
186 * of a random matrix.
187 *
188 DO J = 1, NA
189 DO I = 1, NA
190 A( I, J) = CLARND( 4, ISEED )
191 END DO
192 END DO
193 *
194 IF ( IUPLO.EQ.1 ) THEN
195 *
196 * The case IUPLO.EQ.1 is when SIDE.EQ.'U'
197 * -> QR factorization.
198 *
199 SRNAMT = 'CGEQRF'
200 CALL CGEQRF( NA, NA, A, LDA, TAU,
201 + C_WORK_CGEQRF, LDA,
202 + INFO )
203 ELSE
204 *
205 * The case IUPLO.EQ.2 is when SIDE.EQ.'L'
206 * -> QL factorization.
207 *
208 SRNAMT = 'CGELQF'
209 CALL CGELQF( NA, NA, A, LDA, TAU,
210 + C_WORK_CGEQRF, LDA,
211 + INFO )
212 END IF
213 *
214 * After the QR factorization, the diagonal
215 * of A is made of real numbers, we multiply
216 * by a random complex number of absolute
217 * value 1.0E+00.
218 *
219 DO J = 1, NA
220 A( J, J) = A(J,J) * CLARND( 5, ISEED )
221 END DO
222 *
223 * Store a copy of A in RFP format (in ARF).
224 *
225 SRNAMT = 'CTRTTF'
226 CALL CTRTTF( CFORM, UPLO, NA, A, LDA, ARF,
227 + INFO )
228 *
229 * Generate B1 our M--by--N right-hand side
230 * and store a copy in B2.
231 *
232 DO J = 1, N
233 DO I = 1, M
234 B1( I, J) = CLARND( 4, ISEED )
235 B2( I, J) = B1( I, J)
236 END DO
237 END DO
238 *
239 * Solve op( A ) X = B or X op( A ) = B
240 * with CTRSM
241 *
242 SRNAMT = 'CTRSM'
243 CALL CTRSM( SIDE, UPLO, TRANS, DIAG, M, N,
244 + ALPHA, A, LDA, B1, LDA )
245 *
246 * Solve op( A ) X = B or X op( A ) = B
247 * with CTFSM
248 *
249 SRNAMT = 'CTFSM'
250 CALL CTFSM( CFORM, SIDE, UPLO, TRANS,
251 + DIAG, M, N, ALPHA, ARF, B2,
252 + LDA )
253 *
254 * Check that the result agrees.
255 *
256 DO J = 1, N
257 DO I = 1, M
258 B1( I, J) = B2( I, J ) - B1( I, J )
259 END DO
260 END DO
261 *
262 RESULT(1) = CLANGE( 'I', M, N, B1, LDA,
263 + S_WORK_CLANGE )
264 *
265 RESULT(1) = RESULT(1) / SQRT( EPS )
266 + / MAX ( MAX( M, N), 1 )
267 *
268 IF( RESULT(1).GE.THRESH ) THEN
269 IF( NFAIL.EQ.0 ) THEN
270 WRITE( NOUT, * )
271 WRITE( NOUT, FMT = 9999 )
272 END IF
273 WRITE( NOUT, FMT = 9997 ) 'CTFSM',
274 + CFORM, SIDE, UPLO, TRANS, DIAG, M,
275 + N, RESULT(1)
276 NFAIL = NFAIL + 1
277 END IF
278 *
279 100 CONTINUE
280 110 CONTINUE
281 120 CONTINUE
282 130 CONTINUE
283 140 CONTINUE
284 150 CONTINUE
285 160 CONTINUE
286 170 CONTINUE
287 *
288 * Print a summary of the results.
289 *
290 IF ( NFAIL.EQ.0 ) THEN
291 WRITE( NOUT, FMT = 9996 ) 'CTFSM', NRUN
292 ELSE
293 WRITE( NOUT, FMT = 9995 ) 'CTFSM', NFAIL, NRUN
294 END IF
295 *
296 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CTFSM
297 + ***')
298 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',',
299 + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',',
300 + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5)
301 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ',
302 + 'threshold (',I5,' tests run)')
303 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5,
304 + ' tests failed to pass the threshold')
305 *
306 RETURN
307 *
308 * End of CDRVRF3
309 *
310 END
2 + S_WORK_CLANGE, C_WORK_CGEQRF, TAU )
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, NN, NOUT
10 REAL THRESH
11 * ..
12 * .. Array Arguments ..
13 INTEGER NVAL( NN )
14 REAL S_WORK_CLANGE( * )
15 COMPLEX A( LDA, * ), ARF( * ), B1( LDA, * ),
16 + B2( LDA, * )
17 COMPLEX C_WORK_CGEQRF( * ), TAU( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * CDRVRF3 tests the LAPACK RFP routines:
24 * CTFSM
25 *
26 * Arguments
27 * =========
28 *
29 * NOUT (input) INTEGER
30 * The unit number for output.
31 *
32 * NN (input) INTEGER
33 * The number of values of N contained in the vector NVAL.
34 *
35 * NVAL (input) INTEGER array, dimension (NN)
36 * The values of the matrix dimension N.
37 *
38 * THRESH (input) DOUBLE PRECISION
39 * The threshold value for the test ratios. A result is
40 * included in the output file if RESULT >= THRESH. To have
41 * every test ratio printed, use THRESH = 0.
42 *
43 * A (workspace) COMPLEX*16 array, dimension (LDA,NMAX)
44 *
45 * LDA (input) INTEGER
46 * The leading dimension of the array A. LDA >= max(1,NMAX).
47 *
48 * ARF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2).
49 *
50 * B1 (workspace) COMPLEX array, dimension (LDA,NMAX)
51 *
52 * B2 (workspace) COMPLEX array, dimension (LDA,NMAX)
53 *
54 * S_WORK_CLANGE (workspace) REAL array, dimension (NMAX)
55 *
56 * C_WORK_CGEQRF (workspace) COMPLEX array, dimension (NMAX)
57 *
58 * TAU (workspace) COMPLEX array, dimension (NMAX)
59 *
60 * =====================================================================
61 * ..
62 * .. Parameters ..
63 COMPLEX ZERO, ONE
64 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ,
65 + ONE = ( 1.0E+0, 0.0E+0 ) )
66 INTEGER NTESTS
67 PARAMETER ( NTESTS = 1 )
68 * ..
69 * .. Local Scalars ..
70 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE
71 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
72 + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS
73 COMPLEX ALPHA
74 REAL EPS
75 * ..
76 * .. Local Arrays ..
77 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
78 + DIAGS( 2 ), SIDES( 2 )
79 INTEGER ISEED( 4 ), ISEEDY( 4 )
80 REAL RESULT( NTESTS )
81 * ..
82 * .. External Functions ..
83 REAL SLAMCH, CLANGE
84 COMPLEX CLARND
85 EXTERNAL SLAMCH, CLARND, CLANGE
86 * ..
87 * .. External Subroutines ..
88 EXTERNAL CTRTTF, CGEQRF, CGEQLF, CTFSM, CTRSM
89 * ..
90 * .. Intrinsic Functions ..
91 INTRINSIC MAX, SQRT
92 * ..
93 * .. Scalars in Common ..
94 CHARACTER*32 SRNAMT
95 * ..
96 * .. Common blocks ..
97 COMMON / SRNAMC / SRNAMT
98 * ..
99 * .. Data statements ..
100 DATA ISEEDY / 1988, 1989, 1990, 1991 /
101 DATA UPLOS / 'U', 'L' /
102 DATA FORMS / 'N', 'C' /
103 DATA SIDES / 'L', 'R' /
104 DATA TRANSS / 'N', 'C' /
105 DATA DIAGS / 'N', 'U' /
106 * ..
107 * .. Executable Statements ..
108 *
109 * Initialize constants and the random number seed.
110 *
111 NRUN = 0
112 NFAIL = 0
113 INFO = 0
114 DO 10 I = 1, 4
115 ISEED( I ) = ISEEDY( I )
116 10 CONTINUE
117 EPS = SLAMCH( 'Precision' )
118 *
119 DO 170 IIM = 1, NN
120 *
121 M = NVAL( IIM )
122 *
123 DO 160 IIN = 1, NN
124 *
125 N = NVAL( IIN )
126 *
127 DO 150 IFORM = 1, 2
128 *
129 CFORM = FORMS( IFORM )
130 *
131 DO 140 IUPLO = 1, 2
132 *
133 UPLO = UPLOS( IUPLO )
134 *
135 DO 130 ISIDE = 1, 2
136 *
137 SIDE = SIDES( ISIDE )
138 *
139 DO 120 ITRANS = 1, 2
140 *
141 TRANS = TRANSS( ITRANS )
142 *
143 DO 110 IDIAG = 1, 2
144 *
145 DIAG = DIAGS( IDIAG )
146 *
147 DO 100 IALPHA = 1, 3
148 *
149 IF ( IALPHA.EQ. 1) THEN
150 ALPHA = ZERO
151 ELSE IF ( IALPHA.EQ. 1) THEN
152 ALPHA = ONE
153 ELSE
154 ALPHA = CLARND( 4, ISEED )
155 END IF
156 *
157 * All the parameters are set:
158 * CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
159 * and ALPHA
160 * READY TO TEST!
161 *
162 NRUN = NRUN + 1
163 *
164 IF ( ISIDE.EQ.1 ) THEN
165 *
166 * The case ISIDE.EQ.1 is when SIDE.EQ.'L'
167 * -> A is M-by-M ( B is M-by-N )
168 *
169 NA = M
170 *
171 ELSE
172 *
173 * The case ISIDE.EQ.2 is when SIDE.EQ.'R'
174 * -> A is N-by-N ( B is M-by-N )
175 *
176 NA = N
177 *
178 END IF
179 *
180 * Generate A our NA--by--NA triangular
181 * matrix.
182 * Our test is based on forward error so we
183 * do want A to be well conditionned! To get
184 * a well-conditionned triangular matrix, we
185 * take the R factor of the QR/LQ factorization
186 * of a random matrix.
187 *
188 DO J = 1, NA
189 DO I = 1, NA
190 A( I, J) = CLARND( 4, ISEED )
191 END DO
192 END DO
193 *
194 IF ( IUPLO.EQ.1 ) THEN
195 *
196 * The case IUPLO.EQ.1 is when SIDE.EQ.'U'
197 * -> QR factorization.
198 *
199 SRNAMT = 'CGEQRF'
200 CALL CGEQRF( NA, NA, A, LDA, TAU,
201 + C_WORK_CGEQRF, LDA,
202 + INFO )
203 ELSE
204 *
205 * The case IUPLO.EQ.2 is when SIDE.EQ.'L'
206 * -> QL factorization.
207 *
208 SRNAMT = 'CGELQF'
209 CALL CGELQF( NA, NA, A, LDA, TAU,
210 + C_WORK_CGEQRF, LDA,
211 + INFO )
212 END IF
213 *
214 * After the QR factorization, the diagonal
215 * of A is made of real numbers, we multiply
216 * by a random complex number of absolute
217 * value 1.0E+00.
218 *
219 DO J = 1, NA
220 A( J, J) = A(J,J) * CLARND( 5, ISEED )
221 END DO
222 *
223 * Store a copy of A in RFP format (in ARF).
224 *
225 SRNAMT = 'CTRTTF'
226 CALL CTRTTF( CFORM, UPLO, NA, A, LDA, ARF,
227 + INFO )
228 *
229 * Generate B1 our M--by--N right-hand side
230 * and store a copy in B2.
231 *
232 DO J = 1, N
233 DO I = 1, M
234 B1( I, J) = CLARND( 4, ISEED )
235 B2( I, J) = B1( I, J)
236 END DO
237 END DO
238 *
239 * Solve op( A ) X = B or X op( A ) = B
240 * with CTRSM
241 *
242 SRNAMT = 'CTRSM'
243 CALL CTRSM( SIDE, UPLO, TRANS, DIAG, M, N,
244 + ALPHA, A, LDA, B1, LDA )
245 *
246 * Solve op( A ) X = B or X op( A ) = B
247 * with CTFSM
248 *
249 SRNAMT = 'CTFSM'
250 CALL CTFSM( CFORM, SIDE, UPLO, TRANS,
251 + DIAG, M, N, ALPHA, ARF, B2,
252 + LDA )
253 *
254 * Check that the result agrees.
255 *
256 DO J = 1, N
257 DO I = 1, M
258 B1( I, J) = B2( I, J ) - B1( I, J )
259 END DO
260 END DO
261 *
262 RESULT(1) = CLANGE( 'I', M, N, B1, LDA,
263 + S_WORK_CLANGE )
264 *
265 RESULT(1) = RESULT(1) / SQRT( EPS )
266 + / MAX ( MAX( M, N), 1 )
267 *
268 IF( RESULT(1).GE.THRESH ) THEN
269 IF( NFAIL.EQ.0 ) THEN
270 WRITE( NOUT, * )
271 WRITE( NOUT, FMT = 9999 )
272 END IF
273 WRITE( NOUT, FMT = 9997 ) 'CTFSM',
274 + CFORM, SIDE, UPLO, TRANS, DIAG, M,
275 + N, RESULT(1)
276 NFAIL = NFAIL + 1
277 END IF
278 *
279 100 CONTINUE
280 110 CONTINUE
281 120 CONTINUE
282 130 CONTINUE
283 140 CONTINUE
284 150 CONTINUE
285 160 CONTINUE
286 170 CONTINUE
287 *
288 * Print a summary of the results.
289 *
290 IF ( NFAIL.EQ.0 ) THEN
291 WRITE( NOUT, FMT = 9996 ) 'CTFSM', NRUN
292 ELSE
293 WRITE( NOUT, FMT = 9995 ) 'CTFSM', NFAIL, NRUN
294 END IF
295 *
296 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CTFSM
297 + ***')
298 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',',
299 + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',',
300 + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5)
301 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ',
302 + 'threshold (',I5,' tests run)')
303 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5,
304 + ' tests failed to pass the threshold')
305 *
306 RETURN
307 *
308 * End of CDRVRF3
309 *
310 END