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