LAPACK  3.10.1
LAPACK: Linear Algebra PACKage
schkqr.f
Go to the documentation of this file.
1 *> \brief \b SCHKQR
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 SCHKQR( 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 * REAL THRESH
19 * ..
20 * .. Array Arguments ..
21 * LOGICAL DOTYPE( * )
22 * INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
23 * $ NXVAL( * )
24 * REAL 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 *> SCHKQR tests SGEQRF, SORGQR and SORMQR.
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 REAL
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 REAL array, dimension (NMAX*NMAX)
124 *> \endverbatim
125 *>
126 *> \param[out] AF
127 *> \verbatim
128 *> AF is REAL array, dimension (NMAX*NMAX)
129 *> \endverbatim
130 *>
131 *> \param[out] AQ
132 *> \verbatim
133 *> AQ is REAL array, dimension (NMAX*NMAX)
134 *> \endverbatim
135 *>
136 *> \param[out] AR
137 *> \verbatim
138 *> AR is REAL array, dimension (NMAX*NMAX)
139 *> \endverbatim
140 *>
141 *> \param[out] AC
142 *> \verbatim
143 *> AC is REAL array, dimension (NMAX*NMAX)
144 *> \endverbatim
145 *>
146 *> \param[out] B
147 *> \verbatim
148 *> B is REAL array, dimension (NMAX*NRHS)
149 *> \endverbatim
150 *>
151 *> \param[out] X
152 *> \verbatim
153 *> X is REAL array, dimension (NMAX*NRHS)
154 *> \endverbatim
155 *>
156 *> \param[out] XACT
157 *> \verbatim
158 *> XACT is REAL array, dimension (NMAX*NRHS)
159 *> \endverbatim
160 *>
161 *> \param[out] TAU
162 *> \verbatim
163 *> TAU is REAL array, dimension (NMAX)
164 *> \endverbatim
165 *>
166 *> \param[out] WORK
167 *> \verbatim
168 *> WORK is REAL array, dimension (NMAX*NMAX)
169 *> \endverbatim
170 *>
171 *> \param[out] RWORK
172 *> \verbatim
173 *> RWORK is REAL 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 single_lin
196 *
197 * =====================================================================
198  SUBROUTINE schkqr( 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  REAL THRESH
210 * ..
211 * .. Array Arguments ..
212  LOGICAL DOTYPE( * )
213  INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
214  $ nxval( * )
215  REAL 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  REAL ZERO
228  parameter( zero = 0.0e0 )
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  REAL ANORM, CNDNUM
237 * ..
238 * .. Local Arrays ..
239  INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
240  REAL RESULT( NTESTS )
241 * ..
242 * .. External Functions ..
243  LOGICAL SGENND
244  EXTERNAL SGENND
245 * ..
246 * .. External Subroutines ..
247  EXTERNAL alaerh, alahd, alasum, serrqr, sgeqrs, sget02,
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 ) = 'Single 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 serrqr( 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 SLATB4 and generate a test matrix
307 * with SLATMS.
308 *
309  CALL slatb4( path, imat, m, n, TYPE, kl, ku, anorm, mode,
310  $ cndnum, dist )
311 *
312  srnamt = 'SLATMS'
313  CALL slatms( 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 SLATMS.
318 *
319  IF( info.NE.0 ) THEN
320  CALL alaerh( path, 'SLATMS', 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 SQRT01; other values are
327 * used in the calls of SQRT02, 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 SGEQRF
362 *
363  CALL sqrt01( m, n, a, af, aq, ar, lda, tau,
364  $ work, lwork, rwork, result( 1 ) )
365 *
366 * Test SGEQRFP
367 *
368  CALL sqrt01p( m, n, a, af, aq, ar, lda, tau,
369  $ work, lwork, rwork, result( 8 ) )
370 
371  IF( .NOT. sgennd( m, n, af, lda ) )
372  $ result( 9 ) = 2*thresh
373  nt = nt + 1
374  ELSE IF( m.GE.n ) THEN
375 *
376 * Test SORGQR, using factorization
377 * returned by SQRT01
378 *
379  CALL sqrt02( m, n, k, a, af, aq, ar, lda, tau,
380  $ work, lwork, rwork, result( 1 ) )
381  END IF
382  IF( m.GE.k ) THEN
383 *
384 * Test SORMQR, using factorization returned
385 * by SQRT01
386 *
387  CALL sqrt03( m, n, k, af, ac, ar, aq, lda, tau,
388  $ work, lwork, rwork, result( 3 ) )
389  nt = nt + 4
390 *
391 * If M>=N and K=N, call SGEQRS to solve a system
392 * with NRHS right hand sides and compute the
393 * residual.
394 *
395  IF( k.EQ.n .AND. inb.EQ.1 ) THEN
396 *
397 * Generate a solution and set the right
398 * hand side.
399 *
400  srnamt = 'SLARHS'
401  CALL slarhs( path, 'New', 'Full',
402  $ 'No transpose', m, n, 0, 0,
403  $ nrhs, a, lda, xact, lda, b, lda,
404  $ iseed, info )
405 *
406  CALL slacpy( 'Full', m, nrhs, b, lda, x,
407  $ lda )
408  srnamt = 'SGEQRS'
409  CALL sgeqrs( m, n, nrhs, af, lda, tau, x,
410  $ lda, work, lwork, info )
411 *
412 * Check error code from SGEQRS.
413 *
414  IF( info.NE.0 )
415  $ CALL alaerh( path, 'SGEQRS', info, 0, ' ',
416  $ m, n, nrhs, -1, nb, imat,
417  $ nfail, nerrs, nout )
418 *
419  CALL sget02( 'No transpose', m, n, nrhs, a,
420  $ lda, x, lda, b, lda, rwork,
421  $ result( 7 ) )
422  nt = nt + 1
423  END IF
424  END IF
425 *
426 * Print information about the tests that did not
427 * pass the threshold.
428 *
429  DO 20 i = 1, ntests
430  IF( result( i ).GE.thresh ) THEN
431  IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
432  $ CALL alahd( nout, path )
433  WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
434  $ imat, i, result( i )
435  nfail = nfail + 1
436  END IF
437  20 CONTINUE
438  nrun = nrun + ntests
439  30 CONTINUE
440  40 CONTINUE
441  50 CONTINUE
442  60 CONTINUE
443  70 CONTINUE
444 *
445 * Print a summary of the results.
446 *
447  CALL alasum( path, nout, nfail, nrun, nerrs )
448 *
449  9999 FORMAT( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
450  $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
451  RETURN
452 *
453 * End of SCHKQR
454 *
455  END
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:103
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
Definition: alasum.f:73
subroutine xlaenv(ISPEC, NVALUE)
XLAENV
Definition: xlaenv.f:81
subroutine alahd(IOUNIT, PATH)
ALAHD
Definition: alahd.f:107
subroutine alaerh(PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, N5, IMAT, NFAIL, NERRS, NOUT)
ALAERH
Definition: alaerh.f:147
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:321
subroutine sget02(TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB, RWORK, RESID)
SGET02
Definition: sget02.f:135
subroutine slarhs(PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS, A, LDA, X, LDX, B, LDB, ISEED, INFO)
SLARHS
Definition: slarhs.f:205
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
Definition: slatb4.f:120
subroutine sqrt01p(M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
SQRT01P
Definition: sqrt01p.f:126
subroutine serrqr(PATH, NUNIT)
SERRQR
Definition: serrqr.f:55
subroutine sqrt02(M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
SQRT02
Definition: sqrt02.f:135
subroutine sqrt01(M, N, A, AF, Q, R, LDA, TAU, WORK, LWORK, RWORK, RESULT)
SQRT01
Definition: sqrt01.f:126
subroutine sgeqrs(M, N, NRHS, A, LDA, TAU, B, LDB, WORK, LWORK, INFO)
SGEQRS
Definition: sgeqrs.f:121
subroutine sqrt03(M, N, K, AF, C, CC, Q, LDA, TAU, WORK, LWORK, RWORK, RESULT)
SQRT03
Definition: sqrt03.f:136
subroutine schkqr(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)
SCHKQR
Definition: schkqr.f:201