1 SUBROUTINE ZCHKSY( 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.1) --
6 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
7 * June 2010
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 * ZCHKSY tests ZSYTRF, -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(2,NSMAX))
80 *
81 * RWORK (workspace) DOUBLE PRECISION array,
82 * dimension (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 = 11 )
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, ZLANSY
115 EXTERNAL DGET06, ZLANSY
116 * ..
117 * .. External Subroutines ..
118 EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRSY, ZGET04,
119 $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY, ZPOT05,
120 $ ZSYCON, ZSYRFS, ZSYT01, ZSYT02, ZSYT03, ZSYTRF,
121 $ ZSYTRI2, ZSYTRS, ZSYTRS2
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 ) = 'SY'
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 ZERRSY( 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 IF( IMAT.NE.NTYPES ) THEN
188 *
189 * Set up parameters with ZLATB4 and generate a test
190 * matrix with ZLATMS.
191 *
192 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
193 $ MODE, CNDNUM, DIST )
194 *
195 SRNAMT = 'ZLATMS'
196 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
197 $ CNDNUM, ANORM, KL, KU, 'N', A, LDA, WORK,
198 $ INFO )
199 *
200 * Check error code from ZLATMS.
201 *
202 IF( INFO.NE.0 ) THEN
203 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N,
204 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
205 GO TO 160
206 END IF
207 *
208 * For types 3-6, zero one or more rows and columns of
209 * the matrix to test that INFO is returned correctly.
210 *
211 IF( ZEROT ) THEN
212 IF( IMAT.EQ.3 ) THEN
213 IZERO = 1
214 ELSE IF( IMAT.EQ.4 ) THEN
215 IZERO = N
216 ELSE
217 IZERO = N / 2 + 1
218 END IF
219 *
220 IF( IMAT.LT.6 ) THEN
221 *
222 * Set row and column IZERO to zero.
223 *
224 IF( IUPLO.EQ.1 ) THEN
225 IOFF = ( IZERO-1 )*LDA
226 DO 20 I = 1, IZERO - 1
227 A( IOFF+I ) = ZERO
228 20 CONTINUE
229 IOFF = IOFF + IZERO
230 DO 30 I = IZERO, N
231 A( IOFF ) = ZERO
232 IOFF = IOFF + LDA
233 30 CONTINUE
234 ELSE
235 IOFF = IZERO
236 DO 40 I = 1, IZERO - 1
237 A( IOFF ) = ZERO
238 IOFF = IOFF + LDA
239 40 CONTINUE
240 IOFF = IOFF - IZERO
241 DO 50 I = IZERO, N
242 A( IOFF+I ) = ZERO
243 50 CONTINUE
244 END IF
245 ELSE
246 IF( IUPLO.EQ.1 ) THEN
247 *
248 * Set the first IZERO rows to zero.
249 *
250 IOFF = 0
251 DO 70 J = 1, N
252 I2 = MIN( J, IZERO )
253 DO 60 I = 1, I2
254 A( IOFF+I ) = ZERO
255 60 CONTINUE
256 IOFF = IOFF + LDA
257 70 CONTINUE
258 ELSE
259 *
260 * Set the last IZERO rows to zero.
261 *
262 IOFF = 0
263 DO 90 J = 1, N
264 I1 = MAX( J, IZERO )
265 DO 80 I = I1, N
266 A( IOFF+I ) = ZERO
267 80 CONTINUE
268 IOFF = IOFF + LDA
269 90 CONTINUE
270 END IF
271 END IF
272 ELSE
273 IZERO = 0
274 END IF
275 ELSE
276 *
277 * Use a special block diagonal matrix to test alternate
278 * code for the 2 x 2 blocks.
279 *
280 CALL ZLATSY( UPLO, N, A, LDA, ISEED )
281 END IF
282 *
283 * Do for each value of NB in NBVAL
284 *
285 DO 150 INB = 1, NNB
286 NB = NBVAL( INB )
287 CALL XLAENV( 1, NB )
288 *
289 * Compute the L*D*L' or U*D*U' factorization of the
290 * matrix.
291 *
292 CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
293 LWORK = MAX( 2, NB )*LDA
294 SRNAMT = 'ZSYTRF'
295 CALL ZSYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK,
296 $ INFO )
297 *
298 * Adjust the expected value of INFO to account for
299 * pivoting.
300 *
301 K = IZERO
302 IF( K.GT.0 ) THEN
303 100 CONTINUE
304 IF( IWORK( K ).LT.0 ) THEN
305 IF( IWORK( K ).NE.-K ) THEN
306 K = -IWORK( K )
307 GO TO 100
308 END IF
309 ELSE IF( IWORK( K ).NE.K ) THEN
310 K = IWORK( K )
311 GO TO 100
312 END IF
313 END IF
314 *
315 * Check error code from ZSYTRF.
316 *
317 IF( INFO.NE.K )
318 $ CALL ALAERH( PATH, 'ZSYTRF', INFO, K, UPLO, N, N,
319 $ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT )
320 IF( INFO.NE.0 ) THEN
321 TRFCON = .TRUE.
322 ELSE
323 TRFCON = .FALSE.
324 END IF
325 *
326 *+ TEST 1
327 * Reconstruct matrix from factors and compute residual.
328 *
329 CALL ZSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, AINV,
330 $ LDA, RWORK, RESULT( 1 ) )
331 NT = 1
332 *
333 *+ TEST 2
334 * Form the inverse and compute the residual.
335 *
336 IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
337 CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
338 SRNAMT = 'ZSYTRI2'
339 LWORK = (N+NB+1)*(NB+3)
340 CALL ZSYTRI2( UPLO, N, AINV, LDA, IWORK, WORK,
341 $ LWORK, INFO )
342 *
343 * Check error code from ZSYTRI2.
344 *
345 IF( INFO.NE.0 )
346 $ CALL ALAERH( PATH, 'ZSYTRI2', INFO, 0, UPLO, N,
347 $ N, -1, -1, -1, IMAT, NFAIL, NERRS,
348 $ NOUT )
349 *
350 CALL ZSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
351 $ RWORK, RCONDC, RESULT( 2 ) )
352 NT = 2
353 END IF
354 *
355 * Print information about the tests that did not pass
356 * the threshold.
357 *
358 DO 110 K = 1, NT
359 IF( RESULT( K ).GE.THRESH ) THEN
360 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
361 $ CALL ALAHD( NOUT, PATH )
362 WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
363 $ RESULT( K )
364 NFAIL = NFAIL + 1
365 END IF
366 110 CONTINUE
367 NRUN = NRUN + NT
368 *
369 * Skip the other tests if this is not the first block
370 * size.
371 *
372 IF( INB.GT.1 )
373 $ GO TO 150
374 *
375 * Do only the condition estimate if INFO is not 0.
376 *
377 IF( TRFCON ) THEN
378 RCONDC = ZERO
379 GO TO 140
380 END IF
381 *
382 DO 130 IRHS = 1, NNS
383 NRHS = NSVAL( IRHS )
384 *
385 *+ TEST 3 (Using ZSYTRS)
386 * Solve and compute residual for A * X = B.
387 *
388 SRNAMT = 'ZLARHS'
389 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
390 $ NRHS, A, LDA, XACT, LDA, B, LDA,
391 $ ISEED, INFO )
392 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
393 *
394 SRNAMT = 'ZSYTRS'
395 CALL ZSYTRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
396 $ LDA, INFO )
397 *
398 * Check error code from ZSYTRS.
399 *
400 IF( INFO.NE.0 )
401 $ CALL ALAERH( PATH, 'ZSYTRS', INFO, 0, UPLO, N,
402 $ N, -1, -1, NRHS, IMAT, NFAIL,
403 $ NERRS, NOUT )
404 *
405 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
406 CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
407 $ LDA, RWORK, RESULT( 3 ) )
408 *
409 *+ TEST 4 (Using ZSYTRS2)
410 * Solve and compute residual for A * X = B.
411 *
412 SRNAMT = 'ZLARHS'
413 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
414 $ NRHS, A, LDA, XACT, LDA, B, LDA,
415 $ ISEED, INFO )
416 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
417 *
418 SRNAMT = 'ZSYTRS2'
419 CALL ZSYTRS2( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
420 $ LDA, WORK, INFO )
421 *
422 * Check error code from ZSYTRS.
423 *
424 IF( INFO.NE.0 )
425 $ CALL ALAERH( PATH, 'ZSYTRS', INFO, 0, UPLO, N,
426 $ N, -1, -1, NRHS, IMAT, NFAIL,
427 $ NERRS, NOUT )
428 *
429 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
430 CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
431 $ LDA, RWORK, RESULT( 4 ) )
432 *
433 *
434 *+ TEST 5
435 * Check solution from generated exact solution.
436 *
437 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
438 $ RESULT( 5 ) )
439 *
440 *+ TESTS 6, 7, and 8
441 * Use iterative refinement to improve the solution.
442 *
443 SRNAMT = 'ZSYRFS'
444 CALL ZSYRFS( UPLO, N, NRHS, A, LDA, AFAC, LDA,
445 $ IWORK, B, LDA, X, LDA, RWORK,
446 $ RWORK( NRHS+1 ), WORK,
447 $ RWORK( 2*NRHS+1 ), INFO )
448 *
449 * Check error code from ZSYRFS.
450 *
451 IF( INFO.NE.0 )
452 $ CALL ALAERH( PATH, 'ZSYRFS', INFO, 0, UPLO, N,
453 $ N, -1, -1, NRHS, IMAT, NFAIL,
454 $ NERRS, NOUT )
455 *
456 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
457 $ RESULT( 6 ) )
458 CALL ZPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
459 $ XACT, LDA, RWORK, RWORK( NRHS+1 ),
460 $ RESULT( 7 ) )
461 *
462 * Print information about the tests that did not pass
463 * the threshold.
464 *
465 DO 120 K = 3, 8
466 IF( RESULT( K ).GE.THRESH ) THEN
467 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
468 $ CALL ALAHD( NOUT, PATH )
469 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
470 $ IMAT, K, RESULT( K )
471 NFAIL = NFAIL + 1
472 END IF
473 120 CONTINUE
474 NRUN = NRUN + 5
475 130 CONTINUE
476 *
477 *+ TEST 9
478 * Get an estimate of RCOND = 1/CNDNUM.
479 *
480 140 CONTINUE
481 ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK )
482 SRNAMT = 'ZSYCON'
483 CALL ZSYCON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND,
484 $ WORK, INFO )
485 *
486 * Check error code from ZSYCON.
487 *
488 IF( INFO.NE.0 )
489 $ CALL ALAERH( PATH, 'ZSYCON', INFO, 0, UPLO, N, N,
490 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
491 *
492 RESULT( 9 ) = DGET06( RCOND, RCONDC )
493 *
494 * Print information about the tests that did not pass
495 * the threshold.
496 *
497 IF( RESULT( 9 ).GE.THRESH ) THEN
498 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
499 $ CALL ALAHD( NOUT, PATH )
500 WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 9,
501 $ RESULT( 9 )
502 NFAIL = NFAIL + 1
503 END IF
504 NRUN = NRUN + 1
505 150 CONTINUE
506 160 CONTINUE
507 170 CONTINUE
508 180 CONTINUE
509 *
510 * Print a summary of the results.
511 *
512 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
513 *
514 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
515 $ I2, ', test ', I2, ', ratio =', G12.5 )
516 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
517 $ I2, ', test(', I2, ') =', G12.5 )
518 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
519 $ ', test(', I2, ') =', G12.5 )
520 RETURN
521 *
522 * End of ZCHKSY
523 *
524 END
2 $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
3 $ XACT, WORK, RWORK, IWORK, NOUT )
4 *
5 * -- LAPACK test routine (version 3.1) --
6 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
7 * June 2010
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 * ZCHKSY tests ZSYTRF, -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(2,NSMAX))
80 *
81 * RWORK (workspace) DOUBLE PRECISION array,
82 * dimension (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 = 11 )
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, ZLANSY
115 EXTERNAL DGET06, ZLANSY
116 * ..
117 * .. External Subroutines ..
118 EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRSY, ZGET04,
119 $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY, ZPOT05,
120 $ ZSYCON, ZSYRFS, ZSYT01, ZSYT02, ZSYT03, ZSYTRF,
121 $ ZSYTRI2, ZSYTRS, ZSYTRS2
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 ) = 'SY'
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 ZERRSY( 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 IF( IMAT.NE.NTYPES ) THEN
188 *
189 * Set up parameters with ZLATB4 and generate a test
190 * matrix with ZLATMS.
191 *
192 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM,
193 $ MODE, CNDNUM, DIST )
194 *
195 SRNAMT = 'ZLATMS'
196 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
197 $ CNDNUM, ANORM, KL, KU, 'N', A, LDA, WORK,
198 $ INFO )
199 *
200 * Check error code from ZLATMS.
201 *
202 IF( INFO.NE.0 ) THEN
203 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N,
204 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
205 GO TO 160
206 END IF
207 *
208 * For types 3-6, zero one or more rows and columns of
209 * the matrix to test that INFO is returned correctly.
210 *
211 IF( ZEROT ) THEN
212 IF( IMAT.EQ.3 ) THEN
213 IZERO = 1
214 ELSE IF( IMAT.EQ.4 ) THEN
215 IZERO = N
216 ELSE
217 IZERO = N / 2 + 1
218 END IF
219 *
220 IF( IMAT.LT.6 ) THEN
221 *
222 * Set row and column IZERO to zero.
223 *
224 IF( IUPLO.EQ.1 ) THEN
225 IOFF = ( IZERO-1 )*LDA
226 DO 20 I = 1, IZERO - 1
227 A( IOFF+I ) = ZERO
228 20 CONTINUE
229 IOFF = IOFF + IZERO
230 DO 30 I = IZERO, N
231 A( IOFF ) = ZERO
232 IOFF = IOFF + LDA
233 30 CONTINUE
234 ELSE
235 IOFF = IZERO
236 DO 40 I = 1, IZERO - 1
237 A( IOFF ) = ZERO
238 IOFF = IOFF + LDA
239 40 CONTINUE
240 IOFF = IOFF - IZERO
241 DO 50 I = IZERO, N
242 A( IOFF+I ) = ZERO
243 50 CONTINUE
244 END IF
245 ELSE
246 IF( IUPLO.EQ.1 ) THEN
247 *
248 * Set the first IZERO rows to zero.
249 *
250 IOFF = 0
251 DO 70 J = 1, N
252 I2 = MIN( J, IZERO )
253 DO 60 I = 1, I2
254 A( IOFF+I ) = ZERO
255 60 CONTINUE
256 IOFF = IOFF + LDA
257 70 CONTINUE
258 ELSE
259 *
260 * Set the last IZERO rows to zero.
261 *
262 IOFF = 0
263 DO 90 J = 1, N
264 I1 = MAX( J, IZERO )
265 DO 80 I = I1, N
266 A( IOFF+I ) = ZERO
267 80 CONTINUE
268 IOFF = IOFF + LDA
269 90 CONTINUE
270 END IF
271 END IF
272 ELSE
273 IZERO = 0
274 END IF
275 ELSE
276 *
277 * Use a special block diagonal matrix to test alternate
278 * code for the 2 x 2 blocks.
279 *
280 CALL ZLATSY( UPLO, N, A, LDA, ISEED )
281 END IF
282 *
283 * Do for each value of NB in NBVAL
284 *
285 DO 150 INB = 1, NNB
286 NB = NBVAL( INB )
287 CALL XLAENV( 1, NB )
288 *
289 * Compute the L*D*L' or U*D*U' factorization of the
290 * matrix.
291 *
292 CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
293 LWORK = MAX( 2, NB )*LDA
294 SRNAMT = 'ZSYTRF'
295 CALL ZSYTRF( UPLO, N, AFAC, LDA, IWORK, AINV, LWORK,
296 $ INFO )
297 *
298 * Adjust the expected value of INFO to account for
299 * pivoting.
300 *
301 K = IZERO
302 IF( K.GT.0 ) THEN
303 100 CONTINUE
304 IF( IWORK( K ).LT.0 ) THEN
305 IF( IWORK( K ).NE.-K ) THEN
306 K = -IWORK( K )
307 GO TO 100
308 END IF
309 ELSE IF( IWORK( K ).NE.K ) THEN
310 K = IWORK( K )
311 GO TO 100
312 END IF
313 END IF
314 *
315 * Check error code from ZSYTRF.
316 *
317 IF( INFO.NE.K )
318 $ CALL ALAERH( PATH, 'ZSYTRF', INFO, K, UPLO, N, N,
319 $ -1, -1, NB, IMAT, NFAIL, NERRS, NOUT )
320 IF( INFO.NE.0 ) THEN
321 TRFCON = .TRUE.
322 ELSE
323 TRFCON = .FALSE.
324 END IF
325 *
326 *+ TEST 1
327 * Reconstruct matrix from factors and compute residual.
328 *
329 CALL ZSYT01( UPLO, N, A, LDA, AFAC, LDA, IWORK, AINV,
330 $ LDA, RWORK, RESULT( 1 ) )
331 NT = 1
332 *
333 *+ TEST 2
334 * Form the inverse and compute the residual.
335 *
336 IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
337 CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
338 SRNAMT = 'ZSYTRI2'
339 LWORK = (N+NB+1)*(NB+3)
340 CALL ZSYTRI2( UPLO, N, AINV, LDA, IWORK, WORK,
341 $ LWORK, INFO )
342 *
343 * Check error code from ZSYTRI2.
344 *
345 IF( INFO.NE.0 )
346 $ CALL ALAERH( PATH, 'ZSYTRI2', INFO, 0, UPLO, N,
347 $ N, -1, -1, -1, IMAT, NFAIL, NERRS,
348 $ NOUT )
349 *
350 CALL ZSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
351 $ RWORK, RCONDC, RESULT( 2 ) )
352 NT = 2
353 END IF
354 *
355 * Print information about the tests that did not pass
356 * the threshold.
357 *
358 DO 110 K = 1, NT
359 IF( RESULT( K ).GE.THRESH ) THEN
360 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
361 $ CALL ALAHD( NOUT, PATH )
362 WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
363 $ RESULT( K )
364 NFAIL = NFAIL + 1
365 END IF
366 110 CONTINUE
367 NRUN = NRUN + NT
368 *
369 * Skip the other tests if this is not the first block
370 * size.
371 *
372 IF( INB.GT.1 )
373 $ GO TO 150
374 *
375 * Do only the condition estimate if INFO is not 0.
376 *
377 IF( TRFCON ) THEN
378 RCONDC = ZERO
379 GO TO 140
380 END IF
381 *
382 DO 130 IRHS = 1, NNS
383 NRHS = NSVAL( IRHS )
384 *
385 *+ TEST 3 (Using ZSYTRS)
386 * Solve and compute residual for A * X = B.
387 *
388 SRNAMT = 'ZLARHS'
389 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
390 $ NRHS, A, LDA, XACT, LDA, B, LDA,
391 $ ISEED, INFO )
392 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
393 *
394 SRNAMT = 'ZSYTRS'
395 CALL ZSYTRS( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
396 $ LDA, INFO )
397 *
398 * Check error code from ZSYTRS.
399 *
400 IF( INFO.NE.0 )
401 $ CALL ALAERH( PATH, 'ZSYTRS', INFO, 0, UPLO, N,
402 $ N, -1, -1, NRHS, IMAT, NFAIL,
403 $ NERRS, NOUT )
404 *
405 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
406 CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
407 $ LDA, RWORK, RESULT( 3 ) )
408 *
409 *+ TEST 4 (Using ZSYTRS2)
410 * Solve and compute residual for A * X = B.
411 *
412 SRNAMT = 'ZLARHS'
413 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
414 $ NRHS, A, LDA, XACT, LDA, B, LDA,
415 $ ISEED, INFO )
416 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
417 *
418 SRNAMT = 'ZSYTRS2'
419 CALL ZSYTRS2( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
420 $ LDA, WORK, INFO )
421 *
422 * Check error code from ZSYTRS.
423 *
424 IF( INFO.NE.0 )
425 $ CALL ALAERH( PATH, 'ZSYTRS', INFO, 0, UPLO, N,
426 $ N, -1, -1, NRHS, IMAT, NFAIL,
427 $ NERRS, NOUT )
428 *
429 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
430 CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
431 $ LDA, RWORK, RESULT( 4 ) )
432 *
433 *
434 *+ TEST 5
435 * Check solution from generated exact solution.
436 *
437 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
438 $ RESULT( 5 ) )
439 *
440 *+ TESTS 6, 7, and 8
441 * Use iterative refinement to improve the solution.
442 *
443 SRNAMT = 'ZSYRFS'
444 CALL ZSYRFS( UPLO, N, NRHS, A, LDA, AFAC, LDA,
445 $ IWORK, B, LDA, X, LDA, RWORK,
446 $ RWORK( NRHS+1 ), WORK,
447 $ RWORK( 2*NRHS+1 ), INFO )
448 *
449 * Check error code from ZSYRFS.
450 *
451 IF( INFO.NE.0 )
452 $ CALL ALAERH( PATH, 'ZSYRFS', INFO, 0, UPLO, N,
453 $ N, -1, -1, NRHS, IMAT, NFAIL,
454 $ NERRS, NOUT )
455 *
456 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
457 $ RESULT( 6 ) )
458 CALL ZPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
459 $ XACT, LDA, RWORK, RWORK( NRHS+1 ),
460 $ RESULT( 7 ) )
461 *
462 * Print information about the tests that did not pass
463 * the threshold.
464 *
465 DO 120 K = 3, 8
466 IF( RESULT( K ).GE.THRESH ) THEN
467 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
468 $ CALL ALAHD( NOUT, PATH )
469 WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
470 $ IMAT, K, RESULT( K )
471 NFAIL = NFAIL + 1
472 END IF
473 120 CONTINUE
474 NRUN = NRUN + 5
475 130 CONTINUE
476 *
477 *+ TEST 9
478 * Get an estimate of RCOND = 1/CNDNUM.
479 *
480 140 CONTINUE
481 ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK )
482 SRNAMT = 'ZSYCON'
483 CALL ZSYCON( UPLO, N, AFAC, LDA, IWORK, ANORM, RCOND,
484 $ WORK, INFO )
485 *
486 * Check error code from ZSYCON.
487 *
488 IF( INFO.NE.0 )
489 $ CALL ALAERH( PATH, 'ZSYCON', INFO, 0, UPLO, N, N,
490 $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
491 *
492 RESULT( 9 ) = DGET06( RCOND, RCONDC )
493 *
494 * Print information about the tests that did not pass
495 * the threshold.
496 *
497 IF( RESULT( 9 ).GE.THRESH ) THEN
498 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
499 $ CALL ALAHD( NOUT, PATH )
500 WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 9,
501 $ RESULT( 9 )
502 NFAIL = NFAIL + 1
503 END IF
504 NRUN = NRUN + 1
505 150 CONTINUE
506 160 CONTINUE
507 170 CONTINUE
508 180 CONTINUE
509 *
510 * Print a summary of the results.
511 *
512 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
513 *
514 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
515 $ I2, ', test ', I2, ', ratio =', G12.5 )
516 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
517 $ I2, ', test(', I2, ') =', G12.5 )
518 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
519 $ ', test(', I2, ') =', G12.5 )
520 RETURN
521 *
522 * End of ZCHKSY
523 *
524 END