1 SUBROUTINE SCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
2 $ NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B,
3 $ X, XACT, WORK, RWORK, IWORK, NOUT )
4 *
5 * -- LAPACK test routine (version 3.1.1) --
6 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
7 * January 2007
8 *
9 * .. Scalar Arguments ..
10 LOGICAL TSTERR
11 INTEGER NM, NMAX, NN, NNB, NNS, NOUT
12 REAL THRESH
13 * ..
14 * .. Array Arguments ..
15 LOGICAL DOTYPE( * )
16 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
17 $ NVAL( * )
18 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
19 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
20 * ..
21 *
22 * Purpose
23 * =======
24 *
25 * SCHKGE tests SGETRF, -TRI, -TRS, -RFS, and -CON.
26 *
27 * Arguments
28 * =========
29 *
30 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
31 * The matrix types to be used for testing. Matrices of type j
32 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
33 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
34 *
35 * NM (input) INTEGER
36 * The number of values of M contained in the vector MVAL.
37 *
38 * MVAL (input) INTEGER array, dimension (NM)
39 * The values of the matrix row dimension M.
40 *
41 * NN (input) INTEGER
42 * The number of values of N contained in the vector NVAL.
43 *
44 * NVAL (input) INTEGER array, dimension (NN)
45 * The values of the matrix column dimension N.
46 *
47 * NNB (input) INTEGER
48 * The number of values of NB contained in the vector NBVAL.
49 *
50 * NBVAL (input) INTEGER array, dimension (NBVAL)
51 * The values of the blocksize NB.
52 *
53 * NNS (input) INTEGER
54 * The number of values of NRHS contained in the vector NSVAL.
55 *
56 * NSVAL (input) INTEGER array, dimension (NNS)
57 * The values of the number of right hand sides NRHS.
58 *
59 * THRESH (input) REAL
60 * The threshold value for the test ratios. A result is
61 * included in the output file if RESULT >= THRESH. To have
62 * every test ratio printed, use THRESH = 0.
63 *
64 * TSTERR (input) LOGICAL
65 * Flag that indicates whether error exits are to be tested.
66 *
67 * NMAX (input) INTEGER
68 * The maximum value permitted for M or N, used in dimensioning
69 * the work arrays.
70 *
71 * A (workspace) REAL array, dimension (NMAX*NMAX)
72 *
73 * AFAC (workspace) REAL array, dimension (NMAX*NMAX)
74 *
75 * AINV (workspace) REAL array, dimension (NMAX*NMAX)
76 *
77 * B (workspace) REAL array, dimension (NMAX*NSMAX)
78 * where NSMAX is the largest entry in NSVAL.
79 *
80 * X (workspace) REAL array, dimension (NMAX*NSMAX)
81 *
82 * XACT (workspace) REAL array, dimension (NMAX*NSMAX)
83 *
84 * WORK (workspace) REAL array, dimension
85 * (NMAX*max(3,NSMAX))
86 *
87 * RWORK (workspace) REAL array, dimension
88 * (max(2*NMAX,2*NSMAX+NWORK))
89 *
90 * IWORK (workspace) INTEGER array, dimension (2*NMAX)
91 *
92 * NOUT (input) INTEGER
93 * The unit number for output.
94 *
95 * =====================================================================
96 *
97 * .. Parameters ..
98 REAL ONE, ZERO
99 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
100 INTEGER NTYPES
101 PARAMETER ( NTYPES = 11 )
102 INTEGER NTESTS
103 PARAMETER ( NTESTS = 8 )
104 INTEGER NTRAN
105 PARAMETER ( NTRAN = 3 )
106 * ..
107 * .. Local Scalars ..
108 LOGICAL TRFCON, ZEROT
109 CHARACTER DIST, NORM, TRANS, TYPE, XTYPE
110 CHARACTER*3 PATH
111 INTEGER I, IM, IMAT, IN, INB, INFO, IOFF, IRHS, ITRAN,
112 $ IZERO, K, KL, KU, LDA, LWORK, M, MODE, N, NB,
113 $ NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
114 REAL AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, DUMMY,
115 $ RCOND, RCONDC, RCONDI, RCONDO
116 * ..
117 * .. Local Arrays ..
118 CHARACTER TRANSS( NTRAN )
119 INTEGER ISEED( 4 ), ISEEDY( 4 )
120 REAL RESULT( NTESTS )
121 * ..
122 * .. External Functions ..
123 REAL SGET06, SLANGE
124 EXTERNAL SGET06, SLANGE
125 * ..
126 * .. External Subroutines ..
127 EXTERNAL ALAERH, ALAHD, ALASUM, SERRGE, SGECON, SGERFS,
128 $ SGET01, SGET02, SGET03, SGET04, SGET07, SGETRF,
129 $ SGETRI, SGETRS, SLACPY, SLARHS, SLASET, SLATB4,
130 $ SLATMS, XLAENV
131 * ..
132 * .. Intrinsic Functions ..
133 INTRINSIC MAX, MIN
134 * ..
135 * .. Scalars in Common ..
136 LOGICAL LERR, OK
137 CHARACTER*32 SRNAMT
138 INTEGER INFOT, NUNIT
139 * ..
140 * .. Common blocks ..
141 COMMON / INFOC / INFOT, NUNIT, OK, LERR
142 COMMON / SRNAMC / SRNAMT
143 * ..
144 * .. Data statements ..
145 DATA ISEEDY / 1988, 1989, 1990, 1991 / ,
146 $ TRANSS / 'N', 'T', 'C' /
147 * ..
148 * .. Executable Statements ..
149 *
150 * Initialize constants and the random number seed.
151 *
152 PATH( 1: 1 ) = 'Single precision'
153 PATH( 2: 3 ) = 'GE'
154 NRUN = 0
155 NFAIL = 0
156 NERRS = 0
157 DO 10 I = 1, 4
158 ISEED( I ) = ISEEDY( I )
159 10 CONTINUE
160 *
161 * Test the error exits
162 *
163 CALL XLAENV( 1, 1 )
164 IF( TSTERR )
165 $ CALL SERRGE( PATH, NOUT )
166 INFOT = 0
167 CALL XLAENV( 2, 2 )
168 *
169 * Do for each value of M in MVAL
170 *
171 DO 120 IM = 1, NM
172 M = MVAL( IM )
173 LDA = MAX( 1, M )
174 *
175 * Do for each value of N in NVAL
176 *
177 DO 110 IN = 1, NN
178 N = NVAL( IN )
179 XTYPE = 'N'
180 NIMAT = NTYPES
181 IF( M.LE.0 .OR. N.LE.0 )
182 $ NIMAT = 1
183 *
184 DO 100 IMAT = 1, NIMAT
185 *
186 * Do the tests only if DOTYPE( IMAT ) is true.
187 *
188 IF( .NOT.DOTYPE( IMAT ) )
189 $ GO TO 100
190 *
191 * Skip types 5, 6, or 7 if the matrix size is too small.
192 *
193 ZEROT = IMAT.GE.5 .AND. IMAT.LE.7
194 IF( ZEROT .AND. N.LT.IMAT-4 )
195 $ GO TO 100
196 *
197 * Set up parameters with SLATB4 and generate a test matrix
198 * with SLATMS.
199 *
200 CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
201 $ CNDNUM, DIST )
202 *
203 SRNAMT = 'SLATMS'
204 CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
205 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
206 $ WORK, INFO )
207 *
208 * Check error code from SLATMS.
209 *
210 IF( INFO.NE.0 ) THEN
211 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, -1,
212 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
213 GO TO 100
214 END IF
215 *
216 * For types 5-7, zero one or more columns of the matrix to
217 * test that INFO is returned correctly.
218 *
219 IF( ZEROT ) THEN
220 IF( IMAT.EQ.5 ) THEN
221 IZERO = 1
222 ELSE IF( IMAT.EQ.6 ) THEN
223 IZERO = MIN( M, N )
224 ELSE
225 IZERO = MIN( M, N ) / 2 + 1
226 END IF
227 IOFF = ( IZERO-1 )*LDA
228 IF( IMAT.LT.7 ) THEN
229 DO 20 I = 1, M
230 A( IOFF+I ) = ZERO
231 20 CONTINUE
232 ELSE
233 CALL SLASET( 'Full', M, N-IZERO+1, ZERO, ZERO,
234 $ A( IOFF+1 ), LDA )
235 END IF
236 ELSE
237 IZERO = 0
238 END IF
239 *
240 * These lines, if used in place of the calls in the DO 60
241 * loop, cause the code to bomb on a Sun SPARCstation.
242 *
243 * ANORMO = SLANGE( 'O', M, N, A, LDA, RWORK )
244 * ANORMI = SLANGE( 'I', M, N, A, LDA, RWORK )
245 *
246 * Do for each blocksize in NBVAL
247 *
248 DO 90 INB = 1, NNB
249 NB = NBVAL( INB )
250 CALL XLAENV( 1, NB )
251 *
252 * Compute the LU factorization of the matrix.
253 *
254 CALL SLACPY( 'Full', M, N, A, LDA, AFAC, LDA )
255 SRNAMT = 'SGETRF'
256 CALL SGETRF( M, N, AFAC, LDA, IWORK, INFO )
257 *
258 * Check error code from SGETRF.
259 *
260 IF( INFO.NE.IZERO )
261 $ CALL ALAERH( PATH, 'SGETRF', INFO, IZERO, ' ', M,
262 $ N, -1, -1, NB, IMAT, NFAIL, NERRS,
263 $ NOUT )
264 TRFCON = .FALSE.
265 *
266 *+ TEST 1
267 * Reconstruct matrix from factors and compute residual.
268 *
269 CALL SLACPY( 'Full', M, N, AFAC, LDA, AINV, LDA )
270 CALL SGET01( M, N, A, LDA, AINV, LDA, IWORK, RWORK,
271 $ RESULT( 1 ) )
272 NT = 1
273 *
274 *+ TEST 2
275 * Form the inverse if the factorization was successful
276 * and compute the residual.
277 *
278 IF( M.EQ.N .AND. INFO.EQ.0 ) THEN
279 CALL SLACPY( 'Full', N, N, AFAC, LDA, AINV, LDA )
280 SRNAMT = 'SGETRI'
281 NRHS = NSVAL( 1 )
282 LWORK = NMAX*MAX( 3, NRHS )
283 CALL SGETRI( N, AINV, LDA, IWORK, WORK, LWORK,
284 $ INFO )
285 *
286 * Check error code from SGETRI.
287 *
288 IF( INFO.NE.0 )
289 $ CALL ALAERH( PATH, 'SGETRI', INFO, 0, ' ', N, N,
290 $ -1, -1, NB, IMAT, NFAIL, NERRS,
291 $ NOUT )
292 *
293 * Compute the residual for the matrix times its
294 * inverse. Also compute the 1-norm condition number
295 * of A.
296 *
297 CALL SGET03( N, A, LDA, AINV, LDA, WORK, LDA,
298 $ RWORK, RCONDO, RESULT( 2 ) )
299 ANORMO = SLANGE( 'O', M, N, A, LDA, RWORK )
300 *
301 * Compute the infinity-norm condition number of A.
302 *
303 ANORMI = SLANGE( 'I', M, N, A, LDA, RWORK )
304 AINVNM = SLANGE( 'I', N, N, AINV, LDA, RWORK )
305 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
306 RCONDI = ONE
307 ELSE
308 RCONDI = ( ONE / ANORMI ) / AINVNM
309 END IF
310 NT = 2
311 ELSE
312 *
313 * Do only the condition estimate if INFO > 0.
314 *
315 TRFCON = .TRUE.
316 ANORMO = SLANGE( 'O', M, N, A, LDA, RWORK )
317 ANORMI = SLANGE( 'I', M, N, A, LDA, RWORK )
318 RCONDO = ZERO
319 RCONDI = ZERO
320 END IF
321 *
322 * Print information about the tests so far that did not
323 * pass the threshold.
324 *
325 DO 30 K = 1, NT
326 IF( RESULT( K ).GE.THRESH ) THEN
327 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
328 $ CALL ALAHD( NOUT, PATH )
329 WRITE( NOUT, FMT = 9999 )M, N, NB, IMAT, K,
330 $ RESULT( K )
331 NFAIL = NFAIL + 1
332 END IF
333 30 CONTINUE
334 NRUN = NRUN + NT
335 *
336 * Skip the remaining tests if this is not the first
337 * block size or if M .ne. N. Skip the solve tests if
338 * the matrix is singular.
339 *
340 IF( INB.GT.1 .OR. M.NE.N )
341 $ GO TO 90
342 IF( TRFCON )
343 $ GO TO 70
344 *
345 DO 60 IRHS = 1, NNS
346 NRHS = NSVAL( IRHS )
347 XTYPE = 'N'
348 *
349 DO 50 ITRAN = 1, NTRAN
350 TRANS = TRANSS( ITRAN )
351 IF( ITRAN.EQ.1 ) THEN
352 RCONDC = RCONDO
353 ELSE
354 RCONDC = RCONDI
355 END IF
356 *
357 *+ TEST 3
358 * Solve and compute residual for A * X = B.
359 *
360 SRNAMT = 'SLARHS'
361 CALL SLARHS( PATH, XTYPE, ' ', TRANS, N, N, KL,
362 $ KU, NRHS, A, LDA, XACT, LDA, B,
363 $ LDA, ISEED, INFO )
364 XTYPE = 'C'
365 *
366 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
367 SRNAMT = 'SGETRS'
368 CALL SGETRS( TRANS, N, NRHS, AFAC, LDA, IWORK,
369 $ X, LDA, INFO )
370 *
371 * Check error code from SGETRS.
372 *
373 IF( INFO.NE.0 )
374 $ CALL ALAERH( PATH, 'SGETRS', INFO, 0, TRANS,
375 $ N, N, -1, -1, NRHS, IMAT, NFAIL,
376 $ NERRS, NOUT )
377 *
378 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
379 $ LDA )
380 CALL SGET02( TRANS, N, N, NRHS, A, LDA, X, LDA,
381 $ WORK, LDA, RWORK, RESULT( 3 ) )
382 *
383 *+ TEST 4
384 * Check solution from generated exact solution.
385 *
386 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
387 $ RESULT( 4 ) )
388 *
389 *+ TESTS 5, 6, and 7
390 * Use iterative refinement to improve the
391 * solution.
392 *
393 SRNAMT = 'SGERFS'
394 CALL SGERFS( TRANS, N, NRHS, A, LDA, AFAC, LDA,
395 $ IWORK, B, LDA, X, LDA, RWORK,
396 $ RWORK( NRHS+1 ), WORK,
397 $ IWORK( N+1 ), INFO )
398 *
399 * Check error code from SGERFS.
400 *
401 IF( INFO.NE.0 )
402 $ CALL ALAERH( PATH, 'SGERFS', INFO, 0, TRANS,
403 $ N, N, -1, -1, NRHS, IMAT, NFAIL,
404 $ NERRS, NOUT )
405 *
406 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
407 $ RESULT( 5 ) )
408 CALL SGET07( TRANS, N, NRHS, A, LDA, B, LDA, X,
409 $ LDA, XACT, LDA, RWORK, .TRUE.,
410 $ RWORK( NRHS+1 ), RESULT( 6 ) )
411 *
412 * Print information about the tests that did not
413 * pass the threshold.
414 *
415 DO 40 K = 3, 7
416 IF( RESULT( K ).GE.THRESH ) THEN
417 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
418 $ CALL ALAHD( NOUT, PATH )
419 WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS,
420 $ IMAT, K, RESULT( K )
421 NFAIL = NFAIL + 1
422 END IF
423 40 CONTINUE
424 NRUN = NRUN + 5
425 50 CONTINUE
426 60 CONTINUE
427 *
428 *+ TEST 8
429 * Get an estimate of RCOND = 1/CNDNUM.
430 *
431 70 CONTINUE
432 DO 80 ITRAN = 1, 2
433 IF( ITRAN.EQ.1 ) THEN
434 ANORM = ANORMO
435 RCONDC = RCONDO
436 NORM = 'O'
437 ELSE
438 ANORM = ANORMI
439 RCONDC = RCONDI
440 NORM = 'I'
441 END IF
442 SRNAMT = 'SGECON'
443 CALL SGECON( NORM, N, AFAC, LDA, ANORM, RCOND,
444 $ WORK, IWORK( N+1 ), INFO )
445 *
446 * Check error code from SGECON.
447 *
448 IF( INFO.NE.0 )
449 $ CALL ALAERH( PATH, 'SGECON', INFO, 0, NORM, N,
450 $ N, -1, -1, -1, IMAT, NFAIL, NERRS,
451 $ NOUT )
452 *
453 * This line is needed on a Sun SPARCstation.
454 *
455 DUMMY = RCOND
456 *
457 RESULT( 8 ) = SGET06( RCOND, RCONDC )
458 *
459 * Print information about the tests that did not pass
460 * the threshold.
461 *
462 IF( RESULT( 8 ).GE.THRESH ) THEN
463 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
464 $ CALL ALAHD( NOUT, PATH )
465 WRITE( NOUT, FMT = 9997 )NORM, N, IMAT, 8,
466 $ RESULT( 8 )
467 NFAIL = NFAIL + 1
468 END IF
469 NRUN = NRUN + 1
470 80 CONTINUE
471 90 CONTINUE
472 100 CONTINUE
473 110 CONTINUE
474 120 CONTINUE
475 *
476 * Print a summary of the results.
477 *
478 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
479 *
480 9999 FORMAT( ' M = ', I5, ', N =', I5, ', NB =', I4, ', type ', I2,
481 $ ', test(', I2, ') =', G12.5 )
482 9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
483 $ I2, ', test(', I2, ') =', G12.5 )
484 9997 FORMAT( ' NORM =''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
485 $ ', test(', I2, ') =', G12.5 )
486 RETURN
487 *
488 * End of SCHKGE
489 *
490 END
2 $ NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B,
3 $ X, XACT, WORK, RWORK, IWORK, NOUT )
4 *
5 * -- LAPACK test routine (version 3.1.1) --
6 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
7 * January 2007
8 *
9 * .. Scalar Arguments ..
10 LOGICAL TSTERR
11 INTEGER NM, NMAX, NN, NNB, NNS, NOUT
12 REAL THRESH
13 * ..
14 * .. Array Arguments ..
15 LOGICAL DOTYPE( * )
16 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
17 $ NVAL( * )
18 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
19 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
20 * ..
21 *
22 * Purpose
23 * =======
24 *
25 * SCHKGE tests SGETRF, -TRI, -TRS, -RFS, and -CON.
26 *
27 * Arguments
28 * =========
29 *
30 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
31 * The matrix types to be used for testing. Matrices of type j
32 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
33 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
34 *
35 * NM (input) INTEGER
36 * The number of values of M contained in the vector MVAL.
37 *
38 * MVAL (input) INTEGER array, dimension (NM)
39 * The values of the matrix row dimension M.
40 *
41 * NN (input) INTEGER
42 * The number of values of N contained in the vector NVAL.
43 *
44 * NVAL (input) INTEGER array, dimension (NN)
45 * The values of the matrix column dimension N.
46 *
47 * NNB (input) INTEGER
48 * The number of values of NB contained in the vector NBVAL.
49 *
50 * NBVAL (input) INTEGER array, dimension (NBVAL)
51 * The values of the blocksize NB.
52 *
53 * NNS (input) INTEGER
54 * The number of values of NRHS contained in the vector NSVAL.
55 *
56 * NSVAL (input) INTEGER array, dimension (NNS)
57 * The values of the number of right hand sides NRHS.
58 *
59 * THRESH (input) REAL
60 * The threshold value for the test ratios. A result is
61 * included in the output file if RESULT >= THRESH. To have
62 * every test ratio printed, use THRESH = 0.
63 *
64 * TSTERR (input) LOGICAL
65 * Flag that indicates whether error exits are to be tested.
66 *
67 * NMAX (input) INTEGER
68 * The maximum value permitted for M or N, used in dimensioning
69 * the work arrays.
70 *
71 * A (workspace) REAL array, dimension (NMAX*NMAX)
72 *
73 * AFAC (workspace) REAL array, dimension (NMAX*NMAX)
74 *
75 * AINV (workspace) REAL array, dimension (NMAX*NMAX)
76 *
77 * B (workspace) REAL array, dimension (NMAX*NSMAX)
78 * where NSMAX is the largest entry in NSVAL.
79 *
80 * X (workspace) REAL array, dimension (NMAX*NSMAX)
81 *
82 * XACT (workspace) REAL array, dimension (NMAX*NSMAX)
83 *
84 * WORK (workspace) REAL array, dimension
85 * (NMAX*max(3,NSMAX))
86 *
87 * RWORK (workspace) REAL array, dimension
88 * (max(2*NMAX,2*NSMAX+NWORK))
89 *
90 * IWORK (workspace) INTEGER array, dimension (2*NMAX)
91 *
92 * NOUT (input) INTEGER
93 * The unit number for output.
94 *
95 * =====================================================================
96 *
97 * .. Parameters ..
98 REAL ONE, ZERO
99 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
100 INTEGER NTYPES
101 PARAMETER ( NTYPES = 11 )
102 INTEGER NTESTS
103 PARAMETER ( NTESTS = 8 )
104 INTEGER NTRAN
105 PARAMETER ( NTRAN = 3 )
106 * ..
107 * .. Local Scalars ..
108 LOGICAL TRFCON, ZEROT
109 CHARACTER DIST, NORM, TRANS, TYPE, XTYPE
110 CHARACTER*3 PATH
111 INTEGER I, IM, IMAT, IN, INB, INFO, IOFF, IRHS, ITRAN,
112 $ IZERO, K, KL, KU, LDA, LWORK, M, MODE, N, NB,
113 $ NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
114 REAL AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, DUMMY,
115 $ RCOND, RCONDC, RCONDI, RCONDO
116 * ..
117 * .. Local Arrays ..
118 CHARACTER TRANSS( NTRAN )
119 INTEGER ISEED( 4 ), ISEEDY( 4 )
120 REAL RESULT( NTESTS )
121 * ..
122 * .. External Functions ..
123 REAL SGET06, SLANGE
124 EXTERNAL SGET06, SLANGE
125 * ..
126 * .. External Subroutines ..
127 EXTERNAL ALAERH, ALAHD, ALASUM, SERRGE, SGECON, SGERFS,
128 $ SGET01, SGET02, SGET03, SGET04, SGET07, SGETRF,
129 $ SGETRI, SGETRS, SLACPY, SLARHS, SLASET, SLATB4,
130 $ SLATMS, XLAENV
131 * ..
132 * .. Intrinsic Functions ..
133 INTRINSIC MAX, MIN
134 * ..
135 * .. Scalars in Common ..
136 LOGICAL LERR, OK
137 CHARACTER*32 SRNAMT
138 INTEGER INFOT, NUNIT
139 * ..
140 * .. Common blocks ..
141 COMMON / INFOC / INFOT, NUNIT, OK, LERR
142 COMMON / SRNAMC / SRNAMT
143 * ..
144 * .. Data statements ..
145 DATA ISEEDY / 1988, 1989, 1990, 1991 / ,
146 $ TRANSS / 'N', 'T', 'C' /
147 * ..
148 * .. Executable Statements ..
149 *
150 * Initialize constants and the random number seed.
151 *
152 PATH( 1: 1 ) = 'Single precision'
153 PATH( 2: 3 ) = 'GE'
154 NRUN = 0
155 NFAIL = 0
156 NERRS = 0
157 DO 10 I = 1, 4
158 ISEED( I ) = ISEEDY( I )
159 10 CONTINUE
160 *
161 * Test the error exits
162 *
163 CALL XLAENV( 1, 1 )
164 IF( TSTERR )
165 $ CALL SERRGE( PATH, NOUT )
166 INFOT = 0
167 CALL XLAENV( 2, 2 )
168 *
169 * Do for each value of M in MVAL
170 *
171 DO 120 IM = 1, NM
172 M = MVAL( IM )
173 LDA = MAX( 1, M )
174 *
175 * Do for each value of N in NVAL
176 *
177 DO 110 IN = 1, NN
178 N = NVAL( IN )
179 XTYPE = 'N'
180 NIMAT = NTYPES
181 IF( M.LE.0 .OR. N.LE.0 )
182 $ NIMAT = 1
183 *
184 DO 100 IMAT = 1, NIMAT
185 *
186 * Do the tests only if DOTYPE( IMAT ) is true.
187 *
188 IF( .NOT.DOTYPE( IMAT ) )
189 $ GO TO 100
190 *
191 * Skip types 5, 6, or 7 if the matrix size is too small.
192 *
193 ZEROT = IMAT.GE.5 .AND. IMAT.LE.7
194 IF( ZEROT .AND. N.LT.IMAT-4 )
195 $ GO TO 100
196 *
197 * Set up parameters with SLATB4 and generate a test matrix
198 * with SLATMS.
199 *
200 CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE,
201 $ CNDNUM, DIST )
202 *
203 SRNAMT = 'SLATMS'
204 CALL SLATMS( M, N, DIST, ISEED, TYPE, RWORK, MODE,
205 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
206 $ WORK, INFO )
207 *
208 * Check error code from SLATMS.
209 *
210 IF( INFO.NE.0 ) THEN
211 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, -1,
212 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
213 GO TO 100
214 END IF
215 *
216 * For types 5-7, zero one or more columns of the matrix to
217 * test that INFO is returned correctly.
218 *
219 IF( ZEROT ) THEN
220 IF( IMAT.EQ.5 ) THEN
221 IZERO = 1
222 ELSE IF( IMAT.EQ.6 ) THEN
223 IZERO = MIN( M, N )
224 ELSE
225 IZERO = MIN( M, N ) / 2 + 1
226 END IF
227 IOFF = ( IZERO-1 )*LDA
228 IF( IMAT.LT.7 ) THEN
229 DO 20 I = 1, M
230 A( IOFF+I ) = ZERO
231 20 CONTINUE
232 ELSE
233 CALL SLASET( 'Full', M, N-IZERO+1, ZERO, ZERO,
234 $ A( IOFF+1 ), LDA )
235 END IF
236 ELSE
237 IZERO = 0
238 END IF
239 *
240 * These lines, if used in place of the calls in the DO 60
241 * loop, cause the code to bomb on a Sun SPARCstation.
242 *
243 * ANORMO = SLANGE( 'O', M, N, A, LDA, RWORK )
244 * ANORMI = SLANGE( 'I', M, N, A, LDA, RWORK )
245 *
246 * Do for each blocksize in NBVAL
247 *
248 DO 90 INB = 1, NNB
249 NB = NBVAL( INB )
250 CALL XLAENV( 1, NB )
251 *
252 * Compute the LU factorization of the matrix.
253 *
254 CALL SLACPY( 'Full', M, N, A, LDA, AFAC, LDA )
255 SRNAMT = 'SGETRF'
256 CALL SGETRF( M, N, AFAC, LDA, IWORK, INFO )
257 *
258 * Check error code from SGETRF.
259 *
260 IF( INFO.NE.IZERO )
261 $ CALL ALAERH( PATH, 'SGETRF', INFO, IZERO, ' ', M,
262 $ N, -1, -1, NB, IMAT, NFAIL, NERRS,
263 $ NOUT )
264 TRFCON = .FALSE.
265 *
266 *+ TEST 1
267 * Reconstruct matrix from factors and compute residual.
268 *
269 CALL SLACPY( 'Full', M, N, AFAC, LDA, AINV, LDA )
270 CALL SGET01( M, N, A, LDA, AINV, LDA, IWORK, RWORK,
271 $ RESULT( 1 ) )
272 NT = 1
273 *
274 *+ TEST 2
275 * Form the inverse if the factorization was successful
276 * and compute the residual.
277 *
278 IF( M.EQ.N .AND. INFO.EQ.0 ) THEN
279 CALL SLACPY( 'Full', N, N, AFAC, LDA, AINV, LDA )
280 SRNAMT = 'SGETRI'
281 NRHS = NSVAL( 1 )
282 LWORK = NMAX*MAX( 3, NRHS )
283 CALL SGETRI( N, AINV, LDA, IWORK, WORK, LWORK,
284 $ INFO )
285 *
286 * Check error code from SGETRI.
287 *
288 IF( INFO.NE.0 )
289 $ CALL ALAERH( PATH, 'SGETRI', INFO, 0, ' ', N, N,
290 $ -1, -1, NB, IMAT, NFAIL, NERRS,
291 $ NOUT )
292 *
293 * Compute the residual for the matrix times its
294 * inverse. Also compute the 1-norm condition number
295 * of A.
296 *
297 CALL SGET03( N, A, LDA, AINV, LDA, WORK, LDA,
298 $ RWORK, RCONDO, RESULT( 2 ) )
299 ANORMO = SLANGE( 'O', M, N, A, LDA, RWORK )
300 *
301 * Compute the infinity-norm condition number of A.
302 *
303 ANORMI = SLANGE( 'I', M, N, A, LDA, RWORK )
304 AINVNM = SLANGE( 'I', N, N, AINV, LDA, RWORK )
305 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
306 RCONDI = ONE
307 ELSE
308 RCONDI = ( ONE / ANORMI ) / AINVNM
309 END IF
310 NT = 2
311 ELSE
312 *
313 * Do only the condition estimate if INFO > 0.
314 *
315 TRFCON = .TRUE.
316 ANORMO = SLANGE( 'O', M, N, A, LDA, RWORK )
317 ANORMI = SLANGE( 'I', M, N, A, LDA, RWORK )
318 RCONDO = ZERO
319 RCONDI = ZERO
320 END IF
321 *
322 * Print information about the tests so far that did not
323 * pass the threshold.
324 *
325 DO 30 K = 1, NT
326 IF( RESULT( K ).GE.THRESH ) THEN
327 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
328 $ CALL ALAHD( NOUT, PATH )
329 WRITE( NOUT, FMT = 9999 )M, N, NB, IMAT, K,
330 $ RESULT( K )
331 NFAIL = NFAIL + 1
332 END IF
333 30 CONTINUE
334 NRUN = NRUN + NT
335 *
336 * Skip the remaining tests if this is not the first
337 * block size or if M .ne. N. Skip the solve tests if
338 * the matrix is singular.
339 *
340 IF( INB.GT.1 .OR. M.NE.N )
341 $ GO TO 90
342 IF( TRFCON )
343 $ GO TO 70
344 *
345 DO 60 IRHS = 1, NNS
346 NRHS = NSVAL( IRHS )
347 XTYPE = 'N'
348 *
349 DO 50 ITRAN = 1, NTRAN
350 TRANS = TRANSS( ITRAN )
351 IF( ITRAN.EQ.1 ) THEN
352 RCONDC = RCONDO
353 ELSE
354 RCONDC = RCONDI
355 END IF
356 *
357 *+ TEST 3
358 * Solve and compute residual for A * X = B.
359 *
360 SRNAMT = 'SLARHS'
361 CALL SLARHS( PATH, XTYPE, ' ', TRANS, N, N, KL,
362 $ KU, NRHS, A, LDA, XACT, LDA, B,
363 $ LDA, ISEED, INFO )
364 XTYPE = 'C'
365 *
366 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
367 SRNAMT = 'SGETRS'
368 CALL SGETRS( TRANS, N, NRHS, AFAC, LDA, IWORK,
369 $ X, LDA, INFO )
370 *
371 * Check error code from SGETRS.
372 *
373 IF( INFO.NE.0 )
374 $ CALL ALAERH( PATH, 'SGETRS', INFO, 0, TRANS,
375 $ N, N, -1, -1, NRHS, IMAT, NFAIL,
376 $ NERRS, NOUT )
377 *
378 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
379 $ LDA )
380 CALL SGET02( TRANS, N, N, NRHS, A, LDA, X, LDA,
381 $ WORK, LDA, RWORK, RESULT( 3 ) )
382 *
383 *+ TEST 4
384 * Check solution from generated exact solution.
385 *
386 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
387 $ RESULT( 4 ) )
388 *
389 *+ TESTS 5, 6, and 7
390 * Use iterative refinement to improve the
391 * solution.
392 *
393 SRNAMT = 'SGERFS'
394 CALL SGERFS( TRANS, N, NRHS, A, LDA, AFAC, LDA,
395 $ IWORK, B, LDA, X, LDA, RWORK,
396 $ RWORK( NRHS+1 ), WORK,
397 $ IWORK( N+1 ), INFO )
398 *
399 * Check error code from SGERFS.
400 *
401 IF( INFO.NE.0 )
402 $ CALL ALAERH( PATH, 'SGERFS', INFO, 0, TRANS,
403 $ N, N, -1, -1, NRHS, IMAT, NFAIL,
404 $ NERRS, NOUT )
405 *
406 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
407 $ RESULT( 5 ) )
408 CALL SGET07( TRANS, N, NRHS, A, LDA, B, LDA, X,
409 $ LDA, XACT, LDA, RWORK, .TRUE.,
410 $ RWORK( NRHS+1 ), RESULT( 6 ) )
411 *
412 * Print information about the tests that did not
413 * pass the threshold.
414 *
415 DO 40 K = 3, 7
416 IF( RESULT( K ).GE.THRESH ) THEN
417 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
418 $ CALL ALAHD( NOUT, PATH )
419 WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS,
420 $ IMAT, K, RESULT( K )
421 NFAIL = NFAIL + 1
422 END IF
423 40 CONTINUE
424 NRUN = NRUN + 5
425 50 CONTINUE
426 60 CONTINUE
427 *
428 *+ TEST 8
429 * Get an estimate of RCOND = 1/CNDNUM.
430 *
431 70 CONTINUE
432 DO 80 ITRAN = 1, 2
433 IF( ITRAN.EQ.1 ) THEN
434 ANORM = ANORMO
435 RCONDC = RCONDO
436 NORM = 'O'
437 ELSE
438 ANORM = ANORMI
439 RCONDC = RCONDI
440 NORM = 'I'
441 END IF
442 SRNAMT = 'SGECON'
443 CALL SGECON( NORM, N, AFAC, LDA, ANORM, RCOND,
444 $ WORK, IWORK( N+1 ), INFO )
445 *
446 * Check error code from SGECON.
447 *
448 IF( INFO.NE.0 )
449 $ CALL ALAERH( PATH, 'SGECON', INFO, 0, NORM, N,
450 $ N, -1, -1, -1, IMAT, NFAIL, NERRS,
451 $ NOUT )
452 *
453 * This line is needed on a Sun SPARCstation.
454 *
455 DUMMY = RCOND
456 *
457 RESULT( 8 ) = SGET06( RCOND, RCONDC )
458 *
459 * Print information about the tests that did not pass
460 * the threshold.
461 *
462 IF( RESULT( 8 ).GE.THRESH ) THEN
463 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
464 $ CALL ALAHD( NOUT, PATH )
465 WRITE( NOUT, FMT = 9997 )NORM, N, IMAT, 8,
466 $ RESULT( 8 )
467 NFAIL = NFAIL + 1
468 END IF
469 NRUN = NRUN + 1
470 80 CONTINUE
471 90 CONTINUE
472 100 CONTINUE
473 110 CONTINUE
474 120 CONTINUE
475 *
476 * Print a summary of the results.
477 *
478 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
479 *
480 9999 FORMAT( ' M = ', I5, ', N =', I5, ', NB =', I4, ', type ', I2,
481 $ ', test(', I2, ') =', G12.5 )
482 9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
483 $ I2, ', test(', I2, ') =', G12.5 )
484 9997 FORMAT( ' NORM =''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
485 $ ', test(', I2, ') =', G12.5 )
486 RETURN
487 *
488 * End of SCHKGE
489 *
490 END