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