module lapack_wrap
  use constants, only : dp
  use utilities, only : error
  implicit none

contains
  subroutine cdiagh (h,e,v)

    ! f90 interface to LAPACK routines which calculate 
    ! eigenvalues and eigenvectors of a complex hermitean matrix H. 
    !
    ! On output, the matrix H is unchanged
    !
    ! Requires: LAPACK library (ZHEEV and ZHEEVX)
    !           LOC    integer function which returns the address of 
    !                  a variable
    !          
    use constants, only : zero, tpiba2 

    complex(DP), intent(inout)       :: h(:,:)   ! matrix to be diagonalized
    real   (DP), intent(out), target :: e(:)     ! eigenvalues
    complex(DP), intent(out), target :: v(:,:)   ! eigenvectors (column-wise)

    integer  :: n,      &! dimension of the matrix to be diagonalized
                lwork,  &! auxiliary variable
                info,   &! flag saying if LAPACK execution was OK
                ldh,    &! leading dimension of h, as 
                         ! declared in the calling pgm unit
                ldv,    &! leading dimension of v, as 
                         ! declared in the calling pgm unit
                neigv,  &! number of eigenvalues to calculate
                idummy, i, j, m

    character  (len=1) :: jobz, range, uplo  ! select the task in LAPACK

    real(DP), dimension(:), allocatable    :: rwork,& ! work array used by 
                                                      ! LAPACK
                                              diag_h  ! temp array for saving
                                                      ! diag(h)
    complex(DP), dimension(:), allocatable :: work    ! as above
    integer, dimension(:), allocatable     :: iwork   !    "
    integer, dimension(:), allocatable     :: ifail   !    "
    complex(DP)                            :: copt_sz
    real(DP)                               :: rdummy

    logical                                :: use_zheev
    complex(DP), pointer                   :: hh(:,:)
    real(DP),    pointer                   :: ee(:)
!
!   determine the size of the arrays and decide to use zheev or zheevx
!
    n     = size(h,2)
    if ( n     > size(v,1) ) &
         call error('cdiagh','V array has too few rows', size(v,1) )

    neigv = size(e)
    if ( neigv > size(v,2) ) &
         call error('cdiagh', 'V array has too few columns', size(v,2) )

    use_zheev = (neigv > n/4) ! n/4 is the threshold for using zheev
!
!   Initialize common flags
!
    lwork = -1  ! flag saying that the size of work arrays 
                ! has to be estimated by LAPACK (either ZHEEV or ZHEEVX)
    jobz  = 'V' ! compute eigenvalues and eigenvectors
    uplo  = 'U' ! LAPACK routines use the upper triangle of the input matrx

    v(:,:) = (ZERO,ZERO)

    if(use_zheev) then
       ! ZHEEV calculates all the eigenvalues and eigenvectors
       if( neigv==n ) then
          hh => v
          ee => e
          ldh = ( loc(v(1,2))-loc(v(1,1) ) ) / (2*DP) 
       else
          allocate(hh(1:n,1:n), ee(1:n) )
          ldh = n
       end if
       hh(1:n,1:n) = h(1:n,1:n)

       ! allocate work arrays of known size
       allocate(rwork(3*n-2))

       ! calculate optimal size of work arrays
       call zheev(jobz,uplo,n,hh,ldh,ee,copt_sz,lwork,rwork,info)
       call error('cdiagh', &
            'failed to calculate optimal size of work array',abs(info))
       lwork  = nint(real(copt_sz))

       ! allocate work arrays
       allocate(work(lwork))

       ! DIAGONALIZE!
       call zheev(jobz,uplo,n,hh,ldh,ee,work,lwork,rwork,info)

       call error('cdiagh','info =/= 0',abs(info))

       if(neigv == n) then
          hh => null()
          ee => null()
       else
          e(    1:neigv) = ee(    1:neigv)
          v(1:n,1:neigv) = hh(1:n,1:neigv)
          deallocate(hh, ee)
       end if

       deallocate(work,rwork)

    else
       ! ZHEEVX calculates selected eigenvalues and eigenvectors
       !
       ! Find the leading dimensions of h and v
       !
       ldh   = ( loc(h(1,2))-loc(h(1,1) ) ) / (2*DP) 
       ldv   = ( loc(v(1,2))-loc(v(1,1) ) ) / (2*DP) 

       ! allocate arrays of known size

       allocate(ee(n),rwork(7*n),iwork(5*n),ifail(n),diag_h(n))
       range = 'I'
       rdummy=0.0_DP
       ! calculate optimal size of work arrays
       call zheevx( jobz, range, uplo, n, h, ldh, rdummy, rdummy, 1, neigv, &
            zero, m, ee, v, ldv, copt_sz, lwork, rwork, iwork, ifail, info )
       
       call error('cdiagh', &
            'failed to calculate optimal size of work arrays',abs(info))
       lwork  = nint(real(copt_sz))

       ! allocate work arrays
       allocate(work(lwork))

       ! save the diagonal of H for further use
       diag_h = (/ (real(h(i,i)), i=1, n) /)

       ! DIAGONALIZE!
       call zheevx( jobz, range, uplo, n, h, ldh, rdummy, rdummy, 1, &
            neigv, zero, m, ee, v, ldv, work, lwork, rwork, iwork,   &
            ifail, info )

       call error('cdiagh','info =/= 0',abs(info))
       ! fill back the upper triangle of H which was destroyed by zheevx

       do i=1, n
          h(i,i) = cmplx(diag_h(i),ZERO)
          do j=i+1,n
             h(i,j) = conjg(h(j,i))
          end do
       end do
       e(1:neigv)=ee(1:neigv) 
       
       deallocate(work,rwork,iwork,ifail,diag_h)
       deallocate(ee)
    end if

    return
  end subroutine cdiagh

end module lapack_wrap
