1 SUBROUTINE ZDRVHE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
2 $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
3 $ 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, NOUT, NRHS
12 DOUBLE PRECISION THRESH
13 * ..
14 * .. Array Arguments ..
15 LOGICAL DOTYPE( * )
16 INTEGER IWORK( * ), NVAL( * )
17 DOUBLE PRECISION RWORK( * )
18 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
19 $ WORK( * ), X( * ), XACT( * )
20 * ..
21 *
22 * Purpose
23 * =======
24 *
25 * ZDRVHE tests the driver routines ZHESV, -SVX, and -SVXX.
26 *
27 * Note that this file is used only when the XBLAS are available,
28 * otherwise zdrvhe.f defines this subroutine.
29 *
30 * Arguments
31 * =========
32 *
33 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
34 * The matrix types to be used for testing. Matrices of type j
35 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
36 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
37 *
38 * NN (input) INTEGER
39 * The number of values of N contained in the vector NVAL.
40 *
41 * NVAL (input) INTEGER array, dimension (NN)
42 * The values of the matrix dimension N.
43 *
44 * NRHS (input) INTEGER
45 * The number of right hand side vectors to be generated for
46 * each linear system.
47 *
48 * THRESH (input) DOUBLE PRECISION
49 * The threshold value for the test ratios. A result is
50 * included in the output file if RESULT >= THRESH. To have
51 * every test ratio printed, use THRESH = 0.
52 *
53 * TSTERR (input) LOGICAL
54 * Flag that indicates whether error exits are to be tested.
55 *
56 * NMAX (input) INTEGER
57 * The maximum value permitted for N, used in dimensioning the
58 * work arrays.
59 *
60 * A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
61 *
62 * AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
63 *
64 * AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
65 *
66 * B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
67 *
68 * X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
69 *
70 * XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
71 *
72 * WORK (workspace) COMPLEX*16 array, dimension
73 * (NMAX*max(2,NRHS))
74 *
75 * RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
76 *
77 * IWORK (workspace) INTEGER array, dimension (NMAX)
78 *
79 * NOUT (input) INTEGER
80 * The unit number for output.
81 *
82 * =====================================================================
83 *
84 * .. Parameters ..
85 DOUBLE PRECISION ONE, ZERO
86 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
87 INTEGER NTYPES, NTESTS
88 PARAMETER ( NTYPES = 10, NTESTS = 6 )
89 INTEGER NFACT
90 PARAMETER ( NFACT = 2 )
91 * ..
92 * .. Local Scalars ..
93 LOGICAL ZEROT
94 CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE
95 CHARACTER*3 PATH
96 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
97 $ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N,
98 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT,
99 $ N_ERR_BNDS
100 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC,
101 $ RPVGRW_SVXX
102 * ..
103 * .. Local Arrays ..
104 CHARACTER FACTS( NFACT ), UPLOS( 2 )
105 INTEGER ISEED( 4 ), ISEEDY( 4 )
106 DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ),
107 $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 )
108 * ..
109 * .. External Functions ..
110 DOUBLE PRECISION DGET06, ZLANHE
111 EXTERNAL DGET06, ZLANHE
112 * ..
113 * .. External Subroutines ..
114 EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04,
115 $ ZHESV, ZHESVX, ZHET01, ZHETRF, ZHETRI2, ZLACPY,
116 $ ZLAIPD, ZLARHS, ZLASET, ZLATB4, ZLATMS, ZPOT02,
117 $ ZPOT05, ZHESVXX
118 * ..
119 * .. Scalars in Common ..
120 LOGICAL LERR, OK
121 CHARACTER*32 SRNAMT
122 INTEGER INFOT, NUNIT
123 * ..
124 * .. Common blocks ..
125 COMMON / INFOC / INFOT, NUNIT, OK, LERR
126 COMMON / SRNAMC / SRNAMT
127 * ..
128 * .. Intrinsic Functions ..
129 INTRINSIC DCMPLX, MAX, MIN
130 * ..
131 * .. Data statements ..
132 DATA ISEEDY / 1988, 1989, 1990, 1991 /
133 DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
134 * ..
135 * .. Executable Statements ..
136 *
137 * Initialize constants and the random number seed.
138 *
139 PATH( 1: 1 ) = 'Z'
140 PATH( 2: 3 ) = 'HE'
141 NRUN = 0
142 NFAIL = 0
143 NERRS = 0
144 DO 10 I = 1, 4
145 ISEED( I ) = ISEEDY( I )
146 10 CONTINUE
147 LWORK = MAX( 2*NMAX, NMAX*NRHS )
148 *
149 * Test the error exits
150 *
151 IF( TSTERR )
152 $ CALL ZERRVX( PATH, NOUT )
153 INFOT = 0
154 *
155 * Set the block size and minimum block size for testing.
156 *
157 NB = 1
158 NBMIN = 2
159 CALL XLAENV( 1, NB )
160 CALL XLAENV( 2, NBMIN )
161 *
162 * Do for each value of N in NVAL
163 *
164 DO 180 IN = 1, NN
165 N = NVAL( IN )
166 LDA = MAX( N, 1 )
167 XTYPE = 'N'
168 NIMAT = NTYPES
169 IF( N.LE.0 )
170 $ NIMAT = 1
171 *
172 DO 170 IMAT = 1, NIMAT
173 *
174 * Do the tests only if DOTYPE( IMAT ) is true.
175 *
176 IF( .NOT.DOTYPE( IMAT ) )
177 $ GO TO 170
178 *
179 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
180 *
181 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
182 IF( ZEROT .AND. N.LT.IMAT-2 )
183 $ GO TO 170
184 *
185 * Do first for UPLO = 'U', then for UPLO = 'L'
186 *
187 DO 160 IUPLO = 1, 2
188 UPLO = UPLOS( IUPLO )
189 *
190 * Set up parameters with ZLATB4 and generate a test matrix
191 * with ZLATMS.
192 *
193 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
194 $ CNDNUM, DIST )
195 *
196 SRNAMT = 'ZLATMS'
197 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
198 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
199 $ INFO )
200 *
201 * Check error code from ZLATMS.
202 *
203 IF( INFO.NE.0 ) THEN
204 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1,
205 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
206 GO TO 160
207 END IF
208 *
209 * For types 3-6, zero one or more rows and columns of the
210 * matrix to test that INFO is returned correctly.
211 *
212 IF( ZEROT ) THEN
213 IF( IMAT.EQ.3 ) THEN
214 IZERO = 1
215 ELSE IF( IMAT.EQ.4 ) THEN
216 IZERO = N
217 ELSE
218 IZERO = N / 2 + 1
219 END IF
220 *
221 IF( IMAT.LT.6 ) THEN
222 *
223 * Set row and column IZERO to zero.
224 *
225 IF( IUPLO.EQ.1 ) THEN
226 IOFF = ( IZERO-1 )*LDA
227 DO 20 I = 1, IZERO - 1
228 A( IOFF+I ) = ZERO
229 20 CONTINUE
230 IOFF = IOFF + IZERO
231 DO 30 I = IZERO, N
232 A( IOFF ) = ZERO
233 IOFF = IOFF + LDA
234 30 CONTINUE
235 ELSE
236 IOFF = IZERO
237 DO 40 I = 1, IZERO - 1
238 A( IOFF ) = ZERO
239 IOFF = IOFF + LDA
240 40 CONTINUE
241 IOFF = IOFF - IZERO
242 DO 50 I = IZERO, N
243 A( IOFF+I ) = ZERO
244 50 CONTINUE
245 END IF
246 ELSE
247 IOFF = 0
248 IF( IUPLO.EQ.1 ) THEN
249 *
250 * Set the first IZERO rows and columns to zero.
251 *
252 DO 70 J = 1, N
253 I2 = MIN( J, IZERO )
254 DO 60 I = 1, I2
255 A( IOFF+I ) = ZERO
256 60 CONTINUE
257 IOFF = IOFF + LDA
258 70 CONTINUE
259 ELSE
260 *
261 * Set the last IZERO rows and columns to zero.
262 *
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 *
276 * Set the imaginary part of the diagonals.
277 *
278 CALL ZLAIPD( N, A, LDA+1, 0 )
279 *
280 DO 150 IFACT = 1, NFACT
281 *
282 * Do first for FACT = 'F', then for other values.
283 *
284 FACT = FACTS( IFACT )
285 *
286 * Compute the condition number for comparison with
287 * the value returned by ZHESVX.
288 *
289 IF( ZEROT ) THEN
290 IF( IFACT.EQ.1 )
291 $ GO TO 150
292 RCONDC = ZERO
293 *
294 ELSE IF( IFACT.EQ.1 ) THEN
295 *
296 * Compute the 1-norm of A.
297 *
298 ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
299 *
300 * Factor the matrix A.
301 *
302 CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
303 CALL ZHETRF( UPLO, N, AFAC, LDA, IWORK, WORK,
304 $ LWORK, INFO )
305 *
306 * Compute inv(A) and take its norm.
307 *
308 CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
309 LWORK = (N+NB+1)*(NB+3)
310 CALL ZHETRI2( UPLO, N, AINV, LDA, IWORK, WORK,
311 $ LWORK, INFO )
312 AINVNM = ZLANHE( '1', UPLO, N, AINV, LDA, RWORK )
313 *
314 * Compute the 1-norm condition number of A.
315 *
316 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
317 RCONDC = ONE
318 ELSE
319 RCONDC = ( ONE / ANORM ) / AINVNM
320 END IF
321 END IF
322 *
323 * Form an exact solution and set the right hand side.
324 *
325 SRNAMT = 'ZLARHS'
326 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
327 $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
328 $ INFO )
329 XTYPE = 'C'
330 *
331 * --- Test ZHESV ---
332 *
333 IF( IFACT.EQ.2 ) THEN
334 CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
335 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
336 *
337 * Factor the matrix and solve the system using ZHESV.
338 *
339 SRNAMT = 'ZHESV '
340 CALL ZHESV( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
341 $ LDA, WORK, LWORK, INFO )
342 *
343 * Adjust the expected value of INFO to account for
344 * pivoting.
345 *
346 K = IZERO
347 IF( K.GT.0 ) THEN
348 100 CONTINUE
349 IF( IWORK( K ).LT.0 ) THEN
350 IF( IWORK( K ).NE.-K ) THEN
351 K = -IWORK( K )
352 GO TO 100
353 END IF
354 ELSE IF( IWORK( K ).NE.K ) THEN
355 K = IWORK( K )
356 GO TO 100
357 END IF
358 END IF
359 *
360 * Check error code from ZHESV .
361 *
362 IF( INFO.NE.K ) THEN
363 CALL ALAERH( PATH, 'ZHESV ', INFO, K, UPLO, N,
364 $ N, -1, -1, NRHS, IMAT, NFAIL,
365 $ NERRS, NOUT )
366 GO TO 120
367 ELSE IF( INFO.NE.0 ) THEN
368 GO TO 120
369 END IF
370 *
371 * Reconstruct matrix from factors and compute
372 * residual.
373 *
374 CALL ZHET01( UPLO, N, A, LDA, AFAC, LDA, IWORK,
375 $ AINV, LDA, RWORK, RESULT( 1 ) )
376 *
377 * Compute residual of the computed solution.
378 *
379 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
380 CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
381 $ LDA, RWORK, RESULT( 2 ) )
382 *
383 * Check solution from generated exact solution.
384 *
385 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
386 $ RESULT( 3 ) )
387 NT = 3
388 *
389 * Print information about the tests that did not pass
390 * the threshold.
391 *
392 DO 110 K = 1, NT
393 IF( RESULT( K ).GE.THRESH ) THEN
394 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
395 $ CALL ALADHD( NOUT, PATH )
396 WRITE( NOUT, FMT = 9999 )'ZHESV ', UPLO, N,
397 $ IMAT, K, RESULT( K )
398 NFAIL = NFAIL + 1
399 END IF
400 110 CONTINUE
401 NRUN = NRUN + NT
402 120 CONTINUE
403 END IF
404 *
405 * --- Test ZHESVX ---
406 *
407 IF( IFACT.EQ.2 )
408 $ CALL ZLASET( UPLO, N, N, DCMPLX( ZERO ),
409 $ DCMPLX( ZERO ), AFAC, LDA )
410 CALL ZLASET( 'Full', N, NRHS, DCMPLX( ZERO ),
411 $ DCMPLX( ZERO ), X, LDA )
412 *
413 * Solve the system and compute the condition number and
414 * error bounds using ZHESVX.
415 *
416 SRNAMT = 'ZHESVX'
417 CALL ZHESVX( FACT, UPLO, N, NRHS, A, LDA, AFAC, LDA,
418 $ IWORK, B, LDA, X, LDA, RCOND, RWORK,
419 $ RWORK( NRHS+1 ), WORK, LWORK,
420 $ RWORK( 2*NRHS+1 ), INFO )
421 *
422 * Adjust the expected value of INFO to account for
423 * pivoting.
424 *
425 K = IZERO
426 IF( K.GT.0 ) THEN
427 130 CONTINUE
428 IF( IWORK( K ).LT.0 ) THEN
429 IF( IWORK( K ).NE.-K ) THEN
430 K = -IWORK( K )
431 GO TO 130
432 END IF
433 ELSE IF( IWORK( K ).NE.K ) THEN
434 K = IWORK( K )
435 GO TO 130
436 END IF
437 END IF
438 *
439 * Check the error code from ZHESVX.
440 *
441 IF( INFO.NE.K ) THEN
442 CALL ALAERH( PATH, 'ZHESVX', INFO, K, FACT // UPLO,
443 $ N, N, -1, -1, NRHS, IMAT, NFAIL,
444 $ NERRS, NOUT )
445 GO TO 150
446 END IF
447 *
448 IF( INFO.EQ.0 ) THEN
449 IF( IFACT.GE.2 ) THEN
450 *
451 * Reconstruct matrix from factors and compute
452 * residual.
453 *
454 CALL ZHET01( UPLO, N, A, LDA, AFAC, LDA, IWORK,
455 $ AINV, LDA, RWORK( 2*NRHS+1 ),
456 $ RESULT( 1 ) )
457 K1 = 1
458 ELSE
459 K1 = 2
460 END IF
461 *
462 * Compute residual of the computed solution.
463 *
464 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
465 CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
466 $ LDA, RWORK( 2*NRHS+1 ), RESULT( 2 ) )
467 *
468 * Check solution from generated exact solution.
469 *
470 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
471 $ RESULT( 3 ) )
472 *
473 * Check the error bounds from iterative refinement.
474 *
475 CALL ZPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
476 $ XACT, LDA, RWORK, RWORK( NRHS+1 ),
477 $ RESULT( 4 ) )
478 ELSE
479 K1 = 6
480 END IF
481 *
482 * Compare RCOND from ZHESVX with the computed value
483 * in RCONDC.
484 *
485 RESULT( 6 ) = DGET06( RCOND, RCONDC )
486 *
487 * Print information about the tests that did not pass
488 * the threshold.
489 *
490 DO 140 K = K1, 6
491 IF( RESULT( K ).GE.THRESH ) THEN
492 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
493 $ CALL ALADHD( NOUT, PATH )
494 WRITE( NOUT, FMT = 9998 )'ZHESVX', FACT, UPLO,
495 $ N, IMAT, K, RESULT( K )
496 NFAIL = NFAIL + 1
497 END IF
498 140 CONTINUE
499 NRUN = NRUN + 7 - K1
500 *
501 * --- Test ZHESVXX ---
502 *
503 * Restore the matrices A and B.
504 *
505 IF( IFACT.EQ.2 )
506 $ CALL ZLASET( UPLO, N, N, CMPLX( ZERO ),
507 $ CMPLX( ZERO ), AFAC, LDA )
508 CALL ZLASET( 'Full', N, NRHS, CMPLX( ZERO ),
509 $ CMPLX( ZERO ), X, LDA )
510 *
511 * Solve the system and compute the condition number
512 * and error bounds using ZHESVXX.
513 *
514 SRNAMT = 'ZHESVXX'
515 N_ERR_BNDS = 3
516 EQUED = 'N'
517 CALL ZHESVXX( FACT, UPLO, N, NRHS, A, LDA, AFAC,
518 $ LDA, IWORK, EQUED, WORK( N+1 ), B, LDA, X,
519 $ LDA, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS,
520 $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK,
521 $ IWORK( N+1 ), INFO )
522 *
523 * Adjust the expected value of INFO to account for
524 * pivoting.
525 *
526 K = IZERO
527 IF( K.GT.0 ) THEN
528 135 CONTINUE
529 IF( IWORK( K ).LT.0 ) THEN
530 IF( IWORK( K ).NE.-K ) THEN
531 K = -IWORK( K )
532 GO TO 135
533 END IF
534 ELSE IF( IWORK( K ).NE.K ) THEN
535 K = IWORK( K )
536 GO TO 135
537 END IF
538 END IF
539 *
540 * Check the error code from ZHESVXX.
541 *
542 IF( INFO.NE.K ) THEN
543 CALL ALAERH( PATH, 'ZHESVXX', INFO, K,
544 $ FACT // UPLO, N, N, -1, -1, NRHS, IMAT, NFAIL,
545 $ NERRS, NOUT )
546 GO TO 150
547 END IF
548 *
549 IF( INFO.EQ.0 ) THEN
550 IF( IFACT.GE.2 ) THEN
551 *
552 * Reconstruct matrix from factors and compute
553 * residual.
554 *
555 CALL ZHET01( UPLO, N, A, LDA, AFAC, LDA, IWORK,
556 $ AINV, LDA, RWORK(2*NRHS+1),
557 $ RESULT( 1 ) )
558 K1 = 1
559 ELSE
560 K1 = 2
561 END IF
562 *
563 * Compute residual of the computed solution.
564 *
565 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
566 CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
567 $ LDA, RWORK( 2*NRHS+1 ), RESULT( 2 ) )
568 RESULT( 2 ) = 0.0
569 *
570 * Check solution from generated exact solution.
571 *
572 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
573 $ RESULT( 3 ) )
574 *
575 * Check the error bounds from iterative refinement.
576 *
577 CALL ZPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
578 $ XACT, LDA, RWORK, RWORK( NRHS+1 ),
579 $ RESULT( 4 ) )
580 ELSE
581 K1 = 6
582 END IF
583 *
584 * Compare RCOND from ZHESVXX with the computed value
585 * in RCONDC.
586 *
587 RESULT( 6 ) = DGET06( RCOND, RCONDC )
588 *
589 * Print information about the tests that did not pass
590 * the threshold.
591 *
592 DO 85 K = K1, 6
593 IF( RESULT( K ).GE.THRESH ) THEN
594 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
595 $ CALL ALADHD( NOUT, PATH )
596 WRITE( NOUT, FMT = 9998 )'ZHESVXX',
597 $ FACT, UPLO, N, IMAT, K,
598 $ RESULT( K )
599 NFAIL = NFAIL + 1
600 END IF
601 85 CONTINUE
602 NRUN = NRUN + 7 - K1
603 *
604 150 CONTINUE
605 *
606 160 CONTINUE
607 170 CONTINUE
608 180 CONTINUE
609 *
610 * Print a summary of the results.
611 *
612 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
613 *
614
615 * Test Error Bounds from ZHESVXX
616
617 CALL ZEBCHVXX(THRESH, PATH)
618
619 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
620 $ ', test ', I2, ', ratio =', G12.5 )
621 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
622 $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
623 RETURN
624 *
625 * End of ZDRVHE
626 *
627 END
2 $ A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
3 $ 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, NOUT, NRHS
12 DOUBLE PRECISION THRESH
13 * ..
14 * .. Array Arguments ..
15 LOGICAL DOTYPE( * )
16 INTEGER IWORK( * ), NVAL( * )
17 DOUBLE PRECISION RWORK( * )
18 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
19 $ WORK( * ), X( * ), XACT( * )
20 * ..
21 *
22 * Purpose
23 * =======
24 *
25 * ZDRVHE tests the driver routines ZHESV, -SVX, and -SVXX.
26 *
27 * Note that this file is used only when the XBLAS are available,
28 * otherwise zdrvhe.f defines this subroutine.
29 *
30 * Arguments
31 * =========
32 *
33 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
34 * The matrix types to be used for testing. Matrices of type j
35 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
36 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
37 *
38 * NN (input) INTEGER
39 * The number of values of N contained in the vector NVAL.
40 *
41 * NVAL (input) INTEGER array, dimension (NN)
42 * The values of the matrix dimension N.
43 *
44 * NRHS (input) INTEGER
45 * The number of right hand side vectors to be generated for
46 * each linear system.
47 *
48 * THRESH (input) DOUBLE PRECISION
49 * The threshold value for the test ratios. A result is
50 * included in the output file if RESULT >= THRESH. To have
51 * every test ratio printed, use THRESH = 0.
52 *
53 * TSTERR (input) LOGICAL
54 * Flag that indicates whether error exits are to be tested.
55 *
56 * NMAX (input) INTEGER
57 * The maximum value permitted for N, used in dimensioning the
58 * work arrays.
59 *
60 * A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
61 *
62 * AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
63 *
64 * AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX)
65 *
66 * B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
67 *
68 * X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
69 *
70 * XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS)
71 *
72 * WORK (workspace) COMPLEX*16 array, dimension
73 * (NMAX*max(2,NRHS))
74 *
75 * RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
76 *
77 * IWORK (workspace) INTEGER array, dimension (NMAX)
78 *
79 * NOUT (input) INTEGER
80 * The unit number for output.
81 *
82 * =====================================================================
83 *
84 * .. Parameters ..
85 DOUBLE PRECISION ONE, ZERO
86 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
87 INTEGER NTYPES, NTESTS
88 PARAMETER ( NTYPES = 10, NTESTS = 6 )
89 INTEGER NFACT
90 PARAMETER ( NFACT = 2 )
91 * ..
92 * .. Local Scalars ..
93 LOGICAL ZEROT
94 CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE
95 CHARACTER*3 PATH
96 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
97 $ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N,
98 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT,
99 $ N_ERR_BNDS
100 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC,
101 $ RPVGRW_SVXX
102 * ..
103 * .. Local Arrays ..
104 CHARACTER FACTS( NFACT ), UPLOS( 2 )
105 INTEGER ISEED( 4 ), ISEEDY( 4 )
106 DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ),
107 $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 )
108 * ..
109 * .. External Functions ..
110 DOUBLE PRECISION DGET06, ZLANHE
111 EXTERNAL DGET06, ZLANHE
112 * ..
113 * .. External Subroutines ..
114 EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04,
115 $ ZHESV, ZHESVX, ZHET01, ZHETRF, ZHETRI2, ZLACPY,
116 $ ZLAIPD, ZLARHS, ZLASET, ZLATB4, ZLATMS, ZPOT02,
117 $ ZPOT05, ZHESVXX
118 * ..
119 * .. Scalars in Common ..
120 LOGICAL LERR, OK
121 CHARACTER*32 SRNAMT
122 INTEGER INFOT, NUNIT
123 * ..
124 * .. Common blocks ..
125 COMMON / INFOC / INFOT, NUNIT, OK, LERR
126 COMMON / SRNAMC / SRNAMT
127 * ..
128 * .. Intrinsic Functions ..
129 INTRINSIC DCMPLX, MAX, MIN
130 * ..
131 * .. Data statements ..
132 DATA ISEEDY / 1988, 1989, 1990, 1991 /
133 DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
134 * ..
135 * .. Executable Statements ..
136 *
137 * Initialize constants and the random number seed.
138 *
139 PATH( 1: 1 ) = 'Z'
140 PATH( 2: 3 ) = 'HE'
141 NRUN = 0
142 NFAIL = 0
143 NERRS = 0
144 DO 10 I = 1, 4
145 ISEED( I ) = ISEEDY( I )
146 10 CONTINUE
147 LWORK = MAX( 2*NMAX, NMAX*NRHS )
148 *
149 * Test the error exits
150 *
151 IF( TSTERR )
152 $ CALL ZERRVX( PATH, NOUT )
153 INFOT = 0
154 *
155 * Set the block size and minimum block size for testing.
156 *
157 NB = 1
158 NBMIN = 2
159 CALL XLAENV( 1, NB )
160 CALL XLAENV( 2, NBMIN )
161 *
162 * Do for each value of N in NVAL
163 *
164 DO 180 IN = 1, NN
165 N = NVAL( IN )
166 LDA = MAX( N, 1 )
167 XTYPE = 'N'
168 NIMAT = NTYPES
169 IF( N.LE.0 )
170 $ NIMAT = 1
171 *
172 DO 170 IMAT = 1, NIMAT
173 *
174 * Do the tests only if DOTYPE( IMAT ) is true.
175 *
176 IF( .NOT.DOTYPE( IMAT ) )
177 $ GO TO 170
178 *
179 * Skip types 3, 4, 5, or 6 if the matrix size is too small.
180 *
181 ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
182 IF( ZEROT .AND. N.LT.IMAT-2 )
183 $ GO TO 170
184 *
185 * Do first for UPLO = 'U', then for UPLO = 'L'
186 *
187 DO 160 IUPLO = 1, 2
188 UPLO = UPLOS( IUPLO )
189 *
190 * Set up parameters with ZLATB4 and generate a test matrix
191 * with ZLATMS.
192 *
193 CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
194 $ CNDNUM, DIST )
195 *
196 SRNAMT = 'ZLATMS'
197 CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
198 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
199 $ INFO )
200 *
201 * Check error code from ZLATMS.
202 *
203 IF( INFO.NE.0 ) THEN
204 CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1,
205 $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
206 GO TO 160
207 END IF
208 *
209 * For types 3-6, zero one or more rows and columns of the
210 * matrix to test that INFO is returned correctly.
211 *
212 IF( ZEROT ) THEN
213 IF( IMAT.EQ.3 ) THEN
214 IZERO = 1
215 ELSE IF( IMAT.EQ.4 ) THEN
216 IZERO = N
217 ELSE
218 IZERO = N / 2 + 1
219 END IF
220 *
221 IF( IMAT.LT.6 ) THEN
222 *
223 * Set row and column IZERO to zero.
224 *
225 IF( IUPLO.EQ.1 ) THEN
226 IOFF = ( IZERO-1 )*LDA
227 DO 20 I = 1, IZERO - 1
228 A( IOFF+I ) = ZERO
229 20 CONTINUE
230 IOFF = IOFF + IZERO
231 DO 30 I = IZERO, N
232 A( IOFF ) = ZERO
233 IOFF = IOFF + LDA
234 30 CONTINUE
235 ELSE
236 IOFF = IZERO
237 DO 40 I = 1, IZERO - 1
238 A( IOFF ) = ZERO
239 IOFF = IOFF + LDA
240 40 CONTINUE
241 IOFF = IOFF - IZERO
242 DO 50 I = IZERO, N
243 A( IOFF+I ) = ZERO
244 50 CONTINUE
245 END IF
246 ELSE
247 IOFF = 0
248 IF( IUPLO.EQ.1 ) THEN
249 *
250 * Set the first IZERO rows and columns to zero.
251 *
252 DO 70 J = 1, N
253 I2 = MIN( J, IZERO )
254 DO 60 I = 1, I2
255 A( IOFF+I ) = ZERO
256 60 CONTINUE
257 IOFF = IOFF + LDA
258 70 CONTINUE
259 ELSE
260 *
261 * Set the last IZERO rows and columns to zero.
262 *
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 *
276 * Set the imaginary part of the diagonals.
277 *
278 CALL ZLAIPD( N, A, LDA+1, 0 )
279 *
280 DO 150 IFACT = 1, NFACT
281 *
282 * Do first for FACT = 'F', then for other values.
283 *
284 FACT = FACTS( IFACT )
285 *
286 * Compute the condition number for comparison with
287 * the value returned by ZHESVX.
288 *
289 IF( ZEROT ) THEN
290 IF( IFACT.EQ.1 )
291 $ GO TO 150
292 RCONDC = ZERO
293 *
294 ELSE IF( IFACT.EQ.1 ) THEN
295 *
296 * Compute the 1-norm of A.
297 *
298 ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
299 *
300 * Factor the matrix A.
301 *
302 CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
303 CALL ZHETRF( UPLO, N, AFAC, LDA, IWORK, WORK,
304 $ LWORK, INFO )
305 *
306 * Compute inv(A) and take its norm.
307 *
308 CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
309 LWORK = (N+NB+1)*(NB+3)
310 CALL ZHETRI2( UPLO, N, AINV, LDA, IWORK, WORK,
311 $ LWORK, INFO )
312 AINVNM = ZLANHE( '1', UPLO, N, AINV, LDA, RWORK )
313 *
314 * Compute the 1-norm condition number of A.
315 *
316 IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
317 RCONDC = ONE
318 ELSE
319 RCONDC = ( ONE / ANORM ) / AINVNM
320 END IF
321 END IF
322 *
323 * Form an exact solution and set the right hand side.
324 *
325 SRNAMT = 'ZLARHS'
326 CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
327 $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
328 $ INFO )
329 XTYPE = 'C'
330 *
331 * --- Test ZHESV ---
332 *
333 IF( IFACT.EQ.2 ) THEN
334 CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
335 CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
336 *
337 * Factor the matrix and solve the system using ZHESV.
338 *
339 SRNAMT = 'ZHESV '
340 CALL ZHESV( UPLO, N, NRHS, AFAC, LDA, IWORK, X,
341 $ LDA, WORK, LWORK, INFO )
342 *
343 * Adjust the expected value of INFO to account for
344 * pivoting.
345 *
346 K = IZERO
347 IF( K.GT.0 ) THEN
348 100 CONTINUE
349 IF( IWORK( K ).LT.0 ) THEN
350 IF( IWORK( K ).NE.-K ) THEN
351 K = -IWORK( K )
352 GO TO 100
353 END IF
354 ELSE IF( IWORK( K ).NE.K ) THEN
355 K = IWORK( K )
356 GO TO 100
357 END IF
358 END IF
359 *
360 * Check error code from ZHESV .
361 *
362 IF( INFO.NE.K ) THEN
363 CALL ALAERH( PATH, 'ZHESV ', INFO, K, UPLO, N,
364 $ N, -1, -1, NRHS, IMAT, NFAIL,
365 $ NERRS, NOUT )
366 GO TO 120
367 ELSE IF( INFO.NE.0 ) THEN
368 GO TO 120
369 END IF
370 *
371 * Reconstruct matrix from factors and compute
372 * residual.
373 *
374 CALL ZHET01( UPLO, N, A, LDA, AFAC, LDA, IWORK,
375 $ AINV, LDA, RWORK, RESULT( 1 ) )
376 *
377 * Compute residual of the computed solution.
378 *
379 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
380 CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
381 $ LDA, RWORK, RESULT( 2 ) )
382 *
383 * Check solution from generated exact solution.
384 *
385 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
386 $ RESULT( 3 ) )
387 NT = 3
388 *
389 * Print information about the tests that did not pass
390 * the threshold.
391 *
392 DO 110 K = 1, NT
393 IF( RESULT( K ).GE.THRESH ) THEN
394 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
395 $ CALL ALADHD( NOUT, PATH )
396 WRITE( NOUT, FMT = 9999 )'ZHESV ', UPLO, N,
397 $ IMAT, K, RESULT( K )
398 NFAIL = NFAIL + 1
399 END IF
400 110 CONTINUE
401 NRUN = NRUN + NT
402 120 CONTINUE
403 END IF
404 *
405 * --- Test ZHESVX ---
406 *
407 IF( IFACT.EQ.2 )
408 $ CALL ZLASET( UPLO, N, N, DCMPLX( ZERO ),
409 $ DCMPLX( ZERO ), AFAC, LDA )
410 CALL ZLASET( 'Full', N, NRHS, DCMPLX( ZERO ),
411 $ DCMPLX( ZERO ), X, LDA )
412 *
413 * Solve the system and compute the condition number and
414 * error bounds using ZHESVX.
415 *
416 SRNAMT = 'ZHESVX'
417 CALL ZHESVX( FACT, UPLO, N, NRHS, A, LDA, AFAC, LDA,
418 $ IWORK, B, LDA, X, LDA, RCOND, RWORK,
419 $ RWORK( NRHS+1 ), WORK, LWORK,
420 $ RWORK( 2*NRHS+1 ), INFO )
421 *
422 * Adjust the expected value of INFO to account for
423 * pivoting.
424 *
425 K = IZERO
426 IF( K.GT.0 ) THEN
427 130 CONTINUE
428 IF( IWORK( K ).LT.0 ) THEN
429 IF( IWORK( K ).NE.-K ) THEN
430 K = -IWORK( K )
431 GO TO 130
432 END IF
433 ELSE IF( IWORK( K ).NE.K ) THEN
434 K = IWORK( K )
435 GO TO 130
436 END IF
437 END IF
438 *
439 * Check the error code from ZHESVX.
440 *
441 IF( INFO.NE.K ) THEN
442 CALL ALAERH( PATH, 'ZHESVX', INFO, K, FACT // UPLO,
443 $ N, N, -1, -1, NRHS, IMAT, NFAIL,
444 $ NERRS, NOUT )
445 GO TO 150
446 END IF
447 *
448 IF( INFO.EQ.0 ) THEN
449 IF( IFACT.GE.2 ) THEN
450 *
451 * Reconstruct matrix from factors and compute
452 * residual.
453 *
454 CALL ZHET01( UPLO, N, A, LDA, AFAC, LDA, IWORK,
455 $ AINV, LDA, RWORK( 2*NRHS+1 ),
456 $ RESULT( 1 ) )
457 K1 = 1
458 ELSE
459 K1 = 2
460 END IF
461 *
462 * Compute residual of the computed solution.
463 *
464 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
465 CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
466 $ LDA, RWORK( 2*NRHS+1 ), RESULT( 2 ) )
467 *
468 * Check solution from generated exact solution.
469 *
470 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
471 $ RESULT( 3 ) )
472 *
473 * Check the error bounds from iterative refinement.
474 *
475 CALL ZPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
476 $ XACT, LDA, RWORK, RWORK( NRHS+1 ),
477 $ RESULT( 4 ) )
478 ELSE
479 K1 = 6
480 END IF
481 *
482 * Compare RCOND from ZHESVX with the computed value
483 * in RCONDC.
484 *
485 RESULT( 6 ) = DGET06( RCOND, RCONDC )
486 *
487 * Print information about the tests that did not pass
488 * the threshold.
489 *
490 DO 140 K = K1, 6
491 IF( RESULT( K ).GE.THRESH ) THEN
492 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
493 $ CALL ALADHD( NOUT, PATH )
494 WRITE( NOUT, FMT = 9998 )'ZHESVX', FACT, UPLO,
495 $ N, IMAT, K, RESULT( K )
496 NFAIL = NFAIL + 1
497 END IF
498 140 CONTINUE
499 NRUN = NRUN + 7 - K1
500 *
501 * --- Test ZHESVXX ---
502 *
503 * Restore the matrices A and B.
504 *
505 IF( IFACT.EQ.2 )
506 $ CALL ZLASET( UPLO, N, N, CMPLX( ZERO ),
507 $ CMPLX( ZERO ), AFAC, LDA )
508 CALL ZLASET( 'Full', N, NRHS, CMPLX( ZERO ),
509 $ CMPLX( ZERO ), X, LDA )
510 *
511 * Solve the system and compute the condition number
512 * and error bounds using ZHESVXX.
513 *
514 SRNAMT = 'ZHESVXX'
515 N_ERR_BNDS = 3
516 EQUED = 'N'
517 CALL ZHESVXX( FACT, UPLO, N, NRHS, A, LDA, AFAC,
518 $ LDA, IWORK, EQUED, WORK( N+1 ), B, LDA, X,
519 $ LDA, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS,
520 $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK,
521 $ IWORK( N+1 ), INFO )
522 *
523 * Adjust the expected value of INFO to account for
524 * pivoting.
525 *
526 K = IZERO
527 IF( K.GT.0 ) THEN
528 135 CONTINUE
529 IF( IWORK( K ).LT.0 ) THEN
530 IF( IWORK( K ).NE.-K ) THEN
531 K = -IWORK( K )
532 GO TO 135
533 END IF
534 ELSE IF( IWORK( K ).NE.K ) THEN
535 K = IWORK( K )
536 GO TO 135
537 END IF
538 END IF
539 *
540 * Check the error code from ZHESVXX.
541 *
542 IF( INFO.NE.K ) THEN
543 CALL ALAERH( PATH, 'ZHESVXX', INFO, K,
544 $ FACT // UPLO, N, N, -1, -1, NRHS, IMAT, NFAIL,
545 $ NERRS, NOUT )
546 GO TO 150
547 END IF
548 *
549 IF( INFO.EQ.0 ) THEN
550 IF( IFACT.GE.2 ) THEN
551 *
552 * Reconstruct matrix from factors and compute
553 * residual.
554 *
555 CALL ZHET01( UPLO, N, A, LDA, AFAC, LDA, IWORK,
556 $ AINV, LDA, RWORK(2*NRHS+1),
557 $ RESULT( 1 ) )
558 K1 = 1
559 ELSE
560 K1 = 2
561 END IF
562 *
563 * Compute residual of the computed solution.
564 *
565 CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
566 CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
567 $ LDA, RWORK( 2*NRHS+1 ), RESULT( 2 ) )
568 RESULT( 2 ) = 0.0
569 *
570 * Check solution from generated exact solution.
571 *
572 CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
573 $ RESULT( 3 ) )
574 *
575 * Check the error bounds from iterative refinement.
576 *
577 CALL ZPOT05( UPLO, N, NRHS, A, LDA, B, LDA, X, LDA,
578 $ XACT, LDA, RWORK, RWORK( NRHS+1 ),
579 $ RESULT( 4 ) )
580 ELSE
581 K1 = 6
582 END IF
583 *
584 * Compare RCOND from ZHESVXX with the computed value
585 * in RCONDC.
586 *
587 RESULT( 6 ) = DGET06( RCOND, RCONDC )
588 *
589 * Print information about the tests that did not pass
590 * the threshold.
591 *
592 DO 85 K = K1, 6
593 IF( RESULT( K ).GE.THRESH ) THEN
594 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
595 $ CALL ALADHD( NOUT, PATH )
596 WRITE( NOUT, FMT = 9998 )'ZHESVXX',
597 $ FACT, UPLO, N, IMAT, K,
598 $ RESULT( K )
599 NFAIL = NFAIL + 1
600 END IF
601 85 CONTINUE
602 NRUN = NRUN + 7 - K1
603 *
604 150 CONTINUE
605 *
606 160 CONTINUE
607 170 CONTINUE
608 180 CONTINUE
609 *
610 * Print a summary of the results.
611 *
612 CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
613 *
614
615 * Test Error Bounds from ZHESVXX
616
617 CALL ZEBCHVXX(THRESH, PATH)
618
619 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
620 $ ', test ', I2, ', ratio =', G12.5 )
621 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
622 $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 )
623 RETURN
624 *
625 * End of ZDRVHE
626 *
627 END