1 SUBROUTINE SCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
2 $ COPYA, S, COPYS, TAU, WORK, NOUT )
3 *
4 * -- LAPACK test routine (version 3.1.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * January 2007
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 A( * ), COPYA( * ), COPYS( * ), S( * ),
17 $ TAU( * ), WORK( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * SCHKTZ tests STZRQF and STZRZF.
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) REAL 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) REAL 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) REAL array, dimension (MMAX)
66 *
67 * WORK (workspace) REAL array, dimension
68 * (MMAX*NMAX + 4*NMAX + MMAX)
69 *
70 * NOUT (input) INTEGER
71 * The unit number for output.
72 *
73 * =====================================================================
74 *
75 * .. Parameters ..
76 INTEGER NTYPES
77 PARAMETER ( NTYPES = 3 )
78 INTEGER NTESTS
79 PARAMETER ( NTESTS = 6 )
80 REAL ONE, ZERO
81 PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
82 * ..
83 * .. Local Scalars ..
84 CHARACTER*3 PATH
85 INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
86 $ MNMIN, MODE, N, NERRS, NFAIL, NRUN
87 REAL EPS
88 * ..
89 * .. Local Arrays ..
90 INTEGER ISEED( 4 ), ISEEDY( 4 )
91 REAL RESULT( NTESTS )
92 * ..
93 * .. External Functions ..
94 REAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02
95 EXTERNAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02
96 * ..
97 * .. External Subroutines ..
98 EXTERNAL ALAHD, ALASUM, SERRTZ, SGEQR2, SLACPY, SLAORD,
99 $ SLASET, SLATMS, STZRQF, STZRZF
100 * ..
101 * .. Intrinsic Functions ..
102 INTRINSIC MAX, MIN
103 * ..
104 * .. Scalars in Common ..
105 LOGICAL LERR, OK
106 CHARACTER*32 SRNAMT
107 INTEGER INFOT, IOUNIT
108 * ..
109 * .. Common blocks ..
110 COMMON / INFOC / INFOT, IOUNIT, OK, LERR
111 COMMON / SRNAMC / SRNAMT
112 * ..
113 * .. Data statements ..
114 DATA ISEEDY / 1988, 1989, 1990, 1991 /
115 * ..
116 * .. Executable Statements ..
117 *
118 * Initialize constants and the random number seed.
119 *
120 PATH( 1: 1 ) = 'Single precision'
121 PATH( 2: 3 ) = 'TZ'
122 NRUN = 0
123 NFAIL = 0
124 NERRS = 0
125 DO 10 I = 1, 4
126 ISEED( I ) = ISEEDY( I )
127 10 CONTINUE
128 EPS = SLAMCH( 'Epsilon' )
129 *
130 * Test the error exits
131 *
132 IF( TSTERR )
133 $ CALL SERRTZ( PATH, NOUT )
134 INFOT = 0
135 *
136 DO 70 IM = 1, NM
137 *
138 * Do for each value of M in MVAL.
139 *
140 M = MVAL( IM )
141 LDA = MAX( 1, M )
142 *
143 DO 60 IN = 1, NN
144 *
145 * Do for each value of N in NVAL for which M .LE. N.
146 *
147 N = NVAL( IN )
148 MNMIN = MIN( M, N )
149 LWORK = MAX( 1, N*N+4*M+N, M*N+2*MNMIN+4*N )
150 *
151 IF( M.LE.N ) THEN
152 DO 50 IMODE = 1, NTYPES
153 IF( .NOT.DOTYPE( IMODE ) )
154 $ GO TO 50
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 STZRQF
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 SLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
170 DO 20 I = 1, MNMIN
171 COPYS( I ) = ZERO
172 20 CONTINUE
173 ELSE
174 CALL SLATMS( M, N, 'Uniform', ISEED,
175 $ 'Nonsymmetric', COPYS, IMODE,
176 $ ONE / EPS, ONE, M, N, 'No packing', A,
177 $ LDA, WORK, INFO )
178 CALL SGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
179 $ INFO )
180 CALL SLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
181 $ LDA )
182 CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
183 END IF
184 *
185 * Save A and its singular values
186 *
187 CALL SLACPY( 'All', M, N, A, LDA, COPYA, LDA )
188 *
189 * Call STZRQF to reduce the upper trapezoidal matrix to
190 * upper triangular form.
191 *
192 SRNAMT = 'STZRQF'
193 CALL STZRQF( M, N, A, LDA, TAU, INFO )
194 *
195 * Compute norm(svd(a) - svd(r))
196 *
197 RESULT( 1 ) = SQRT12( M, M, A, LDA, COPYS, WORK,
198 $ LWORK )
199 *
200 * Compute norm( A - R*Q )
201 *
202 RESULT( 2 ) = STZT01( M, N, COPYA, A, LDA, TAU, WORK,
203 $ LWORK )
204 *
205 * Compute norm(Q'*Q - I).
206 *
207 RESULT( 3 ) = STZT02( M, N, A, LDA, TAU, WORK, LWORK )
208 *
209 * Test STZRZF
210 *
211 * Generate test matrix of size m by n using
212 * singular value distribution indicated by `mode'.
213 *
214 IF( MODE.EQ.0 ) THEN
215 CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
216 DO 30 I = 1, MNMIN
217 COPYS( I ) = ZERO
218 30 CONTINUE
219 ELSE
220 CALL SLATMS( M, N, 'Uniform', ISEED,
221 $ 'Nonsymmetric', COPYS, IMODE,
222 $ ONE / EPS, ONE, M, N, 'No packing', A,
223 $ LDA, WORK, INFO )
224 CALL SGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
225 $ INFO )
226 CALL SLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
227 $ LDA )
228 CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
229 END IF
230 *
231 * Save A and its singular values
232 *
233 CALL SLACPY( 'All', M, N, A, LDA, COPYA, LDA )
234 *
235 * Call STZRZF to reduce the upper trapezoidal matrix to
236 * upper triangular form.
237 *
238 SRNAMT = 'STZRZF'
239 CALL STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
240 *
241 * Compute norm(svd(a) - svd(r))
242 *
243 RESULT( 4 ) = SQRT12( M, M, A, LDA, COPYS, WORK,
244 $ LWORK )
245 *
246 * Compute norm( A - R*Q )
247 *
248 RESULT( 5 ) = SRZT01( M, N, COPYA, A, LDA, TAU, WORK,
249 $ LWORK )
250 *
251 * Compute norm(Q'*Q - I).
252 *
253 RESULT( 6 ) = SRZT02( M, N, A, LDA, TAU, WORK, LWORK )
254 *
255 * Print information about the tests that did not pass
256 * the threshold.
257 *
258 DO 40 K = 1, 6
259 IF( RESULT( K ).GE.THRESH ) THEN
260 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
261 $ CALL ALAHD( NOUT, PATH )
262 WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
263 $ RESULT( K )
264 NFAIL = NFAIL + 1
265 END IF
266 40 CONTINUE
267 NRUN = NRUN + 6
268 50 CONTINUE
269 END IF
270 60 CONTINUE
271 70 CONTINUE
272 *
273 * Print a summary of the results.
274 *
275 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
276 *
277 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
278 $ ', ratio =', G12.5 )
279 *
280 * End if SCHKTZ
281 *
282 END
2 $ COPYA, S, COPYS, TAU, WORK, NOUT )
3 *
4 * -- LAPACK test routine (version 3.1.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * January 2007
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 A( * ), COPYA( * ), COPYS( * ), S( * ),
17 $ TAU( * ), WORK( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * SCHKTZ tests STZRQF and STZRZF.
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) REAL 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) REAL 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) REAL array, dimension (MMAX)
66 *
67 * WORK (workspace) REAL array, dimension
68 * (MMAX*NMAX + 4*NMAX + MMAX)
69 *
70 * NOUT (input) INTEGER
71 * The unit number for output.
72 *
73 * =====================================================================
74 *
75 * .. Parameters ..
76 INTEGER NTYPES
77 PARAMETER ( NTYPES = 3 )
78 INTEGER NTESTS
79 PARAMETER ( NTESTS = 6 )
80 REAL ONE, ZERO
81 PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
82 * ..
83 * .. Local Scalars ..
84 CHARACTER*3 PATH
85 INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
86 $ MNMIN, MODE, N, NERRS, NFAIL, NRUN
87 REAL EPS
88 * ..
89 * .. Local Arrays ..
90 INTEGER ISEED( 4 ), ISEEDY( 4 )
91 REAL RESULT( NTESTS )
92 * ..
93 * .. External Functions ..
94 REAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02
95 EXTERNAL SLAMCH, SQRT12, SRZT01, SRZT02, STZT01, STZT02
96 * ..
97 * .. External Subroutines ..
98 EXTERNAL ALAHD, ALASUM, SERRTZ, SGEQR2, SLACPY, SLAORD,
99 $ SLASET, SLATMS, STZRQF, STZRZF
100 * ..
101 * .. Intrinsic Functions ..
102 INTRINSIC MAX, MIN
103 * ..
104 * .. Scalars in Common ..
105 LOGICAL LERR, OK
106 CHARACTER*32 SRNAMT
107 INTEGER INFOT, IOUNIT
108 * ..
109 * .. Common blocks ..
110 COMMON / INFOC / INFOT, IOUNIT, OK, LERR
111 COMMON / SRNAMC / SRNAMT
112 * ..
113 * .. Data statements ..
114 DATA ISEEDY / 1988, 1989, 1990, 1991 /
115 * ..
116 * .. Executable Statements ..
117 *
118 * Initialize constants and the random number seed.
119 *
120 PATH( 1: 1 ) = 'Single precision'
121 PATH( 2: 3 ) = 'TZ'
122 NRUN = 0
123 NFAIL = 0
124 NERRS = 0
125 DO 10 I = 1, 4
126 ISEED( I ) = ISEEDY( I )
127 10 CONTINUE
128 EPS = SLAMCH( 'Epsilon' )
129 *
130 * Test the error exits
131 *
132 IF( TSTERR )
133 $ CALL SERRTZ( PATH, NOUT )
134 INFOT = 0
135 *
136 DO 70 IM = 1, NM
137 *
138 * Do for each value of M in MVAL.
139 *
140 M = MVAL( IM )
141 LDA = MAX( 1, M )
142 *
143 DO 60 IN = 1, NN
144 *
145 * Do for each value of N in NVAL for which M .LE. N.
146 *
147 N = NVAL( IN )
148 MNMIN = MIN( M, N )
149 LWORK = MAX( 1, N*N+4*M+N, M*N+2*MNMIN+4*N )
150 *
151 IF( M.LE.N ) THEN
152 DO 50 IMODE = 1, NTYPES
153 IF( .NOT.DOTYPE( IMODE ) )
154 $ GO TO 50
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 STZRQF
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 SLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
170 DO 20 I = 1, MNMIN
171 COPYS( I ) = ZERO
172 20 CONTINUE
173 ELSE
174 CALL SLATMS( M, N, 'Uniform', ISEED,
175 $ 'Nonsymmetric', COPYS, IMODE,
176 $ ONE / EPS, ONE, M, N, 'No packing', A,
177 $ LDA, WORK, INFO )
178 CALL SGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
179 $ INFO )
180 CALL SLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
181 $ LDA )
182 CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
183 END IF
184 *
185 * Save A and its singular values
186 *
187 CALL SLACPY( 'All', M, N, A, LDA, COPYA, LDA )
188 *
189 * Call STZRQF to reduce the upper trapezoidal matrix to
190 * upper triangular form.
191 *
192 SRNAMT = 'STZRQF'
193 CALL STZRQF( M, N, A, LDA, TAU, INFO )
194 *
195 * Compute norm(svd(a) - svd(r))
196 *
197 RESULT( 1 ) = SQRT12( M, M, A, LDA, COPYS, WORK,
198 $ LWORK )
199 *
200 * Compute norm( A - R*Q )
201 *
202 RESULT( 2 ) = STZT01( M, N, COPYA, A, LDA, TAU, WORK,
203 $ LWORK )
204 *
205 * Compute norm(Q'*Q - I).
206 *
207 RESULT( 3 ) = STZT02( M, N, A, LDA, TAU, WORK, LWORK )
208 *
209 * Test STZRZF
210 *
211 * Generate test matrix of size m by n using
212 * singular value distribution indicated by `mode'.
213 *
214 IF( MODE.EQ.0 ) THEN
215 CALL SLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
216 DO 30 I = 1, MNMIN
217 COPYS( I ) = ZERO
218 30 CONTINUE
219 ELSE
220 CALL SLATMS( M, N, 'Uniform', ISEED,
221 $ 'Nonsymmetric', COPYS, IMODE,
222 $ ONE / EPS, ONE, M, N, 'No packing', A,
223 $ LDA, WORK, INFO )
224 CALL SGEQR2( M, N, A, LDA, WORK, WORK( MNMIN+1 ),
225 $ INFO )
226 CALL SLASET( 'Lower', M-1, N, ZERO, ZERO, A( 2 ),
227 $ LDA )
228 CALL SLAORD( 'Decreasing', MNMIN, COPYS, 1 )
229 END IF
230 *
231 * Save A and its singular values
232 *
233 CALL SLACPY( 'All', M, N, A, LDA, COPYA, LDA )
234 *
235 * Call STZRZF to reduce the upper trapezoidal matrix to
236 * upper triangular form.
237 *
238 SRNAMT = 'STZRZF'
239 CALL STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
240 *
241 * Compute norm(svd(a) - svd(r))
242 *
243 RESULT( 4 ) = SQRT12( M, M, A, LDA, COPYS, WORK,
244 $ LWORK )
245 *
246 * Compute norm( A - R*Q )
247 *
248 RESULT( 5 ) = SRZT01( M, N, COPYA, A, LDA, TAU, WORK,
249 $ LWORK )
250 *
251 * Compute norm(Q'*Q - I).
252 *
253 RESULT( 6 ) = SRZT02( M, N, A, LDA, TAU, WORK, LWORK )
254 *
255 * Print information about the tests that did not pass
256 * the threshold.
257 *
258 DO 40 K = 1, 6
259 IF( RESULT( K ).GE.THRESH ) THEN
260 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
261 $ CALL ALAHD( NOUT, PATH )
262 WRITE( NOUT, FMT = 9999 )M, N, IMODE, K,
263 $ RESULT( K )
264 NFAIL = NFAIL + 1
265 END IF
266 40 CONTINUE
267 NRUN = NRUN + 6
268 50 CONTINUE
269 END IF
270 60 CONTINUE
271 70 CONTINUE
272 *
273 * Print a summary of the results.
274 *
275 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
276 *
277 9999 FORMAT( ' M =', I5, ', N =', I5, ', type ', I2, ', test ', I2,
278 $ ', ratio =', G12.5 )
279 *
280 * End if SCHKTZ
281 *
282 END