1 SUBROUTINE SCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
2 $ A, D, E, B, X, XACT, WORK, RWORK, 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, NNS, NOUT
11 REAL THRESH
12 * ..
13 * .. Array Arguments ..
14 LOGICAL DOTYPE( * )
15 INTEGER NSVAL( * ), NVAL( * )
16 REAL A( * ), B( * ), D( * ), E( * ), RWORK( * ),
17 $ WORK( * ), X( * ), XACT( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * SCHKPT tests SPTTRF, -TRS, -RFS, and -CON
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 * NNS (input) INTEGER
40 * The number of values of NRHS contained in the vector NSVAL.
41 *
42 * NSVAL (input) INTEGER array, dimension (NNS)
43 * The values of the number of right hand sides NRHS.
44 *
45 * THRESH (input) REAL
46 * The threshold value for the test ratios. A result is
47 * included in the output file if RESULT >= THRESH. To have
48 * every test ratio printed, use THRESH = 0.
49 *
50 * TSTERR (input) LOGICAL
51 * Flag that indicates whether error exits are to be tested.
52 *
53 * A (workspace) REAL array, dimension (NMAX*2)
54 *
55 * D (workspace) REAL array, dimension (NMAX*2)
56 *
57 * E (workspace) REAL array, dimension (NMAX*2)
58 *
59 * B (workspace) REAL array, dimension (NMAX*NSMAX)
60 * where NSMAX is the largest entry in NSVAL.
61 *
62 * X (workspace) REAL array, dimension (NMAX*NSMAX)
63 *
64 * XACT (workspace) REAL array, dimension (NMAX*NSMAX)
65 *
66 * WORK (workspace) REAL array, dimension
67 * (NMAX*max(3,NSMAX))
68 *
69 * RWORK (workspace) REAL array, dimension
70 * (max(NMAX,2*NSMAX))
71 *
72 * NOUT (input) INTEGER
73 * The unit number for output.
74 *
75 * =====================================================================
76 *
77 * .. Parameters ..
78 REAL ONE, ZERO
79 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
80 INTEGER NTYPES
81 PARAMETER ( NTYPES = 12 )
82 INTEGER NTESTS
83 PARAMETER ( NTESTS = 7 )
84 * ..
85 * .. Local Scalars ..
86 LOGICAL ZEROT
87 CHARACTER DIST, TYPE
88 CHARACTER*3 PATH
89 INTEGER I, IA, IMAT, IN, INFO, IRHS, IX, IZERO, J, K,
90 $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT,
91 $ NRHS, NRUN
92 REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
93 * ..
94 * .. Local Arrays ..
95 INTEGER ISEED( 4 ), ISEEDY( 4 )
96 REAL RESULT( NTESTS ), Z( 3 )
97 * ..
98 * .. External Functions ..
99 INTEGER ISAMAX
100 REAL SASUM, SGET06, SLANST
101 EXTERNAL ISAMAX, SASUM, SGET06, SLANST
102 * ..
103 * .. External Subroutines ..
104 EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRGT, SGET04,
105 $ SLACPY, SLAPTM, SLARNV, SLATB4, SLATMS, SPTCON,
106 $ SPTRFS, SPTT01, SPTT02, SPTT05, SPTTRF, SPTTRS,
107 $ SSCAL
108 * ..
109 * .. Intrinsic Functions ..
110 INTRINSIC ABS, MAX
111 * ..
112 * .. Scalars in Common ..
113 LOGICAL LERR, OK
114 CHARACTER*32 SRNAMT
115 INTEGER INFOT, NUNIT
116 * ..
117 * .. Common blocks ..
118 COMMON / INFOC / INFOT, NUNIT, OK, LERR
119 COMMON / SRNAMC / SRNAMT
120 * ..
121 * .. Data statements ..
122 DATA ISEEDY / 0, 0, 0, 1 /
123 * ..
124 * .. Executable Statements ..
125 *
126 PATH( 1: 1 ) = 'Single precision'
127 PATH( 2: 3 ) = 'PT'
128 NRUN = 0
129 NFAIL = 0
130 NERRS = 0
131 DO 10 I = 1, 4
132 ISEED( I ) = ISEEDY( I )
133 10 CONTINUE
134 *
135 * Test the error exits
136 *
137 IF( TSTERR )
138 $ CALL SERRGT( PATH, NOUT )
139 INFOT = 0
140 *
141 DO 110 IN = 1, NN
142 *
143 * Do for each value of N in NVAL.
144 *
145 N = NVAL( IN )
146 LDA = MAX( 1, N )
147 NIMAT = NTYPES
148 IF( N.LE.0 )
149 $ NIMAT = 1
150 *
151 DO 100 IMAT = 1, NIMAT
152 *
153 * Do the tests only if DOTYPE( IMAT ) is true.
154 *
155 IF( N.GT.0 .AND. .NOT.DOTYPE( IMAT ) )
156 $ GO TO 100
157 *
158 * Set up parameters with SLATB4.
159 *
160 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
161 $ COND, DIST )
162 *
163 ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
164 IF( IMAT.LE.6 ) THEN
165 *
166 * Type 1-6: generate a symmetric tridiagonal matrix of
167 * known condition number in lower triangular band storage.
168 *
169 SRNAMT = 'SLATMS'
170 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
171 $ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
172 *
173 * Check the error code from SLATMS.
174 *
175 IF( INFO.NE.0 ) THEN
176 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, KL,
177 $ KU, -1, IMAT, NFAIL, NERRS, NOUT )
178 GO TO 100
179 END IF
180 IZERO = 0
181 *
182 * Copy the matrix to D and E.
183 *
184 IA = 1
185 DO 20 I = 1, N - 1
186 D( I ) = A( IA )
187 E( I ) = A( IA+1 )
188 IA = IA + 2
189 20 CONTINUE
190 IF( N.GT.0 )
191 $ D( N ) = A( IA )
192 ELSE
193 *
194 * Type 7-12: generate a diagonally dominant matrix with
195 * unknown condition number in the vectors D and E.
196 *
197 IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
198 *
199 * Let D and E have values from [-1,1].
200 *
201 CALL SLARNV( 2, ISEED, N, D )
202 CALL SLARNV( 2, ISEED, N-1, E )
203 *
204 * Make the tridiagonal matrix diagonally dominant.
205 *
206 IF( N.EQ.1 ) THEN
207 D( 1 ) = ABS( D( 1 ) )
208 ELSE
209 D( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) )
210 D( N ) = ABS( D( N ) ) + ABS( E( N-1 ) )
211 DO 30 I = 2, N - 1
212 D( I ) = ABS( D( I ) ) + ABS( E( I ) ) +
213 $ ABS( E( I-1 ) )
214 30 CONTINUE
215 END IF
216 *
217 * Scale D and E so the maximum element is ANORM.
218 *
219 IX = ISAMAX( N, D, 1 )
220 DMAX = D( IX )
221 CALL SSCAL( N, ANORM / DMAX, D, 1 )
222 CALL SSCAL( N-1, ANORM / DMAX, E, 1 )
223 *
224 ELSE IF( IZERO.GT.0 ) THEN
225 *
226 * Reuse the last matrix by copying back the zeroed out
227 * elements.
228 *
229 IF( IZERO.EQ.1 ) THEN
230 D( 1 ) = Z( 2 )
231 IF( N.GT.1 )
232 $ E( 1 ) = Z( 3 )
233 ELSE IF( IZERO.EQ.N ) THEN
234 E( N-1 ) = Z( 1 )
235 D( N ) = Z( 2 )
236 ELSE
237 E( IZERO-1 ) = Z( 1 )
238 D( IZERO ) = Z( 2 )
239 E( IZERO ) = Z( 3 )
240 END IF
241 END IF
242 *
243 * For types 8-10, set one row and column of the matrix to
244 * zero.
245 *
246 IZERO = 0
247 IF( IMAT.EQ.8 ) THEN
248 IZERO = 1
249 Z( 2 ) = D( 1 )
250 D( 1 ) = ZERO
251 IF( N.GT.1 ) THEN
252 Z( 3 ) = E( 1 )
253 E( 1 ) = ZERO
254 END IF
255 ELSE IF( IMAT.EQ.9 ) THEN
256 IZERO = N
257 IF( N.GT.1 ) THEN
258 Z( 1 ) = E( N-1 )
259 E( N-1 ) = ZERO
260 END IF
261 Z( 2 ) = D( N )
262 D( N ) = ZERO
263 ELSE IF( IMAT.EQ.10 ) THEN
264 IZERO = ( N+1 ) / 2
265 IF( IZERO.GT.1 ) THEN
266 Z( 1 ) = E( IZERO-1 )
267 E( IZERO-1 ) = ZERO
268 Z( 3 ) = E( IZERO )
269 E( IZERO ) = ZERO
270 END IF
271 Z( 2 ) = D( IZERO )
272 D( IZERO ) = ZERO
273 END IF
274 END IF
275 *
276 CALL SCOPY( N, D, 1, D( N+1 ), 1 )
277 IF( N.GT.1 )
278 $ CALL SCOPY( N-1, E, 1, E( N+1 ), 1 )
279 *
280 *+ TEST 1
281 * Factor A as L*D*L' and compute the ratio
282 * norm(L*D*L' - A) / (n * norm(A) * EPS )
283 *
284 CALL SPTTRF( N, D( N+1 ), E( N+1 ), INFO )
285 *
286 * Check error code from SPTTRF.
287 *
288 IF( INFO.NE.IZERO ) THEN
289 CALL ALAERH( PATH, 'SPTTRF', INFO, IZERO, ' ', N, N, -1,
290 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
291 GO TO 100
292 END IF
293 *
294 IF( INFO.GT.0 ) THEN
295 RCONDC = ZERO
296 GO TO 90
297 END IF
298 *
299 CALL SPTT01( N, D, E, D( N+1 ), E( N+1 ), WORK,
300 $ RESULT( 1 ) )
301 *
302 * Print the test ratio if greater than or equal to THRESH.
303 *
304 IF( RESULT( 1 ).GE.THRESH ) THEN
305 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
306 $ CALL ALAHD( NOUT, PATH )
307 WRITE( NOUT, FMT = 9999 )N, IMAT, 1, RESULT( 1 )
308 NFAIL = NFAIL + 1
309 END IF
310 NRUN = NRUN + 1
311 *
312 * Compute RCONDC = 1 / (norm(A) * norm(inv(A))
313 *
314 * Compute norm(A).
315 *
316 ANORM = SLANST( '1', N, D, E )
317 *
318 * Use SPTTRS to solve for one column at a time of inv(A),
319 * computing the maximum column sum as we go.
320 *
321 AINVNM = ZERO
322 DO 50 I = 1, N
323 DO 40 J = 1, N
324 X( J ) = ZERO
325 40 CONTINUE
326 X( I ) = ONE
327 CALL SPTTRS( N, 1, D( N+1 ), E( N+1 ), X, LDA, INFO )
328 AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) )
329 50 CONTINUE
330 RCONDC = ONE / MAX( ONE, ANORM*AINVNM )
331 *
332 DO 80 IRHS = 1, NNS
333 NRHS = NSVAL( IRHS )
334 *
335 * Generate NRHS random solution vectors.
336 *
337 IX = 1
338 DO 60 J = 1, NRHS
339 CALL SLARNV( 2, ISEED, N, XACT( IX ) )
340 IX = IX + LDA
341 60 CONTINUE
342 *
343 * Set the right hand side.
344 *
345 CALL SLAPTM( N, NRHS, ONE, D, E, XACT, LDA, ZERO, B,
346 $ LDA )
347 *
348 *+ TEST 2
349 * Solve A*x = b and compute the residual.
350 *
351 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
352 CALL SPTTRS( N, NRHS, D( N+1 ), E( N+1 ), X, LDA, INFO )
353 *
354 * Check error code from SPTTRS.
355 *
356 IF( INFO.NE.0 )
357 $ CALL ALAERH( PATH, 'SPTTRS', INFO, 0, ' ', N, N, -1,
358 $ -1, NRHS, IMAT, NFAIL, NERRS, NOUT )
359 *
360 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
361 CALL SPTT02( N, NRHS, D, E, X, LDA, WORK, LDA,
362 $ RESULT( 2 ) )
363 *
364 *+ TEST 3
365 * Check solution from generated exact solution.
366 *
367 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
368 $ RESULT( 3 ) )
369 *
370 *+ TESTS 4, 5, and 6
371 * Use iterative refinement to improve the solution.
372 *
373 SRNAMT = 'SPTRFS'
374 CALL SPTRFS( N, NRHS, D, E, D( N+1 ), E( N+1 ), B, LDA,
375 $ X, LDA, RWORK, RWORK( NRHS+1 ), WORK, INFO )
376 *
377 * Check error code from SPTRFS.
378 *
379 IF( INFO.NE.0 )
380 $ CALL ALAERH( PATH, 'SPTRFS', INFO, 0, ' ', N, N, -1,
381 $ -1, NRHS, IMAT, NFAIL, NERRS, NOUT )
382 *
383 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
384 $ RESULT( 4 ) )
385 CALL SPTT05( N, NRHS, D, E, B, LDA, X, LDA, XACT, LDA,
386 $ RWORK, RWORK( NRHS+1 ), RESULT( 5 ) )
387 *
388 * Print information about the tests that did not pass the
389 * threshold.
390 *
391 DO 70 K = 2, 6
392 IF( RESULT( K ).GE.THRESH ) THEN
393 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
394 $ CALL ALAHD( NOUT, PATH )
395 WRITE( NOUT, FMT = 9998 )N, NRHS, IMAT, K,
396 $ RESULT( K )
397 NFAIL = NFAIL + 1
398 END IF
399 70 CONTINUE
400 NRUN = NRUN + 5
401 80 CONTINUE
402 *
403 *+ TEST 7
404 * Estimate the reciprocal of the condition number of the
405 * matrix.
406 *
407 90 CONTINUE
408 SRNAMT = 'SPTCON'
409 CALL SPTCON( N, D( N+1 ), E( N+1 ), ANORM, RCOND, RWORK,
410 $ INFO )
411 *
412 * Check error code from SPTCON.
413 *
414 IF( INFO.NE.0 )
415 $ CALL ALAERH( PATH, 'SPTCON', INFO, 0, ' ', N, N, -1, -1,
416 $ -1, IMAT, NFAIL, NERRS, NOUT )
417 *
418 RESULT( 7 ) = SGET06( RCOND, RCONDC )
419 *
420 * Print the test ratio if greater than or equal to THRESH.
421 *
422 IF( RESULT( 7 ).GE.THRESH ) THEN
423 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
424 $ CALL ALAHD( NOUT, PATH )
425 WRITE( NOUT, FMT = 9999 )N, IMAT, 7, RESULT( 7 )
426 NFAIL = NFAIL + 1
427 END IF
428 NRUN = NRUN + 1
429 100 CONTINUE
430 110 CONTINUE
431 *
432 * Print a summary of the results.
433 *
434 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
435 *
436 9999 FORMAT( ' N =', I5, ', type ', I2, ', test ', I2, ', ratio = ',
437 $ G12.5 )
438 9998 FORMAT( ' N =', I5, ', NRHS=', I3, ', type ', I2, ', test(', I2,
439 $ ') = ', G12.5 )
440 RETURN
441 *
442 * End of SCHKPT
443 *
444 END
2 $ A, D, E, B, X, XACT, WORK, RWORK, 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, NNS, NOUT
11 REAL THRESH
12 * ..
13 * .. Array Arguments ..
14 LOGICAL DOTYPE( * )
15 INTEGER NSVAL( * ), NVAL( * )
16 REAL A( * ), B( * ), D( * ), E( * ), RWORK( * ),
17 $ WORK( * ), X( * ), XACT( * )
18 * ..
19 *
20 * Purpose
21 * =======
22 *
23 * SCHKPT tests SPTTRF, -TRS, -RFS, and -CON
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 * NNS (input) INTEGER
40 * The number of values of NRHS contained in the vector NSVAL.
41 *
42 * NSVAL (input) INTEGER array, dimension (NNS)
43 * The values of the number of right hand sides NRHS.
44 *
45 * THRESH (input) REAL
46 * The threshold value for the test ratios. A result is
47 * included in the output file if RESULT >= THRESH. To have
48 * every test ratio printed, use THRESH = 0.
49 *
50 * TSTERR (input) LOGICAL
51 * Flag that indicates whether error exits are to be tested.
52 *
53 * A (workspace) REAL array, dimension (NMAX*2)
54 *
55 * D (workspace) REAL array, dimension (NMAX*2)
56 *
57 * E (workspace) REAL array, dimension (NMAX*2)
58 *
59 * B (workspace) REAL array, dimension (NMAX*NSMAX)
60 * where NSMAX is the largest entry in NSVAL.
61 *
62 * X (workspace) REAL array, dimension (NMAX*NSMAX)
63 *
64 * XACT (workspace) REAL array, dimension (NMAX*NSMAX)
65 *
66 * WORK (workspace) REAL array, dimension
67 * (NMAX*max(3,NSMAX))
68 *
69 * RWORK (workspace) REAL array, dimension
70 * (max(NMAX,2*NSMAX))
71 *
72 * NOUT (input) INTEGER
73 * The unit number for output.
74 *
75 * =====================================================================
76 *
77 * .. Parameters ..
78 REAL ONE, ZERO
79 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
80 INTEGER NTYPES
81 PARAMETER ( NTYPES = 12 )
82 INTEGER NTESTS
83 PARAMETER ( NTESTS = 7 )
84 * ..
85 * .. Local Scalars ..
86 LOGICAL ZEROT
87 CHARACTER DIST, TYPE
88 CHARACTER*3 PATH
89 INTEGER I, IA, IMAT, IN, INFO, IRHS, IX, IZERO, J, K,
90 $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT,
91 $ NRHS, NRUN
92 REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
93 * ..
94 * .. Local Arrays ..
95 INTEGER ISEED( 4 ), ISEEDY( 4 )
96 REAL RESULT( NTESTS ), Z( 3 )
97 * ..
98 * .. External Functions ..
99 INTEGER ISAMAX
100 REAL SASUM, SGET06, SLANST
101 EXTERNAL ISAMAX, SASUM, SGET06, SLANST
102 * ..
103 * .. External Subroutines ..
104 EXTERNAL ALAERH, ALAHD, ALASUM, SCOPY, SERRGT, SGET04,
105 $ SLACPY, SLAPTM, SLARNV, SLATB4, SLATMS, SPTCON,
106 $ SPTRFS, SPTT01, SPTT02, SPTT05, SPTTRF, SPTTRS,
107 $ SSCAL
108 * ..
109 * .. Intrinsic Functions ..
110 INTRINSIC ABS, MAX
111 * ..
112 * .. Scalars in Common ..
113 LOGICAL LERR, OK
114 CHARACTER*32 SRNAMT
115 INTEGER INFOT, NUNIT
116 * ..
117 * .. Common blocks ..
118 COMMON / INFOC / INFOT, NUNIT, OK, LERR
119 COMMON / SRNAMC / SRNAMT
120 * ..
121 * .. Data statements ..
122 DATA ISEEDY / 0, 0, 0, 1 /
123 * ..
124 * .. Executable Statements ..
125 *
126 PATH( 1: 1 ) = 'Single precision'
127 PATH( 2: 3 ) = 'PT'
128 NRUN = 0
129 NFAIL = 0
130 NERRS = 0
131 DO 10 I = 1, 4
132 ISEED( I ) = ISEEDY( I )
133 10 CONTINUE
134 *
135 * Test the error exits
136 *
137 IF( TSTERR )
138 $ CALL SERRGT( PATH, NOUT )
139 INFOT = 0
140 *
141 DO 110 IN = 1, NN
142 *
143 * Do for each value of N in NVAL.
144 *
145 N = NVAL( IN )
146 LDA = MAX( 1, N )
147 NIMAT = NTYPES
148 IF( N.LE.0 )
149 $ NIMAT = 1
150 *
151 DO 100 IMAT = 1, NIMAT
152 *
153 * Do the tests only if DOTYPE( IMAT ) is true.
154 *
155 IF( N.GT.0 .AND. .NOT.DOTYPE( IMAT ) )
156 $ GO TO 100
157 *
158 * Set up parameters with SLATB4.
159 *
160 CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
161 $ COND, DIST )
162 *
163 ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
164 IF( IMAT.LE.6 ) THEN
165 *
166 * Type 1-6: generate a symmetric tridiagonal matrix of
167 * known condition number in lower triangular band storage.
168 *
169 SRNAMT = 'SLATMS'
170 CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
171 $ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
172 *
173 * Check the error code from SLATMS.
174 *
175 IF( INFO.NE.0 ) THEN
176 CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, KL,
177 $ KU, -1, IMAT, NFAIL, NERRS, NOUT )
178 GO TO 100
179 END IF
180 IZERO = 0
181 *
182 * Copy the matrix to D and E.
183 *
184 IA = 1
185 DO 20 I = 1, N - 1
186 D( I ) = A( IA )
187 E( I ) = A( IA+1 )
188 IA = IA + 2
189 20 CONTINUE
190 IF( N.GT.0 )
191 $ D( N ) = A( IA )
192 ELSE
193 *
194 * Type 7-12: generate a diagonally dominant matrix with
195 * unknown condition number in the vectors D and E.
196 *
197 IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
198 *
199 * Let D and E have values from [-1,1].
200 *
201 CALL SLARNV( 2, ISEED, N, D )
202 CALL SLARNV( 2, ISEED, N-1, E )
203 *
204 * Make the tridiagonal matrix diagonally dominant.
205 *
206 IF( N.EQ.1 ) THEN
207 D( 1 ) = ABS( D( 1 ) )
208 ELSE
209 D( 1 ) = ABS( D( 1 ) ) + ABS( E( 1 ) )
210 D( N ) = ABS( D( N ) ) + ABS( E( N-1 ) )
211 DO 30 I = 2, N - 1
212 D( I ) = ABS( D( I ) ) + ABS( E( I ) ) +
213 $ ABS( E( I-1 ) )
214 30 CONTINUE
215 END IF
216 *
217 * Scale D and E so the maximum element is ANORM.
218 *
219 IX = ISAMAX( N, D, 1 )
220 DMAX = D( IX )
221 CALL SSCAL( N, ANORM / DMAX, D, 1 )
222 CALL SSCAL( N-1, ANORM / DMAX, E, 1 )
223 *
224 ELSE IF( IZERO.GT.0 ) THEN
225 *
226 * Reuse the last matrix by copying back the zeroed out
227 * elements.
228 *
229 IF( IZERO.EQ.1 ) THEN
230 D( 1 ) = Z( 2 )
231 IF( N.GT.1 )
232 $ E( 1 ) = Z( 3 )
233 ELSE IF( IZERO.EQ.N ) THEN
234 E( N-1 ) = Z( 1 )
235 D( N ) = Z( 2 )
236 ELSE
237 E( IZERO-1 ) = Z( 1 )
238 D( IZERO ) = Z( 2 )
239 E( IZERO ) = Z( 3 )
240 END IF
241 END IF
242 *
243 * For types 8-10, set one row and column of the matrix to
244 * zero.
245 *
246 IZERO = 0
247 IF( IMAT.EQ.8 ) THEN
248 IZERO = 1
249 Z( 2 ) = D( 1 )
250 D( 1 ) = ZERO
251 IF( N.GT.1 ) THEN
252 Z( 3 ) = E( 1 )
253 E( 1 ) = ZERO
254 END IF
255 ELSE IF( IMAT.EQ.9 ) THEN
256 IZERO = N
257 IF( N.GT.1 ) THEN
258 Z( 1 ) = E( N-1 )
259 E( N-1 ) = ZERO
260 END IF
261 Z( 2 ) = D( N )
262 D( N ) = ZERO
263 ELSE IF( IMAT.EQ.10 ) THEN
264 IZERO = ( N+1 ) / 2
265 IF( IZERO.GT.1 ) THEN
266 Z( 1 ) = E( IZERO-1 )
267 E( IZERO-1 ) = ZERO
268 Z( 3 ) = E( IZERO )
269 E( IZERO ) = ZERO
270 END IF
271 Z( 2 ) = D( IZERO )
272 D( IZERO ) = ZERO
273 END IF
274 END IF
275 *
276 CALL SCOPY( N, D, 1, D( N+1 ), 1 )
277 IF( N.GT.1 )
278 $ CALL SCOPY( N-1, E, 1, E( N+1 ), 1 )
279 *
280 *+ TEST 1
281 * Factor A as L*D*L' and compute the ratio
282 * norm(L*D*L' - A) / (n * norm(A) * EPS )
283 *
284 CALL SPTTRF( N, D( N+1 ), E( N+1 ), INFO )
285 *
286 * Check error code from SPTTRF.
287 *
288 IF( INFO.NE.IZERO ) THEN
289 CALL ALAERH( PATH, 'SPTTRF', INFO, IZERO, ' ', N, N, -1,
290 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
291 GO TO 100
292 END IF
293 *
294 IF( INFO.GT.0 ) THEN
295 RCONDC = ZERO
296 GO TO 90
297 END IF
298 *
299 CALL SPTT01( N, D, E, D( N+1 ), E( N+1 ), WORK,
300 $ RESULT( 1 ) )
301 *
302 * Print the test ratio if greater than or equal to THRESH.
303 *
304 IF( RESULT( 1 ).GE.THRESH ) THEN
305 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
306 $ CALL ALAHD( NOUT, PATH )
307 WRITE( NOUT, FMT = 9999 )N, IMAT, 1, RESULT( 1 )
308 NFAIL = NFAIL + 1
309 END IF
310 NRUN = NRUN + 1
311 *
312 * Compute RCONDC = 1 / (norm(A) * norm(inv(A))
313 *
314 * Compute norm(A).
315 *
316 ANORM = SLANST( '1', N, D, E )
317 *
318 * Use SPTTRS to solve for one column at a time of inv(A),
319 * computing the maximum column sum as we go.
320 *
321 AINVNM = ZERO
322 DO 50 I = 1, N
323 DO 40 J = 1, N
324 X( J ) = ZERO
325 40 CONTINUE
326 X( I ) = ONE
327 CALL SPTTRS( N, 1, D( N+1 ), E( N+1 ), X, LDA, INFO )
328 AINVNM = MAX( AINVNM, SASUM( N, X, 1 ) )
329 50 CONTINUE
330 RCONDC = ONE / MAX( ONE, ANORM*AINVNM )
331 *
332 DO 80 IRHS = 1, NNS
333 NRHS = NSVAL( IRHS )
334 *
335 * Generate NRHS random solution vectors.
336 *
337 IX = 1
338 DO 60 J = 1, NRHS
339 CALL SLARNV( 2, ISEED, N, XACT( IX ) )
340 IX = IX + LDA
341 60 CONTINUE
342 *
343 * Set the right hand side.
344 *
345 CALL SLAPTM( N, NRHS, ONE, D, E, XACT, LDA, ZERO, B,
346 $ LDA )
347 *
348 *+ TEST 2
349 * Solve A*x = b and compute the residual.
350 *
351 CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
352 CALL SPTTRS( N, NRHS, D( N+1 ), E( N+1 ), X, LDA, INFO )
353 *
354 * Check error code from SPTTRS.
355 *
356 IF( INFO.NE.0 )
357 $ CALL ALAERH( PATH, 'SPTTRS', INFO, 0, ' ', N, N, -1,
358 $ -1, NRHS, IMAT, NFAIL, NERRS, NOUT )
359 *
360 CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
361 CALL SPTT02( N, NRHS, D, E, X, LDA, WORK, LDA,
362 $ RESULT( 2 ) )
363 *
364 *+ TEST 3
365 * Check solution from generated exact solution.
366 *
367 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
368 $ RESULT( 3 ) )
369 *
370 *+ TESTS 4, 5, and 6
371 * Use iterative refinement to improve the solution.
372 *
373 SRNAMT = 'SPTRFS'
374 CALL SPTRFS( N, NRHS, D, E, D( N+1 ), E( N+1 ), B, LDA,
375 $ X, LDA, RWORK, RWORK( NRHS+1 ), WORK, INFO )
376 *
377 * Check error code from SPTRFS.
378 *
379 IF( INFO.NE.0 )
380 $ CALL ALAERH( PATH, 'SPTRFS', INFO, 0, ' ', N, N, -1,
381 $ -1, NRHS, IMAT, NFAIL, NERRS, NOUT )
382 *
383 CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
384 $ RESULT( 4 ) )
385 CALL SPTT05( N, NRHS, D, E, B, LDA, X, LDA, XACT, LDA,
386 $ RWORK, RWORK( NRHS+1 ), RESULT( 5 ) )
387 *
388 * Print information about the tests that did not pass the
389 * threshold.
390 *
391 DO 70 K = 2, 6
392 IF( RESULT( K ).GE.THRESH ) THEN
393 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
394 $ CALL ALAHD( NOUT, PATH )
395 WRITE( NOUT, FMT = 9998 )N, NRHS, IMAT, K,
396 $ RESULT( K )
397 NFAIL = NFAIL + 1
398 END IF
399 70 CONTINUE
400 NRUN = NRUN + 5
401 80 CONTINUE
402 *
403 *+ TEST 7
404 * Estimate the reciprocal of the condition number of the
405 * matrix.
406 *
407 90 CONTINUE
408 SRNAMT = 'SPTCON'
409 CALL SPTCON( N, D( N+1 ), E( N+1 ), ANORM, RCOND, RWORK,
410 $ INFO )
411 *
412 * Check error code from SPTCON.
413 *
414 IF( INFO.NE.0 )
415 $ CALL ALAERH( PATH, 'SPTCON', INFO, 0, ' ', N, N, -1, -1,
416 $ -1, IMAT, NFAIL, NERRS, NOUT )
417 *
418 RESULT( 7 ) = SGET06( RCOND, RCONDC )
419 *
420 * Print the test ratio if greater than or equal to THRESH.
421 *
422 IF( RESULT( 7 ).GE.THRESH ) THEN
423 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
424 $ CALL ALAHD( NOUT, PATH )
425 WRITE( NOUT, FMT = 9999 )N, IMAT, 7, RESULT( 7 )
426 NFAIL = NFAIL + 1
427 END IF
428 NRUN = NRUN + 1
429 100 CONTINUE
430 110 CONTINUE
431 *
432 * Print a summary of the results.
433 *
434 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
435 *
436 9999 FORMAT( ' N =', I5, ', type ', I2, ', test ', I2, ', ratio = ',
437 $ G12.5 )
438 9998 FORMAT( ' N =', I5, ', NRHS=', I3, ', type ', I2, ', test(', I2,
439 $ ') = ', G12.5 )
440 RETURN
441 *
442 * End of SCHKPT
443 *
444 END