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