1 SUBROUTINE CCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
2 $ COPYA, S, COPYS, TAU, WORK, RWORK, NOUT )
3 *
4 * -- LAPACK test routine (version 3.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * November 2006
7 *
8 * .. Scalar Arguments ..
9 LOGICAL TSTERR
10 INTEGER NM, NN, NOUT
11 REAL THRESH
12 * ..
13 * .. Array Arguments ..
14 LOGICAL DOTYPE( * )
15 INTEGER MVAL( * ), NVAL( * )
16 REAL COPYS( * ), RWORK( * ), S( * )
17 COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * CCHKTZ tests CTZRQF and CTZRZF.
24 *
25 * Arguments
26 * =========
27 *
28 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
29 * The matrix types to be used for testing. Matrices of type j
30 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
31 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
32 *
33 * NM (input) INTEGER
34 * The number of values of M contained in the vector MVAL.
35 *
36 * MVAL (input) INTEGER array, dimension (NM)
37 * The values of the matrix row dimension M.
38 *
39 * NN (input) INTEGER
40 * The number of values of N contained in the vector NVAL.
41 *
42 * NVAL (input) INTEGER array, dimension (NN)
43 * The values of the matrix column dimension N.
44 *
45 * THRESH (input) REAL
46 * The threshold value for the test ratios. A result is
47 * included in the output file if RESULT >= THRESH. To have
48 * every test ratio printed, use THRESH = 0.
49 *
50 * TSTERR (input) LOGICAL
51 * Flag that indicates whether error exits are to be tested.
52 *
53 * A (workspace) COMPLEX array, dimension (MMAX*NMAX)
54 * where MMAX is the maximum value of M in MVAL and NMAX is the
55 * maximum value of N in NVAL.
56 *
57 * COPYA (workspace) COMPLEX array, dimension (MMAX*NMAX)
58 *
59 * S (workspace) REAL array, dimension
60 * (min(MMAX,NMAX))
61 *
62 * COPYS (workspace) REAL array, dimension
63 * (min(MMAX,NMAX))
64 *
65 * TAU (workspace) COMPLEX array, dimension (MMAX)
66 *
67 * WORK (workspace) COMPLEX array, dimension
68 * (MMAX*NMAX + 4*NMAX + MMAX)
69 *
70 * RWORK (workspace) REAL array, dimension (2*NMAX)
71 *
72 * NOUT (input) INTEGER
73 * The unit number for output.
74 *
75 * =====================================================================
76 *
77 * .. Parameters ..
78 INTEGER NTYPES
79 PARAMETER ( NTYPES = 3 )
80 INTEGER NTESTS
81 PARAMETER ( NTESTS = 6 )
82 REAL ONE, ZERO
83 PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
84 * ..
85 * .. Local Scalars ..
86 CHARACTER*3 PATH
87 INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
88 $ MNMIN, MODE, N, NERRS, NFAIL, NRUN
89 REAL EPS
90 * ..
91 * .. Local Arrays ..
92 INTEGER ISEED( 4 ), ISEEDY( 4 )
93 REAL RESULT( NTESTS )
94 * ..
95 * .. External Functions ..
96 REAL CQRT12, CRZT01, CRZT02, CTZT01, CTZT02, SLAMCH
97 EXTERNAL CQRT12, CRZT01, CRZT02, CTZT01, CTZT02, SLAMCH
98 * ..
99 * .. External Subroutines ..
100 EXTERNAL ALAHD, ALASUM, CERRTZ, CGEQR2, CLACPY, CLASET,
101 $ CLATMS, CTZRQF, CTZRZF, SLAORD
102 * ..
103 * .. Intrinsic Functions ..
104 INTRINSIC CMPLX, MAX, MIN
105 * ..
106 * .. Scalars in Common ..
107 LOGICAL LERR, OK
108 CHARACTER*32 SRNAMT
109 INTEGER INFOT, IOUNIT
110 * ..
111 * .. Common blocks ..
112 COMMON / INFOC / INFOT, IOUNIT, OK, LERR
113 COMMON / SRNAMC / SRNAMT
114 * ..
115 * .. Data statements ..
116 DATA ISEEDY / 1988, 1989, 1990, 1991 /
117 * ..
118 * .. Executable Statements ..
119 *
120 * Initialize constants and the random number seed.
121 *
122 PATH( 1: 1 ) = 'Complex precision'
123 PATH( 2: 3 ) = 'TZ'
124 NRUN = 0
125 NFAIL = 0
126 NERRS = 0
127 DO 10 I = 1, 4
128 ISEED( I ) = ISEEDY( I )
129 10 CONTINUE
130 EPS = SLAMCH( 'Epsilon' )
131 *
132 * Test the error exits
133 *
134 IF( TSTERR )
135 $ CALL CERRTZ( PATH, NOUT )
136 INFOT = 0
137 *
138 DO 70 IM = 1, NM
139 *
140 * Do for each value of M in MVAL.
141 *
142 M = MVAL( IM )
143 LDA = MAX( 1, M )
144 *
145 DO 60 IN = 1, NN
146 *
147 * Do for each value of N in NVAL for which M .LE. N.
148 *
149 N = NVAL( IN )
150 MNMIN = MIN( M, N )
151 LWORK = MAX( 1, N*N+4*M+N )
152 *
153 IF( M.LE.N ) THEN
154 DO 50 IMODE = 1, NTYPES
155 *
156 * Do for each type of singular value distribution.
157 * 0: zero matrix
158 * 1: one small singular value
159 * 2: exponential distribution
160 *
161 MODE = IMODE - 1
162 *
163 * Test CTZRQF
164 *
165 * Generate test matrix of size m by n using
166 * singular value distribution indicated by `mode'.
167 *
168 IF( MODE.EQ.0 ) THEN
169 CALL CLASET( 'Full', M, N, CMPLX( ZERO ),
170 $ CMPLX( ZERO ), A, LDA )
171 DO 20 I = 1, MNMIN
172 COPYS( I ) = ZERO
173 20 CONTINUE
174 ELSE
175 CALL CLATMS( M, N, 'Uniform', ISEED,
176 $ 'Nonsymmetric', COPYS, IMODE,
177 $ ONE / EPS, ONE, M, N, 'No packing', A,
178 $ LDA, WORK, INFO )
179 CALL CGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
180 $ INFO )
181 CALL CLASET( 'Lower', M-1, N, CMPLX( ZERO ),
182 $ CMPLX( ZERO ), A( 2 ), LDA )
183 CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
184 END IF
185 *
186 * Save A and its singular values
187 *
188 CALL CLACPY( 'All', M, N, A, LDA, COPYA, LDA )
189 *
190 * Call CTZRQF to reduce the upper trapezoidal matrix to
191 * upper triangular form.
192 *
193 SRNAMT = 'CTZRQF'
194 CALL CTZRQF( M, N, A, LDA, TAU, INFO )
195 *
196 * Compute norm(svd(a) - svd(r))
197 *
198 RESULT( 1 ) = CQRT12( M, M, A, LDA, COPYS, WORK,
199 $ LWORK, RWORK )
200 *
201 * Compute norm( A - R*Q )
202 *
203 RESULT( 2 ) = CTZT01( M, N, COPYA, A, LDA, TAU, WORK,
204 $ LWORK )
205 *
206 * Compute norm(Q'*Q - I).
207 *
208 RESULT( 3 ) = CTZT02( M, N, A, LDA, TAU, WORK, LWORK )
209 *
210 * Test CTZRZF
211 *
212 * Generate test matrix of size m by n using
213 * singular value distribution indicated by `mode'.
214 *
215 IF( MODE.EQ.0 ) THEN
216 CALL CLASET( 'Full', M, N, CMPLX( ZERO ),
217 $ CMPLX( ZERO ), A, LDA )
218 DO 30 I = 1, MNMIN
219 COPYS( I ) = ZERO
220 30 CONTINUE
221 ELSE
222 CALL CLATMS( M, N, 'Uniform', ISEED,
223 $ 'Nonsymmetric', COPYS, IMODE,
224 $ ONE / EPS, ONE, M, N, 'No packing', A,
225 $ LDA, WORK, INFO )
226 CALL CGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
227 $ INFO )
228 CALL CLASET( 'Lower', M-1, N, CMPLX( ZERO ),
229 $ CMPLX( ZERO ), A( 2 ), LDA )
230 CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
231 END IF
232 *
233 * Save A and its singular values
234 *
235 CALL CLACPY( 'All', M, N, A, LDA, COPYA, LDA )
236 *
237 * Call CTZRZF to reduce the upper trapezoidal matrix to
238 * upper triangular form.
239 *
240 SRNAMT = 'CTZRZF'
241 CALL CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
242 *
243 * Compute norm(svd(a) - svd(r))
244 *
245 RESULT( 4 ) = CQRT12( M, M, A, LDA, COPYS, WORK,
246 $ LWORK, RWORK )
247 *
248 * Compute norm( A - R*Q )
249 *
250 RESULT( 5 ) = CRZT01( M, N, COPYA, A, LDA, TAU, WORK,
251 $ LWORK )
252 *
253 * Compute norm(Q'*Q - I).
254 *
255 RESULT( 6 ) = CRZT02( M, N, A, LDA, TAU, WORK, LWORK )
256 *
257 * Print information about the tests that did not pass
258 * the threshold.
259 *
260 DO 40 K = 1, 6
261 IF( RESULT( K ).GE.THRESH ) THEN
262 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
263 $ CALL ALAHD( NOUT, PATH )
264 WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
265 $ RESULT( K )
266 NFAIL = NFAIL + 1
267 END IF
268 40 CONTINUE
269 NRUN = NRUN + 6
270 50 CONTINUE
271 END IF
272 60 CONTINUE
273 70 CONTINUE
274 *
275 * Print a summary of the results.
276 *
277 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
278 *
279 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
280 $ ', ratio =', G12.5 )
281 *
282 * End if CCHKTZ
283 *
284 END
2 $ COPYA, S, COPYS, TAU, WORK, RWORK, NOUT )
3 *
4 * -- LAPACK test routine (version 3.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * November 2006
7 *
8 * .. Scalar Arguments ..
9 LOGICAL TSTERR
10 INTEGER NM, NN, NOUT
11 REAL THRESH
12 * ..
13 * .. Array Arguments ..
14 LOGICAL DOTYPE( * )
15 INTEGER MVAL( * ), NVAL( * )
16 REAL COPYS( * ), RWORK( * ), S( * )
17 COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * CCHKTZ tests CTZRQF and CTZRZF.
24 *
25 * Arguments
26 * =========
27 *
28 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
29 * The matrix types to be used for testing. Matrices of type j
30 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
31 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
32 *
33 * NM (input) INTEGER
34 * The number of values of M contained in the vector MVAL.
35 *
36 * MVAL (input) INTEGER array, dimension (NM)
37 * The values of the matrix row dimension M.
38 *
39 * NN (input) INTEGER
40 * The number of values of N contained in the vector NVAL.
41 *
42 * NVAL (input) INTEGER array, dimension (NN)
43 * The values of the matrix column dimension N.
44 *
45 * THRESH (input) REAL
46 * The threshold value for the test ratios. A result is
47 * included in the output file if RESULT >= THRESH. To have
48 * every test ratio printed, use THRESH = 0.
49 *
50 * TSTERR (input) LOGICAL
51 * Flag that indicates whether error exits are to be tested.
52 *
53 * A (workspace) COMPLEX array, dimension (MMAX*NMAX)
54 * where MMAX is the maximum value of M in MVAL and NMAX is the
55 * maximum value of N in NVAL.
56 *
57 * COPYA (workspace) COMPLEX array, dimension (MMAX*NMAX)
58 *
59 * S (workspace) REAL array, dimension
60 * (min(MMAX,NMAX))
61 *
62 * COPYS (workspace) REAL array, dimension
63 * (min(MMAX,NMAX))
64 *
65 * TAU (workspace) COMPLEX array, dimension (MMAX)
66 *
67 * WORK (workspace) COMPLEX array, dimension
68 * (MMAX*NMAX + 4*NMAX + MMAX)
69 *
70 * RWORK (workspace) REAL array, dimension (2*NMAX)
71 *
72 * NOUT (input) INTEGER
73 * The unit number for output.
74 *
75 * =====================================================================
76 *
77 * .. Parameters ..
78 INTEGER NTYPES
79 PARAMETER ( NTYPES = 3 )
80 INTEGER NTESTS
81 PARAMETER ( NTESTS = 6 )
82 REAL ONE, ZERO
83 PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
84 * ..
85 * .. Local Scalars ..
86 CHARACTER*3 PATH
87 INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
88 $ MNMIN, MODE, N, NERRS, NFAIL, NRUN
89 REAL EPS
90 * ..
91 * .. Local Arrays ..
92 INTEGER ISEED( 4 ), ISEEDY( 4 )
93 REAL RESULT( NTESTS )
94 * ..
95 * .. External Functions ..
96 REAL CQRT12, CRZT01, CRZT02, CTZT01, CTZT02, SLAMCH
97 EXTERNAL CQRT12, CRZT01, CRZT02, CTZT01, CTZT02, SLAMCH
98 * ..
99 * .. External Subroutines ..
100 EXTERNAL ALAHD, ALASUM, CERRTZ, CGEQR2, CLACPY, CLASET,
101 $ CLATMS, CTZRQF, CTZRZF, SLAORD
102 * ..
103 * .. Intrinsic Functions ..
104 INTRINSIC CMPLX, MAX, MIN
105 * ..
106 * .. Scalars in Common ..
107 LOGICAL LERR, OK
108 CHARACTER*32 SRNAMT
109 INTEGER INFOT, IOUNIT
110 * ..
111 * .. Common blocks ..
112 COMMON / INFOC / INFOT, IOUNIT, OK, LERR
113 COMMON / SRNAMC / SRNAMT
114 * ..
115 * .. Data statements ..
116 DATA ISEEDY / 1988, 1989, 1990, 1991 /
117 * ..
118 * .. Executable Statements ..
119 *
120 * Initialize constants and the random number seed.
121 *
122 PATH( 1: 1 ) = 'Complex precision'
123 PATH( 2: 3 ) = 'TZ'
124 NRUN = 0
125 NFAIL = 0
126 NERRS = 0
127 DO 10 I = 1, 4
128 ISEED( I ) = ISEEDY( I )
129 10 CONTINUE
130 EPS = SLAMCH( 'Epsilon' )
131 *
132 * Test the error exits
133 *
134 IF( TSTERR )
135 $ CALL CERRTZ( PATH, NOUT )
136 INFOT = 0
137 *
138 DO 70 IM = 1, NM
139 *
140 * Do for each value of M in MVAL.
141 *
142 M = MVAL( IM )
143 LDA = MAX( 1, M )
144 *
145 DO 60 IN = 1, NN
146 *
147 * Do for each value of N in NVAL for which M .LE. N.
148 *
149 N = NVAL( IN )
150 MNMIN = MIN( M, N )
151 LWORK = MAX( 1, N*N+4*M+N )
152 *
153 IF( M.LE.N ) THEN
154 DO 50 IMODE = 1, NTYPES
155 *
156 * Do for each type of singular value distribution.
157 * 0: zero matrix
158 * 1: one small singular value
159 * 2: exponential distribution
160 *
161 MODE = IMODE - 1
162 *
163 * Test CTZRQF
164 *
165 * Generate test matrix of size m by n using
166 * singular value distribution indicated by `mode'.
167 *
168 IF( MODE.EQ.0 ) THEN
169 CALL CLASET( 'Full', M, N, CMPLX( ZERO ),
170 $ CMPLX( ZERO ), A, LDA )
171 DO 20 I = 1, MNMIN
172 COPYS( I ) = ZERO
173 20 CONTINUE
174 ELSE
175 CALL CLATMS( M, N, 'Uniform', ISEED,
176 $ 'Nonsymmetric', COPYS, IMODE,
177 $ ONE / EPS, ONE, M, N, 'No packing', A,
178 $ LDA, WORK, INFO )
179 CALL CGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
180 $ INFO )
181 CALL CLASET( 'Lower', M-1, N, CMPLX( ZERO ),
182 $ CMPLX( ZERO ), A( 2 ), LDA )
183 CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
184 END IF
185 *
186 * Save A and its singular values
187 *
188 CALL CLACPY( 'All', M, N, A, LDA, COPYA, LDA )
189 *
190 * Call CTZRQF to reduce the upper trapezoidal matrix to
191 * upper triangular form.
192 *
193 SRNAMT = 'CTZRQF'
194 CALL CTZRQF( M, N, A, LDA, TAU, INFO )
195 *
196 * Compute norm(svd(a) - svd(r))
197 *
198 RESULT( 1 ) = CQRT12( M, M, A, LDA, COPYS, WORK,
199 $ LWORK, RWORK )
200 *
201 * Compute norm( A - R*Q )
202 *
203 RESULT( 2 ) = CTZT01( M, N, COPYA, A, LDA, TAU, WORK,
204 $ LWORK )
205 *
206 * Compute norm(Q'*Q - I).
207 *
208 RESULT( 3 ) = CTZT02( M, N, A, LDA, TAU, WORK, LWORK )
209 *
210 * Test CTZRZF
211 *
212 * Generate test matrix of size m by n using
213 * singular value distribution indicated by `mode'.
214 *
215 IF( MODE.EQ.0 ) THEN
216 CALL CLASET( 'Full', M, N, CMPLX( ZERO ),
217 $ CMPLX( ZERO ), A, LDA )
218 DO 30 I = 1, MNMIN
219 COPYS( I ) = ZERO
220 30 CONTINUE
221 ELSE
222 CALL CLATMS( M, N, 'Uniform', ISEED,
223 $ 'Nonsymmetric', COPYS, IMODE,
224 $ ONE / EPS, ONE, M, N, 'No packing', A,
225 $ LDA, WORK, INFO )
226 CALL CGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
227 $ INFO )
228 CALL CLASET( 'Lower', M-1, N, CMPLX( ZERO ),
229 $ CMPLX( ZERO ), A( 2 ), LDA )
230 CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
231 END IF
232 *
233 * Save A and its singular values
234 *
235 CALL CLACPY( 'All', M, N, A, LDA, COPYA, LDA )
236 *
237 * Call CTZRZF to reduce the upper trapezoidal matrix to
238 * upper triangular form.
239 *
240 SRNAMT = 'CTZRZF'
241 CALL CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
242 *
243 * Compute norm(svd(a) - svd(r))
244 *
245 RESULT( 4 ) = CQRT12( M, M, A, LDA, COPYS, WORK,
246 $ LWORK, RWORK )
247 *
248 * Compute norm( A - R*Q )
249 *
250 RESULT( 5 ) = CRZT01( M, N, COPYA, A, LDA, TAU, WORK,
251 $ LWORK )
252 *
253 * Compute norm(Q'*Q - I).
254 *
255 RESULT( 6 ) = CRZT02( M, N, A, LDA, TAU, WORK, LWORK )
256 *
257 * Print information about the tests that did not pass
258 * the threshold.
259 *
260 DO 40 K = 1, 6
261 IF( RESULT( K ).GE.THRESH ) THEN
262 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
263 $ CALL ALAHD( NOUT, PATH )
264 WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
265 $ RESULT( K )
266 NFAIL = NFAIL + 1
267 END IF
268 40 CONTINUE
269 NRUN = NRUN + 6
270 50 CONTINUE
271 END IF
272 60 CONTINUE
273 70 CONTINUE
274 *
275 * Print a summary of the results.
276 *
277 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
278 *
279 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
280 $ ', ratio =', G12.5 )
281 *
282 * End if CCHKTZ
283 *
284 END