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