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