LAPACK  3.4.2 LAPACK: Linear Algebra PACKage
cchkqp.f
Go to the documentation of this file.
1 *> \brief \b CCHKQP
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * SUBROUTINE CCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
12 * COPYA, S, TAU, WORK, RWORK, IWORK,
13 * NOUT )
14 *
15 * .. Scalar Arguments ..
16 * LOGICAL TSTERR
17 * INTEGER NM, NN, NOUT
18 * REAL THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER IWORK( * ), MVAL( * ), NVAL( * )
23 * REAL S( * ), RWORK( * )
24 * COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * )
25 * ..
26 *
27 *
28 *> \par Purpose:
29 * =============
30 *>
31 *> \verbatim
32 *>
33 *> CCHKQP tests CGEQPF.
34 *> \endverbatim
35 *
36 * Arguments:
37 * ==========
38 *
39 *> \param[in] DOTYPE
40 *> \verbatim
41 *> DOTYPE is LOGICAL array, dimension (NTYPES)
42 *> The matrix types to be used for testing. Matrices of type j
43 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
44 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
45 *> \endverbatim
46 *>
47 *> \param[in] NM
48 *> \verbatim
49 *> NM is INTEGER
50 *> The number of values of M contained in the vector MVAL.
51 *> \endverbatim
52 *>
53 *> \param[in] MVAL
54 *> \verbatim
55 *> MVAL is INTEGER array, dimension (NM)
56 *> The values of the matrix row dimension M.
57 *> \endverbatim
58 *>
59 *> \param[in] NN
60 *> \verbatim
61 *> NN is INTEGER
62 *> The number of values of N contained in the vector NVAL.
63 *> \endverbatim
64 *>
65 *> \param[in] NVAL
66 *> \verbatim
67 *> NVAL is INTEGER array, dimension (NN)
68 *> The values of the matrix column dimension N.
69 *> \endverbatim
70 *>
71 *> \param[in] THRESH
72 *> \verbatim
73 *> THRESH is REAL
74 *> The threshold value for the test ratios. A result is
75 *> included in the output file if RESULT >= THRESH. To have
76 *> every test ratio printed, use THRESH = 0.
77 *> \endverbatim
78 *>
79 *> \param[in] TSTERR
80 *> \verbatim
81 *> TSTERR is LOGICAL
82 *> Flag that indicates whether error exits are to be tested.
83 *> \endverbatim
84 *>
85 *> \param[out] A
86 *> \verbatim
87 *> A is COMPLEX array, dimension (MMAX*NMAX)
88 *> where MMAX is the maximum value of M in MVAL and NMAX is the
89 *> maximum value of N in NVAL.
90 *> \endverbatim
91 *>
92 *> \param[out] COPYA
93 *> \verbatim
94 *> COPYA is COMPLEX array, dimension (MMAX*NMAX)
95 *> \endverbatim
96 *>
97 *> \param[out] S
98 *> \verbatim
99 *> S is REAL array, dimension
100 *> (min(MMAX,NMAX))
101 *> \endverbatim
102 *>
103 *> \param[out] TAU
104 *> \verbatim
105 *> TAU is COMPLEX array, dimension (MMAX)
106 *> \endverbatim
107 *>
108 *> \param[out] WORK
109 *> \verbatim
110 *> WORK is COMPLEX array, dimension
111 *> (max(M*max(M,N) + 4*min(M,N) + max(M,N)))
112 *> \endverbatim
113 *>
114 *> \param[out] RWORK
115 *> \verbatim
116 *> RWORK is REAL array, dimension (4*NMAX)
117 *> \endverbatim
118 *>
119 *> \param[out] IWORK
120 *> \verbatim
121 *> IWORK is INTEGER array, dimension (NMAX)
122 *> \endverbatim
123 *>
124 *> \param[in] NOUT
125 *> \verbatim
126 *> NOUT is INTEGER
127 *> The unit number for output.
128 *> \endverbatim
129 *
130 * Authors:
131 * ========
132 *
133 *> \author Univ. of Tennessee
134 *> \author Univ. of California Berkeley
135 *> \author Univ. of Colorado Denver
136 *> \author NAG Ltd.
137 *
138 *> \date November 2011
139 *
140 *> \ingroup complex_lin
141 *
142 * =====================================================================
143  SUBROUTINE cchkqp( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR, A,
144  \$ copya, s, tau, work, rwork, iwork,
145  \$ nout )
146 *
147 * -- LAPACK test routine (version 3.4.0) --
148 * -- LAPACK is a software package provided by Univ. of Tennessee, --
149 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
150 * November 2011
151 *
152 * .. Scalar Arguments ..
153  LOGICAL tsterr
154  INTEGER nm, nn, nout
155  REAL thresh
156 * ..
157 * .. Array Arguments ..
158  LOGICAL dotype( * )
159  INTEGER iwork( * ), mval( * ), nval( * )
160  REAL s( * ), rwork( * )
161  COMPLEX a( * ), copya( * ), tau( * ), work( * )
162 * ..
163 *
164 * =====================================================================
165 *
166 * .. Parameters ..
167  INTEGER ntypes
168  parameter( ntypes = 6 )
169  INTEGER ntests
170  parameter( ntests = 3 )
171  REAL one, zero
172  parameter( one = 1.0e0, zero = 0.0e0 )
173 * ..
174 * .. Local Scalars ..
175  CHARACTER*3 path
176  INTEGER i, ihigh, ilow, im, imode, in, info, istep, k,
177  \$ lda, lwork, m, mnmin, mode, n, nerrs, nfail,
178  \$ nrun
179  REAL eps
180 * ..
181 * .. Local Arrays ..
182  INTEGER iseed( 4 ), iseedy( 4 )
183  REAL result( ntests )
184 * ..
185 * .. External Functions ..
186  REAL cqpt01, cqrt11, cqrt12, slamch
187  EXTERNAL cqpt01, cqrt11, cqrt12, slamch
188 * ..
189 * .. External Subroutines ..
190  EXTERNAL alahd, alasum, cerrqp, cgeqpf, clacpy, claset,
191  \$ clatms, slaord
192 * ..
193 * .. Intrinsic Functions ..
194  INTRINSIC cmplx, max, min
195 * ..
196 * .. Scalars in Common ..
197  LOGICAL lerr, ok
198  CHARACTER*32 srnamt
199  INTEGER infot, iounit
200 * ..
201 * .. Common blocks ..
202  common / infoc / infot, iounit, ok, lerr
203  common / srnamc / srnamt
204 * ..
205 * .. Data statements ..
206  DATA iseedy / 1988, 1989, 1990, 1991 /
207 * ..
208 * .. Executable Statements ..
209 *
210 * Initialize constants and the random number seed.
211 *
212  path( 1: 1 ) = 'Complex precision'
213  path( 2: 3 ) = 'QP'
214  nrun = 0
215  nfail = 0
216  nerrs = 0
217  DO 10 i = 1, 4
218  iseed( i ) = iseedy( i )
219  10 continue
220  eps = slamch( 'Epsilon' )
221 *
222 * Test the error exits
223 *
224  IF( tsterr )
225  \$ CALL cerrqp( path, nout )
226  infot = 0
227 *
228  DO 80 im = 1, nm
229 *
230 * Do for each value of M in MVAL.
231 *
232  m = mval( im )
233  lda = max( 1, m )
234 *
235  DO 70 in = 1, nn
236 *
237 * Do for each value of N in NVAL.
238 *
239  n = nval( in )
240  mnmin = min( m, n )
241  lwork = max( 1, m*max( m, n )+4*mnmin+max( m, n ) )
242 *
243  DO 60 imode = 1, ntypes
244  IF( .NOT.dotype( imode ) )
245  \$ go to 60
246 *
247 * Do for each type of matrix
248 * 1: zero matrix
249 * 2: one small singular value
250 * 3: geometric distribution of singular values
251 * 4: first n/2 columns fixed
252 * 5: last n/2 columns fixed
253 * 6: every second column fixed
254 *
255  mode = imode
256  IF( imode.GT.3 )
257  \$ mode = 1
258 *
259 * Generate test matrix of size m by n using
260 * singular value distribution indicated by `mode'.
261 *
262  DO 20 i = 1, n
263  iwork( i ) = 0
264  20 continue
265  IF( imode.EQ.1 ) THEN
266  CALL claset( 'Full', m, n, cmplx( zero ),
267  \$ cmplx( zero ), copya, lda )
268  DO 30 i = 1, mnmin
269  s( i ) = zero
270  30 continue
271  ELSE
272  CALL clatms( m, n, 'Uniform', iseed, 'Nonsymm', s,
273  \$ mode, one / eps, one, m, n, 'No packing',
274  \$ copya, lda, work, info )
275  IF( imode.GE.4 ) THEN
276  IF( imode.EQ.4 ) THEN
277  ilow = 1
278  istep = 1
279  ihigh = max( 1, n / 2 )
280  ELSE IF( imode.EQ.5 ) THEN
281  ilow = max( 1, n / 2 )
282  istep = 1
283  ihigh = n
284  ELSE IF( imode.EQ.6 ) THEN
285  ilow = 1
286  istep = 2
287  ihigh = n
288  END IF
289  DO 40 i = ilow, ihigh, istep
290  iwork( i ) = 1
291  40 continue
292  END IF
293  CALL slaord( 'Decreasing', mnmin, s, 1 )
294  END IF
295 *
296 * Save A and its singular values
297 *
298  CALL clacpy( 'All', m, n, copya, lda, a, lda )
299 *
300 * Compute the QR factorization with pivoting of A
301 *
302  srnamt = 'CGEQPF'
303  CALL cgeqpf( m, n, a, lda, iwork, tau, work, rwork,
304  \$ info )
305 *
306 * Compute norm(svd(a) - svd(r))
307 *
308  result( 1 ) = cqrt12( m, n, a, lda, s, work, lwork,
309  \$ rwork )
310 *
311 * Compute norm( A*P - Q*R )
312 *
313  result( 2 ) = cqpt01( m, n, mnmin, copya, a, lda, tau,
314  \$ iwork, work, lwork )
315 *
316 * Compute Q'*Q
317 *
318  result( 3 ) = cqrt11( m, mnmin, a, lda, tau, work,
319  \$ lwork )
320 *
321 * Print information about the tests that did not pass
322 * the threshold.
323 *
324  DO 50 k = 1, 3
325  IF( result( k ).GE.thresh ) THEN
326  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
327  \$ CALL alahd( nout, path )
328  WRITE( nout, fmt = 9999 )m, n, imode, k,
329  \$ result( k )
330  nfail = nfail + 1
331  END IF
332  50 continue
333  nrun = nrun + 3
334  60 continue
335  70 continue
336  80 continue
337 *
338 * Print a summary of the results.
339 *
340  CALL alasum( path, nout, nfail, nrun, nerrs )
341 *
342  9999 format( ' M =', i5, ', N =', i5, ', type ', i2, ', test ', i2,
343  \$ ', ratio =', g12.5 )
344 *
345 * End of CCHKQP
346 *
347  END