1 SUBROUTINE SDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, AF,
2 $ B, X, XACT, WORK, RWORK, IWORK, NOUT )
3 *
4 * -- LAPACK test routine (version 3.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * November 2006
7 *
8 * .. Scalar Arguments ..
9 LOGICAL TSTERR
10 INTEGER NN, NOUT, NRHS
11 REAL THRESH
12 * ..
13 * .. Array Arguments ..
14 LOGICAL DOTYPE( * )
15 INTEGER IWORK( * ), NVAL( * )
16 REAL A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ),
17 $ X( * ), XACT( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * SDRVGT tests SGTSV and -SVX.
24 *
25 * Arguments
26 * =========
27 *
28 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
29 * The matrix types to be used for testing. Matrices of type j
30 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
31 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
32 *
33 * NN (input) INTEGER
34 * The number of values of N contained in the vector NVAL.
35 *
36 * NVAL (input) INTEGER array, dimension (NN)
37 * The values of the matrix dimension N.
38 *
39 * THRESH (input) REAL
40 * The threshold value for the test ratios. A result is
41 * included in the output file if RESULT >= THRESH. To have
42 * every test ratio printed, use THRESH = 0.
43 *
44 * TSTERR (input) LOGICAL
45 * Flag that indicates whether error exits are to be tested.
46 *
47 * A (workspace) REAL array, dimension (NMAX*4)
48 *
49 * AF (workspace) REAL array, dimension (NMAX*4)
50 *
51 * B (workspace) REAL array, dimension (NMAX*NRHS)
52 *
53 * X (workspace) REAL array, dimension (NMAX*NRHS)
54 *
55 * XACT (workspace) REAL array, dimension (NMAX*NRHS)
56 *
57 * WORK (workspace) REAL array, dimension
58 * (NMAX*max(3,NRHS))
59 *
60 * RWORK (workspace) REAL array, dimension
61 * (max(NMAX,2*NRHS))
62 *
63 * IWORK (workspace) INTEGER array, dimension (2*NMAX)
64 *
65 * NOUT (input) INTEGER
66 * The unit number for output.
67 *
68 * =====================================================================
69 *
70 * .. Parameters ..
71 REAL ONE, ZERO
72 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
73 INTEGER NTYPES
74 PARAMETER ( NTYPES = 12 )
75 INTEGER NTESTS
76 PARAMETER ( NTESTS = 6 )
77 * ..
78 * .. Local Scalars ..
79 LOGICAL TRFCON, ZEROT
80 CHARACTER DIST, FACT, TRANS, TYPE
81 CHARACTER*3 PATH
82 INTEGER I, IFACT, IMAT, IN, INFO, ITRAN, IX, IZERO, J,
83 $ K, K1, KL, KOFF, KU, LDA, M, MODE, N, NERRS,
84 $ NFAIL, NIMAT, NRUN, NT
85 REAL AINVNM, ANORM, ANORMI, ANORMO, COND, RCOND,
86 $ RCONDC, RCONDI, RCONDO
87 * ..
88 * .. Local Arrays ..
89 CHARACTER TRANSS( 3 )
90 INTEGER ISEED( 4 ), ISEEDY( 4 )
91 REAL RESULT( NTESTS ), Z( 3 )
92 * ..
93 * .. External Functions ..
94 REAL SASUM, SGET06, SLANGT
95 EXTERNAL SASUM, SGET06, SLANGT
96 * ..
97 * .. External Subroutines ..
98 EXTERNAL ALADHD, ALAERH, ALASVM, SCOPY, SERRVX, SGET04,
99 $ SGTSV, SGTSVX, SGTT01, SGTT02, SGTT05, SGTTRF,
100 $ SGTTRS, SLACPY, SLAGTM, SLARNV, SLASET, SLATB4,
101 $ SLATMS, SSCAL
102 * ..
103 * .. Intrinsic Functions ..
104 INTRINSIC MAX
105 * ..
106 * .. Scalars in Common ..
107 LOGICAL LERR, OK
108 CHARACTER*32 SRNAMT
109 INTEGER INFOT, NUNIT
110 * ..
111 * .. Common blocks ..
112 COMMON / INFOC / INFOT, NUNIT, OK, LERR
113 COMMON / SRNAMC / SRNAMT
114 * ..
115 * .. Data statements ..
116 DATA ISEEDY / 0, 0, 0, 1 / , TRANSS / 'N', 'T',
117 $ 'C' /
118 * ..
119 * .. Executable Statements ..
120 *
121 PATH( 1: 1 ) = 'Single precision'
122 PATH( 2: 3 ) = 'GT'
123 NRUN = 0
124 NFAIL = 0
125 NERRS = 0
126 DO 10 I = 1, 4
127 ISEED( I ) = ISEEDY( I )
128 10 CONTINUE
129 *
130 * Test the error exits
131 *
132 IF( TSTERR )
133 $ CALL SERRVX( PATH, NOUT )
134 INFOT = 0
135 *
136 DO 140 IN = 1, NN
137 *
138 * Do for each value of N in NVAL.
139 *
140 N = NVAL( IN )
141 M = MAX( N-1, 0 )
142 LDA = MAX( 1, N )
143 NIMAT = NTYPES
144 IF( N.LE.0 )
145 $ NIMAT = 1
146 *
147 DO 130 IMAT = 1, NIMAT
148 *
149 * Do the tests only if DOTYPE( IMAT ) is true.
150 *
151 IF( .NOT.DOTYPE( IMAT ) )
152 $ GO TO 130
153 *
154 * Set up parameters with SLATB4.
155 *
156 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
157 $ COND, DIST )
158 *
159 ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
160 IF( IMAT.LE.6 ) THEN
161 *
162 * Types 1-6: generate matrices of known condition number.
163 *
164 KOFF = MAX( 2-KU, 3-MAX( 1, N ) )
165 SRNAMT = 'SLATMS'
166 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
167 $ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
168 $ INFO )
169 *
170 * Check the error code from SLATMS.
171 *
172 IF( INFO.NE.0 ) THEN
173 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, KL,
174 $ KU, -1, IMAT, NFAIL, NERRS, NOUT )
175 GO TO 130
176 END IF
177 IZERO = 0
178 *
179 IF( N.GT.1 ) THEN
180 CALL SCOPY( N-1, AF( 4 ), 3, A, 1 )
181 CALL SCOPY( N-1, AF( 3 ), 3, A( N+M+1 ), 1 )
182 END IF
183 CALL SCOPY( N, AF( 2 ), 3, A( M+1 ), 1 )
184 ELSE
185 *
186 * Types 7-12: generate tridiagonal matrices with
187 * unknown condition numbers.
188 *
189 IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
190 *
191 * Generate a matrix with elements from [-1,1].
192 *
193 CALL SLARNV( 2, ISEED, N+2*M, A )
194 IF( ANORM.NE.ONE )
195 $ CALL SSCAL( N+2*M, ANORM, A, 1 )
196 ELSE IF( IZERO.GT.0 ) THEN
197 *
198 * Reuse the last matrix by copying back the zeroed out
199 * elements.
200 *
201 IF( IZERO.EQ.1 ) THEN
202 A( N ) = Z( 2 )
203 IF( N.GT.1 )
204 $ A( 1 ) = Z( 3 )
205 ELSE IF( IZERO.EQ.N ) THEN
206 A( 3*N-2 ) = Z( 1 )
207 A( 2*N-1 ) = Z( 2 )
208 ELSE
209 A( 2*N-2+IZERO ) = Z( 1 )
210 A( N-1+IZERO ) = Z( 2 )
211 A( IZERO ) = Z( 3 )
212 END IF
213 END IF
214 *
215 * If IMAT > 7, set one column of the matrix to 0.
216 *
217 IF( .NOT.ZEROT ) THEN
218 IZERO = 0
219 ELSE IF( IMAT.EQ.8 ) THEN
220 IZERO = 1
221 Z( 2 ) = A( N )
222 A( N ) = ZERO
223 IF( N.GT.1 ) THEN
224 Z( 3 ) = A( 1 )
225 A( 1 ) = ZERO
226 END IF
227 ELSE IF( IMAT.EQ.9 ) THEN
228 IZERO = N
229 Z( 1 ) = A( 3*N-2 )
230 Z( 2 ) = A( 2*N-1 )
231 A( 3*N-2 ) = ZERO
232 A( 2*N-1 ) = ZERO
233 ELSE
234 IZERO = ( N+1 ) / 2
235 DO 20 I = IZERO, N - 1
236 A( 2*N-2+I ) = ZERO
237 A( N-1+I ) = ZERO
238 A( I ) = ZERO
239 20 CONTINUE
240 A( 3*N-2 ) = ZERO
241 A( 2*N-1 ) = ZERO
242 END IF
243 END IF
244 *
245 DO 120 IFACT = 1, 2
246 IF( IFACT.EQ.1 ) THEN
247 FACT = 'F'
248 ELSE
249 FACT = 'N'
250 END IF
251 *
252 * Compute the condition number for comparison with
253 * the value returned by SGTSVX.
254 *
255 IF( ZEROT ) THEN
256 IF( IFACT.EQ.1 )
257 $ GO TO 120
258 RCONDO = ZERO
259 RCONDI = ZERO
260 *
261 ELSE IF( IFACT.EQ.1 ) THEN
262 CALL SCOPY( N+2*M, A, 1, AF, 1 )
263 *
264 * Compute the 1-norm and infinity-norm of A.
265 *
266 ANORMO = SLANGT( '1', N, A, A( M+1 ), A( N+M+1 ) )
267 ANORMI = SLANGT( 'I', N, A, A( M+1 ), A( N+M+1 ) )
268 *
269 * Factor the matrix A.
270 *
271 CALL SGTTRF( N, AF, AF( M+1 ), AF( N+M+1 ),
272 $ AF( N+2*M+1 ), IWORK, INFO )
273 *
274 * Use SGTTRS to solve for one column at a time of
275 * inv(A), computing the maximum column sum as we go.
276 *
277 AINVNM = ZERO
278 DO 40 I = 1, N
279 DO 30 J = 1, N
280 X( J ) = ZERO
281 30 CONTINUE
282 X( I ) = ONE
283 CALL SGTTRS( 'No transpose', N, 1, AF, AF( M+1 ),
284 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
285 $ LDA, INFO )
286 AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) )
287 40 CONTINUE
288 *
289 * Compute the 1-norm condition number of A.
290 *
291 IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
292 RCONDO = ONE
293 ELSE
294 RCONDO = ( ONE / ANORMO ) / AINVNM
295 END IF
296 *
297 * Use SGTTRS to solve for one column at a time of
298 * inv(A'), computing the maximum column sum as we go.
299 *
300 AINVNM = ZERO
301 DO 60 I = 1, N
302 DO 50 J = 1, N
303 X( J ) = ZERO
304 50 CONTINUE
305 X( I ) = ONE
306 CALL SGTTRS( 'Transpose', N, 1, AF, AF( M+1 ),
307 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
308 $ LDA, INFO )
309 AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) )
310 60 CONTINUE
311 *
312 * Compute the infinity-norm condition number of A.
313 *
314 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
315 RCONDI = ONE
316 ELSE
317 RCONDI = ( ONE / ANORMI ) / AINVNM
318 END IF
319 END IF
320 *
321 DO 110 ITRAN = 1, 3
322 TRANS = TRANSS( ITRAN )
323 IF( ITRAN.EQ.1 ) THEN
324 RCONDC = RCONDO
325 ELSE
326 RCONDC = RCONDI
327 END IF
328 *
329 * Generate NRHS random solution vectors.
330 *
331 IX = 1
332 DO 70 J = 1, NRHS
333 CALL SLARNV( 2, ISEED, N, XACT( IX ) )
334 IX = IX + LDA
335 70 CONTINUE
336 *
337 * Set the right hand side.
338 *
339 CALL SLAGTM( TRANS, N, NRHS, ONE, A, A( M+1 ),
340 $ A( N+M+1 ), XACT, LDA, ZERO, B, LDA )
341 *
342 IF( IFACT.EQ.2 .AND. ITRAN.EQ.1 ) THEN
343 *
344 * --- Test SGTSV ---
345 *
346 * Solve the system using Gaussian elimination with
347 * partial pivoting.
348 *
349 CALL SCOPY( N+2*M, A, 1, AF, 1 )
350 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
351 *
352 SRNAMT = 'SGTSV '
353 CALL SGTSV( N, NRHS, AF, AF( M+1 ), AF( N+M+1 ), X,
354 $ LDA, INFO )
355 *
356 * Check error code from SGTSV .
357 *
358 IF( INFO.NE.IZERO )
359 $ CALL ALAERH( PATH, 'SGTSV ', INFO, IZERO, ' ',
360 $ N, N, 1, 1, NRHS, IMAT, NFAIL,
361 $ NERRS, NOUT )
362 NT = 1
363 IF( IZERO.EQ.0 ) THEN
364 *
365 * Check residual of computed solution.
366 *
367 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
368 $ LDA )
369 CALL SGTT02( TRANS, N, NRHS, A, A( M+1 ),
370 $ A( N+M+1 ), X, LDA, WORK, LDA,
371 $ RWORK, RESULT( 2 ) )
372 *
373 * Check solution from generated exact solution.
374 *
375 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
376 $ RESULT( 3 ) )
377 NT = 3
378 END IF
379 *
380 * Print information about the tests that did not pass
381 * the threshold.
382 *
383 DO 80 K = 2, NT
384 IF( RESULT( K ).GE.THRESH ) THEN
385 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
386 $ CALL ALADHD( NOUT, PATH )
387 WRITE( NOUT, FMT = 9999 )'SGTSV ', N, IMAT,
388 $ K, RESULT( K )
389 NFAIL = NFAIL + 1
390 END IF
391 80 CONTINUE
392 NRUN = NRUN + NT - 1
393 END IF
394 *
395 * --- Test SGTSVX ---
396 *
397 IF( IFACT.GT.1 ) THEN
398 *
399 * Initialize AF to zero.
400 *
401 DO 90 I = 1, 3*N - 2
402 AF( I ) = ZERO
403 90 CONTINUE
404 END IF
405 CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
406 *
407 * Solve the system and compute the condition number and
408 * error bounds using SGTSVX.
409 *
410 SRNAMT = 'SGTSVX'
411 CALL SGTSVX( FACT, TRANS, N, NRHS, A, A( M+1 ),
412 $ A( N+M+1 ), AF, AF( M+1 ), AF( N+M+1 ),
413 $ AF( N+2*M+1 ), IWORK, B, LDA, X, LDA,
414 $ RCOND, RWORK, RWORK( NRHS+1 ), WORK,
415 $ IWORK( N+1 ), INFO )
416 *
417 * Check the error code from SGTSVX.
418 *
419 IF( INFO.NE.IZERO )
420 $ CALL ALAERH( PATH, 'SGTSVX', INFO, IZERO,
421 $ FACT // TRANS, N, N, 1, 1, NRHS, IMAT,
422 $ NFAIL, NERRS, NOUT )
423 *
424 IF( IFACT.GE.2 ) THEN
425 *
426 * Reconstruct matrix from factors and compute
427 * residual.
428 *
429 CALL SGTT01( N, A, A( M+1 ), A( N+M+1 ), AF,
430 $ AF( M+1 ), AF( N+M+1 ), AF( N+2*M+1 ),
431 $ IWORK, WORK, LDA, RWORK, RESULT( 1 ) )
432 K1 = 1
433 ELSE
434 K1 = 2
435 END IF
436 *
437 IF( INFO.EQ.0 ) THEN
438 TRFCON = .FALSE.
439 *
440 * Check residual of computed solution.
441 *
442 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
443 CALL SGTT02( TRANS, N, NRHS, A, A( M+1 ),
444 $ A( N+M+1 ), X, LDA, WORK, LDA, RWORK,
445 $ RESULT( 2 ) )
446 *
447 * Check solution from generated exact solution.
448 *
449 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
450 $ RESULT( 3 ) )
451 *
452 * Check the error bounds from iterative refinement.
453 *
454 CALL SGTT05( TRANS, N, NRHS, A, A( M+1 ),
455 $ A( N+M+1 ), B, LDA, X, LDA, XACT, LDA,
456 $ RWORK, RWORK( NRHS+1 ), RESULT( 4 ) )
457 NT = 5
458 END IF
459 *
460 * Print information about the tests that did not pass
461 * the threshold.
462 *
463 DO 100 K = K1, NT
464 IF( RESULT( K ).GE.THRESH ) THEN
465 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
466 $ CALL ALADHD( NOUT, PATH )
467 WRITE( NOUT, FMT = 9998 )'SGTSVX', FACT, TRANS,
468 $ N, IMAT, K, RESULT( K )
469 NFAIL = NFAIL + 1
470 END IF
471 100 CONTINUE
472 *
473 * Check the reciprocal of the condition number.
474 *
475 RESULT( 6 ) = SGET06( RCOND, RCONDC )
476 IF( RESULT( 6 ).GE.THRESH ) THEN
477 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
478 $ CALL ALADHD( NOUT, PATH )
479 WRITE( NOUT, FMT = 9998 )'SGTSVX', FACT, TRANS, N,
480 $ IMAT, K, RESULT( K )
481 NFAIL = NFAIL + 1
482 END IF
483 NRUN = NRUN + NT - K1 + 2
484 *
485 110 CONTINUE
486 120 CONTINUE
487 130 CONTINUE
488 140 CONTINUE
489 *
490 * Print a summary of the results.
491 *
492 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
493 *
494 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test ', I2,
495 $ ', ratio = ', G12.5 )
496 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N =',
497 $ I5, ', type ', I2, ', test ', I2, ', ratio = ', G12.5 )
498 RETURN
499 *
500 * End of SDRVGT
501 *
502 END
2 $ B, X, XACT, WORK, RWORK, IWORK, NOUT )
3 *
4 * -- LAPACK test routine (version 3.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * November 2006
7 *
8 * .. Scalar Arguments ..
9 LOGICAL TSTERR
10 INTEGER NN, NOUT, NRHS
11 REAL THRESH
12 * ..
13 * .. Array Arguments ..
14 LOGICAL DOTYPE( * )
15 INTEGER IWORK( * ), NVAL( * )
16 REAL A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ),
17 $ X( * ), XACT( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * SDRVGT tests SGTSV and -SVX.
24 *
25 * Arguments
26 * =========
27 *
28 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
29 * The matrix types to be used for testing. Matrices of type j
30 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
31 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
32 *
33 * NN (input) INTEGER
34 * The number of values of N contained in the vector NVAL.
35 *
36 * NVAL (input) INTEGER array, dimension (NN)
37 * The values of the matrix dimension N.
38 *
39 * THRESH (input) REAL
40 * The threshold value for the test ratios. A result is
41 * included in the output file if RESULT >= THRESH. To have
42 * every test ratio printed, use THRESH = 0.
43 *
44 * TSTERR (input) LOGICAL
45 * Flag that indicates whether error exits are to be tested.
46 *
47 * A (workspace) REAL array, dimension (NMAX*4)
48 *
49 * AF (workspace) REAL array, dimension (NMAX*4)
50 *
51 * B (workspace) REAL array, dimension (NMAX*NRHS)
52 *
53 * X (workspace) REAL array, dimension (NMAX*NRHS)
54 *
55 * XACT (workspace) REAL array, dimension (NMAX*NRHS)
56 *
57 * WORK (workspace) REAL array, dimension
58 * (NMAX*max(3,NRHS))
59 *
60 * RWORK (workspace) REAL array, dimension
61 * (max(NMAX,2*NRHS))
62 *
63 * IWORK (workspace) INTEGER array, dimension (2*NMAX)
64 *
65 * NOUT (input) INTEGER
66 * The unit number for output.
67 *
68 * =====================================================================
69 *
70 * .. Parameters ..
71 REAL ONE, ZERO
72 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
73 INTEGER NTYPES
74 PARAMETER ( NTYPES = 12 )
75 INTEGER NTESTS
76 PARAMETER ( NTESTS = 6 )
77 * ..
78 * .. Local Scalars ..
79 LOGICAL TRFCON, ZEROT
80 CHARACTER DIST, FACT, TRANS, TYPE
81 CHARACTER*3 PATH
82 INTEGER I, IFACT, IMAT, IN, INFO, ITRAN, IX, IZERO, J,
83 $ K, K1, KL, KOFF, KU, LDA, M, MODE, N, NERRS,
84 $ NFAIL, NIMAT, NRUN, NT
85 REAL AINVNM, ANORM, ANORMI, ANORMO, COND, RCOND,
86 $ RCONDC, RCONDI, RCONDO
87 * ..
88 * .. Local Arrays ..
89 CHARACTER TRANSS( 3 )
90 INTEGER ISEED( 4 ), ISEEDY( 4 )
91 REAL RESULT( NTESTS ), Z( 3 )
92 * ..
93 * .. External Functions ..
94 REAL SASUM, SGET06, SLANGT
95 EXTERNAL SASUM, SGET06, SLANGT
96 * ..
97 * .. External Subroutines ..
98 EXTERNAL ALADHD, ALAERH, ALASVM, SCOPY, SERRVX, SGET04,
99 $ SGTSV, SGTSVX, SGTT01, SGTT02, SGTT05, SGTTRF,
100 $ SGTTRS, SLACPY, SLAGTM, SLARNV, SLASET, SLATB4,
101 $ SLATMS, SSCAL
102 * ..
103 * .. Intrinsic Functions ..
104 INTRINSIC MAX
105 * ..
106 * .. Scalars in Common ..
107 LOGICAL LERR, OK
108 CHARACTER*32 SRNAMT
109 INTEGER INFOT, NUNIT
110 * ..
111 * .. Common blocks ..
112 COMMON / INFOC / INFOT, NUNIT, OK, LERR
113 COMMON / SRNAMC / SRNAMT
114 * ..
115 * .. Data statements ..
116 DATA ISEEDY / 0, 0, 0, 1 / , TRANSS / 'N', 'T',
117 $ 'C' /
118 * ..
119 * .. Executable Statements ..
120 *
121 PATH( 1: 1 ) = 'Single precision'
122 PATH( 2: 3 ) = 'GT'
123 NRUN = 0
124 NFAIL = 0
125 NERRS = 0
126 DO 10 I = 1, 4
127 ISEED( I ) = ISEEDY( I )
128 10 CONTINUE
129 *
130 * Test the error exits
131 *
132 IF( TSTERR )
133 $ CALL SERRVX( PATH, NOUT )
134 INFOT = 0
135 *
136 DO 140 IN = 1, NN
137 *
138 * Do for each value of N in NVAL.
139 *
140 N = NVAL( IN )
141 M = MAX( N-1, 0 )
142 LDA = MAX( 1, N )
143 NIMAT = NTYPES
144 IF( N.LE.0 )
145 $ NIMAT = 1
146 *
147 DO 130 IMAT = 1, NIMAT
148 *
149 * Do the tests only if DOTYPE( IMAT ) is true.
150 *
151 IF( .NOT.DOTYPE( IMAT ) )
152 $ GO TO 130
153 *
154 * Set up parameters with SLATB4.
155 *
156 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
157 $ COND, DIST )
158 *
159 ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
160 IF( IMAT.LE.6 ) THEN
161 *
162 * Types 1-6: generate matrices of known condition number.
163 *
164 KOFF = MAX( 2-KU, 3-MAX( 1, N ) )
165 SRNAMT = 'SLATMS'
166 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
167 $ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
168 $ INFO )
169 *
170 * Check the error code from SLATMS.
171 *
172 IF( INFO.NE.0 ) THEN
173 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, KL,
174 $ KU, -1, IMAT, NFAIL, NERRS, NOUT )
175 GO TO 130
176 END IF
177 IZERO = 0
178 *
179 IF( N.GT.1 ) THEN
180 CALL SCOPY( N-1, AF( 4 ), 3, A, 1 )
181 CALL SCOPY( N-1, AF( 3 ), 3, A( N+M+1 ), 1 )
182 END IF
183 CALL SCOPY( N, AF( 2 ), 3, A( M+1 ), 1 )
184 ELSE
185 *
186 * Types 7-12: generate tridiagonal matrices with
187 * unknown condition numbers.
188 *
189 IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
190 *
191 * Generate a matrix with elements from [-1,1].
192 *
193 CALL SLARNV( 2, ISEED, N+2*M, A )
194 IF( ANORM.NE.ONE )
195 $ CALL SSCAL( N+2*M, ANORM, A, 1 )
196 ELSE IF( IZERO.GT.0 ) THEN
197 *
198 * Reuse the last matrix by copying back the zeroed out
199 * elements.
200 *
201 IF( IZERO.EQ.1 ) THEN
202 A( N ) = Z( 2 )
203 IF( N.GT.1 )
204 $ A( 1 ) = Z( 3 )
205 ELSE IF( IZERO.EQ.N ) THEN
206 A( 3*N-2 ) = Z( 1 )
207 A( 2*N-1 ) = Z( 2 )
208 ELSE
209 A( 2*N-2+IZERO ) = Z( 1 )
210 A( N-1+IZERO ) = Z( 2 )
211 A( IZERO ) = Z( 3 )
212 END IF
213 END IF
214 *
215 * If IMAT > 7, set one column of the matrix to 0.
216 *
217 IF( .NOT.ZEROT ) THEN
218 IZERO = 0
219 ELSE IF( IMAT.EQ.8 ) THEN
220 IZERO = 1
221 Z( 2 ) = A( N )
222 A( N ) = ZERO
223 IF( N.GT.1 ) THEN
224 Z( 3 ) = A( 1 )
225 A( 1 ) = ZERO
226 END IF
227 ELSE IF( IMAT.EQ.9 ) THEN
228 IZERO = N
229 Z( 1 ) = A( 3*N-2 )
230 Z( 2 ) = A( 2*N-1 )
231 A( 3*N-2 ) = ZERO
232 A( 2*N-1 ) = ZERO
233 ELSE
234 IZERO = ( N+1 ) / 2
235 DO 20 I = IZERO, N - 1
236 A( 2*N-2+I ) = ZERO
237 A( N-1+I ) = ZERO
238 A( I ) = ZERO
239 20 CONTINUE
240 A( 3*N-2 ) = ZERO
241 A( 2*N-1 ) = ZERO
242 END IF
243 END IF
244 *
245 DO 120 IFACT = 1, 2
246 IF( IFACT.EQ.1 ) THEN
247 FACT = 'F'
248 ELSE
249 FACT = 'N'
250 END IF
251 *
252 * Compute the condition number for comparison with
253 * the value returned by SGTSVX.
254 *
255 IF( ZEROT ) THEN
256 IF( IFACT.EQ.1 )
257 $ GO TO 120
258 RCONDO = ZERO
259 RCONDI = ZERO
260 *
261 ELSE IF( IFACT.EQ.1 ) THEN
262 CALL SCOPY( N+2*M, A, 1, AF, 1 )
263 *
264 * Compute the 1-norm and infinity-norm of A.
265 *
266 ANORMO = SLANGT( '1', N, A, A( M+1 ), A( N+M+1 ) )
267 ANORMI = SLANGT( 'I', N, A, A( M+1 ), A( N+M+1 ) )
268 *
269 * Factor the matrix A.
270 *
271 CALL SGTTRF( N, AF, AF( M+1 ), AF( N+M+1 ),
272 $ AF( N+2*M+1 ), IWORK, INFO )
273 *
274 * Use SGTTRS to solve for one column at a time of
275 * inv(A), computing the maximum column sum as we go.
276 *
277 AINVNM = ZERO
278 DO 40 I = 1, N
279 DO 30 J = 1, N
280 X( J ) = ZERO
281 30 CONTINUE
282 X( I ) = ONE
283 CALL SGTTRS( 'No transpose', N, 1, AF, AF( M+1 ),
284 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
285 $ LDA, INFO )
286 AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) )
287 40 CONTINUE
288 *
289 * Compute the 1-norm condition number of A.
290 *
291 IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
292 RCONDO = ONE
293 ELSE
294 RCONDO = ( ONE / ANORMO ) / AINVNM
295 END IF
296 *
297 * Use SGTTRS to solve for one column at a time of
298 * inv(A'), computing the maximum column sum as we go.
299 *
300 AINVNM = ZERO
301 DO 60 I = 1, N
302 DO 50 J = 1, N
303 X( J ) = ZERO
304 50 CONTINUE
305 X( I ) = ONE
306 CALL SGTTRS( 'Transpose', N, 1, AF, AF( M+1 ),
307 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
308 $ LDA, INFO )
309 AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) )
310 60 CONTINUE
311 *
312 * Compute the infinity-norm condition number of A.
313 *
314 IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
315 RCONDI = ONE
316 ELSE
317 RCONDI = ( ONE / ANORMI ) / AINVNM
318 END IF
319 END IF
320 *
321 DO 110 ITRAN = 1, 3
322 TRANS = TRANSS( ITRAN )
323 IF( ITRAN.EQ.1 ) THEN
324 RCONDC = RCONDO
325 ELSE
326 RCONDC = RCONDI
327 END IF
328 *
329 * Generate NRHS random solution vectors.
330 *
331 IX = 1
332 DO 70 J = 1, NRHS
333 CALL SLARNV( 2, ISEED, N, XACT( IX ) )
334 IX = IX + LDA
335 70 CONTINUE
336 *
337 * Set the right hand side.
338 *
339 CALL SLAGTM( TRANS, N, NRHS, ONE, A, A( M+1 ),
340 $ A( N+M+1 ), XACT, LDA, ZERO, B, LDA )
341 *
342 IF( IFACT.EQ.2 .AND. ITRAN.EQ.1 ) THEN
343 *
344 * --- Test SGTSV ---
345 *
346 * Solve the system using Gaussian elimination with
347 * partial pivoting.
348 *
349 CALL SCOPY( N+2*M, A, 1, AF, 1 )
350 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
351 *
352 SRNAMT = 'SGTSV '
353 CALL SGTSV( N, NRHS, AF, AF( M+1 ), AF( N+M+1 ), X,
354 $ LDA, INFO )
355 *
356 * Check error code from SGTSV .
357 *
358 IF( INFO.NE.IZERO )
359 $ CALL ALAERH( PATH, 'SGTSV ', INFO, IZERO, ' ',
360 $ N, N, 1, 1, NRHS, IMAT, NFAIL,
361 $ NERRS, NOUT )
362 NT = 1
363 IF( IZERO.EQ.0 ) THEN
364 *
365 * Check residual of computed solution.
366 *
367 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK,
368 $ LDA )
369 CALL SGTT02( TRANS, N, NRHS, A, A( M+1 ),
370 $ A( N+M+1 ), X, LDA, WORK, LDA,
371 $ RWORK, RESULT( 2 ) )
372 *
373 * Check solution from generated exact solution.
374 *
375 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
376 $ RESULT( 3 ) )
377 NT = 3
378 END IF
379 *
380 * Print information about the tests that did not pass
381 * the threshold.
382 *
383 DO 80 K = 2, NT
384 IF( RESULT( K ).GE.THRESH ) THEN
385 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
386 $ CALL ALADHD( NOUT, PATH )
387 WRITE( NOUT, FMT = 9999 )'SGTSV ', N, IMAT,
388 $ K, RESULT( K )
389 NFAIL = NFAIL + 1
390 END IF
391 80 CONTINUE
392 NRUN = NRUN + NT - 1
393 END IF
394 *
395 * --- Test SGTSVX ---
396 *
397 IF( IFACT.GT.1 ) THEN
398 *
399 * Initialize AF to zero.
400 *
401 DO 90 I = 1, 3*N - 2
402 AF( I ) = ZERO
403 90 CONTINUE
404 END IF
405 CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA )
406 *
407 * Solve the system and compute the condition number and
408 * error bounds using SGTSVX.
409 *
410 SRNAMT = 'SGTSVX'
411 CALL SGTSVX( FACT, TRANS, N, NRHS, A, A( M+1 ),
412 $ A( N+M+1 ), AF, AF( M+1 ), AF( N+M+1 ),
413 $ AF( N+2*M+1 ), IWORK, B, LDA, X, LDA,
414 $ RCOND, RWORK, RWORK( NRHS+1 ), WORK,
415 $ IWORK( N+1 ), INFO )
416 *
417 * Check the error code from SGTSVX.
418 *
419 IF( INFO.NE.IZERO )
420 $ CALL ALAERH( PATH, 'SGTSVX', INFO, IZERO,
421 $ FACT // TRANS, N, N, 1, 1, NRHS, IMAT,
422 $ NFAIL, NERRS, NOUT )
423 *
424 IF( IFACT.GE.2 ) THEN
425 *
426 * Reconstruct matrix from factors and compute
427 * residual.
428 *
429 CALL SGTT01( N, A, A( M+1 ), A( N+M+1 ), AF,
430 $ AF( M+1 ), AF( N+M+1 ), AF( N+2*M+1 ),
431 $ IWORK, WORK, LDA, RWORK, RESULT( 1 ) )
432 K1 = 1
433 ELSE
434 K1 = 2
435 END IF
436 *
437 IF( INFO.EQ.0 ) THEN
438 TRFCON = .FALSE.
439 *
440 * Check residual of computed solution.
441 *
442 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
443 CALL SGTT02( TRANS, N, NRHS, A, A( M+1 ),
444 $ A( N+M+1 ), X, LDA, WORK, LDA, RWORK,
445 $ RESULT( 2 ) )
446 *
447 * Check solution from generated exact solution.
448 *
449 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
450 $ RESULT( 3 ) )
451 *
452 * Check the error bounds from iterative refinement.
453 *
454 CALL SGTT05( TRANS, N, NRHS, A, A( M+1 ),
455 $ A( N+M+1 ), B, LDA, X, LDA, XACT, LDA,
456 $ RWORK, RWORK( NRHS+1 ), RESULT( 4 ) )
457 NT = 5
458 END IF
459 *
460 * Print information about the tests that did not pass
461 * the threshold.
462 *
463 DO 100 K = K1, NT
464 IF( RESULT( K ).GE.THRESH ) THEN
465 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
466 $ CALL ALADHD( NOUT, PATH )
467 WRITE( NOUT, FMT = 9998 )'SGTSVX', FACT, TRANS,
468 $ N, IMAT, K, RESULT( K )
469 NFAIL = NFAIL + 1
470 END IF
471 100 CONTINUE
472 *
473 * Check the reciprocal of the condition number.
474 *
475 RESULT( 6 ) = SGET06( RCOND, RCONDC )
476 IF( RESULT( 6 ).GE.THRESH ) THEN
477 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
478 $ CALL ALADHD( NOUT, PATH )
479 WRITE( NOUT, FMT = 9998 )'SGTSVX', FACT, TRANS, N,
480 $ IMAT, K, RESULT( K )
481 NFAIL = NFAIL + 1
482 END IF
483 NRUN = NRUN + NT - K1 + 2
484 *
485 110 CONTINUE
486 120 CONTINUE
487 130 CONTINUE
488 140 CONTINUE
489 *
490 * Print a summary of the results.
491 *
492 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
493 *
494 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test ', I2,
495 $ ', ratio = ', G12.5 )
496 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N =',
497 $ I5, ', type ', I2, ', test ', I2, ', ratio = ', G12.5 )
498 RETURN
499 *
500 * End of SDRVGT
501 *
502 END