
! Copyright (C) 2002-2005 J. K. Dewhurst, S. Sharma and C. Ambrosch-Draxl.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.

subroutine gradwf2(ik,evecfv,evecsv,gwf2mt,gwf2ir)
use modmain
implicit none
! arguments
integer, intent(in) :: ik
complex(8), intent(in) :: evecfv(nmatmax,nstfv,nspnfv),evecsv(nstsv,nstsv)
real(8), intent(inout) :: gwf2mt(npmtmax,natmtot),gwf2ir(ngtot)
! local variables
integer ist,ispn,jspn
integer is,ias,i,j
integer nr,nri,ir,np
integer igk,ifg
real(8) wo
complex(8) zq(2),z1
! automatic arrays
logical done(nstfv,nspnfv)
! allocatable arrays
complex(8), allocatable :: apwalm(:,:,:,:,:)
complex(8), allocatable :: wfmt1(:,:,:),wfmt2(:,:)
complex(8), allocatable :: gwfmt(:,:),zfmt(:)
complex(8), allocatable :: zfft1(:,:),zfft2(:)
!-------------------------!
!     muffin-tin part     !
!-------------------------!
allocate(apwalm(ngkmax,apwordmax,lmmaxapw,natmtot,nspnfv))
allocate(wfmt1(npmtmax,nstfv,nspnfv),wfmt2(npmtmax,nspinor))
allocate(gwfmt(npmtmax,3),zfmt(npmtmax))
! find the matching coefficients
do ispn=1,nspnfv
  call match(ngk(ispn,ik),vgkc(:,:,ispn,ik),gkc(:,ispn,ik), &
   sfacgk(:,:,ispn,ik),apwalm(:,:,:,:,ispn))
end do
do ias=1,natmtot
  is=idxis(ias)
  nr=nrmt(is)
  nri=nrmti(is)
  np=npmt(is)
! de-phasing factor for spin-spirals
  if (ssdph) then
    zq(1)=zqss(ias)
    zq(2)=conjg(zq(1))
  end if
  done(:,:)=.false.
  do j=1,nstsv
    if (abs(occsv(j,ik)).lt.epsocc) cycle
    wo=wkpt(ik)*occsv(j,ik)
    if (tevecsv) then
! generate spinor wavefunction from second-variational eigenvectors
      wfmt2(1:np,:)=0.d0
      i=0
      do ispn=1,nspinor
        jspn=jspnfv(ispn)
        do ist=1,nstfv
          i=i+1
          z1=evecsv(i,j)
          if (ssdph) z1=z1*zq(ispn)
          if (abs(dble(z1))+abs(aimag(z1)).gt.epsocc) then
            if (.not.done(ist,jspn)) then
              call wavefmt(1,ias,ngk(jspn,ik),apwalm(:,:,:,ias,jspn), &
               evecfv(:,ist,jspn),wfmt1(:,ist,jspn))
              done(ist,jspn)=.true.
            end if
! add to spinor wavefunction
            wfmt2(1:np,ispn)=wfmt2(1:np,ispn)+z1*wfmt1(1:np,ist,jspn)
          end if
        end do
      end do
    else
! spin-unpolarised wavefunction
      call wavefmt(1,ias,ngk(1,ik),apwalm(:,:,:,ias,1),evecfv(:,j,1),wfmt2)
    end if
! compute the gradient of the wavefunction
    do ispn=1,nspinor
      call gradzfmt(nr,nri,rlmt(:,-1,is),wcrmt(:,:,is),wfmt2(:,ispn),npmtmax, &
       gwfmt)
      do i=1,3
! convert gradient from spherical harmonics to spherical coordinates
        call zbsht(nr,nri,gwfmt(:,i),zfmt)
! add to total
        gwf2mt(1:np,ias)=gwf2mt(1:np,ias) &
         +wo*(dble(zfmt(1:np))**2+aimag(zfmt(1:np))**2)
      end do
    end do
  end do
end do
deallocate(apwalm,wfmt1,wfmt2,gwfmt,zfmt)
!---------------------------!
!     interstitial part     !
!---------------------------!
allocate(zfft1(ngtot,nspinor),zfft2(ngtot))
do j=1,nstsv
  if (abs(occsv(j,ik)).lt.epsocc) cycle
  wo=wkpt(ik)*occsv(j,ik)/omega
  zfft1(:,:)=0.d0
  if (tevecsv) then
! generate spinor wavefunction from second-variational eigenvectors
    i=0
    do ispn=1,nspinor
      jspn=jspnfv(ispn)
      do ist=1,nstfv
        i=i+1
        z1=evecsv(i,j)
        if (abs(dble(z1))+abs(aimag(z1)).gt.epsocc) then
          do igk=1,ngk(jspn,ik)
            ifg=igfft(igkig(igk,jspn,ik))
            zfft1(ifg,ispn)=zfft1(ifg,ispn)+z1*evecfv(igk,ist,jspn)
          end do
        end if
      end do
    end do
  else
! spin-unpolarised wavefunction
    do igk=1,ngk(1,ik)
      ifg=igfft(igkig(igk,1,ik))
      zfft1(ifg,1)=evecfv(igk,j,1)
    end do
  end if
! compute gradient of wavefunction
  do ispn=1,nspinor
    jspn=jspnfv(ispn)
    do i=1,3
      zfft2(:)=0.d0
      do igk=1,ngk(jspn,ik)
        ifg=igfft(igkig(igk,jspn,ik))
        zfft2(ifg)=zi*vgkc(i,igk,jspn,ik)*zfft1(ifg,ispn)
      end do
! Fourier transform gradient to real-space
      call zfftifc(3,ngridg,1,zfft2)
      do ir=1,ngtot
        gwf2ir(ir)=gwf2ir(ir)+wo*(dble(zfft2(ir))**2+aimag(zfft2(ir))**2)
      end do
    end do
  end do
end do
deallocate(zfft1,zfft2)
end subroutine

