OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
schklq.f
Go to the documentation of this file.
1*> \brief \b SCHKLQ
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 SCHKLQ( 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, 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 MVAL( * ), NBVAL( * ), NVAL( * ),
23* $ NXVAL( * )
24* REAL 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*> SCHKLQ tests SGELQF, SORGLQ and SORMLQ.
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] AL
137*> \verbatim
138*> AL 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[in] NOUT
177*> \verbatim
178*> NOUT is INTEGER
179*> The unit number for output.
180*> \endverbatim
181*
182* Authors:
183* ========
184*
185*> \author Univ. of Tennessee
186*> \author Univ. of California Berkeley
187*> \author Univ. of Colorado Denver
188*> \author NAG Ltd.
189*
190*> \ingroup single_lin
191*
192* =====================================================================
193 SUBROUTINE schklq( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
194 $ NRHS, THRESH, TSTERR, NMAX, A, AF, AQ, AL, AC,
195 $ B, X, XACT, TAU, WORK, RWORK, NOUT )
196*
197* -- LAPACK test routine --
198* -- LAPACK is a software package provided by Univ. of Tennessee, --
199* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
200*
201* .. Scalar Arguments ..
202 LOGICAL TSTERR
203 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
204 REAL THRESH
205* ..
206* .. Array Arguments ..
207 LOGICAL DOTYPE( * )
208 INTEGER MVAL( * ), NBVAL( * ), NVAL( * ),
209 $ nxval( * )
210 REAL A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
211 $ B( * ), RWORK( * ), TAU( * ), WORK( * ),
212 $ x( * ), xact( * )
213* ..
214*
215* =====================================================================
216*
217* .. Parameters ..
218 INTEGER NTESTS
219 PARAMETER ( NTESTS = 7 )
220 INTEGER NTYPES
221 parameter( ntypes = 8 )
222 REAL ZERO
223 parameter( zero = 0.0e0 )
224* ..
225* .. Local Scalars ..
226 CHARACTER DIST, TYPE
227 CHARACTER*3 PATH
228 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
229 $ lwork, m, minmn, mode, n, nb, nerrs, nfail, nk,
230 $ nrun, nt, nx
231 REAL ANORM, CNDNUM
232* ..
233* .. Local Arrays ..
234 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
235 REAL RESULT( NTESTS )
236* ..
237* .. External Subroutines ..
238 EXTERNAL alaerh, alahd, alasum, serrlq, sgelqs, sget02,
239 $ slacpy, slarhs, slatb4, slatms, slqt01, slqt02,
240 $ slqt03, xlaenv
241* ..
242* .. Intrinsic Functions ..
243 INTRINSIC max, min
244* ..
245* .. Scalars in Common ..
246 LOGICAL LERR, OK
247 CHARACTER*32 SRNAMT
248 INTEGER INFOT, NUNIT
249* ..
250* .. Common blocks ..
251 COMMON / infoc / infot, nunit, ok, lerr
252 COMMON / srnamc / srnamt
253* ..
254* .. Data statements ..
255 DATA iseedy / 1988, 1989, 1990, 1991 /
256* ..
257* .. Executable Statements ..
258*
259* Initialize constants and the random number seed.
260*
261 path( 1: 1 ) = 'Single precision'
262 path( 2: 3 ) = 'LQ'
263 nrun = 0
264 nfail = 0
265 nerrs = 0
266 DO 10 i = 1, 4
267 iseed( i ) = iseedy( i )
268 10 CONTINUE
269*
270* Test the error exits
271*
272 IF( tsterr )
273 $ CALL serrlq( path, nout )
274 infot = 0
275 CALL xlaenv( 2, 2 )
276*
277 lda = nmax
278 lwork = nmax*max( nmax, nrhs )
279*
280* Do for each value of M in MVAL.
281*
282 DO 70 im = 1, nm
283 m = mval( im )
284*
285* Do for each value of N in NVAL.
286*
287 DO 60 in = 1, nn
288 n = nval( in )
289 minmn = min( m, n )
290 DO 50 imat = 1, ntypes
291*
292* Do the tests only if DOTYPE( IMAT ) is true.
293*
294 IF( .NOT.dotype( imat ) )
295 $ GO TO 50
296*
297* Set up parameters with SLATB4 and generate a test matrix
298* with SLATMS.
299*
300 CALL slatb4( path, imat, m, n, TYPE, kl, ku, anorm, mode,
301 $ cndnum, dist )
302*
303 srnamt = 'SLATMS'
304 CALL slatms( m, n, dist, iseed, TYPE, rwork, mode,
305 $ cndnum, anorm, kl, ku, 'No packing', a, lda,
306 $ work, info )
307*
308* Check error code from SLATMS.
309*
310 IF( info.NE.0 ) THEN
311 CALL alaerh( path, 'SLATMS', info, 0, ' ', m, n, -1,
312 $ -1, -1, imat, nfail, nerrs, nout )
313 GO TO 50
314 END IF
315*
316* Set some values for K: the first value must be MINMN,
317* corresponding to the call of SLQT01; other values are
318* used in the calls of SLQT02, and must not exceed MINMN.
319*
320 kval( 1 ) = minmn
321 kval( 2 ) = 0
322 kval( 3 ) = 1
323 kval( 4 ) = minmn / 2
324 IF( minmn.EQ.0 ) THEN
325 nk = 1
326 ELSE IF( minmn.EQ.1 ) THEN
327 nk = 2
328 ELSE IF( minmn.LE.3 ) THEN
329 nk = 3
330 ELSE
331 nk = 4
332 END IF
333*
334* Do for each value of K in KVAL
335*
336 DO 40 ik = 1, nk
337 k = kval( ik )
338*
339* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
340*
341 DO 30 inb = 1, nnb
342 nb = nbval( inb )
343 CALL xlaenv( 1, nb )
344 nx = nxval( inb )
345 CALL xlaenv( 3, nx )
346 DO i = 1, ntests
347 result( i ) = zero
348 END DO
349 nt = 2
350 IF( ik.EQ.1 ) THEN
351*
352* Test SGELQF
353*
354 CALL slqt01( m, n, a, af, aq, al, lda, tau,
355 $ work, lwork, rwork, result( 1 ) )
356 ELSE IF( m.LE.n ) THEN
357*
358* Test SORGLQ, using factorization
359* returned by SLQT01
360*
361 CALL slqt02( m, n, k, a, af, aq, al, lda, tau,
362 $ work, lwork, rwork, result( 1 ) )
363 END IF
364 IF( m.GE.k ) THEN
365*
366* Test SORMLQ, using factorization returned
367* by SLQT01
368*
369 CALL slqt03( m, n, k, af, ac, al, aq, lda, tau,
370 $ work, lwork, rwork, result( 3 ) )
371 nt = nt + 4
372*
373* If M>=N and K=N, call SGELQS to solve a system
374* with NRHS right hand sides and compute the
375* residual.
376*
377 IF( k.EQ.m .AND. inb.EQ.1 ) THEN
378*
379* Generate a solution and set the right
380* hand side.
381*
382 srnamt = 'SLARHS'
383 CALL slarhs( path, 'New', 'Full',
384 $ 'No transpose', m, n, 0, 0,
385 $ nrhs, a, lda, xact, lda, b, lda,
386 $ iseed, info )
387*
388 CALL slacpy( 'Full', m, nrhs, b, lda, x,
389 $ lda )
390 srnamt = 'SGELQS'
391 CALL sgelqs( m, n, nrhs, af, lda, tau, x,
392 $ lda, work, lwork, info )
393*
394* Check error code from SGELQS.
395*
396 IF( info.NE.0 )
397 $ CALL alaerh( path, 'SGELQS', info, 0, ' ',
398 $ m, n, nrhs, -1, nb, imat,
399 $ nfail, nerrs, nout )
400*
401 CALL sget02( 'No transpose', m, n, nrhs, a,
402 $ lda, x, lda, b, lda, rwork,
403 $ result( 7 ) )
404 nt = nt + 1
405 END IF
406 END IF
407*
408* Print information about the tests that did not
409* pass the threshold.
410*
411 DO 20 i = 1, nt
412 IF( result( i ).GE.thresh ) THEN
413 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
414 $ CALL alahd( nout, path )
415 WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
416 $ imat, i, result( i )
417 nfail = nfail + 1
418 END IF
419 20 CONTINUE
420 nrun = nrun + nt
421 30 CONTINUE
422 40 CONTINUE
423 50 CONTINUE
424 60 CONTINUE
425 70 CONTINUE
426*
427* Print a summary of the results.
428*
429 CALL alasum( path, nout, nfail, nrun, nerrs )
430*
431 9999 FORMAT( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
432 $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
433 RETURN
434*
435* End of SCHKLQ
436*
437 END
slacpy
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
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
slatms
subroutine slatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
SLATMS
Definition slatms.f:321
sget02
subroutine sget02(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
SGET02
Definition sget02.f:135
slarhs
subroutine slarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
SLARHS
Definition slarhs.f:205
serrlq
subroutine serrlq(path, nunit)
SERRLQ
Definition serrlq.f:55
slqt02
subroutine slqt02(m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
SLQT02
Definition slqt02.f:135
schklq
subroutine schklq(dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, al, ac, b, x, xact, tau, work, rwork, nout)
SCHKLQ
Definition schklq.f:196
sgelqs
subroutine sgelqs(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
SGELQS
Definition sgelqs.f:121
slqt01
subroutine slqt01(m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
SLQT01
Definition slqt01.f:126
slatb4
subroutine slatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
SLATB4
Definition slatb4.f:120
slqt03
subroutine slqt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
SLQT03
Definition slqt03.f:136
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21