1SUBROUTINE DSPEVD_F95( A, W, UPLO, Z, INFO )
2!
3!  -- LAPACK95 interface driver routine (version 3.0) --
4!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
5!     September, 2000
6!
7!  .. USE STATEMENTS ..
8   USE LA_PRECISION, ONLY: WP => DP
9   USE LA_AUXMOD, ONLY: ERINFO, LSAME
10   USE F77_LAPACK, ONLY: SPEVD_F77 => LA_SPEVD
11!  .. IMPLICIT STATEMENT ..
12   IMPLICIT NONE
13!  .. CHARACTER ARGUMENTS ..
14   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
15!  .. SCALAR ARGUMENTS ..
16   INTEGER, INTENT(OUT), OPTIONAL :: INFO
17!  .. ARRAY ARGUMENTS ..
18   REAL(WP), INTENT(INOUT) :: A(:)
19   REAL(WP), INTENT(OUT) :: W(:)
20   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: Z(:,:)
21!----------------------------------------------------------------------
22!
23! Purpose
24! =======
25!
26!     LA_SPEV and LA_SPEVD compute all eigenvalues and, optionally, all
27! eigenvectors of a real symmetric matrix A in packed storage.
28!     LA_HPEV and LA_HPEVD compute all eigenvalues and, optionally, all
29! eigenvectors of a complex Hermitian matrix A in packed storage.
30!     LA_SPEVD and LA_HPEVD use a divide and conquer algorithm. If
31! eigenvectors are desired, they can be much faster than LA_SPEV and
32! LA_HPEV for large matrices but use more workspace.
33!
34! =========
35!
36!       SUBROUTINE LA_SPEV / LA_HPEV / LA_SPEVD / LA_HPEVD( AP, W, &
37!                     UPLO=uplo, Z=z, INFO=info )
38!           <type>(<wp>), INTENT(INOUT) :: AP(:)
39!           REAL(<wp>), INTENT(OUT) :: W(:)
40!           CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
41!           <type>(<wp>), INTENT(OUT), OPTIONAL :: Z(:,:)
42!           INTEGER, INTENT(OUT), OPTIONAL :: INFO
43!       where
44!           <type> ::= REAL | COMPLEX
45!           <wp>   ::= KIND(1.0) | KIND(1.0D0)
46!
47! Arguments
48! =========
49!
50! AP      (input/output) REAL or COMPLEX array, shape (:) with size(AP)=
51!         n*(n+1)/2, where n is the order of A.
52!         On entry, the upper or lower triangle of matrix A in packed
53!  	  storage. The elements are stored columnwise as follows:
54!         if UPLO = 'U', AP(i+(j-1)*j/2)=A(i,j) for 1<=i<=j<=n;
55!         if UPLO = 'L', AP(i+(j-1)*(2*n-j)/2)=A(i,j) for 1<=j<=i<=n.
56!         On exit, AP is overwritten by values generated during the
57!         reduction of A to a tridiagonal matrix T . If UPLO = 'U', the
58!         diagonal and first superdiagonal of T overwrite the correspond-
59!         ing diagonals of A. If UPLO = 'L', the diagonal and first
60! 	  subdiagonal of T overwrite the corresponding diagonals of A.
61! W       (output) REAL array, shape (:) with size(W) = n.
62!         The eigenvalues in ascending order.
63! UPLO    Optional (input) CHARACTER(LEN=1).
64!         = 'U': Upper triangle of A is stored;
65!         = 'L': Lower triangle of A is stored.
66!         Default value: 'U'.
67! Z       Optional (output) REAL or COMPLEX square array, shape (:,:)
68!         with size(Z,1) = n.
69!         The columns of Z contain the orthonormal eigenvectors of A in
70! 	  the order of the eigenvalues.
71! INFO    Optional (output) INTEGER.
72!         = 0: successful exit.
73!         < 0: if INFO = -i, the i-th argument had an illegal value
74!         > 0: if INFO = i, then i off-diagonal elements of an
75! 	  intermediate tridiagonal form did not converge to zero.
76!         If INFO is not present and an error occurs, then the program is
77! 	  terminated with an error message.
78!----------------------------------------------------------------------
79!  .. LOCAL PARAMETERS ..
80   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_SPEVD'
81!  .. LOCAL SCALARS ..
82   CHARACTER(LEN=1) :: LUPLO, LJOBZ
83   INTEGER :: N, NN, LINFO, LD, ISTAT, ISTAT1, S1Z, S2Z, LWORK, LIWORK
84   INTEGER, SAVE :: LWORKN = 0, LIWORKN = 0, LWORKV = 0, LIWORKV = 0
85   COMPLEX(WP) :: WW
86!  .. LOCAL ARRAYS ..
87   REAL(WP), TARGET :: LLZ(1,1)
88   INTEGER, POINTER :: IWORK(:)
89   REAL(WP), POINTER :: WORK(:)
90!  .. INTRINSIC FUNCTIONS ..
91   INTRINSIC MAX, PRESENT
92!  .. EXECUTABLE STATEMENTS ..
93   LINFO = 0; NN = SIZE(A)
94   WW = (-1+SQRT(1+8*REAL(NN,WP)))*0.5; N = INT(WW);  LD = MAX(1,N)
95   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
96   IF( PRESENT(Z) )THEN; S1Z = SIZE(Z,1); S2Z = SIZE(Z,2); LJOBZ = 'V'
97   ELSE; S1Z = 1; S2Z = 1; LJOBZ = 'N'; END IF
98!  .. TEST THE ARGUMENTS
99   IF( NN < 0 .OR. AIMAG(WW) /= 0 .OR. REAL(N,WP) /= REAL(WW) ) THEN; LINFO = -1
100   ELSE IF( SIZE( W ) /= N )THEN; LINFO = -2
101   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -3
102   ELSE IF( PRESENT(Z) .AND. ( S1Z /= LD .OR. S2Z /= N ) )THEN; LINFO = -4
103   ELSE IF( N > 0 )THEN
104!  .. DETERMINE THE WORKSPACE
105      IF( LSAME(LJOBZ,'N') )THEN
106         LWORK = MAX( 1, 2*N, LWORKN ); LIWORK = MAX( 1, LIWORKN )
107      ELSE
108         LWORK = MAX( 1+ 6*N+N**2, LWORKV )
109         LIWORK = MAX( 3+5*N, LIWORKV )
110      END IF
111      ALLOCATE(WORK(LWORK), IWORK(LIWORK), STAT=ISTAT)
112      IF( ISTAT /= 0 )THEN
113         DEALLOCATE( WORK, IWORK, STAT=ISTAT1 )
114         IF( LSAME(LJOBZ,'N') )THEN; LWORK = MAX( 1, 2*N ); LIWORK = 1
115         ELSE
116	    LWORK = 1+ 6*N+N**2
117	    LIWORK = 3+5*N; END IF
118         ALLOCATE(WORK(LWORK), IWORK(LIWORK), STAT=ISTAT)
119         IF( ISTAT == 0 ) CALL ERINFO( -200, SRNAME, LINFO )
120      END IF
121      IF( ISTAT == 0 ) THEN
122         IF( PRESENT(Z) )THEN
123           CALL SPEVD_F77( LJOBZ, LUPLO, N, A, W, Z, S2Z, WORK, LWORK, &
124                         IWORK, LIWORK, LINFO )
125	 ELSE
126  	   CALL SPEVD_F77( LJOBZ, LUPLO, N, A, W, LLZ, S2Z, WORK, LWORK, &
127                         IWORK, LIWORK, LINFO )
128	 ENDIF
129         IF (LINFO == 0 ) THEN
130            IF (LSAME(LJOBZ,'N')) THEN
131               LWORKN = INT(WORK(1)); LIWORKN = IWORK(1)
132            ELSE; LWORKV = INT(WORK(1)); LIWORKV = IWORK(1); END IF
133         END IF
134      ELSE; LINFO = -100; ENDIF
135      DEALLOCATE(WORK,IWORK,STAT=ISTAT1)
136   ENDIF
137   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
138END SUBROUTINE DSPEVD_F95
139