LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
dchkql.f
Go to the documentation of this file.
1 *> \brief \b DCHKQL
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 DCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
12 * NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC,
13 * B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
14 *
15 * .. Scalar Arguments ..
16 * LOGICAL TSTERR
17 * INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
18 * DOUBLE PRECISION THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
23 * $ NXVAL( * )
24 * DOUBLE PRECISION A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
25 * $ B( * ), RWORK( * ), TAU( * ), WORK( * ),
26 * $ X( * ), XACT( * )
27 * ..
28 *
29 *
30 *> \par Purpose:
31 * =============
32 *>
33 *> \verbatim
34 *>
35 *> DCHKQL tests DGEQLF, DORGQL and DORMQL.
36 *> \endverbatim
37 *
38 * Arguments:
39 * ==========
40 *
41 *> \param[in] DOTYPE
42 *> \verbatim
43 *> DOTYPE is LOGICAL array, dimension (NTYPES)
44 *> The matrix types to be used for testing. Matrices of type j
45 *> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
46 *> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
47 *> \endverbatim
48 *>
49 *> \param[in] NM
50 *> \verbatim
51 *> NM is INTEGER
52 *> The number of values of M contained in the vector MVAL.
53 *> \endverbatim
54 *>
55 *> \param[in] MVAL
56 *> \verbatim
57 *> MVAL is INTEGER array, dimension (NM)
58 *> The values of the matrix row dimension M.
59 *> \endverbatim
60 *>
61 *> \param[in] NN
62 *> \verbatim
63 *> NN is INTEGER
64 *> The number of values of N contained in the vector NVAL.
65 *> \endverbatim
66 *>
67 *> \param[in] NVAL
68 *> \verbatim
69 *> NVAL is INTEGER array, dimension (NN)
70 *> The values of the matrix column dimension N.
71 *> \endverbatim
72 *>
73 *> \param[in] NNB
74 *> \verbatim
75 *> NNB is INTEGER
76 *> The number of values of NB and NX contained in the
77 *> vectors NBVAL and NXVAL. The blocking parameters are used
78 *> in pairs (NB,NX).
79 *> \endverbatim
80 *>
81 *> \param[in] NBVAL
82 *> \verbatim
83 *> NBVAL is INTEGER array, dimension (NNB)
84 *> The values of the blocksize NB.
85 *> \endverbatim
86 *>
87 *> \param[in] NXVAL
88 *> \verbatim
89 *> NXVAL is INTEGER array, dimension (NNB)
90 *> The values of the crossover point NX.
91 *> \endverbatim
92 *>
93 *> \param[in] NRHS
94 *> \verbatim
95 *> NRHS is INTEGER
96 *> The number of right hand side vectors to be generated for
97 *> each linear system.
98 *> \endverbatim
99 *>
100 *> \param[in] THRESH
101 *> \verbatim
102 *> THRESH is DOUBLE PRECISION
103 *> The threshold value for the test ratios. A result is
104 *> included in the output file if RESULT >= THRESH. To have
105 *> every test ratio printed, use THRESH = 0.
106 *> \endverbatim
107 *>
108 *> \param[in] TSTERR
109 *> \verbatim
110 *> TSTERR is LOGICAL
111 *> Flag that indicates whether error exits are to be tested.
112 *> \endverbatim
113 *>
114 *> \param[in] NMAX
115 *> \verbatim
116 *> NMAX is INTEGER
117 *> The maximum value permitted for M or N, used in dimensioning
118 *> the work arrays.
119 *> \endverbatim
120 *>
121 *> \param[out] A
122 *> \verbatim
123 *> A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
124 *> \endverbatim
125 *>
126 *> \param[out] AF
127 *> \verbatim
128 *> AF is DOUBLE PRECISION array, dimension (NMAX*NMAX)
129 *> \endverbatim
130 *>
131 *> \param[out] AQ
132 *> \verbatim
133 *> AQ is DOUBLE PRECISION array, dimension (NMAX*NMAX)
134 *> \endverbatim
135 *>
136 *> \param[out] AL
137 *> \verbatim
138 *> AL is DOUBLE PRECISION array, dimension (NMAX*NMAX)
139 *> \endverbatim
140 *>
141 *> \param[out] AC
142 *> \verbatim
143 *> AC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
144 *> \endverbatim
145 *>
146 *> \param[out] B
147 *> \verbatim
148 *> B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
149 *> \endverbatim
150 *>
151 *> \param[out] X
152 *> \verbatim
153 *> X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
154 *> \endverbatim
155 *>
156 *> \param[out] XACT
157 *> \verbatim
158 *> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
159 *> \endverbatim
160 *>
161 *> \param[out] TAU
162 *> \verbatim
163 *> TAU is DOUBLE PRECISION array, dimension (NMAX)
164 *> \endverbatim
165 *>
166 *> \param[out] WORK
167 *> \verbatim
168 *> WORK is DOUBLE PRECISION array, dimension (NMAX*NMAX)
169 *> \endverbatim
170 *>
171 *> \param[out] RWORK
172 *> \verbatim
173 *> RWORK is DOUBLE PRECISION array, dimension (NMAX)
174 *> \endverbatim
175 *>
176 *> \param[out] IWORK
177 *> \verbatim
178 *> IWORK is INTEGER array, dimension (NMAX)
179 *> \endverbatim
180 *>
181 *> \param[in] NOUT
182 *> \verbatim
183 *> NOUT is INTEGER
184 *> The unit number for output.
185 *> \endverbatim
186 *
187 * Authors:
188 * ========
189 *
190 *> \author Univ. of Tennessee
191 *> \author Univ. of California Berkeley
192 *> \author Univ. of Colorado Denver
193 *> \author NAG Ltd.
194 *
195 *> \date November 2011
196 *
197 *> \ingroup double_lin
198 *
199 * =====================================================================
200  SUBROUTINE dchkql( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
201  $ nrhs, thresh, tsterr, nmax, a, af, aq, al, ac,
202  $ b, x, xact, tau, work, rwork, iwork, nout )
203 *
204 * -- LAPACK test routine (version 3.4.0) --
205 * -- LAPACK is a software package provided by Univ. of Tennessee, --
206 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
207 * November 2011
208 *
209 * .. Scalar Arguments ..
210  LOGICAL tsterr
211  INTEGER nm, nmax, nn, nnb, nout, nrhs
212  DOUBLE PRECISION thresh
213 * ..
214 * .. Array Arguments ..
215  LOGICAL dotype( * )
216  INTEGER iwork( * ), mval( * ), nbval( * ), nval( * ),
217  $ nxval( * )
218  DOUBLE PRECISION a( * ), ac( * ), af( * ), al( * ), aq( * ),
219  $ b( * ), rwork( * ), tau( * ), work( * ),
220  $ x( * ), xact( * )
221 * ..
222 *
223 * =====================================================================
224 *
225 * .. Parameters ..
226  INTEGER ntests
227  parameter( ntests = 7 )
228  INTEGER ntypes
229  parameter( ntypes = 8 )
230  DOUBLE PRECISION zero
231  parameter( zero = 0.0d0 )
232 * ..
233 * .. Local Scalars ..
234  CHARACTER dist, type
235  CHARACTER*3 path
236  INTEGER i, ik, im, imat, in, inb, info, k, kl, ku, lda,
237  $ lwork, m, minmn, mode, n, nb, nerrs, nfail, nk,
238  $ nrun, nt, nx
239  DOUBLE PRECISION anorm, cndnum
240 * ..
241 * .. Local Arrays ..
242  INTEGER iseed( 4 ), iseedy( 4 ), kval( 4 )
243  DOUBLE PRECISION result( ntests )
244 * ..
245 * .. External Subroutines ..
246  EXTERNAL alaerh, alahd, alasum, derrql, dgeqls, dget02,
247  $ dlacpy, dlarhs, dlatb4, dlatms, dqlt01, dqlt02,
248  $ dqlt03, xlaenv
249 * ..
250 * .. Intrinsic Functions ..
251  INTRINSIC max, min
252 * ..
253 * .. Scalars in Common ..
254  LOGICAL lerr, ok
255  CHARACTER*32 srnamt
256  INTEGER infot, nunit
257 * ..
258 * .. Common blocks ..
259  common / infoc / infot, nunit, ok, lerr
260  common / srnamc / srnamt
261 * ..
262 * .. Data statements ..
263  DATA iseedy / 1988, 1989, 1990, 1991 /
264 * ..
265 * .. Executable Statements ..
266 *
267 * Initialize constants and the random number seed.
268 *
269  path( 1: 1 ) = 'Double precision'
270  path( 2: 3 ) = 'QL'
271  nrun = 0
272  nfail = 0
273  nerrs = 0
274  DO 10 i = 1, 4
275  iseed( i ) = iseedy( i )
276  10 continue
277 *
278 * Test the error exits
279 *
280  IF( tsterr )
281  $ CALL derrql( path, nout )
282  infot = 0
283  CALL xlaenv( 2, 2 )
284 *
285  lda = nmax
286  lwork = nmax*max( nmax, nrhs )
287 *
288 * Do for each value of M in MVAL.
289 *
290  DO 70 im = 1, nm
291  m = mval( im )
292 *
293 * Do for each value of N in NVAL.
294 *
295  DO 60 in = 1, nn
296  n = nval( in )
297  minmn = min( m, n )
298  DO 50 imat = 1, ntypes
299 *
300 * Do the tests only if DOTYPE( IMAT ) is true.
301 *
302  IF( .NOT.dotype( imat ) )
303  $ go to 50
304 *
305 * Set up parameters with DLATB4 and generate a test matrix
306 * with DLATMS.
307 *
308  CALL dlatb4( path, imat, m, n, type, kl, ku, anorm, mode,
309  $ cndnum, dist )
310 *
311  srnamt = 'DLATMS'
312  CALL dlatms( m, n, dist, iseed, type, rwork, mode,
313  $ cndnum, anorm, kl, ku, 'No packing', a, lda,
314  $ work, info )
315 *
316 * Check error code from DLATMS.
317 *
318  IF( info.NE.0 ) THEN
319  CALL alaerh( path, 'DLATMS', info, 0, ' ', m, n, -1,
320  $ -1, -1, imat, nfail, nerrs, nout )
321  go to 50
322  END IF
323 *
324 * Set some values for K: the first value must be MINMN,
325 * corresponding to the call of DQLT01; other values are
326 * used in the calls of DQLT02, and must not exceed MINMN.
327 *
328  kval( 1 ) = minmn
329  kval( 2 ) = 0
330  kval( 3 ) = 1
331  kval( 4 ) = minmn / 2
332  IF( minmn.EQ.0 ) THEN
333  nk = 1
334  ELSE IF( minmn.EQ.1 ) THEN
335  nk = 2
336  ELSE IF( minmn.LE.3 ) THEN
337  nk = 3
338  ELSE
339  nk = 4
340  END IF
341 *
342 * Do for each value of K in KVAL
343 *
344  DO 40 ik = 1, nk
345  k = kval( ik )
346 *
347 * Do for each pair of values (NB,NX) in NBVAL and NXVAL.
348 *
349  DO 30 inb = 1, nnb
350  nb = nbval( inb )
351  CALL xlaenv( 1, nb )
352  nx = nxval( inb )
353  CALL xlaenv( 3, nx )
354  DO i = 1, ntests
355  result( i ) = zero
356  END DO
357  nt = 2
358  IF( ik.EQ.1 ) THEN
359 *
360 * Test DGEQLF
361 *
362  CALL dqlt01( m, n, a, af, aq, al, lda, tau,
363  $ work, lwork, rwork, result( 1 ) )
364  ELSE IF( m.GE.n ) THEN
365 *
366 * Test DORGQL, using factorization
367 * returned by DQLT01
368 *
369  CALL dqlt02( m, n, k, a, af, aq, al, lda, tau,
370  $ work, lwork, rwork, result( 1 ) )
371  END IF
372  IF( m.GE.k ) THEN
373 *
374 * Test DORMQL, using factorization returned
375 * by DQLT01
376 *
377  CALL dqlt03( m, n, k, af, ac, al, aq, lda, tau,
378  $ work, lwork, rwork, result( 3 ) )
379  nt = nt + 4
380 *
381 * If M>=N and K=N, call DGEQLS to solve a system
382 * with NRHS right hand sides and compute the
383 * residual.
384 *
385  IF( k.EQ.n .AND. inb.EQ.1 ) THEN
386 *
387 * Generate a solution and set the right
388 * hand side.
389 *
390  srnamt = 'DLARHS'
391  CALL dlarhs( path, 'New', 'Full',
392  $ 'No transpose', m, n, 0, 0,
393  $ nrhs, a, lda, xact, lda, b, lda,
394  $ iseed, info )
395 *
396  CALL dlacpy( 'Full', m, nrhs, b, lda, x,
397  $ lda )
398  srnamt = 'DGEQLS'
399  CALL dgeqls( m, n, nrhs, af, lda, tau, x,
400  $ lda, work, lwork, info )
401 *
402 * Check error code from DGEQLS.
403 *
404  IF( info.NE.0 )
405  $ CALL alaerh( path, 'DGEQLS', info, 0, ' ',
406  $ m, n, nrhs, -1, nb, imat,
407  $ nfail, nerrs, nout )
408 *
409  CALL dget02( 'No transpose', m, n, nrhs, a,
410  $ lda, x( m-n+1 ), lda, b, lda,
411  $ rwork, result( 7 ) )
412  nt = nt + 1
413  END IF
414  END IF
415 *
416 * Print information about the tests that did not
417 * pass the threshold.
418 *
419  DO 20 i = 1, nt
420  IF( result( i ).GE.thresh ) THEN
421  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
422  $ CALL alahd( nout, path )
423  WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
424  $ imat, i, result( i )
425  nfail = nfail + 1
426  END IF
427  20 continue
428  nrun = nrun + nt
429  30 continue
430  40 continue
431  50 continue
432  60 continue
433  70 continue
434 *
435 * Print a summary of the results.
436 *
437  CALL alasum( path, nout, nfail, nrun, nerrs )
438 *
439  9999 format( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
440  $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
441  return
442 *
443 * End of DCHKQL
444 *
445  END