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