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