1SUBROUTINE CHEEVX_F95( A, W, JOBZ, UPLO, VL, VU, IL, IU, &
2                       M, IFAIL, ABSTOL, INFO )
3!
4!  -- LAPACK95 interface driver routine (version 3.0) --
5!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
6!     September, 2000
7!
8!  .. USE STATEMENTS ..
9   USE LA_PRECISION, ONLY: WP => SP
10   USE LA_AUXMOD, ONLY: ERINFO, LSAME
11   USE F77_LAPACK, ONLY: HEEVX_F77 => LA_HEEVX, ILAENV_F77 => ILAENV
12!  .. IMPLICIT STATEMENT ..
13   IMPLICIT NONE
14!  .. CHARACTER ARGUMENTS ..
15   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: JOBZ, UPLO
16!  .. SCALAR ARGUMENTS ..
17   INTEGER, INTENT(IN), OPTIONAL :: IL, IU
18   INTEGER, INTENT(OUT), OPTIONAL :: INFO, M
19   REAL(WP), INTENT(IN), OPTIONAL :: ABSTOL, VL, VU
20!  .. ARRAY ARGUMENTS ..
21   INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IFAIL(:)
22   COMPLEX(WP), INTENT(INOUT) :: A(:,:)
23   REAL(WP), INTENT(OUT) :: W(:)
24!----------------------------------------------------------------------
25!
26! Purpose
27! =======
28!
29!      LA_SYEVX / LA_HEEVX compute selected eigenvalues and, optionally,
30! the corresponding eigenvectors of a real symmetric/complex Hermitian
31! matrix A. Eigenvalues and eigenvectors can be selected by specifying
32! either a range of values or a range of indices for the desired
33! eigenvalues.
34!
35! =========
36!
37!         SUBROUTINE LA_SYEVX / LA_HEEVX ( A, W, JOBZ=jobz, UPLO=uplo, &
38!                        VL=vl, VU=vu, IL=il, IU=iu, M=m, IFAIL=ifail, &
39!                        ABSTOL=abstol, INFO=info )
40!              <type>(<wp>), INTENT(INOUT) :: A(:,:)
41!              REAL(<wp>), INTENT(OUT) :: W(:)
42!              CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: JOBZ, UPLO
43!              REAL(<wp>), INTENT(IN), OPTIONAL :: VL, VU
44!              INTEGER, INTENT(IN), OPTIONAL :: IL, IU
45!              INTEGER, INTENT(OUT), OPTIONAL :: M
46!              INTEGER, INTENT(OUT), OPTIONAL :: IFAIL(:)
47!              REAL(<wp>), INTENT(IN), OPTIONAL :: ABSTOL
48!              INTEGER, INTENT(OUT), OPTIONAL :: INFO
49!         where
50!              <type> ::= REAL | COMPLEX
51!              <wp> ::= KIND(1.0) | KIND(1.0D0)
52!
53! Arguments
54! =========
55!
56! A      (input/output) REAL or COMPLEX square array, shape (:,:).
57!        On entry, the matrix A.
58!        If UPLO = 'U', the upper triangular part of A contains the upper
59!        triangular part of the matrix A. If UPLO = 'L', the lower
60!        triangular part of A contains the lower triangular part of the
61!        matrix A.
62!        On exit:
63!        If JOBZ = 'V', then the first M columns of A contain the
64!        orthonormal eigenvectors of the matrix A corresponding to the
65!        selected eigenvalues, with the i-th column of A containing the
66!        eigenvector associated with the eigenvalue in W(i) . If an
67!        eigenvector fails to converge, then that column of A contains the
68!        latest approximation to the eigenvector and the index of the
69!        eigenvector is returned in IFAIL.
70!        If JOBZ = 'N', then the upper triangle (if UPLO = 'U') or the
71!        lower triangle (if UPLO = 'L') of A, including the diagonal, is
72!        destroyed.
73! W      (output) REAL array, shape (:) with size(W) = size(A,1).
74!        The first M elements contain the selected eigenvalues in
75!        ascending order.
76! JOBZ   Optional (input) CHARACTER(LEN=1).
77!        = 'N': Computes eigenvalues only;
78!        = 'V': Computes eigenvalues and eigenvectors.
79!        Default value: 'N'.
80! UPLO   Optional (input) CHARACTER(LEN=1).
81!        = 'U': Upper triangle of A is stored;
82!        = 'L': Lower triangle of A is stored.
83!        Default value: 'U'.
84! VL,VU  Optional (input) REAL.
85!        The lower and upper bounds of the interval to be searched for
86!        eigenvalues. VL < VU.
87!        Default values: VL = -HUGE(<wp>) and VU = HUGE(<wp>), where
88!        <wp> ::= KIND(1.0) | KIND(1.0D0).
89!        Note: Neither VL nor VU may be present if IL and/or IU is
90!        present.
91! IL,IU  Optional (input) INTEGER.
92!        The indices of the smallest and largest eigenvalues to be
93!        returned. The IL-th through IU-th eigenvalues will be found.
94!        1 <= IL <= IU <= size(A,1).
95!        Default values: IL = 1 and IU = size(A,1).
96!        Note: Neither IL nor IU may be present if VL and/or VU is
97!        present.
98!        Note: All eigenvalues are calculated if none of the arguments
99!        VL, VU, IL and IU are present.
100! M      Optional (output) INTEGER.
101!        The total number of eigenvalues found. 0 <= M <= size(A,1).
102!        Note: If IL and IU are present then M = IU-IL+1.
103! IFAIL  Optional (output) INTEGER array, shape (:) with size(IFAIL) =
104!        size(A,1).
105!        If INFO = 0, the first M elements of IFAIL are zero.
106!        If INFO > 0, then IFAIL contains the indices of the eigenvectors
107!        that failed to converge.
108!        Note: IFAIL must be absent if JOBZ = 'N'.
109! ABSTOL Optional (input) REAL.
110!        The absolute error tolerance for the eigenvalues. An approximate
111!        eigenvalue is accepted as converged when it is determined to lie
112!        in an interval [a,b] of width less than or equal to
113!        ABSTOL + EPSILON(1.0_<wp>) * max(|a|,|b|),
114!        where <wp> is the working precision. If ABSTOL<= 0, then
115!        EPSILON(1.0_<wp>)*||T||1 will be used in its place, where ||T||1
116!        is the l1 norm of the tridiagonal matrix obtained by reducing A
117!        to tridiagonal form. Eigenvalues will be computed most accurately
118!        when ABSTOL is set to twice the underflow threshold
119!        2 * LA_LAMCH(1.0_<wp>, 'Safe minimum'), not zero.
120!        Default value: 0.0_<wp>.
121!        Note: If this routine returns with INFO > 0, then some
122!        eigenvectors did not converge. Try setting ABSTOL to
123!        2 * LA_LAMCH(1.0_<wp>, 'Safe minimum').
124! INFO   Optional (output) INTEGER.
125!        = 0: successful exit.
126!        < 0: if INFO = -i, the i-th argument had an illegal value.
127!        > 0: if INFO = i, then i eigenvectors failed to converge. Their
128!        indices are stored in array IFAIL.
129!        If INFO is not present and an error occurs, then the program is
130!        terminated with an error message.
131!----------------------------------------------------------------------
132!  .. LOCAL PARAMETERS ..
133   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_HEEVX'
134   CHARACTER(LEN=6), PARAMETER :: BSNAME = 'CHETRD'
135!  .. LOCAL SCALARS ..
136   CHARACTER(LEN=1) :: LJOBZ, LUPLO, LRANGE
137   INTEGER :: N, LINFO, LD, LDZ, LZ, LIL, LIU, LM, LWORK, NB, ISTAT, &
138              SIFAIL
139   INTEGER, TARGET :: ISTAT1(1)
140   REAL(WP) :: LABSTOL, LVL, LVU
141!  .. LOCAL ARRAYS ..
142   INTEGER, POINTER :: IWORK(:), LIFAIL(:)
143   COMPLEX(WP), POINTER :: WORK(:), Z(:,:)
144   REAL(WP), POINTER :: RWORK(:)
145   COMPLEX(WP) :: WORKMIN(1)
146!  .. INTRINSIC FUNCTIONS ..
147   INTRINSIC HUGE, PRESENT, SIZE
148!  .. EXECUTABLE STATEMENTS ..
149   N = SIZE(A,1); LD = MAX(1,N); LINFO = 0; ISTAT = 0
150   IF( PRESENT(JOBZ) )THEN; LJOBZ = JOBZ; ELSE; LJOBZ = 'N'; ENDIF
151   IF( PRESENT(M)) M=0
152   IF( PRESENT(IFAIL) )THEN
153      SIFAIL = SIZE(IFAIL)
154   ELSE
155      SIFAIL = N
156   END IF
157   IF( PRESENT(UPLO) ) THEN
158      LUPLO = UPLO
159   ELSE
160      LUPLO = 'U'
161   END IF
162   IF( PRESENT(VL) )THEN
163      LVL = VL
164   ELSE
165      LVL = -HUGE(LVL)
166   ENDIF
167   IF( PRESENT(VU) )THEN
168      LVU = VU
169   ELSE
170      LVU = HUGE(LVU)
171   ENDIF
172   IF( PRESENT(IL) )THEN
173      LIL = IL
174   ELSE
175      LIL = 1
176   ENDIF
177   IF( PRESENT(IU) )THEN
178      LIU = IU
179   ELSE
180      LIU = N
181   ENDIF
182!  .. TEST THE ARGUMENTS
183   IF( SIZE( A, 2 ) /= N .OR. N < 0 )THEN
184      LINFO = -1
185   ELSE IF( SIZE( W ) /= N )THEN
186      LINFO = -2
187   ELSE IF( .NOT.LSAME(LJOBZ,'N') .AND. .NOT.LSAME(LJOBZ,'V') )THEN
188      LINFO = -3
189   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN
190      LINFO = -4
191   ELSE IF( LVU < LVL )THEN
192      LINFO = -5
193   ELSE IF( (PRESENT(VL) .OR. PRESENT(VU)) .AND. &
194            (PRESENT(IL) .OR. PRESENT(IU)) )THEN
195      LINFO = -6
196   ELSE IF(( LIU < LIL .OR. LIL < 1) .AND. N>0  )THEN
197      LINFO = -7
198   ELSE IF( N < LIU )THEN
199      LINFO = -8
200   ELSE IF( SIFAIL /= N .OR. PRESENT(IFAIL).AND.LSAME(LJOBZ,'N') )THEN
201          LINFO = -10
202   ELSE IF( N > 0 )THEN
203      IF( PRESENT(VL) .OR. PRESENT(VU) )THEN
204         LRANGE = 'V'
205         LM = N
206      ELSE IF( PRESENT(IL) .OR. PRESENT(IU) )THEN
207         LRANGE = 'I'
208         LM = LIU-LIL+1
209      ELSE
210         LRANGE = 'A'
211         LM = N
212      END IF
213      IF ( LSAME(LJOBZ,'V') ) THEN
214         LDZ = N
215         LZ = LM
216      ELSE
217         LDZ = 1
218         LZ = 1
219      ENDIF
220      IF( PRESENT(IFAIL) )THEN;
221         LIFAIL => IFAIL
222      ELSE
223         LIFAIL => ISTAT1
224      ENDIF
225!     .. DETERMINE THE WORKSPACE
226      NB = ILAENV_F77( 1, BSNAME, LUPLO, N, -1, -1, -1 )
227      IF( NB < 5 .OR. NB >= N )THEN
228         NB = 5
229      END IF
230      LWORK = N*(3+NB)
231      ALLOCATE(IWORK(5*N),RWORK(7*N),Z(LDZ,LM), STAT=ISTAT)
232      IF( ISTAT /= 0 )THEN
233         DEALLOCATE(IWORK, RWORK, Z, STAT=ISTAT1(1))
234         ALLOCATE(IWORK(5*N), RWORK(7*N), Z(LDZ,LM), STAT=ISTAT)
235         IF( ISTAT /= 0 ) THEN
236            LINFO = - 100
237         ELSE
238            CALL ERINFO( -200, SRNAME, LINFO )
239         ENDIF
240      END IF
241      IF( LINFO == 0 )THEN
242       LWORK = -1
243       CALL HEEVX_F77( LJOBZ, LRANGE, LUPLO, N, A, LD, LVL, LVU, &
244     &         LIL, LIU, LABSTOL, LM, W, Z, LDZ, WORKMIN, &
245     &         LWORK, RWORK, IWORK, LIFAIL, LINFO )
246       LWORK = WORKMIN(1)
247       ALLOCATE (WORK(LWORK), STAT = ISTAT)
248       IF  (ISTAT == 0) THEN
249         IF( PRESENT(ABSTOL) )THEN
250            LABSTOL = ABSTOL
251         ELSE
252            LABSTOL = 0.0_WP
253         ENDIF
254!     .. CALL LAPACK77 ROUTINE
255         CALL HEEVX_F77( LJOBZ, LRANGE, LUPLO, N, A, LD, LVL, LVU, &
256                         LIL, LIU, LABSTOL, LM, W, Z, LDZ, WORK, &
257                         LWORK, RWORK, IWORK, LIFAIL, LINFO )
258         IF( LSAME(LJOBZ,'V') ) A(1:LDZ,1:LM) = Z(1:LDZ,1:LM)
259         IF( PRESENT(M) ) M = LM
260         W(LM+1:N) = 0.0_WP
261      END IF
262      ENDIF
263      DEALLOCATE(IWORK, Z, RWORK, STAT=ISTAT1(1))
264      DEALLOCATE (WORK)
265   END IF
266   CALL ERINFO(LINFO, SRNAME, INFO, ISTAT)
267END SUBROUTINE CHEEVX_F95
268