1 SUBROUTINE ZCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
2 $ A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT )
3 *
4 * -- LAPACK test routine (version 3.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * November 2006
7 *
8 * .. Scalar Arguments ..
9 LOGICAL TSTERR
10 INTEGER NN, NNS, NOUT
11 DOUBLE PRECISION THRESH
12 * ..
13 * .. Array Arguments ..
14 LOGICAL DOTYPE( * )
15 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
16 DOUBLE PRECISION RWORK( * )
17 COMPLEX*16 A( * ), AF( * ), B( * ), WORK( * ), X( * ),
18 $ XACT( * )
19 * ..
20 *
21 * Purpose
22 * =======
23 *
24 * ZCHKGT tests ZGTTRF, -TRS, -RFS, and -CON
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 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 * A (workspace) COMPLEX*16 array, dimension (NMAX*4)
55 *
56 * AF (workspace) COMPLEX*16 array, dimension (NMAX*4)
57 *
58 * B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
59 * where NSMAX is the largest entry in NSVAL.
60 *
61 * X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
62 *
63 * XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
64 *
65 * WORK (workspace) COMPLEX*16 array, dimension
66 * (NMAX*max(3,NSMAX))
67 *
68 * RWORK (workspace) DOUBLE PRECISION array, dimension
69 * (max(NMAX)+2*NSMAX)
70 *
71 * IWORK (workspace) INTEGER array, dimension (NMAX)
72 *
73 * NOUT (input) INTEGER
74 * The unit number for output.
75 *
76 * =====================================================================
77 *
78 * .. Parameters ..
79 DOUBLE PRECISION ONE, ZERO
80 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
81 INTEGER NTYPES
82 PARAMETER ( NTYPES = 12 )
83 INTEGER NTESTS
84 PARAMETER ( NTESTS = 7 )
85 * ..
86 * .. Local Scalars ..
87 LOGICAL TRFCON, ZEROT
88 CHARACTER DIST, NORM, TRANS, TYPE
89 CHARACTER*3 PATH
90 INTEGER I, IMAT, IN, INFO, IRHS, ITRAN, IX, IZERO, J,
91 $ K, KL, KOFF, KU, LDA, M, MODE, N, NERRS, NFAIL,
92 $ NIMAT, NRHS, NRUN
93 DOUBLE PRECISION AINVNM, ANORM, COND, RCOND, RCONDC, RCONDI,
94 $ RCONDO
95 * ..
96 * .. Local Arrays ..
97 CHARACTER TRANSS( 3 )
98 INTEGER ISEED( 4 ), ISEEDY( 4 )
99 DOUBLE PRECISION RESULT( NTESTS )
100 COMPLEX*16 Z( 3 )
101 * ..
102 * .. External Functions ..
103 DOUBLE PRECISION DGET06, DZASUM, ZLANGT
104 EXTERNAL DGET06, DZASUM, ZLANGT
105 * ..
106 * .. External Subroutines ..
107 EXTERNAL ALAERH, ALAHD, ALASUM, ZCOPY, ZDSCAL, ZERRGE,
108 $ ZGET04, ZGTCON, ZGTRFS, ZGTT01, ZGTT02, ZGTT05,
109 $ ZGTTRF, ZGTTRS, ZLACPY, ZLAGTM, ZLARNV, ZLATB4,
110 $ ZLATMS
111 * ..
112 * .. Intrinsic Functions ..
113 INTRINSIC MAX
114 * ..
115 * .. Scalars in Common ..
116 LOGICAL LERR, OK
117 CHARACTER*32 SRNAMT
118 INTEGER INFOT, NUNIT
119 * ..
120 * .. Common blocks ..
121 COMMON / INFOC / INFOT, NUNIT, OK, LERR
122 COMMON / SRNAMC / SRNAMT
123 * ..
124 * .. Data statements ..
125 DATA ISEEDY / 0, 0, 0, 1 / , TRANSS / 'N', 'T',
126 $ 'C' /
127 * ..
128 * .. Executable Statements ..
129 *
130 PATH( 1: 1 ) = 'Zomplex precision'
131 PATH( 2: 3 ) = 'GT'
132 NRUN = 0
133 NFAIL = 0
134 NERRS = 0
135 DO 10 I = 1, 4
136 ISEED( I ) = ISEEDY( I )
137 10 CONTINUE
138 *
139 * Test the error exits
140 *
141 IF( TSTERR )
142 $ CALL ZERRGE( PATH, NOUT )
143 INFOT = 0
144 *
145 DO 110 IN = 1, NN
146 *
147 * Do for each value of N in NVAL.
148 *
149 N = NVAL( IN )
150 M = MAX( N-1, 0 )
151 LDA = MAX( 1, N )
152 NIMAT = NTYPES
153 IF( N.LE.0 )
154 $ NIMAT = 1
155 *
156 DO 100 IMAT = 1, NIMAT
157 *
158 * Do the tests only if DOTYPE( IMAT ) is true.
159 *
160 IF( .NOT.DOTYPE( IMAT ) )
161 $ GO TO 100
162 *
163 * Set up parameters with ZLATB4.
164 *
165 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
166 $ COND, DIST )
167 *
168 ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
169 IF( IMAT.LE.6 ) THEN
170 *
171 * Types 1-6: generate matrices of known condition number.
172 *
173 KOFF = MAX( 2-KU, 3-MAX( 1, N ) )
174 SRNAMT = 'ZLATMS'
175 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
176 $ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
177 $ INFO )
178 *
179 * Check the error code from ZLATMS.
180 *
181 IF( INFO.NE.0 ) THEN
182 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', N, N, KL,
183 $ KU, -1, IMAT, NFAIL, NERRS, NOUT )
184 GO TO 100
185 END IF
186 IZERO = 0
187 *
188 IF( N.GT.1 ) THEN
189 CALL ZCOPY( N-1, AF( 4 ), 3, A, 1 )
190 CALL ZCOPY( N-1, AF( 3 ), 3, A( N+M+1 ), 1 )
191 END IF
192 CALL ZCOPY( N, AF( 2 ), 3, A( M+1 ), 1 )
193 ELSE
194 *
195 * Types 7-12: generate tridiagonal matrices with
196 * unknown condition numbers.
197 *
198 IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
199 *
200 * Generate a matrix with elements whose real and
201 * imaginary parts are from [-1,1].
202 *
203 CALL ZLARNV( 2, ISEED, N+2*M, A )
204 IF( ANORM.NE.ONE )
205 $ CALL ZDSCAL( N+2*M, ANORM, A, 1 )
206 ELSE IF( IZERO.GT.0 ) THEN
207 *
208 * Reuse the last matrix by copying back the zeroed out
209 * elements.
210 *
211 IF( IZERO.EQ.1 ) THEN
212 A( N ) = Z( 2 )
213 IF( N.GT.1 )
214 $ A( 1 ) = Z( 3 )
215 ELSE IF( IZERO.EQ.N ) THEN
216 A( 3*N-2 ) = Z( 1 )
217 A( 2*N-1 ) = Z( 2 )
218 ELSE
219 A( 2*N-2+IZERO ) = Z( 1 )
220 A( N-1+IZERO ) = Z( 2 )
221 A( IZERO ) = Z( 3 )
222 END IF
223 END IF
224 *
225 * If IMAT > 7, set one column of the matrix to 0.
226 *
227 IF( .NOT.ZEROT ) THEN
228 IZERO = 0
229 ELSE IF( IMAT.EQ.8 ) THEN
230 IZERO = 1
231 Z( 2 ) = A( N )
232 A( N ) = ZERO
233 IF( N.GT.1 ) THEN
234 Z( 3 ) = A( 1 )
235 A( 1 ) = ZERO
236 END IF
237 ELSE IF( IMAT.EQ.9 ) THEN
238 IZERO = N
239 Z( 1 ) = A( 3*N-2 )
240 Z( 2 ) = A( 2*N-1 )
241 A( 3*N-2 ) = ZERO
242 A( 2*N-1 ) = ZERO
243 ELSE
244 IZERO = ( N+1 ) / 2
245 DO 20 I = IZERO, N - 1
246 A( 2*N-2+I ) = ZERO
247 A( N-1+I ) = ZERO
248 A( I ) = ZERO
249 20 CONTINUE
250 A( 3*N-2 ) = ZERO
251 A( 2*N-1 ) = ZERO
252 END IF
253 END IF
254 *
255 *+ TEST 1
256 * Factor A as L*U and compute the ratio
257 * norm(L*U - A) / (n * norm(A) * EPS )
258 *
259 CALL ZCOPY( N+2*M, A, 1, AF, 1 )
260 SRNAMT = 'ZGTTRF'
261 CALL ZGTTRF( N, AF, AF( M+1 ), AF( N+M+1 ), AF( N+2*M+1 ),
262 $ IWORK, INFO )
263 *
264 * Check error code from ZGTTRF.
265 *
266 IF( INFO.NE.IZERO )
267 $ CALL ALAERH( PATH, 'ZGTTRF', INFO, IZERO, ' ', N, N, 1,
268 $ 1, -1, IMAT, NFAIL, NERRS, NOUT )
269 TRFCON = INFO.NE.0
270 *
271 CALL ZGTT01( N, A, A( M+1 ), A( N+M+1 ), AF, AF( M+1 ),
272 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, WORK, LDA,
273 $ RWORK, RESULT( 1 ) )
274 *
275 * Print the test ratio if it is .GE. THRESH.
276 *
277 IF( RESULT( 1 ).GE.THRESH ) THEN
278 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
279 $ CALL ALAHD( NOUT, PATH )
280 WRITE( NOUT, FMT = 9999 )N, IMAT, 1, RESULT( 1 )
281 NFAIL = NFAIL + 1
282 END IF
283 NRUN = NRUN + 1
284 *
285 DO 50 ITRAN = 1, 2
286 TRANS = TRANSS( ITRAN )
287 IF( ITRAN.EQ.1 ) THEN
288 NORM = 'O'
289 ELSE
290 NORM = 'I'
291 END IF
292 ANORM = ZLANGT( NORM, N, A, A( M+1 ), A( N+M+1 ) )
293 *
294 IF( .NOT.TRFCON ) THEN
295 *
296 * Use ZGTTRS to solve for one column at a time of
297 * inv(A), computing the maximum column sum as we go.
298 *
299 AINVNM = ZERO
300 DO 40 I = 1, N
301 DO 30 J = 1, N
302 X( J ) = ZERO
303 30 CONTINUE
304 X( I ) = ONE
305 CALL ZGTTRS( TRANS, N, 1, AF, AF( M+1 ),
306 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
307 $ LDA, INFO )
308 AINVNM = MAX( AINVNM, DZASUM( N, X, 1 ) )
309 40 CONTINUE
310 *
311 * Compute RCONDC = 1 / (norm(A) * norm(inv(A))
312 *
313 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
314 RCONDC = ONE
315 ELSE
316 RCONDC = ( ONE / ANORM ) / AINVNM
317 END IF
318 IF( ITRAN.EQ.1 ) THEN
319 RCONDO = RCONDC
320 ELSE
321 RCONDI = RCONDC
322 END IF
323 ELSE
324 RCONDC = ZERO
325 END IF
326 *
327 *+ TEST 7
328 * Estimate the reciprocal of the condition number of the
329 * matrix.
330 *
331 SRNAMT = 'ZGTCON'
332 CALL ZGTCON( NORM, N, AF, AF( M+1 ), AF( N+M+1 ),
333 $ AF( N+2*M+1 ), IWORK, ANORM, RCOND, WORK,
334 $ INFO )
335 *
336 * Check error code from ZGTCON.
337 *
338 IF( INFO.NE.0 )
339 $ CALL ALAERH( PATH, 'ZGTCON', INFO, 0, NORM, N, N, -1,
340 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
341 *
342 RESULT( 7 ) = DGET06( RCOND, RCONDC )
343 *
344 * Print the test ratio if it is .GE. THRESH.
345 *
346 IF( RESULT( 7 ).GE.THRESH ) THEN
347 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
348 $ CALL ALAHD( NOUT, PATH )
349 WRITE( NOUT, FMT = 9997 )NORM, N, IMAT, 7,
350 $ RESULT( 7 )
351 NFAIL = NFAIL + 1
352 END IF
353 NRUN = NRUN + 1
354 50 CONTINUE
355 *
356 * Skip the remaining tests if the matrix is singular.
357 *
358 IF( TRFCON )
359 $ GO TO 100
360 *
361 DO 90 IRHS = 1, NNS
362 NRHS = NSVAL( IRHS )
363 *
364 * Generate NRHS random solution vectors.
365 *
366 IX = 1
367 DO 60 J = 1, NRHS
368 CALL ZLARNV( 2, ISEED, N, XACT( IX ) )
369 IX = IX + LDA
370 60 CONTINUE
371 *
372 DO 80 ITRAN = 1, 3
373 TRANS = TRANSS( ITRAN )
374 IF( ITRAN.EQ.1 ) THEN
375 RCONDC = RCONDO
376 ELSE
377 RCONDC = RCONDI
378 END IF
379 *
380 * Set the right hand side.
381 *
382 CALL ZLAGTM( TRANS, N, NRHS, ONE, A, A( M+1 ),
383 $ A( N+M+1 ), XACT, LDA, ZERO, B, LDA )
384 *
385 *+ TEST 2
386 * Solve op(A) * X = B and compute the residual.
387 *
388 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
389 SRNAMT = 'ZGTTRS'
390 CALL ZGTTRS( TRANS, N, NRHS, AF, AF( M+1 ),
391 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
392 $ LDA, INFO )
393 *
394 * Check error code from ZGTTRS.
395 *
396 IF( INFO.NE.0 )
397 $ CALL ALAERH( PATH, 'ZGTTRS', INFO, 0, TRANS, N, N,
398 $ -1, -1, NRHS, IMAT, NFAIL, NERRS,
399 $ NOUT )
400 *
401 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
402 CALL ZGTT02( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
403 $ X, LDA, WORK, LDA, RWORK, RESULT( 2 ) )
404 *
405 *+ TEST 3
406 * Check solution from generated exact solution.
407 *
408 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
409 $ RESULT( 3 ) )
410 *
411 *+ TESTS 4, 5, and 6
412 * Use iterative refinement to improve the solution.
413 *
414 SRNAMT = 'ZGTRFS'
415 CALL ZGTRFS( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
416 $ AF, AF( M+1 ), AF( N+M+1 ),
417 $ AF( N+2*M+1 ), IWORK, B, LDA, X, LDA,
418 $ RWORK, RWORK( NRHS+1 ), WORK,
419 $ RWORK( 2*NRHS+1 ), INFO )
420 *
421 * Check error code from ZGTRFS.
422 *
423 IF( INFO.NE.0 )
424 $ CALL ALAERH( PATH, 'ZGTRFS', INFO, 0, TRANS, N, N,
425 $ -1, -1, NRHS, IMAT, NFAIL, NERRS,
426 $ NOUT )
427 *
428 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
429 $ RESULT( 4 ) )
430 CALL ZGTT05( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
431 $ B, LDA, X, LDA, XACT, LDA, RWORK,
432 $ RWORK( NRHS+1 ), RESULT( 5 ) )
433 *
434 * Print information about the tests that did not pass the
435 * threshold.
436 *
437 DO 70 K = 2, 6
438 IF( RESULT( K ).GE.THRESH ) THEN
439 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
440 $ CALL ALAHD( NOUT, PATH )
441 WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS, IMAT,
442 $ K, RESULT( K )
443 NFAIL = NFAIL + 1
444 END IF
445 70 CONTINUE
446 NRUN = NRUN + 5
447 80 CONTINUE
448 90 CONTINUE
449 100 CONTINUE
450 110 CONTINUE
451 *
452 * Print a summary of the results.
453 *
454 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
455 *
456 9999 FORMAT( 12X, 'N =', I5, ',', 10X, ' type ', I2, ', test(', I2,
457 $ ') = ', G12.5 )
458 9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
459 $ I2, ', test(', I2, ') = ', G12.5 )
460 9997 FORMAT( ' NORM =''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
461 $ ', test(', I2, ') = ', G12.5 )
462 RETURN
463 *
464 * End of ZCHKGT
465 *
466 END
2 $ A, AF, B, X, XACT, WORK, RWORK, IWORK, NOUT )
3 *
4 * -- LAPACK test routine (version 3.1) --
5 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
6 * November 2006
7 *
8 * .. Scalar Arguments ..
9 LOGICAL TSTERR
10 INTEGER NN, NNS, NOUT
11 DOUBLE PRECISION THRESH
12 * ..
13 * .. Array Arguments ..
14 LOGICAL DOTYPE( * )
15 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
16 DOUBLE PRECISION RWORK( * )
17 COMPLEX*16 A( * ), AF( * ), B( * ), WORK( * ), X( * ),
18 $ XACT( * )
19 * ..
20 *
21 * Purpose
22 * =======
23 *
24 * ZCHKGT tests ZGTTRF, -TRS, -RFS, and -CON
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 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 * A (workspace) COMPLEX*16 array, dimension (NMAX*4)
55 *
56 * AF (workspace) COMPLEX*16 array, dimension (NMAX*4)
57 *
58 * B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
59 * where NSMAX is the largest entry in NSVAL.
60 *
61 * X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
62 *
63 * XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
64 *
65 * WORK (workspace) COMPLEX*16 array, dimension
66 * (NMAX*max(3,NSMAX))
67 *
68 * RWORK (workspace) DOUBLE PRECISION array, dimension
69 * (max(NMAX)+2*NSMAX)
70 *
71 * IWORK (workspace) INTEGER array, dimension (NMAX)
72 *
73 * NOUT (input) INTEGER
74 * The unit number for output.
75 *
76 * =====================================================================
77 *
78 * .. Parameters ..
79 DOUBLE PRECISION ONE, ZERO
80 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
81 INTEGER NTYPES
82 PARAMETER ( NTYPES = 12 )
83 INTEGER NTESTS
84 PARAMETER ( NTESTS = 7 )
85 * ..
86 * .. Local Scalars ..
87 LOGICAL TRFCON, ZEROT
88 CHARACTER DIST, NORM, TRANS, TYPE
89 CHARACTER*3 PATH
90 INTEGER I, IMAT, IN, INFO, IRHS, ITRAN, IX, IZERO, J,
91 $ K, KL, KOFF, KU, LDA, M, MODE, N, NERRS, NFAIL,
92 $ NIMAT, NRHS, NRUN
93 DOUBLE PRECISION AINVNM, ANORM, COND, RCOND, RCONDC, RCONDI,
94 $ RCONDO
95 * ..
96 * .. Local Arrays ..
97 CHARACTER TRANSS( 3 )
98 INTEGER ISEED( 4 ), ISEEDY( 4 )
99 DOUBLE PRECISION RESULT( NTESTS )
100 COMPLEX*16 Z( 3 )
101 * ..
102 * .. External Functions ..
103 DOUBLE PRECISION DGET06, DZASUM, ZLANGT
104 EXTERNAL DGET06, DZASUM, ZLANGT
105 * ..
106 * .. External Subroutines ..
107 EXTERNAL ALAERH, ALAHD, ALASUM, ZCOPY, ZDSCAL, ZERRGE,
108 $ ZGET04, ZGTCON, ZGTRFS, ZGTT01, ZGTT02, ZGTT05,
109 $ ZGTTRF, ZGTTRS, ZLACPY, ZLAGTM, ZLARNV, ZLATB4,
110 $ ZLATMS
111 * ..
112 * .. Intrinsic Functions ..
113 INTRINSIC MAX
114 * ..
115 * .. Scalars in Common ..
116 LOGICAL LERR, OK
117 CHARACTER*32 SRNAMT
118 INTEGER INFOT, NUNIT
119 * ..
120 * .. Common blocks ..
121 COMMON / INFOC / INFOT, NUNIT, OK, LERR
122 COMMON / SRNAMC / SRNAMT
123 * ..
124 * .. Data statements ..
125 DATA ISEEDY / 0, 0, 0, 1 / , TRANSS / 'N', 'T',
126 $ 'C' /
127 * ..
128 * .. Executable Statements ..
129 *
130 PATH( 1: 1 ) = 'Zomplex precision'
131 PATH( 2: 3 ) = 'GT'
132 NRUN = 0
133 NFAIL = 0
134 NERRS = 0
135 DO 10 I = 1, 4
136 ISEED( I ) = ISEEDY( I )
137 10 CONTINUE
138 *
139 * Test the error exits
140 *
141 IF( TSTERR )
142 $ CALL ZERRGE( PATH, NOUT )
143 INFOT = 0
144 *
145 DO 110 IN = 1, NN
146 *
147 * Do for each value of N in NVAL.
148 *
149 N = NVAL( IN )
150 M = MAX( N-1, 0 )
151 LDA = MAX( 1, N )
152 NIMAT = NTYPES
153 IF( N.LE.0 )
154 $ NIMAT = 1
155 *
156 DO 100 IMAT = 1, NIMAT
157 *
158 * Do the tests only if DOTYPE( IMAT ) is true.
159 *
160 IF( .NOT.DOTYPE( IMAT ) )
161 $ GO TO 100
162 *
163 * Set up parameters with ZLATB4.
164 *
165 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
166 $ COND, DIST )
167 *
168 ZEROT = IMAT.GE.8 .AND. IMAT.LE.10
169 IF( IMAT.LE.6 ) THEN
170 *
171 * Types 1-6: generate matrices of known condition number.
172 *
173 KOFF = MAX( 2-KU, 3-MAX( 1, N ) )
174 SRNAMT = 'ZLATMS'
175 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, COND,
176 $ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
177 $ INFO )
178 *
179 * Check the error code from ZLATMS.
180 *
181 IF( INFO.NE.0 ) THEN
182 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', N, N, KL,
183 $ KU, -1, IMAT, NFAIL, NERRS, NOUT )
184 GO TO 100
185 END IF
186 IZERO = 0
187 *
188 IF( N.GT.1 ) THEN
189 CALL ZCOPY( N-1, AF( 4 ), 3, A, 1 )
190 CALL ZCOPY( N-1, AF( 3 ), 3, A( N+M+1 ), 1 )
191 END IF
192 CALL ZCOPY( N, AF( 2 ), 3, A( M+1 ), 1 )
193 ELSE
194 *
195 * Types 7-12: generate tridiagonal matrices with
196 * unknown condition numbers.
197 *
198 IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 7 ) ) THEN
199 *
200 * Generate a matrix with elements whose real and
201 * imaginary parts are from [-1,1].
202 *
203 CALL ZLARNV( 2, ISEED, N+2*M, A )
204 IF( ANORM.NE.ONE )
205 $ CALL ZDSCAL( N+2*M, ANORM, A, 1 )
206 ELSE IF( IZERO.GT.0 ) THEN
207 *
208 * Reuse the last matrix by copying back the zeroed out
209 * elements.
210 *
211 IF( IZERO.EQ.1 ) THEN
212 A( N ) = Z( 2 )
213 IF( N.GT.1 )
214 $ A( 1 ) = Z( 3 )
215 ELSE IF( IZERO.EQ.N ) THEN
216 A( 3*N-2 ) = Z( 1 )
217 A( 2*N-1 ) = Z( 2 )
218 ELSE
219 A( 2*N-2+IZERO ) = Z( 1 )
220 A( N-1+IZERO ) = Z( 2 )
221 A( IZERO ) = Z( 3 )
222 END IF
223 END IF
224 *
225 * If IMAT > 7, set one column of the matrix to 0.
226 *
227 IF( .NOT.ZEROT ) THEN
228 IZERO = 0
229 ELSE IF( IMAT.EQ.8 ) THEN
230 IZERO = 1
231 Z( 2 ) = A( N )
232 A( N ) = ZERO
233 IF( N.GT.1 ) THEN
234 Z( 3 ) = A( 1 )
235 A( 1 ) = ZERO
236 END IF
237 ELSE IF( IMAT.EQ.9 ) THEN
238 IZERO = N
239 Z( 1 ) = A( 3*N-2 )
240 Z( 2 ) = A( 2*N-1 )
241 A( 3*N-2 ) = ZERO
242 A( 2*N-1 ) = ZERO
243 ELSE
244 IZERO = ( N+1 ) / 2
245 DO 20 I = IZERO, N - 1
246 A( 2*N-2+I ) = ZERO
247 A( N-1+I ) = ZERO
248 A( I ) = ZERO
249 20 CONTINUE
250 A( 3*N-2 ) = ZERO
251 A( 2*N-1 ) = ZERO
252 END IF
253 END IF
254 *
255 *+ TEST 1
256 * Factor A as L*U and compute the ratio
257 * norm(L*U - A) / (n * norm(A) * EPS )
258 *
259 CALL ZCOPY( N+2*M, A, 1, AF, 1 )
260 SRNAMT = 'ZGTTRF'
261 CALL ZGTTRF( N, AF, AF( M+1 ), AF( N+M+1 ), AF( N+2*M+1 ),
262 $ IWORK, INFO )
263 *
264 * Check error code from ZGTTRF.
265 *
266 IF( INFO.NE.IZERO )
267 $ CALL ALAERH( PATH, 'ZGTTRF', INFO, IZERO, ' ', N, N, 1,
268 $ 1, -1, IMAT, NFAIL, NERRS, NOUT )
269 TRFCON = INFO.NE.0
270 *
271 CALL ZGTT01( N, A, A( M+1 ), A( N+M+1 ), AF, AF( M+1 ),
272 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, WORK, LDA,
273 $ RWORK, RESULT( 1 ) )
274 *
275 * Print the test ratio if it is .GE. THRESH.
276 *
277 IF( RESULT( 1 ).GE.THRESH ) THEN
278 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
279 $ CALL ALAHD( NOUT, PATH )
280 WRITE( NOUT, FMT = 9999 )N, IMAT, 1, RESULT( 1 )
281 NFAIL = NFAIL + 1
282 END IF
283 NRUN = NRUN + 1
284 *
285 DO 50 ITRAN = 1, 2
286 TRANS = TRANSS( ITRAN )
287 IF( ITRAN.EQ.1 ) THEN
288 NORM = 'O'
289 ELSE
290 NORM = 'I'
291 END IF
292 ANORM = ZLANGT( NORM, N, A, A( M+1 ), A( N+M+1 ) )
293 *
294 IF( .NOT.TRFCON ) THEN
295 *
296 * Use ZGTTRS to solve for one column at a time of
297 * inv(A), computing the maximum column sum as we go.
298 *
299 AINVNM = ZERO
300 DO 40 I = 1, N
301 DO 30 J = 1, N
302 X( J ) = ZERO
303 30 CONTINUE
304 X( I ) = ONE
305 CALL ZGTTRS( TRANS, N, 1, AF, AF( M+1 ),
306 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
307 $ LDA, INFO )
308 AINVNM = MAX( AINVNM, DZASUM( N, X, 1 ) )
309 40 CONTINUE
310 *
311 * Compute RCONDC = 1 / (norm(A) * norm(inv(A))
312 *
313 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
314 RCONDC = ONE
315 ELSE
316 RCONDC = ( ONE / ANORM ) / AINVNM
317 END IF
318 IF( ITRAN.EQ.1 ) THEN
319 RCONDO = RCONDC
320 ELSE
321 RCONDI = RCONDC
322 END IF
323 ELSE
324 RCONDC = ZERO
325 END IF
326 *
327 *+ TEST 7
328 * Estimate the reciprocal of the condition number of the
329 * matrix.
330 *
331 SRNAMT = 'ZGTCON'
332 CALL ZGTCON( NORM, N, AF, AF( M+1 ), AF( N+M+1 ),
333 $ AF( N+2*M+1 ), IWORK, ANORM, RCOND, WORK,
334 $ INFO )
335 *
336 * Check error code from ZGTCON.
337 *
338 IF( INFO.NE.0 )
339 $ CALL ALAERH( PATH, 'ZGTCON', INFO, 0, NORM, N, N, -1,
340 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
341 *
342 RESULT( 7 ) = DGET06( RCOND, RCONDC )
343 *
344 * Print the test ratio if it is .GE. THRESH.
345 *
346 IF( RESULT( 7 ).GE.THRESH ) THEN
347 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
348 $ CALL ALAHD( NOUT, PATH )
349 WRITE( NOUT, FMT = 9997 )NORM, N, IMAT, 7,
350 $ RESULT( 7 )
351 NFAIL = NFAIL + 1
352 END IF
353 NRUN = NRUN + 1
354 50 CONTINUE
355 *
356 * Skip the remaining tests if the matrix is singular.
357 *
358 IF( TRFCON )
359 $ GO TO 100
360 *
361 DO 90 IRHS = 1, NNS
362 NRHS = NSVAL( IRHS )
363 *
364 * Generate NRHS random solution vectors.
365 *
366 IX = 1
367 DO 60 J = 1, NRHS
368 CALL ZLARNV( 2, ISEED, N, XACT( IX ) )
369 IX = IX + LDA
370 60 CONTINUE
371 *
372 DO 80 ITRAN = 1, 3
373 TRANS = TRANSS( ITRAN )
374 IF( ITRAN.EQ.1 ) THEN
375 RCONDC = RCONDO
376 ELSE
377 RCONDC = RCONDI
378 END IF
379 *
380 * Set the right hand side.
381 *
382 CALL ZLAGTM( TRANS, N, NRHS, ONE, A, A( M+1 ),
383 $ A( N+M+1 ), XACT, LDA, ZERO, B, LDA )
384 *
385 *+ TEST 2
386 * Solve op(A) * X = B and compute the residual.
387 *
388 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
389 SRNAMT = 'ZGTTRS'
390 CALL ZGTTRS( TRANS, N, NRHS, AF, AF( M+1 ),
391 $ AF( N+M+1 ), AF( N+2*M+1 ), IWORK, X,
392 $ LDA, INFO )
393 *
394 * Check error code from ZGTTRS.
395 *
396 IF( INFO.NE.0 )
397 $ CALL ALAERH( PATH, 'ZGTTRS', INFO, 0, TRANS, N, N,
398 $ -1, -1, NRHS, IMAT, NFAIL, NERRS,
399 $ NOUT )
400 *
401 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
402 CALL ZGTT02( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
403 $ X, LDA, WORK, LDA, RWORK, RESULT( 2 ) )
404 *
405 *+ TEST 3
406 * Check solution from generated exact solution.
407 *
408 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
409 $ RESULT( 3 ) )
410 *
411 *+ TESTS 4, 5, and 6
412 * Use iterative refinement to improve the solution.
413 *
414 SRNAMT = 'ZGTRFS'
415 CALL ZGTRFS( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
416 $ AF, AF( M+1 ), AF( N+M+1 ),
417 $ AF( N+2*M+1 ), IWORK, B, LDA, X, LDA,
418 $ RWORK, RWORK( NRHS+1 ), WORK,
419 $ RWORK( 2*NRHS+1 ), INFO )
420 *
421 * Check error code from ZGTRFS.
422 *
423 IF( INFO.NE.0 )
424 $ CALL ALAERH( PATH, 'ZGTRFS', INFO, 0, TRANS, N, N,
425 $ -1, -1, NRHS, IMAT, NFAIL, NERRS,
426 $ NOUT )
427 *
428 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
429 $ RESULT( 4 ) )
430 CALL ZGTT05( TRANS, N, NRHS, A, A( M+1 ), A( N+M+1 ),
431 $ B, LDA, X, LDA, XACT, LDA, RWORK,
432 $ RWORK( NRHS+1 ), RESULT( 5 ) )
433 *
434 * Print information about the tests that did not pass the
435 * threshold.
436 *
437 DO 70 K = 2, 6
438 IF( RESULT( K ).GE.THRESH ) THEN
439 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
440 $ CALL ALAHD( NOUT, PATH )
441 WRITE( NOUT, FMT = 9998 )TRANS, N, NRHS, IMAT,
442 $ K, RESULT( K )
443 NFAIL = NFAIL + 1
444 END IF
445 70 CONTINUE
446 NRUN = NRUN + 5
447 80 CONTINUE
448 90 CONTINUE
449 100 CONTINUE
450 110 CONTINUE
451 *
452 * Print a summary of the results.
453 *
454 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
455 *
456 9999 FORMAT( 12X, 'N =', I5, ',', 10X, ' type ', I2, ', test(', I2,
457 $ ') = ', G12.5 )
458 9998 FORMAT( ' TRANS=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
459 $ I2, ', test(', I2, ') = ', G12.5 )
460 9997 FORMAT( ' NORM =''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
461 $ ', test(', I2, ') = ', G12.5 )
462 RETURN
463 *
464 * End of ZCHKGT
465 *
466 END