1 SUBROUTINE ZCHKHE( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
2 $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
3 $ XACT, WORK, RWORK, IWORK, NOUT )
4 *
5 * -- LAPACK test routine (version 3.3.1) --
6 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
7 * -- April 2011 --
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 RWORK( * )
18 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
19 $ WORK( * ), X( * ), XACT( * )
20 * ..
21 *
22 * Purpose
23 * =======
24 *
25 * ZCHKHE tests ZHETRF, -TRI2, -TRS, -TRS2, -RFS, and -CON.
26 *
27 * Arguments
28 * =========
29 *
30 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
31 * The matrix types to be used for testing. Matrices of type j
32 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
33 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
34 *
35 * NN (input) INTEGER
36 * The number of values of N contained in the vector NVAL.
37 *
38 * NVAL (input) INTEGER array, dimension (NN)
39 * The values of the matrix dimension N.
40 *
41 * NNB (input) INTEGER
42 * The number of values of NB contained in the vector NBVAL.
43 *
44 * NBVAL (input) INTEGER array, dimension (NBVAL)
45 * The values of the blocksize NB.
46 *
47 * NNS (input) INTEGER
48 * The number of values of NRHS contained in the vector NSVAL.
49 *
50 * NSVAL (input) INTEGER array, dimension (NNS)
51 * The values of the number of right hand sides NRHS.
52 *
53 * THRESH (input) DOUBLE PRECISION
54 * The threshold value for the test ratios. A result is
55 * included in the output file if RESULT >= THRESH. To have
56 * every test ratio printed, use THRESH = 0.
57 *
58 * TSTERR (input) LOGICAL
59 * Flag that indicates whether error exits are to be tested.
60 *
61 * NMAX (input) INTEGER
62 * The maximum value permitted for N, used in dimensioning the
63 * work arrays.
64 *
65 * A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
66 *
67 * AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
68 *
69 * AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
70 *
71 * B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
72 * where NSMAX is the largest entry in NSVAL.
73 *
74 * X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
75 *
76 * XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
77 *
78 * WORK (workspace) COMPLEX*16 array, dimension
79 * (NMAX*max(3,NSMAX))
80 *
81 * RWORK (workspace) DOUBLE PRECISION array, dimension
82 * (max(NMAX,2*NSMAX))
83 *
84 * IWORK (workspace) INTEGER array, dimension (NMAX)
85 *
86 * NOUT (input) INTEGER
87 * The unit number for output.
88 *
89 * =====================================================================
90 *
91 * .. Parameters ..
92 DOUBLE PRECISION ZERO
93 PARAMETER ( ZERO = 0.0D+0 )
94 INTEGER NTYPES
95 PARAMETER ( NTYPES = 10 )
96 INTEGER NTESTS
97 PARAMETER ( NTESTS = 9 )
98 * ..
99 * .. Local Scalars ..
100 LOGICAL TRFCON, ZEROT
101 CHARACTER DIST, TYPE, UPLO, XTYPE
102 CHARACTER*3 PATH
103 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
104 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
105 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
106 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
107 * ..
108 * .. Local Arrays ..
109 CHARACTER UPLOS( 2 )
110 INTEGER ISEED( 4 ), ISEEDY( 4 )
111 DOUBLE PRECISION RESULT( NTESTS )
112 * ..
113 * .. External Functions ..
114 DOUBLE PRECISION DGET06, ZLANHE
115 EXTERNAL DGET06, ZLANHE
116 * ..
117 * .. External Subroutines ..
118 EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRHE, ZGET04,
119 $ ZHECON, ZHERFS, ZHET01, ZHETRF, ZHETRI2,
120 $ ZHETRS, ZLACPY, ZLAIPD, ZLARHS, ZLATB4, ZLATMS,
121 $ ZPOT02, ZPOT03, ZPOT05
122 * ..
123 * .. Intrinsic Functions ..
124 INTRINSIC MAX, MIN
125 * ..
126 * .. Scalars in Common ..
127 LOGICAL LERR, OK
128 CHARACTER*32 SRNAMT
129 INTEGER INFOT, NUNIT
130 * ..
131 * .. Common blocks ..
132 COMMON / INFOC / INFOT, NUNIT, OK, LERR
133 COMMON / SRNAMC / SRNAMT
134 * ..
135 * .. Data statements ..
136 DATA ISEEDY / 1988, 1989, 1990, 1991 /
137 DATA UPLOS / 'U', 'L' /
138 * ..
139 * .. Executable Statements ..
140 *
141 * Initialize constants and the random number seed.
142 *
143 PATH( 1: 1 ) = 'Zomplex precision'
144 PATH( 2: 3 ) = 'HE'
145 NRUN = 0
146 NFAIL = 0
147 NERRS = 0
148 DO 10 I = 1, 4
149 ISEED( I ) = ISEEDY( I )
150 10 CONTINUE
151 *
152 * Test the error exits
153 *
154 IF( TSTERR )
155 $ CALL ZERRHE( PATH, NOUT )
156 INFOT = 0
157 *
158 * Do for each value of N in NVAL
159 *
160 DO 180 IN = 1, NN
161 N = NVAL( IN )
162 LDA = MAX( N, 1 )
163 XTYPE = 'N'
164 NIMAT = NTYPES
165 IF( N.LE.0 )
166 $ NIMAT = 1
167 *
168 IZERO = 0
169 DO 170 IMAT = 1, NIMAT
170 *
171 * Do the tests only if DOTYPE( IMAT ) is true.
172 *
173 IF( .NOT.DOTYPE( IMAT ) )
174 $ GO TO 170
175 *
176 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
177 *
178 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
179 IF( ZEROT .AND. N.LT.IMAT-2 )
180 $ GO TO 170
181 *
182 * Do first for UPLO = 'U', then for UPLO = 'L'
183 *
184 DO 160 IUPLO = 1, 2
185 UPLO = UPLOS( IUPLO )
186 *
187 * Set up parameters with ZLATB4 and generate a test matrix
188 * with ZLATMS.
189 *
190 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
191 $ CNDNUM, DIST )
192 *
193 SRNAMT = 'ZLATMS'
194 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
195 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
196 $ INFO )
197 *
198 * Check error code from ZLATMS.
199 *
200 IF( INFO.NE.0 ) THEN
201 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1,
202 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
203 GO TO 160
204 END IF
205 *
206 * For types 3-6, zero one or more rows and columns of
207 * the matrix to test that INFO is returned correctly.
208 *
209 IF( ZEROT ) THEN
210 IF( IMAT.EQ.3 ) THEN
211 IZERO = 1
212 ELSE IF( IMAT.EQ.4 ) THEN
213 IZERO = N
214 ELSE
215 IZERO = N / 2 + 1
216 END IF
217 *
218 IF( IMAT.LT.6 ) THEN
219 *
220 * Set row and column IZERO to zero.
221 *
222 IF( IUPLO.EQ.1 ) THEN
223 IOFF = ( IZERO-1 )*LDA
224 DO 20 I = 1, IZERO - 1
225 A( IOFF+I ) = ZERO
226 20 CONTINUE
227 IOFF = IOFF + IZERO
228 DO 30 I = IZERO, N
229 A( IOFF ) = ZERO
230 IOFF = IOFF + LDA
231 30 CONTINUE
232 ELSE
233 IOFF = IZERO
234 DO 40 I = 1, IZERO - 1
235 A( IOFF ) = ZERO
236 IOFF = IOFF + LDA
237 40 CONTINUE
238 IOFF = IOFF - IZERO
239 DO 50 I = IZERO, N
240 A( IOFF+I ) = ZERO
241 50 CONTINUE
242 END IF
243 ELSE
244 IOFF = 0
245 IF( IUPLO.EQ.1 ) THEN
246 *
247 * Set the first IZERO rows and columns to zero.
248 *
249 DO 70 J = 1, N
250 I2 = MIN( J, IZERO )
251 DO 60 I = 1, I2
252 A( IOFF+I ) = ZERO
253 60 CONTINUE
254 IOFF = IOFF + LDA
255 70 CONTINUE
256 ELSE
257 *
258 * Set the last IZERO rows and columns to zero.
259 *
260 DO 90 J = 1, N
261 I1 = MAX( J, IZERO )
262 DO 80 I = I1, N
263 A( IOFF+I ) = ZERO
264 80 CONTINUE
265 IOFF = IOFF + LDA
266 90 CONTINUE
267 END IF
268 END IF
269 ELSE
270 IZERO = 0
271 END IF
272 *
273 * Set the imaginary part of the diagonals.
274 *
275 CALL ZLAIPD( N, A, LDA+1, 0 )
276 *
277 * Do for each value of NB in NBVAL
278 *
279 DO 150 INB = 1, NNB
280 NB = NBVAL( INB )
281 CALL XLAENV( 1, NB )
282 *
283 * Compute the L*D*L' or U*D*U' factorization of the
284 * matrix.
285 *
286 CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
287 LWORK = MAX( 2, NB )*LDA
288 SRNAMT = 'ZHETRF'
289 CALL ZHETRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK,
290 $ INFO )
291 *
292 * Adjust the expected value of INFO to account for
293 * pivoting.
294 *
295 K = IZERO
296 IF( K.GT.0 ) THEN
297 100 CONTINUE
298 IF( IWORK( K ).LT.0 ) THEN
299 IF( IWORK( K ).NE.-K ) THEN
300 K = -IWORK( K )
301 GO TO 100
302 END IF
303 ELSE IF( IWORK( K ).NE.K ) THEN
304 K = IWORK( K )
305 GO TO 100
306 END IF
307 END IF
308 *
309 * Check error code from ZHETRF.
310 *
311 IF( INFO.NE.K )
312 $ CALL ALAERH( PATH, 'ZHETRF', INFO, K, UPLO, N, N,
313 $ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT )
314 IF( INFO.NE.0 ) THEN
315 TRFCON = .TRUE.
316 ELSE
317 TRFCON = .FALSE.
318 END IF
319 *
320 *+ TEST 1
321 * Reconstruct matrix from factors and compute residual.
322 *
323 CALL ZHET01( UPLO, N, A, LDA, AFAC, LDA, IWORK, AINV,
324 $ LDA, RWORK, RESULT( 1 ) )
325 NT = 1
326 *
327 *+ TEST 2
328 * Form the inverse and compute the residual.
329 *
330 IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
331 CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
332 SRNAMT = 'ZHETRI2'
333 LWORK = (N+NB+1)*(NB+3)
334 CALL ZHETRI2( UPLO, N, AINV, LDA, IWORK, WORK,
335 $ LWORK, INFO )
336 *
337 * Check error code from ZHETRI.
338 *
339 IF( INFO.NE.0 )
340 $ CALL ALAERH( PATH, 'ZHETRI', INFO, -1, UPLO, N,
341 $ N, -1, -1, -1, IMAT, NFAIL, NERRS,
342 $ NOUT )
343 *
344 CALL ZPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
345 $ RWORK, RCONDC, RESULT( 2 ) )
346 NT = 2
347 END IF
348 *
349 * Print information about the tests that did not pass
350 * the threshold.
351 *
352 DO 110 K = 1, NT
353 IF( RESULT( K ).GE.THRESH ) THEN
354 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
355 $ CALL ALAHD( NOUT, PATH )
356 WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
357 $ RESULT( K )
358 NFAIL = NFAIL + 1
359 END IF
360 110 CONTINUE
361 NRUN = NRUN + NT
362 *
363 * Skip the other tests if this is not the first block
364 * size.
365 *
366 IF( INB.GT.1 )
367 $ GO TO 150
368 *
369 * Do only the condition estimate if INFO is not 0.
370 *
371 IF( TRFCON ) THEN
372 RCONDC = ZERO
373 GO TO 140
374 END IF
375 *
376 DO 130 IRHS = 1, NNS
377 NRHS = NSVAL( IRHS )
378 *
379 *+ TEST 3
380 * Solve and compute residual for A * X = B.
381 *
382 SRNAMT = 'ZLARHS'
383 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
384 $ NRHS, A, LDA, XACT, LDA, B, LDA,
385 $ ISEED, INFO )
386 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
387 *
388 SRNAMT = 'ZHETRS'
389 CALL ZHETRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
390 $ LDA, INFO )
391 *
392 * Check error code from ZHETRS.
393 *
394 IF( INFO.NE.0 )
395 $ CALL ALAERH( PATH, 'ZHETRS', INFO, 0, UPLO, N,
396 $ N, -1, -1, NRHS, IMAT, NFAIL,
397 $ NERRS, NOUT )
398 *
399 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
400 CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
401 $ LDA, RWORK, RESULT( 3 ) )
402 *
403 *+ TEST 4
404 * Solve and compute residual for A * X = B.
405 *
406 SRNAMT = 'ZLARHS'
407 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
408 $ NRHS, A, LDA, XACT, LDA, B, LDA,
409 $ ISEED, INFO )
410 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
411 *
412 SRNAMT = 'ZHETRS2'
413 CALL ZHETRS2( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
414 $ LDA, WORK, INFO )
415 *
416 * Check error code from ZSYTRS2.
417 *
418 IF( INFO.NE.0 )
419 $ CALL ALAERH( PATH, 'ZHETRS2', INFO, 0, UPLO, N,
420 $ N, -1, -1, NRHS, IMAT, NFAIL,
421 $ NERRS, NOUT )
422 *
423 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
424 CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
425 $ LDA, RWORK, RESULT( 4 ) )
426 *
427 *+ TEST 5
428 * Check solution from generated exact solution.
429 *
430 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
431 $ RESULT( 5 ) )
432 *
433 *+ TESTS 6, 7, and 8
434 * Use iterative refinement to improve the solution.
435 *
436 SRNAMT = 'ZHERFS'
437 CALL ZHERFS( UPLO, N, NRHS, A, LDA, AFAC, LDA,
438 $ IWORK, B, LDA, X, LDA, RWORK,
439 $ RWORK( NRHS+1 ), WORK,
440 $ RWORK( 2*NRHS+1 ), INFO )
441 *
442 * Check error code from ZHERFS.
443 *
444 IF( INFO.NE.0 )
445 $ CALL ALAERH( PATH, 'ZHERFS', INFO, 0, UPLO, N,
446 $ N, -1, -1, NRHS, IMAT, NFAIL,
447 $ NERRS, NOUT )
448 *
449 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
450 $ RESULT( 6 ) )
451 CALL ZPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
452 $ XACT, LDA, RWORK, RWORK( NRHS+1 ),
453 $ RESULT( 7 ) )
454 *
455 * Print information about the tests that did not pass
456 * the threshold.
457 *
458 DO 120 K = 3, 8
459 IF( RESULT( K ).GE.THRESH ) THEN
460 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
461 $ CALL ALAHD( NOUT, PATH )
462 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
463 $ IMAT, K, RESULT( K )
464 NFAIL = NFAIL + 1
465 END IF
466 120 CONTINUE
467 NRUN = NRUN + 5
468 130 CONTINUE
469 *
470 *+ TEST 9
471 * Get an estimate of RCOND = 1/CNDNUM.
472 *
473 140 CONTINUE
474 ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
475 SRNAMT = 'ZHECON'
476 CALL ZHECON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND,
477 $ WORK, INFO )
478 *
479 * Check error code from ZHECON.
480 *
481 IF( INFO.NE.0 )
482 $ CALL ALAERH( PATH, 'ZHECON', INFO, 0, UPLO, N, N,
483 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
484 *
485 RESULT( 9 ) = DGET06( RCOND, RCONDC )
486 *
487 * Print information about the tests that did not pass
488 * the threshold.
489 *
490 IF( RESULT( 9 ).GE.THRESH ) THEN
491 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
492 $ CALL ALAHD( NOUT, PATH )
493 WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 9,
494 $ RESULT( 9 )
495 NFAIL = NFAIL + 1
496 END IF
497 NRUN = NRUN + 1
498 150 CONTINUE
499 160 CONTINUE
500 170 CONTINUE
501 180 CONTINUE
502 *
503 * Print a summary of the results.
504 *
505 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
506 *
507 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
508 $ I2, ', test ', I2, ', ratio =', G12.5 )
509 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
510 $ I2, ', test(', I2, ') =', G12.5 )
511 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
512 $ ', test(', I2, ') =', G12.5 )
513 RETURN
514 *
515 * End of ZCHKHE
516 *
517 END
2 $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
3 $ XACT, WORK, RWORK, IWORK, NOUT )
4 *
5 * -- LAPACK test routine (version 3.3.1) --
6 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
7 * -- April 2011 --
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 RWORK( * )
18 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
19 $ WORK( * ), X( * ), XACT( * )
20 * ..
21 *
22 * Purpose
23 * =======
24 *
25 * ZCHKHE tests ZHETRF, -TRI2, -TRS, -TRS2, -RFS, and -CON.
26 *
27 * Arguments
28 * =========
29 *
30 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
31 * The matrix types to be used for testing. Matrices of type j
32 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
33 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
34 *
35 * NN (input) INTEGER
36 * The number of values of N contained in the vector NVAL.
37 *
38 * NVAL (input) INTEGER array, dimension (NN)
39 * The values of the matrix dimension N.
40 *
41 * NNB (input) INTEGER
42 * The number of values of NB contained in the vector NBVAL.
43 *
44 * NBVAL (input) INTEGER array, dimension (NBVAL)
45 * The values of the blocksize NB.
46 *
47 * NNS (input) INTEGER
48 * The number of values of NRHS contained in the vector NSVAL.
49 *
50 * NSVAL (input) INTEGER array, dimension (NNS)
51 * The values of the number of right hand sides NRHS.
52 *
53 * THRESH (input) DOUBLE PRECISION
54 * The threshold value for the test ratios. A result is
55 * included in the output file if RESULT >= THRESH. To have
56 * every test ratio printed, use THRESH = 0.
57 *
58 * TSTERR (input) LOGICAL
59 * Flag that indicates whether error exits are to be tested.
60 *
61 * NMAX (input) INTEGER
62 * The maximum value permitted for N, used in dimensioning the
63 * work arrays.
64 *
65 * A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
66 *
67 * AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
68 *
69 * AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
70 *
71 * B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
72 * where NSMAX is the largest entry in NSVAL.
73 *
74 * X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
75 *
76 * XACT (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX)
77 *
78 * WORK (workspace) COMPLEX*16 array, dimension
79 * (NMAX*max(3,NSMAX))
80 *
81 * RWORK (workspace) DOUBLE PRECISION array, dimension
82 * (max(NMAX,2*NSMAX))
83 *
84 * IWORK (workspace) INTEGER array, dimension (NMAX)
85 *
86 * NOUT (input) INTEGER
87 * The unit number for output.
88 *
89 * =====================================================================
90 *
91 * .. Parameters ..
92 DOUBLE PRECISION ZERO
93 PARAMETER ( ZERO = 0.0D+0 )
94 INTEGER NTYPES
95 PARAMETER ( NTYPES = 10 )
96 INTEGER NTESTS
97 PARAMETER ( NTESTS = 9 )
98 * ..
99 * .. Local Scalars ..
100 LOGICAL TRFCON, ZEROT
101 CHARACTER DIST, TYPE, UPLO, XTYPE
102 CHARACTER*3 PATH
103 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
104 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
105 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
106 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
107 * ..
108 * .. Local Arrays ..
109 CHARACTER UPLOS( 2 )
110 INTEGER ISEED( 4 ), ISEEDY( 4 )
111 DOUBLE PRECISION RESULT( NTESTS )
112 * ..
113 * .. External Functions ..
114 DOUBLE PRECISION DGET06, ZLANHE
115 EXTERNAL DGET06, ZLANHE
116 * ..
117 * .. External Subroutines ..
118 EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRHE, ZGET04,
119 $ ZHECON, ZHERFS, ZHET01, ZHETRF, ZHETRI2,
120 $ ZHETRS, ZLACPY, ZLAIPD, ZLARHS, ZLATB4, ZLATMS,
121 $ ZPOT02, ZPOT03, ZPOT05
122 * ..
123 * .. Intrinsic Functions ..
124 INTRINSIC MAX, MIN
125 * ..
126 * .. Scalars in Common ..
127 LOGICAL LERR, OK
128 CHARACTER*32 SRNAMT
129 INTEGER INFOT, NUNIT
130 * ..
131 * .. Common blocks ..
132 COMMON / INFOC / INFOT, NUNIT, OK, LERR
133 COMMON / SRNAMC / SRNAMT
134 * ..
135 * .. Data statements ..
136 DATA ISEEDY / 1988, 1989, 1990, 1991 /
137 DATA UPLOS / 'U', 'L' /
138 * ..
139 * .. Executable Statements ..
140 *
141 * Initialize constants and the random number seed.
142 *
143 PATH( 1: 1 ) = 'Zomplex precision'
144 PATH( 2: 3 ) = 'HE'
145 NRUN = 0
146 NFAIL = 0
147 NERRS = 0
148 DO 10 I = 1, 4
149 ISEED( I ) = ISEEDY( I )
150 10 CONTINUE
151 *
152 * Test the error exits
153 *
154 IF( TSTERR )
155 $ CALL ZERRHE( PATH, NOUT )
156 INFOT = 0
157 *
158 * Do for each value of N in NVAL
159 *
160 DO 180 IN = 1, NN
161 N = NVAL( IN )
162 LDA = MAX( N, 1 )
163 XTYPE = 'N'
164 NIMAT = NTYPES
165 IF( N.LE.0 )
166 $ NIMAT = 1
167 *
168 IZERO = 0
169 DO 170 IMAT = 1, NIMAT
170 *
171 * Do the tests only if DOTYPE( IMAT ) is true.
172 *
173 IF( .NOT.DOTYPE( IMAT ) )
174 $ GO TO 170
175 *
176 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
177 *
178 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
179 IF( ZEROT .AND. N.LT.IMAT-2 )
180 $ GO TO 170
181 *
182 * Do first for UPLO = 'U', then for UPLO = 'L'
183 *
184 DO 160 IUPLO = 1, 2
185 UPLO = UPLOS( IUPLO )
186 *
187 * Set up parameters with ZLATB4 and generate a test matrix
188 * with ZLATMS.
189 *
190 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
191 $ CNDNUM, DIST )
192 *
193 SRNAMT = 'ZLATMS'
194 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
195 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
196 $ INFO )
197 *
198 * Check error code from ZLATMS.
199 *
200 IF( INFO.NE.0 ) THEN
201 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1,
202 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
203 GO TO 160
204 END IF
205 *
206 * For types 3-6, zero one or more rows and columns of
207 * the matrix to test that INFO is returned correctly.
208 *
209 IF( ZEROT ) THEN
210 IF( IMAT.EQ.3 ) THEN
211 IZERO = 1
212 ELSE IF( IMAT.EQ.4 ) THEN
213 IZERO = N
214 ELSE
215 IZERO = N / 2 + 1
216 END IF
217 *
218 IF( IMAT.LT.6 ) THEN
219 *
220 * Set row and column IZERO to zero.
221 *
222 IF( IUPLO.EQ.1 ) THEN
223 IOFF = ( IZERO-1 )*LDA
224 DO 20 I = 1, IZERO - 1
225 A( IOFF+I ) = ZERO
226 20 CONTINUE
227 IOFF = IOFF + IZERO
228 DO 30 I = IZERO, N
229 A( IOFF ) = ZERO
230 IOFF = IOFF + LDA
231 30 CONTINUE
232 ELSE
233 IOFF = IZERO
234 DO 40 I = 1, IZERO - 1
235 A( IOFF ) = ZERO
236 IOFF = IOFF + LDA
237 40 CONTINUE
238 IOFF = IOFF - IZERO
239 DO 50 I = IZERO, N
240 A( IOFF+I ) = ZERO
241 50 CONTINUE
242 END IF
243 ELSE
244 IOFF = 0
245 IF( IUPLO.EQ.1 ) THEN
246 *
247 * Set the first IZERO rows and columns to zero.
248 *
249 DO 70 J = 1, N
250 I2 = MIN( J, IZERO )
251 DO 60 I = 1, I2
252 A( IOFF+I ) = ZERO
253 60 CONTINUE
254 IOFF = IOFF + LDA
255 70 CONTINUE
256 ELSE
257 *
258 * Set the last IZERO rows and columns to zero.
259 *
260 DO 90 J = 1, N
261 I1 = MAX( J, IZERO )
262 DO 80 I = I1, N
263 A( IOFF+I ) = ZERO
264 80 CONTINUE
265 IOFF = IOFF + LDA
266 90 CONTINUE
267 END IF
268 END IF
269 ELSE
270 IZERO = 0
271 END IF
272 *
273 * Set the imaginary part of the diagonals.
274 *
275 CALL ZLAIPD( N, A, LDA+1, 0 )
276 *
277 * Do for each value of NB in NBVAL
278 *
279 DO 150 INB = 1, NNB
280 NB = NBVAL( INB )
281 CALL XLAENV( 1, NB )
282 *
283 * Compute the L*D*L' or U*D*U' factorization of the
284 * matrix.
285 *
286 CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
287 LWORK = MAX( 2, NB )*LDA
288 SRNAMT = 'ZHETRF'
289 CALL ZHETRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK,
290 $ INFO )
291 *
292 * Adjust the expected value of INFO to account for
293 * pivoting.
294 *
295 K = IZERO
296 IF( K.GT.0 ) THEN
297 100 CONTINUE
298 IF( IWORK( K ).LT.0 ) THEN
299 IF( IWORK( K ).NE.-K ) THEN
300 K = -IWORK( K )
301 GO TO 100
302 END IF
303 ELSE IF( IWORK( K ).NE.K ) THEN
304 K = IWORK( K )
305 GO TO 100
306 END IF
307 END IF
308 *
309 * Check error code from ZHETRF.
310 *
311 IF( INFO.NE.K )
312 $ CALL ALAERH( PATH, 'ZHETRF', INFO, K, UPLO, N, N,
313 $ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT )
314 IF( INFO.NE.0 ) THEN
315 TRFCON = .TRUE.
316 ELSE
317 TRFCON = .FALSE.
318 END IF
319 *
320 *+ TEST 1
321 * Reconstruct matrix from factors and compute residual.
322 *
323 CALL ZHET01( UPLO, N, A, LDA, AFAC, LDA, IWORK, AINV,
324 $ LDA, RWORK, RESULT( 1 ) )
325 NT = 1
326 *
327 *+ TEST 2
328 * Form the inverse and compute the residual.
329 *
330 IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
331 CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
332 SRNAMT = 'ZHETRI2'
333 LWORK = (N+NB+1)*(NB+3)
334 CALL ZHETRI2( UPLO, N, AINV, LDA, IWORK, WORK,
335 $ LWORK, INFO )
336 *
337 * Check error code from ZHETRI.
338 *
339 IF( INFO.NE.0 )
340 $ CALL ALAERH( PATH, 'ZHETRI', INFO, -1, UPLO, N,
341 $ N, -1, -1, -1, IMAT, NFAIL, NERRS,
342 $ NOUT )
343 *
344 CALL ZPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
345 $ RWORK, RCONDC, RESULT( 2 ) )
346 NT = 2
347 END IF
348 *
349 * Print information about the tests that did not pass
350 * the threshold.
351 *
352 DO 110 K = 1, NT
353 IF( RESULT( K ).GE.THRESH ) THEN
354 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
355 $ CALL ALAHD( NOUT, PATH )
356 WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
357 $ RESULT( K )
358 NFAIL = NFAIL + 1
359 END IF
360 110 CONTINUE
361 NRUN = NRUN + NT
362 *
363 * Skip the other tests if this is not the first block
364 * size.
365 *
366 IF( INB.GT.1 )
367 $ GO TO 150
368 *
369 * Do only the condition estimate if INFO is not 0.
370 *
371 IF( TRFCON ) THEN
372 RCONDC = ZERO
373 GO TO 140
374 END IF
375 *
376 DO 130 IRHS = 1, NNS
377 NRHS = NSVAL( IRHS )
378 *
379 *+ TEST 3
380 * Solve and compute residual for A * X = B.
381 *
382 SRNAMT = 'ZLARHS'
383 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
384 $ NRHS, A, LDA, XACT, LDA, B, LDA,
385 $ ISEED, INFO )
386 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
387 *
388 SRNAMT = 'ZHETRS'
389 CALL ZHETRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
390 $ LDA, INFO )
391 *
392 * Check error code from ZHETRS.
393 *
394 IF( INFO.NE.0 )
395 $ CALL ALAERH( PATH, 'ZHETRS', INFO, 0, UPLO, N,
396 $ N, -1, -1, NRHS, IMAT, NFAIL,
397 $ NERRS, NOUT )
398 *
399 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
400 CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
401 $ LDA, RWORK, RESULT( 3 ) )
402 *
403 *+ TEST 4
404 * Solve and compute residual for A * X = B.
405 *
406 SRNAMT = 'ZLARHS'
407 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
408 $ NRHS, A, LDA, XACT, LDA, B, LDA,
409 $ ISEED, INFO )
410 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
411 *
412 SRNAMT = 'ZHETRS2'
413 CALL ZHETRS2( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
414 $ LDA, WORK, INFO )
415 *
416 * Check error code from ZSYTRS2.
417 *
418 IF( INFO.NE.0 )
419 $ CALL ALAERH( PATH, 'ZHETRS2', INFO, 0, UPLO, N,
420 $ N, -1, -1, NRHS, IMAT, NFAIL,
421 $ NERRS, NOUT )
422 *
423 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
424 CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
425 $ LDA, RWORK, RESULT( 4 ) )
426 *
427 *+ TEST 5
428 * Check solution from generated exact solution.
429 *
430 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
431 $ RESULT( 5 ) )
432 *
433 *+ TESTS 6, 7, and 8
434 * Use iterative refinement to improve the solution.
435 *
436 SRNAMT = 'ZHERFS'
437 CALL ZHERFS( UPLO, N, NRHS, A, LDA, AFAC, LDA,
438 $ IWORK, B, LDA, X, LDA, RWORK,
439 $ RWORK( NRHS+1 ), WORK,
440 $ RWORK( 2*NRHS+1 ), INFO )
441 *
442 * Check error code from ZHERFS.
443 *
444 IF( INFO.NE.0 )
445 $ CALL ALAERH( PATH, 'ZHERFS', INFO, 0, UPLO, N,
446 $ N, -1, -1, NRHS, IMAT, NFAIL,
447 $ NERRS, NOUT )
448 *
449 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
450 $ RESULT( 6 ) )
451 CALL ZPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
452 $ XACT, LDA, RWORK, RWORK( NRHS+1 ),
453 $ RESULT( 7 ) )
454 *
455 * Print information about the tests that did not pass
456 * the threshold.
457 *
458 DO 120 K = 3, 8
459 IF( RESULT( K ).GE.THRESH ) THEN
460 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
461 $ CALL ALAHD( NOUT, PATH )
462 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
463 $ IMAT, K, RESULT( K )
464 NFAIL = NFAIL + 1
465 END IF
466 120 CONTINUE
467 NRUN = NRUN + 5
468 130 CONTINUE
469 *
470 *+ TEST 9
471 * Get an estimate of RCOND = 1/CNDNUM.
472 *
473 140 CONTINUE
474 ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
475 SRNAMT = 'ZHECON'
476 CALL ZHECON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND,
477 $ WORK, INFO )
478 *
479 * Check error code from ZHECON.
480 *
481 IF( INFO.NE.0 )
482 $ CALL ALAERH( PATH, 'ZHECON', INFO, 0, UPLO, N, N,
483 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
484 *
485 RESULT( 9 ) = DGET06( RCOND, RCONDC )
486 *
487 * Print information about the tests that did not pass
488 * the threshold.
489 *
490 IF( RESULT( 9 ).GE.THRESH ) THEN
491 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
492 $ CALL ALAHD( NOUT, PATH )
493 WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 9,
494 $ RESULT( 9 )
495 NFAIL = NFAIL + 1
496 END IF
497 NRUN = NRUN + 1
498 150 CONTINUE
499 160 CONTINUE
500 170 CONTINUE
501 180 CONTINUE
502 *
503 * Print a summary of the results.
504 *
505 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
506 *
507 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
508 $ I2, ', test ', I2, ', ratio =', G12.5 )
509 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
510 $ I2, ', test(', I2, ') =', G12.5 )
511 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
512 $ ', test(', I2, ') =', G12.5 )
513 RETURN
514 *
515 * End of ZCHKHE
516 *
517 END