LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
dchkqr.f
Go to the documentation of this file.
1*> \brief \b DCHKQR
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 DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
12* NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, 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( * ), AQ( * ), AR( * ),
25* $ B( * ), RWORK( * ), TAU( * ), WORK( * ),
26* $ X( * ), XACT( * )
27* ..
28*
29*
30*> \par Purpose:
31* =============
32*>
33*> \verbatim
34*>
35*> DCHKQR tests DGEQRF, DORGQR and DORMQR.
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] AR
137*> \verbatim
138*> AR 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*> \ingroup double_lin
196*
197* =====================================================================
198 SUBROUTINE dchkqr( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
199 $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AR, AC,
200 $ B, X, XACT, TAU, WORK, RWORK, IWORK, NOUT )
201*
202* -- LAPACK test routine --
203* -- LAPACK is a software package provided by Univ. of Tennessee, --
204* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
205*
206* .. Scalar Arguments ..
207 LOGICAL TSTERR
208 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
209 DOUBLE PRECISION THRESH
210* ..
211* .. Array Arguments ..
212 LOGICAL DOTYPE( * )
213 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
214 $ nxval( * )
215 DOUBLE PRECISION A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
216 $ B( * ), RWORK( * ), TAU( * ), WORK( * ),
217 $ x( * ), xact( * )
218* ..
219*
220* =====================================================================
221*
222* .. Parameters ..
223 INTEGER NTESTS
224 PARAMETER ( NTESTS = 9 )
225 INTEGER NTYPES
226 parameter( ntypes = 8 )
227 DOUBLE PRECISION ZERO
228 parameter( zero = 0.0d0 )
229* ..
230* .. Local Scalars ..
231 CHARACTER DIST, TYPE
232 CHARACTER*3 PATH
233 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
234 $ lwork, m, minmn, mode, n, nb, nerrs, nfail, nk,
235 $ nrun, nt, nx
236 DOUBLE PRECISION ANORM, CNDNUM
237* ..
238* .. Local Arrays ..
239 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
240 DOUBLE PRECISION RESULT( NTESTS )
241* ..
242* .. External Functions ..
243 LOGICAL DGENND
244 EXTERNAL DGENND
245* ..
246* .. External Subroutines ..
247 EXTERNAL alaerh, alahd, alasum, derrqr, dgels, dget02,
248 $ dlacpy, dlarhs, dlatb4, dlatms, dqrt01,
249 $ dqrt01p, dqrt02, dqrt03, xlaenv
250* ..
251* .. Intrinsic Functions ..
252 INTRINSIC max, min
253* ..
254* .. Scalars in Common ..
255 LOGICAL LERR, OK
256 CHARACTER*32 SRNAMT
257 INTEGER INFOT, NUNIT
258* ..
259* .. Common blocks ..
260 COMMON / infoc / infot, nunit, ok, lerr
261 COMMON / srnamc / srnamt
262* ..
263* .. Data statements ..
264 DATA iseedy / 1988, 1989, 1990, 1991 /
265* ..
266* .. Executable Statements ..
267*
268* Initialize constants and the random number seed.
269*
270 path( 1: 1 ) = 'Double precision'
271 path( 2: 3 ) = 'QR'
272 nrun = 0
273 nfail = 0
274 nerrs = 0
275 DO 10 i = 1, 4
276 iseed( i ) = iseedy( i )
277 10 CONTINUE
278*
279* Test the error exits
280*
281 IF( tsterr )
282 $ CALL derrqr( path, nout )
283 infot = 0
284 CALL xlaenv( 2, 2 )
285*
286 lda = nmax
287 lwork = nmax*max( nmax, nrhs )
288*
289* Do for each value of M in MVAL.
290*
291 DO 70 im = 1, nm
292 m = mval( im )
293*
294* Do for each value of N in NVAL.
295*
296 DO 60 in = 1, nn
297 n = nval( in )
298 minmn = min( m, n )
299 DO 50 imat = 1, ntypes
300*
301* Do the tests only if DOTYPE( IMAT ) is true.
302*
303 IF( .NOT.dotype( imat ) )
304 $ GO TO 50
305*
306* Set up parameters with DLATB4 and generate a test matrix
307* with DLATMS.
308*
309 CALL dlatb4( path, imat, m, n, TYPE, kl, ku, anorm, mode,
310 $ cndnum, dist )
311*
312 srnamt = 'DLATMS'
313 CALL dlatms( m, n, dist, iseed, TYPE, rwork, mode,
314 $ cndnum, anorm, kl, ku, 'No packing', a, lda,
315 $ work, info )
316*
317* Check error code from DLATMS.
318*
319 IF( info.NE.0 ) THEN
320 CALL alaerh( path, 'DLATMS', info, 0, ' ', m, n, -1,
321 $ -1, -1, imat, nfail, nerrs, nout )
322 GO TO 50
323 END IF
324*
325* Set some values for K: the first value must be MINMN,
326* corresponding to the call of DQRT01; other values are
327* used in the calls of DQRT02, and must not exceed MINMN.
328*
329 kval( 1 ) = minmn
330 kval( 2 ) = 0
331 kval( 3 ) = 1
332 kval( 4 ) = minmn / 2
333 IF( minmn.EQ.0 ) THEN
334 nk = 1
335 ELSE IF( minmn.EQ.1 ) THEN
336 nk = 2
337 ELSE IF( minmn.LE.3 ) THEN
338 nk = 3
339 ELSE
340 nk = 4
341 END IF
342*
343* Do for each value of K in KVAL
344*
345 DO 40 ik = 1, nk
346 k = kval( ik )
347*
348* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
349*
350 DO 30 inb = 1, nnb
351 nb = nbval( inb )
352 CALL xlaenv( 1, nb )
353 nx = nxval( inb )
354 CALL xlaenv( 3, nx )
355 DO i = 1, ntests
356 result( i ) = zero
357 END DO
358 nt = 2
359 IF( ik.EQ.1 ) THEN
360*
361* Test DGEQRF
362*
363 CALL dqrt01( m, n, a, af, aq, ar, lda, tau,
364 $ work, lwork, rwork, result( 1 ) )
365
366*
367* Test DGEQRFP
368*
369 CALL dqrt01p( m, n, a, af, aq, ar, lda, tau,
370 $ work, lwork, rwork, result( 8 ) )
371
372 IF( .NOT. dgennd( m, n, af, lda ) )
373 $ result( 9 ) = 2*thresh
374 nt = nt + 1
375 ELSE IF( m.GE.n ) THEN
376*
377* Test DORGQR, using factorization
378* returned by DQRT01
379*
380 CALL dqrt02( m, n, k, a, af, aq, ar, lda, tau,
381 $ work, lwork, rwork, result( 1 ) )
382 END IF
383 IF( m.GE.k ) THEN
384*
385* Test DORMQR, using factorization returned
386* by DQRT01
387*
388 CALL dqrt03( m, n, k, af, ac, ar, aq, lda, tau,
389 $ work, lwork, rwork, result( 3 ) )
390 nt = nt + 4
391*
392* If M>=N and K=N, call DGELS to solve a system
393* with NRHS right hand sides and compute the
394* residual.
395*
396 IF( k.EQ.n .AND. inb.EQ.1 ) THEN
397*
398* Generate a solution and set the right
399* hand side.
400*
401 srnamt = 'DLARHS'
402 CALL dlarhs( path, 'New', 'Full',
403 $ 'No transpose', m, n, 0, 0,
404 $ nrhs, a, lda, xact, lda, b, lda,
405 $ iseed, info )
406*
407 CALL dlacpy( 'Full', m, nrhs, b, lda, x,
408 $ lda )
409*
410* Reset AF. DGELS overwrites the matrix with
411* its factorization.
412*
413 CALL dlacpy( 'Full', m, n, a, lda, af, lda )
414*
415 srnamt = 'DGELS'
416 CALL dgels( 'No transpose', m, n, nrhs, af,
417 $ lda, x, lda, work, lwork, info )
418*
419* Check error code from DGELS.
420*
421 IF( info.NE.0 )
422 $ CALL alaerh( path, 'DGELS', info, 0, 'N',
423 $ m, n, nrhs, -1, nb, imat,
424 $ nfail, nerrs, nout )
425*
426 CALL dget02( 'No transpose', m, n, nrhs, a,
427 $ lda, x, lda, b, lda, rwork,
428 $ result( 7 ) )
429 nt = nt + 1
430 END IF
431 END IF
432*
433* Print information about the tests that did not
434* pass the threshold.
435*
436 DO 20 i = 1, ntests
437 IF( result( i ).GE.thresh ) THEN
438 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
439 $ CALL alahd( nout, path )
440 WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
441 $ imat, i, result( i )
442 nfail = nfail + 1
443 END IF
444 20 CONTINUE
445 nrun = nrun + ntests
446 30 CONTINUE
447 40 CONTINUE
448 50 CONTINUE
449 60 CONTINUE
450 70 CONTINUE
451*
452* Print a summary of the results.
453*
454 CALL alasum( path, nout, nfail, nrun, nerrs )
455*
456 9999 FORMAT( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
457 $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
458 RETURN
459*
460* End of DCHKQR
461*
462 END
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
dget02
subroutine dget02(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
DGET02
Definition dget02.f:135
dlarhs
subroutine dlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
DLARHS
Definition dlarhs.f:205
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
dchkqr
subroutine dchkqr(dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, ar, ac, b, x, xact, tau, work, rwork, iwork, nout)
DCHKQR
Definition dchkqr.f:201
derrqr
subroutine derrqr(path, nunit)
DERRQR
Definition derrqr.f:55
dlatb4
subroutine dlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
DLATB4
Definition dlatb4.f:120
dlatms
subroutine dlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
DLATMS
Definition dlatms.f:321
dqrt01
subroutine dqrt01(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
DQRT01
Definition dqrt01.f:126
dqrt01p
subroutine dqrt01p(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
DQRT01P
Definition dqrt01p.f:126
dqrt02
subroutine dqrt02(m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
DQRT02
Definition dqrt02.f:135
dqrt03
subroutine dqrt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
DQRT03
Definition dqrt03.f:136
dgels
subroutine dgels(trans, m, n, nrhs, a, lda, b, ldb, work, lwork, info)
DGELS solves overdetermined or underdetermined systems for GE matrices
Definition dgels.f:192
dlacpy
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.
Definition dlacpy.f:101