program wan_iterp
  implicit none
  integer, parameter :: DP = 8
  real(kind=DP), parameter :: PAI  = 3.141592653589793238462D0
  real(kind=DP), parameter :: PAI2 = PAI*2.d0, PAI4 = PAI*4.d0
  real(kind=DP), parameter :: Hartree = 27.21139615d0

  integer, parameter :: nfwannier = 10
  integer :: i, j, ir, id, jd
  integer :: ikx,iky,ikz,idk
  integer :: nkpt, num_wan, nrpts, num_band_kpt
  integer :: nspin
  integer, allocatable :: ndegen(:), ipos(:,:)
  real(kind=DP) :: altv(3,3), rltv(3,3)
  real(kind=DP) :: v1(3), v2(3)
  real(kind=DP) :: hr, hi
  real(kind=DP) :: efermi
  complex(kind=DP), allocatable :: hmat(:,:,:)
  real(kind=DP), allocatable :: kvec(:,:)
  real(kind=DP), allocatable :: eig(:,:)
  complex(kind=DP), allocatable :: umat(:,:,:)
  real(kind=DP), allocatable :: kpt_band(:,:), klen(:)
  character(len=128) :: seedname
  if(iargc()<1) then
     stop 'wan_interp.x seedname'
  end if
  call getarg(1,seedname)
  
  open(nfwannier,file=trim(seedname)//".nnkp")
  do i=1,5
     read(nfwannier,*)
  end do
  read(nfwannier,*) altv(1:3,1)
  read(nfwannier,*) altv(1:3,2)
  read(nfwannier,*) altv(1:3,3)
     read(nfwannier,*)
     read(nfwannier,*)
     read(nfwannier,*)
  read(nfwannier,*) rltv(1:3,1)
  read(nfwannier,*) rltv(1:3,2)
  read(nfwannier,*) rltv(1:3,3)
     read(nfwannier,*)
     read(nfwannier,*)
     read(nfwannier,*)
  read(nfwannier,*) nkpt
  allocate(kvec(3,nkpt))
  do i=1,nkpt
     read(nfwannier,*) kvec(1:3,i)
  end do
  close(nfwannier)

  write(*,'("Lattice vectors:")')
  do i=1,3
     write(*,'(3(1x,f10.5))') altv(1:3,i)
  end do
  write(*,'("Reciprocal lattice vectors:")')
  do i=1,3
     write(*,'(3(1x,f10.5))') rltv(1:3,i)
  end do
  write(*,'("k-points: nkpt=",i5)') nkpt
  do i=1,nkpt
     write(*,'(3(1x,f10.5))') kvec(1:3,i)
  end do

  open(nfwannier,file=trim(seedname)//"_hr.dat")
     read(nfwannier,*)
  read(nfwannier,*) num_wan
  read(nfwannier,*) nrpts
  allocate(ndegen(nrpts))
  allocate(hmat(num_wan,num_wan,nrpts))
  allocate(ipos(3,nrpts))
  read(nfwannier,*) ndegen(1:nrpts)
  do ir=1,nrpts 
     do j=1,num_wan
        do i=1,num_wan
           read(nfwannier,*) ipos(1:3,ir),id,jd, hr, hi 
           hmat(i,j,ir) = cmplx(hr,hi)
        end do
     end do
  end do
  close(nfwannier)

  write(*,'("Hamiltonian matrix in the WF basis:")')
  do ir=1,nrpts 
     do j=1,num_wan
        do i=1,num_wan
           write(*,'(5i5,2f10.6)') ipos(1:3,ir),i,j,hmat(i,j,ir)
        end do
     end do
  end do

  open(nfwannier,file="kpoint.data")
  read(nfwannier,*) num_band_kpt
  allocate(kpt_band(3,num_band_kpt))
  do i=1,num_band_kpt
     read(nfwannier,*) ikx,iky,ikz,idk
     kpt_band(1,i) = real(ikx)/real(idk)
     kpt_band(2,i) = real(iky)/real(idk)
     kpt_band(3,i) = real(ikz)/real(idk)
  end do
  close(nfwannier)

  allocate(eig(num_wan,num_band_kpt))
  allocate(umat(num_wan,num_wan,num_band_kpt))
  do i=1,num_band_kpt
     call solve_hmat_k(kpt_band(1,i),eig(1,i),umat(1,1,i))
  end do

  efermi = 0.d0
  open(nfwannier,file="nfefermi.data")
  read(nfwannier,*) efermi
  close(nfwannier)
  nspin = 1

  open(nfwannier,file="nfenergy.data")
  write(nfwannier,'(" num_kpoints = ",i6)') num_band_kpt
  write(nfwannier,'(" num_bands   = ",i6)') num_wan
  write(nfwannier,'(" nspin       = ",i6)') nspin
  write(nfwannier,'(" Fermi energy level = ",f10.5)') efermi
  write(nfwannier,*)
  do i=1,num_band_kpt
     write(nfwannier,'("=== energy_eigen_values ===")')
     write(nfwannier,'(" ik = ",i4," (",3f10.6," )")') i,kpt_band(1:3,i)
     write(nfwannier,'(4f18.10)') eig(1:num_wan,i)/Hartree
  end do
  close(nfwannier)
  
contains
 
  subroutine solve_hmat_k(kpt,eig,umat)
    implicit none
    real(kind=DP), intent(in) :: kpt(3)
    real(kind=DP), intent(out) :: eig(num_wan)
    complex(kind=DP), intent(out) :: umat(num_wan,num_wan)
 
    integer :: i,j,ir
    real(kind=DP) :: ph
    complex(kind=DP) :: zf
    complex(kind=DP), allocatable :: hmat_k(:,:)

    character(len=1) :: JOBZ,UPLO
    integer :: lwork, lrwork, info
    complex(kind=DP),allocatable,dimension(:) :: work
    real(kind=DP),allocatable,dimension(:) :: rwork

    allocate(hmat_k(num_wan,num_wan))

    hmat_k = cmplx(0.d0,0.d0)
    do j=1,num_wan
       do i=1,num_wan
          do ir=1,nrpts
             ph = PAI2 * dot_product(kpt,real(ipos(1:3,ir),DP))
             zf = cmplx(cos(ph),sin(ph))/real(ndegen(ir),DP)
             hmat_k(i,j) = hmat_k(i,j) + zf * hmat(i,j,ir)
          end do
       end do
    end do

    JOBZ = 'V'
    UPLO = 'U'
    lwork = max(1,2*num_wan-1)
    lrwork = max(3*num_wan-2,1)

    allocate(work(lwork))
    allocate(rwork(lrwork))
    umat = hmat_k
    call zheev(JOBZ,UPLO,num_wan,umat,num_wan,eig,work,lwork,rwork,info)
    deallocate(work)
    deallocate(rwork)

    deallocate(hmat_k)
  end subroutine solve_hmat_k
  
end program wan_iterp
