module phonon_mod

 use constants, only : dp
 use pw_types,  only : field
 use energy_bands, only : evc, et, unit_psi_in
 implicit none

 type(field) :: dmuxc                        ! the derivative of xc potential
 integer :: nks, nbnd
 real(kind=dp) :: q(3)                       ! the q point
 real(kind=dp) :: alpha_pv
 real(kind=dp), allocatable :: xkq(:,:), wkq(:)
 real(kind=dp), allocatable :: amass(:)      ! the mass of the atoms      
 complex(kind=dp), allocatable :: dyn(:,:)         ! the dynamical matrix
 complex(kind=dp), allocatable, target :: evq(:,:)  ! wavefunctions and

 
contains
!
!---------------------------------------------------------------------------
!
subroutine phonon(ecut)
!>
!> This routine is the main driver of the linear response calculation.
!> It uses four additional routines.
use structure, only : nats
implicit none
real(kind=dp) :: ecut

allocate(dyn(3*nats, 3*nats))
dyn=(0.d0,0.d0)
!>
!> {\tt phq\_init} initializes the variables of the phonon calculation:
   call phq_init(ecut)
!>
!> {\tt dynmat0} computes the part of the dynamical matrix indepedent
!> from the induced change density. This part of the dynamical matrix
!> has two terms. The second derivative of the ion-ion Ewald energy
!> with respect to two atomic displacements and the expectation value 
!> of the second derivative of the bare potential with respect to 
!> the displacement of the same atom.
   call dynmat0
!>
!> {\tt phqscf} sets up the linear system, evaluates the change of the 
!> wavefunctions due to the atomic displacement and computes the
!> induced charge density. Finally, it computes the part of
!> the dynamical matrix which depends on the induced charge density.
   call phqscf(ecut)
!>
!> {\tt dyndia} forces the dynamical matrixi to be Hermitian. It divides this
!> matrix by the square root of the masses and diagonalizes it.
   call dyndia

   deallocate(dyn)

end subroutine phonon
!
!--------------------------------------------------------------------------
!
 subroutine dynmat0
!>
!>  This routine computes the part of the dynamical matrix independent
!>  from the induced charge density.
 use constants, only : tpiba2, tpi
 use pw_types,  only : destroy, assignment(=), field_ft, &
                       direct_to_reciprocal_space
 use structure, only : atoms, species, nats, ntyp
 use reciprocal_lattice, only : g, ngm
 use ewald, only : d2ionq
 use scf, only: rho
 
 complex(kind=DP),pointer :: vg(:)
 real(kind=DP) :: fac, gtau
 type(field) :: aux
 integer :: na, icart, jcart, na_icart, na_jcart, ng
!>
!> The routine {\tt d2ionq} computes the second derivative of the ion-ion
!> Ewald energy:
 call d2ionq(q,dyn)
!>
!> The expectation value of the second derivative of the bare potential
!> with respect to an atomic displacement is calculated here.
!> It has only diagonal elements $s=s'$ and it reads: 
!> \begin{equation}  
!> \int d^3 r {\partial^2 V_{bare}\over \partial u_{s\alpha}({\bf q=0})
!> u_{s'\beta}({\bf q=0})} \rho({\bf r})= -\delta_{ss'}\sum_{\bf G} 
!> \rho^*({\bf G})
!> e^{-i{\bf G}\cdot{\tau_s}} {\bf G}_\alpha {\bf G}_\beta V^s({\bf G})
!> \end{equation}
 aux=rho
 call field_ft(aux,DIRECT_TO_RECIPROCAL_SPACE)

 do na = 1, nats
    vg => species(atoms(na)%itype)%ps%vg
    do ng = 1, ngm
       gtau = tpi*(g(1,ng)*atoms(na)%tau(1) + &
                   g(2,ng)*atoms(na)%tau(2) + &
                   g(3,ng)*atoms(na)%tau(3) )
       fac = vg(ng)*tpiba2* &
            (DREAL(aux%val(aux%ig1(ng),aux%ig2(ng),aux%ig3(ng)))*cos(gtau)&
            -DIMAG(aux%val(aux%ig1(ng),aux%ig2(ng),aux%ig3(ng)))*sin(gtau))
       do icart = 1, 3
          na_icart = 3 * (na - 1) + icart
          do jcart = 1, 3
             na_jcart = 3 * (na - 1) + jcart
            dyn (na_icart,na_jcart)=dyn(na_icart,na_jcart)- &
                                     fac*g(icart,ng)*g(jcart,ng)
          enddo
       enddo
    enddo
 enddo
 
 call destroy(aux)

 return
 end subroutine dynmat0
!
!--------------------------------------------------------------------------
!
 subroutine phqscf(ecut)
 use pw_types, only : construct, destroy, direct_space
 use structure, only :  nats
!>
!>  This routine is a driver. For each atom $s$ which moves in the
!>  $\alpha$ direction ($x$, $y$ or $z$), {\tt solve\_linter} sets up
!>  and solves a linear system which gives the first order change of the 
!>  wavefunctions due to the perturbation. These quantities are used 
!>  to calculate the induced charge density
!>  $d\rho\over d u_{s\alpha}({\bf q})$. Finally, this routine calls 
!>  {\tt drhodv} which calculates the remaining part of the dynamical matrix. 
 implicit none
 real(kind=dp) :: ecut
 type(field) :: drhoscf    ! for each mode contains d rho / d u
 integer :: mode

 call construct(drhoscf,DIRECT_SPACE)
 do mode=1,3*nats
    call solve_linter (drhoscf,mode,ecut)
    call drhodv(drhoscf, mode)
 enddo 
 call destroy(drhoscf)
 
 return
 end subroutine phqscf
!
!--------------------------------------------------------------------------
!
 subroutine solve_linter(drhoscf,mode,ecut)
!>
!> This routine sets up and solves a self-consistent linear system.
!> The solutions are the derivatives of the wave-functions with respect 
!> to the atomic displacement.
!> This routine is called for each perturbation. 
 use constants, only : zero
 use scf, only : broyden, linear_mixing
 use pw_types, only: construct, destroy, assignment(=), axpy, &
                     field_times_wvfct, k_point, wave_function, field, &
                     direct_space, operator(.dot.)

 implicit none

 integer, intent(in) :: mode             ! the mode to do
 type(field), intent(inout) :: drhoscf   ! save the delta rho
 real(kind=dp), intent(in) :: ecut       ! cut-off energy


 integer :: kter                      ! counter on interation
 integer :: ibnd,jbnd                 ! counters on bands
 integer :: ik,i,n_iter,npw,npwq, idum ! counters
 integer, parameter :: niter_ph=100   ! maximum number of iterations
 type(k_point), target :: kvect, kqvect ! the k vector

 complex(kind=dp), allocatable,target :: dvpsi(:,:), dpsi(:,:)
 type(wave_function), allocatable :: psi(:), psiq(:), dvpsiq(:), dpsiq(:)
 type(wave_function)  :: auxg         ! auxiliary
 type(field) :: dvin, dvout           ! self consistent potentials
 real(kind=dp) :: dr2, thresh, weight, beta, tol, anorm, kk(3)
 real(kind=dp), allocatable :: h_diag(:)! preconditioning
 real(kind=dp), allocatable :: etq(:) ! eigenvalues at k+q
 complex(kind=dp) :: ps               ! auxiliary
 logical :: conv_root                 ! check convergence of linear system
 logical :: convt                     ! if true convergence has been achieved


 write(6,'(''Computing perturbation #'',i5)') mode
 write(6,*)

 call construct(dvin,DIRECT_SPACE)
 call construct(dvout,DIRECT_SPACE)

 open(unit=4,form='unformatted',status='scratch') 
 open(unit=8,form='unformatted',status='scratch') 
 open(unit=9,form='unformatted',status='scratch') 
!>
!>  Iterate to self-consistence:
 do kter = 1, niter_ph
     
    convt = .true.
    drhoscf=(ZERO, ZERO)
    rewind (unit = unit_psi_in) ! with wavefunctions 
    rewind (unit = 4) ! with dvpsi
    rewind (unit = 8) ! with dpsi 
    rewind (unit = 9) ! with dpsi 
!>
!> Threshold for the iterative solution of the linear system:
    if (kter.gt.1) thresh = max(min(thresh*0.25d0,sqrt(dr2)),1.d-12)
!>
!>  For each ${\bf k}$ point we construct and solve the linear system:
    do ik = 1, nks
       call construct( kvect, xkq(:,2*ik-1), ecut )
       call construct( kqvect, xkq(:,2*ik), ecut )
       npw=kvect%npw
       npwq=kqvect%npw
       allocate(evc(npw,nbnd),et(nbnd))
       allocate(evq(npwq,nbnd),etq(nbnd))
       allocate(dpsi(npwq,nbnd),dvpsi(npwq,nbnd),h_diag(npwq))
       allocate(psi(nbnd),psiq(nbnd),dvpsiq(nbnd),dpsiq(nbnd))
       read(unit_psi_in) kk(:), idum, idum
       read(unit_psi_in) evc, et
       read(unit_psi_in) kk(:), idum, idum
       read(unit_psi_in) evq, etq
       call construct(psi,kvect,evc)
       call construct(psiq,kqvect,evq)
       call construct(dvpsiq,kqvect,dvpsi)
       call construct(dpsiq,kqvect,dpsi)
       call construct(auxg,kqvect)

       if (kter.eq.1) then
!>
!>  At the first iteration the change of the wavefunction
!>  {\tt dpsi} and the change of the Hartree and exchange and 
!>  correlation potential
!>  {\tt dvin} are set to zero. We also call {\tt dvqpsi} to compute
!>  the non self-consistent part of the right hand side of the linear system.
          dpsi=(ZERO,ZERO)
          dvin=(ZERO,ZERO)
          call dvqpsi (dvpsiq,psi,mode)
          write(4) dvpsi
!>
!> Starting threshold for the iterative solution of the linear system:
          thresh = 1.0d-2
       else
!>
!>  After the first iteration, the non self-consistent part of the right
!>  hand side is read from file, as well as an estimate of the solution of the
!>  linear system {\tt dpsi}. This estimate is the solution of the 
!>  linear system at the previous iteration.
          read(4) dvpsi
          if (mod(kter,2)==0) read(8) dpsi
          if (mod(kter,2)==1) read(9) dpsi
!> 
!> After the first iteration we have an estimate of the induced Hartree 
!> and exchange and correlation potential. The right hand side of the
!> linear system depends self-consistently from the induced potential.
!> We compute here the product ${\partial V_{Hxc}({\bf r})\over 
!> \partial u_{s\alpha}({\bf q})}\|\psi_{{\bf k}v}\rangle$
!> and add it to {\tt dvpsi}.
          do ibnd = 1, nbnd
             call field_times_wvfct(dvin,psi(ibnd),auxg)
             call axpy((1.d0,0.d0), auxg, dvpsiq(ibnd))
          enddo
       endif
!>
!>  Here we apply the projector on the conduction band to the right
!>  hand side of the linear system ($P_{{\bf k+q}c}=1-P_{{\bf k+q}v}$):
       do ibnd = 1, nbnd
!          auxg%val=(0.d0,0.d0)
          auxg=(0.d0,0.d0)
          do jbnd = 1, nbnd
             ps=-(psiq(jbnd).dot.dvpsiq(ibnd))
             call axpy(ps, psiq(jbnd), auxg)
          enddo
          call axpy((1.d0,0.d0), auxg, dvpsiq(ibnd))
       enddo
!>
!> Finally we put the minus sign: 
       dvpsi=-dvpsi
!>
!>  and call {\tt cgsolve\_all} to solve the linear system for all bands.
!>  {\tt h\_diag} is a preconditioning vector.
       h_diag=1.d0/max(1.0d0,kqvect%gk)
       conv_root = .true.
       call cgsolve_all (et, dvpsi, dpsi, h_diag, npwq, &
                    thresh, kqvect, conv_root, anorm, nbnd)
       if (.not.conv_root) write(6,'('' Some roots are not converged'')')
!>
!> Now {\tt dpsi} contains the change of the wavefunctions, at the current
!> ${\bf k}$ point, due to the current perturbation.
!> We save it on file to use it at the next iteration.
       if (mod(kter,2).eq.1) write(8) dpsi
       if (mod(kter,2).eq.0) write(9) dpsi
!>
!> And add the contribution of this wavefunctions to the induced charge
!> density, calling the routine {\tt incdrhoscf}:
       weight = wkq(2*ik-1)
       call incdrhoscf (drhoscf, psi, dpsiq, weight)
!>
!>  Deallocate and destroy all the variables which depend on the ${\bf k}$
!>  and ${\bf k+q}$ point.

       call destroy(psi)
       call destroy(psiq)
       call destroy(dvpsiq)
       call destroy(dpsiq)
       call destroy(auxg)
       deallocate(evc,et,evq,etq)
       deallocate(dpsi,dvpsi,h_diag)
       deallocate(psi,psiq,dvpsiq,dpsiq)
       call destroy(kvect)
       call destroy(kqvect)
  enddo
!>
!> After the loop on ${\bf k}$ points, {\tt drhoscf} contains the 
!> current estimate of the induced charge density. Now we can compute 
!> the induced Hartree and exchange and correlation potential.
  call dv_of_drho (drhoscf, dvout)
!>
!>  Finally we mix the old and the new potential and check for self-consistency.
!>  We use the same routine ({\tt Broyden}) written for mixing the potentials
!>  in the unperturbed problem.
  beta=0.7
  tol=1.d-12
  n_iter=4
  convt = broyden(dvin,dvout,beta,kter,n_iter,tol,dr2)
  dvin=dvout

  write(6, 500) kter, tol, dr2
500 format('iter =', i5, ' expected scf =', e15.3, ' delta dv = ', e15.3)
  if (convt) goto 155
!>
!> If not converged, make another iteration with the new potential.
enddo   ! on iterations
155 continue
call destroy(dvin)
call destroy(dvout)
write(6,*)
close(4)
close(8)
close(9)
return
end subroutine solve_linter
!
!--------------------------------------------------------------------------
!
subroutine drhodv(drhoscf,mode)
!>
!>  The part of the dynamical matrix which depends on the induced
!>  charge density is: 
!>  \begin{equation}
!>  \int d^3 r {\partial \rho({\bf r})^* \over \partial u_{s\alpha}({\bf q})}
!>  {\partial V_{bare}({\bf r})\over \partial u_{s'\beta}({\bf q})}
!>  \end{equation}
!>  The routine {\tt compute\_dvloc} computes the derivative of the bare
!>  potential for each mode while {\tt drhoscf} contains the charge
!>  induced by a displacement along the {\tt mode} mode.
!>  This routine calculates the integral using the {\tt .dot.} operator
!>  defined in the {\tt pw\_types} to integrate the product of two fields.
!>
use structure, only : omega, nats
use pw_types, only : field, construct, destroy, operator(.dot.), &
                     reciprocal_space
implicit none
integer, intent(in) :: mode
type(field), intent(in) :: drhoscf
type(field) :: dvloc
integer :: nu
do nu = 1, 3 * nats
   call construct(dvloc,RECIPROCAL_SPACE)
   call compute_dvloc(nu, dvloc)
   dyn(mode,nu)=dyn(mode,nu)+ (drhoscf.dot.dvloc)*omega
   call destroy(dvloc)
enddo

return
end subroutine drhodv
!
!--------------------------------------------------------------------------
!
subroutine incdrhoscf(drhoscf,psi,dpsiq,weight)
!>
!>  This routine adds the contribution of the current ${\bf k}$ point
!>  wavefunctions to the induced charge density:
!>  \begin{equation}
!>  {d \rho_{\bf k} \over d u_{s\alpha}({\bf q})} = 4 \sum_v 
!>  \psi^*_{{\bf k}v}({\bf r})
!>  {d \psi_{{\bf k}v}({\bf r}) \over d u_{s\alpha}({\bf q}) } 
!>  \end{equation}
use constants, only : degspin
use structure, only : omega
use pw_types,  only : field_ft, assignment(=), set_field_state, &
                      reciprocal_space, reciprocal_to_direct_space, &
                      field, wave_function, destroy
implicit none
type(field), intent(inout) :: drhoscf
type(wave_function), intent(in) :: psi(:), dpsiq(:)
real(kind=dp),intent(in) :: weight

type(field) :: aux1, aux2
real(kind=dp) :: wgt
integer :: ibnd

wgt=2.d0*weight*degspin/omega

do ibnd = 1, nbnd
   aux1=psi(ibnd)
   aux2=dpsiq(ibnd)
   call field_ft(aux1, RECIPROCAL_TO_DIRECT_SPACE)
   call field_ft(aux2, RECIPROCAL_TO_DIRECT_SPACE)
   drhoscf%val = drhoscf%val + wgt*conjg(aux1%val)*aux2%val
   call set_field_state(aux1,RECIPROCAL_SPACE)
   call set_field_state(aux2,RECIPROCAL_SPACE)
enddo
call destroy(aux1)
call destroy(aux2)

return
end subroutine incdrhoscf
!
!--------------------------------------------------------------------------
!
subroutine dv_of_drho(drhoscf,dvout)
!>
!> This routine receives as input the induced charge density at a
!> given iteration and calculates the induced Hartree and exchange 
!> and correlation potential.
!> The induced exchange and correlation potential is calculated 
!> in direct space. We have:
!> \begin{equation}
!> {\partial V_{xc}({\bf r})\over \partial u_{s\alpha}({\bf q})} =
!> {\partial V_{xc}({\bf r})\over \partial \rho({\bf r})}
!> {\partial \rho({\bf r})\over \partial u_{s\alpha}({\bf q})}
!> \end{equation}
!> ${\partial V_{xc}({\bf r})\over \partial \rho({\bf r})}$ is calculated
!> only once in {\tt phq\_init} and saved in {\tt dmuxc}.
!>
!> The induced Hartree potential is calculated in reciprocal space 
!> and Fourier transform brings it to direct space.
!> \begin{equation}
!> {\partial V_{H}({\bf q+G})\over \partial u_{s\alpha}({\bf q})}=
!> {\partial \rho({\bf q+G})\over \partial u_{s\alpha}({\bf q})} 
!> {4\pi e^2 \over ({\bf q+G})^2}
!> \end{equation}
use constants, only : e2, fpi, tpiba2
use pw_types, only : construct, destroy, field_ft, assignment(=), field, &
                     direct_space, reciprocal_to_direct_space, &
                     direct_to_reciprocal_space
use reciprocal_lattice, only : g, ngm, ig1, ig2, ig3
implicit none
type(field) :: drhoscf, dvout
type(field) :: dvaux
real(kind=dp) :: qg2
integer :: ig
!>
!>  The induced exchange and correlation potential:
call construct(dvaux,DIRECT_SPACE)
dvaux%val  = dmuxc%val * drhoscf%val
!>
!>  This potential is transformed to reciprocal space to be added to the 
!>  induced Hartree potential:
call field_ft(dvaux,DIRECT_TO_RECIPROCAL_SPACE)
!>
!>  The induced Hartree potential. First we bring the charge to reciprocal
!>  space and then apply the equation, adding it to the exchange and
!>  correlation part
dvout=drhoscf
call field_ft(dvout,DIRECT_TO_RECIPROCAL_SPACE)
do ig = 1, ngm
   qg2 = (g(1,ig)+q(1))**2+(g(2,ig)+q(2))**2+(g(3,ig)+q(3))**2
   if (qg2.gt.1.d-8) then
       dvaux%val(ig1(ig),ig2(ig),ig3(ig))= &
             dvaux%val(ig1(ig),ig2(ig),ig3(ig))+e2*fpi* &
             dvout%val(ig1(ig),ig2(ig),ig3(ig))/(tpiba2*qg2)
   endif
enddo
!>
!> Finally, transform to direct space:
dvout=dvaux

call field_ft(dvout,RECIPROCAL_TO_DIRECT_SPACE)
call destroy(dvaux)

return
end subroutine dv_of_drho
!
!------------------------------------------------------------------------
!
subroutine dvqpsi(dvpsiq,psi,mode)
!>
!>  This routine computes the non self-consistent part of the right 
!>  hand side of the linear system
!>  ${\partial V_{bare}({\bf r})\over \partial u_{s\alpha}({\bf q})} 
!>  \| \psi_{{\bf k}v} \rangle$. The routine {\tt compute\_dvloc}
!>  computes the derivative of the potential and this routine calls
!>  {\tt field\_times\_wvfct} to apply the potential to the wavefunctions:
use pw_types, only : construct, field, wave_function, field_times_wvfct, &
                     reciprocal_space, destroy
implicit none

integer, intent(in) :: mode                ! the mode for this perturbation
type(wave_function), intent(inout) :: psi(:), dvpsiq(:) 
type(field) :: aux1
integer :: ibnd

call construct(aux1,RECIPROCAL_SPACE)
call compute_dvloc(mode,aux1)
do ibnd = 1, nbnd
   call field_times_wvfct(aux1,psi(ibnd),dvpsiq(ibnd))
enddo
call destroy(aux1)
return
end subroutine dvqpsi
!
!---------------------------------------------------------------------------
!
subroutine ch_psi_all (n, h, ah, e, kqvect, m)
!>
!>  This routine applies to the $m$ vectors {\tt h(:,m)}
!>  the operator $H-\varepsilon_m+Q$ where $H$ is the Hamiltonian, 
!>  $\varepsilon_m$ is the eigenvalue and
!>  $Q=\alpha_v \sum_{kv} \|\psi_{{\bf k}v} \rangle\langle
!>  \psi_{{\bf k}v}\|$ is the projector on the valence band, multiplied
!>  by $\alpha_v$. $\alpha_v$ is computed in {\tt phq\_init} and
!>  is sufficiently big to assure that the linear system is not
!>  singular.
use energy_bands, only : et
use hamiltonian, only: h_psi
use pw_types, only : k_point, wave_function, construct, destroy
implicit none
integer :: n, m

type(k_point) :: kqvect
type(wave_function) :: psih, psip
complex(kind=dp) :: h(n,nbnd), ah(n,nbnd)
real(kind=dp) :: e(nbnd)

complex(kind=dp), allocatable, target :: ps(:,:)
integer ibnd

allocate(ps(nbnd,m))
!>
!> Compute the product of the Hamiltonian and the h vector
do ibnd = 1, m
   call construct(psih,kqvect,h(:,ibnd))
   call construct(psip,kqvect)
!>
!>  Apply $H$ to the wavefunction
   call h_psi(psih,psip)
!>
!>   then we compute the operator $(H-\epsilon)$ on the wavefunctions
   ah(:,ibnd) = psip%val(:) - e(ibnd)*psih%val(:)
   call destroy(psip)
   call destroy(psih)
enddo
!>
!>   Here we apply the $Q$ operator 
ps=(0.d0,0.d0)

call ZGEMM ('C', 'N', nbnd, m, n, (1.d0, 0.d0) , evq, &
      n, h, n, (0.d0, 0.d0) , ps, nbnd)

ps=ps*alpha_pv

call ZGEMM ('N', 'N', n, m, nbnd, (1.d0, 0.d0) , evq, &
      n, ps, nbnd, (1.d0, 0.d0) , ah, n)

deallocate(ps)

return
end subroutine ch_psi_all
!
!---------------------------------------------------------------------------
!
subroutine cg_psi(psi, h_diag)
!>
!>  Preconditioning of the CG procedure.
implicit none

complex(kind=DP) :: psi (:, :) ! inp/out: the vector to be preconditioned
real(kind=DP) :: h_diag (:, :) ! input: the preconditioning vector

psi = psi * h_diag

return
end subroutine cg_psi 
!
!---------------------------------------------------------------------------
!
subroutine compute_dvloc(mode,dvloc)
!>
!>  This routine computes ${\partial V_{bare}({\bf r})\over \partial 
!>  u_{s\alpha}({\bf q})}$. It sets its Fourier components and 
!>  makes a Fourier transform to direct space.
!>  We have:
!>  \begin{equation}
!>  {\partial V_{bare}({\bf q+G})\over \partial u_{s\alpha}({\bf q})}=
!>  -i({\bf q}+{\bf G})_\alpha V^s({\bf q}+{\bf G}) 
!>   e^{-i({\bf q}+{\bf G})\cdot {\bf \tau}_s}
!>  \end{equation}
use constants, only : tpiba, tpi
use structure, only : atoms, omega, species
use pw_types, only : assignment(=), field, field_ft, reciprocal_to_direct_space
implicit none
integer, intent(in) :: mode
type(field), intent(inout) :: dvloc

integer :: na, ipol, nt, ig
real(kind=dp) :: arg
complex(kind=dp) :: eigqts, fact, gtau

dvloc=(0.d0,0.d0)

na=(mode-1)/3+1
ipol=mod(mode-1,3)+1

arg = (q(1)*atoms(na)%tau(1)+q(2)*atoms(na)%tau(2)+q(3)*atoms(na)%tau(3))*tpi
eigqts=cmplx(cos(arg),-sin(arg))
fact = tpiba*(0.d0, -1.d0)*eigqts/ omega
nt = atoms(na)%itype
do ig = 1, dvloc%ngm
   arg = ( dvloc%g(1,ig)*atoms(na)%tau(1) + &
           dvloc%g(2,ig)*atoms(na)%tau(2) + &
           dvloc%g(3,ig)*atoms(na)%tau(3)  ) * tpi
   gtau = cmplx(cos(arg),-sin(arg))
   dvloc%val(dvloc%ig1(ig),dvloc%ig2(ig),dvloc%ig3(ig)) = &
   dvloc%val(dvloc%ig1(ig),dvloc%ig2(ig),dvloc%ig3(ig) )  &
   +species(nt)%ps%vgq(ig)*(q(ipol)+ dvloc%g(ipol,ig))*fact*gtau
enddo
call field_ft (dvloc,RECIPROCAL_TO_DIRECT_SPACE)

return
end subroutine compute_dvloc
!
!---------------------------------------------------------------------------
!
subroutine phq_init(ecut)
!>
!>  This routine computes the main quantities needed in the phonon
!>  calculation. It converts the masses to atomic units,
!>  computes the second derivative of the exchange and
!>  correlation energy with respect to the charge, 
!>  and sets the shift $\alpha_v$ which multiply the valence band
!>  projector. 
use scf, only : rho
use pw_types, only : construct, k_point, direct_space, destroy

implicit none
integer :: i,j,k
real(kind=dp) :: rhotot, emin, emax, ecut, kk(3)
real(kind=dp), parameter :: amconv= 1.66042d-24/9.1095d-28*0.5d0
integer :: ik, ibnd, inbnd, inpw
type(k_point) :: kvect
!>
!>  Mass conversion:
amass=amconv*amass
!>
!>  The function {\tt dmxc} calculates numerically the derivative of 
!>  the exchange and correlation potential with respect to the charge.
!>  Within LDA, this function is local.
call construct(dmuxc, DIRECT_SPACE)

dmuxc%val=0.d0
do i=1, rho%nr1
   do j=1, rho%nr2
      do k=1, rho%nr3
         rhotot=rho%val(i,j,k)
         if (rhotot.gt.1.d-30) dmuxc%val(i,j,k) = dmxc (rhotot)
      enddo
   enddo
enddo
!>
!>  Reads from file all the eigenvalues and finds the maximum and minimum
!>  eigenvalues which are used to set $\alpha_v$.
rewind(unit_psi_in)
call construct( kvect, xkq(:,1), ecut )
read(unit_psi_in) kk(:), inbnd, inpw
allocate(evc(kvect%npw,nbnd),et(nbnd))
read(unit_psi_in) evc,et
emin = et(1)
emax = et(1)
do ik=1,2*nks
   if (ik.gt.1) then
      call construct( kvect, xkq(:,ik), ecut )
      read(unit_psi_in) kk(:), inbnd, inpw
      allocate(evc(kvect%npw,nbnd),et(nbnd))
      read(unit_psi_in) evc,et
   endif  
   do ibnd = 1, nbnd
      emax = max (emax, et (ibnd) )
      emin = min (emin, et (ibnd) )
   enddo
   call destroy(kvect)
   deallocate(evc,et)
enddo
alpha_pv = 2.d0 * (emax - emin)
!>
!> if $\alpha_v$ is too small set it to a small but reasonable number.
alpha_pv = max (alpha_pv, 1.0d-2)

return
end subroutine phq_init
!
!-----------------------------------------------------------------------
!
function dmxc (rho)  
!>
!> This routine evaluates the derivative of the xc potential with 
!> respect to the charge density.
use constants,   only : e2
use functionals, only : xc
implicit none  

real(kind=DP) :: rho, dmxc  
! input: the charge density ( positive )
! output: the derivative of the xc potential

real(kind=DP) :: dr, vxp, vcp, vxm, vcm, ex, ec  
! delta rrho for numerical derivatives
! the potentials for + charge
! the potentials for - charge
! the energy
real(kind=DP) :: small
parameter (small = 1.d-30)  

 dmxc = 0.d0  
 if (rho.le.small) return  
!>
!> Numerical differentiation of the exchange and correlation potential.
  dr = min (1.d-6, 1.d-4 * rho)  
  call xc(rho + dr, ex, ec, vxp, vcp)  
  call xc(rho - dr, ex, ec, vxm, vcm)  
  dmxc = (vxp + vcp - vxm - vcm) / (2.d0 * dr)  
!>
!> e2 brings energy to Ry units
  dmxc = e2 * dmxc  
  return  

end function dmxc
!
!---------------------------------------------------------------------------
!
subroutine cgsolve_all (e, d0psi, dpsi, h_diag, ndim, ethr, &
                           kqvect, conv_root, anorm, nbnd)
!----------------------------------------------------------------------
!
!     iterative solution of the linear system:
!
!                 ( h - e + Q ) * dpsi = d0psi                      (1)
!
!                 where h is a complex hermitian matrix, e is a real sca
!                 dpsi and d0psi are complex vectors
!
!     on input:
!                 h_psi             EXTERNAL  name of a subroutine:
!                                   h_psi(ndim,psi,psip)
!                                   Calculates  H*psi products.
!                                   Vectors psi and psip shoul be dimens
!                                   (ndim,nvec). nvec=1 is used!
!
!                 cg_psi             EXTERNAL  name of a subroutine:
!                                   g_psi(ndim,ndim,notcnv,psi,e)
!                                   which calculates (h-e)^-1 * psi, wit
!                                   some approximation, e.g. (diag(h)-e)
!
!                 e                 real     unperturbed eigenvalue.
!
!                 dpsi              contains an estimate of the solution
!                                   vector.
!
!                 d0psi             contains the right hand side vector
!                                   of the system.
!
!                 ndim              integer row dimension of dpsi, ecc.
!
!                 ndim              integer actual row dimension of dpsi
!
!                 ethr              real     convergence threshold. solu
!                                   improvement is stopped when the erro
!                                   eq (1), defined as l.h.s. - r.h.s.,
!                                   less than ethr in norm.
!
!     on output:  dpsi              contains the refined estimate of the
!                                   solution vector.
!
!                 d0psi             is corrupted on exit
!
!
!   Last revised 6 apr. 1997 by A. Dal Corso & F. Mauri
!
!
use pw_types, only : k_point

implicit none  
!
!   first the dummy variables
!
integer :: ndim, nbnd
! input: the maximum dimension of the vectors
! input: the actual dimension of the vectors
! output: counter on iterations
! input: the number of bands
type(k_point) :: kqvect
! input: the k point

real(kind=DP) :: e (nbnd), anorm, h_diag (ndim), ethr  
! input: the actual eigenvalue
! output: the norm of the error in the solution
! input: an estimate of ( H - epsilon
! input: the required precision

complex(kind=DP) :: dpsi (ndim, nbnd), d0psi (ndim, nbnd)  
! output: the solution of the linear syst
! input: the known term

logical :: conv_root  
! output: if true the root is converged
! input: the routine computing h_psi
! input: the routine computing cg_psi
!
!  three parameters
!

integer :: maxter  
! the maximum number of iterations
parameter (maxter = 200)  
!
!  here the local variables
!

integer :: iter, ibnd, lbnd
integer , pointer :: conv (:)  
! counter on iteration
! counter on bands
! if 1 the root is converged

complex(kind=DP), pointer :: g (:,:), gp (:,:), t (:,:), &
     h (:,:), hold (:,:), aux (:,:), aux1 (:,:)
complex(kind=DP) ::  dcgamma, dclambda, ZDOTC
!  the gradient of psi
!  the preconditioned gradient
!  the delta gradient
!  the conjugate gradient
!  the the old h
!  the the old h
!  the the old h
!  the ratio between rho
!  step lenght
!  the scalar product


real(kind=DP), pointer :: rho (:), rhoold (:), auxr (:,:), eu (:)
real(kind=DP) :: kter_eff, a, c
! the residue
! auxiliary for h_diag
! account the number of iterations with b
! coefficient of quadratic form
!
allocate(g(ndim,nbnd))  
allocate(gp(ndim,nbnd))  
allocate(t(ndim,nbnd))  
allocate(h(ndim,nbnd))  
allocate(hold(ndim,nbnd))  
allocate(aux1(ndim,nbnd))  
allocate(aux(ndim,nbnd))  
allocate(conv(nbnd))  
allocate(rho(nbnd))  
allocate(rhoold(nbnd))  
allocate(auxr(ndim,nbnd)) 
allocate(eu(nbnd)) 

kter_eff = 0.d0  
do ibnd = 1, nbnd  
   conv (ibnd) = 0  
enddo
do iter = 1, maxter  
!
!        compute the gradient. can reuse information from previous step
!
!
   if (iter.eq.1) then  
      call ch_psi_all (ndim, dpsi, g, e, kqvect, nbnd)  
      do ibnd = 1, nbnd  
        call ZAXPY(ndim,(-1.d0, 0.d0), d0psi(1,ibnd), 1, g(1,ibnd), 1)
      enddo
   endif
!
!  compute residual
!
   lbnd = 0  
   do ibnd = 1, nbnd  
      if (conv (ibnd) .eq.0) then  
         call ZCOPY (ndim, g (1, ibnd), 1, gp (1, ibnd), 1)  
         lbnd = lbnd+1  
         call ZCOPY (ndim, gp (1, ibnd), 1, aux (1, lbnd), 1)  
         call DCOPY (ndim, h_diag, 1, auxr (1, lbnd), 1)  
      endif
   enddo
   call cg_psi (aux(:,1:lbnd), auxr(:,1:lbnd))  
   kter_eff = kter_eff + float (lbnd) / float (nbnd)  
   lbnd = 0  
   do ibnd = 1, nbnd  
      if (conv (ibnd) .eq.0) then  
        lbnd = lbnd+1  
        call ZCOPY (ndim, aux (1, lbnd), 1, gp (1, ibnd), 1)  
      endif
   enddo
   do ibnd = 1, nbnd  
      if (conv (ibnd) .eq.0) then  
         rho(ibnd) = ZDOTC(ndim, gp (1, ibnd), 1, g (1, ibnd), 1)
         anorm = sqrt (rho (ibnd) )  
!               write(6,'(2i5,e20.5)') iter,ibnd,anorm
         if (anorm.lt.ethr) conv (ibnd) = 1  
      endif
   enddo
   conv_root = .true.  
   do ibnd = 1, nbnd  
      conv_root = conv_root.and. (conv (ibnd) .eq.1)  
   enddo
   if (conv_root) goto 100  
!
!        compute the step direction h. Conjugate it to previous step
!
   lbnd = 0  
   do ibnd = 1, nbnd  
      if (conv (ibnd) .eq.0) then  
        call ZCOPY (ndim, gp (1, ibnd), 1, h (1, ibnd), 1)  
        call DSCAL (2 * ndim, - 1.d0, h (1, ibnd), 1)  
        if (iter.ne.1) then  
           dcgamma = rho (ibnd) / rhoold (ibnd)  
           call ZAXPY (ndim, dcgamma, hold (1, ibnd), 1, h (1, ibnd), 1)
        endif
        rhoold (ibnd) = rho (ibnd)  
        call ZCOPY (ndim, h (1, ibnd), 1, hold (1, ibnd), 1)  
        lbnd = lbnd+1  
        call ZCOPY (ndim, h (1, ibnd), 1, aux (1, lbnd), 1)  
        eu (lbnd) = e (ibnd)  
      endif
   enddo
!
!        compute t = A*h
!
   call ch_psi_all (ndim, aux, aux1, eu, kqvect, lbnd)  
   lbnd = 0  
   do ibnd = 1, nbnd  
      if (conv (ibnd) .eq.0) then  
         lbnd = lbnd+1  
         call ZCOPY (ndim, aux1 (1, lbnd), 1, t (1, ibnd), 1)  
      endif
   enddo
!
!        compute the coefficients a and c for the line minimization
!        compute step length lambda
   do ibnd = 1, nbnd  
      if (conv (ibnd) .eq.0) then  
         a = ZDOTC (ndim, h (1, ibnd), 1, g (1, ibnd), 1)  
         c = ZDOTC (ndim, h (1, ibnd), 1, t (1, ibnd), 1)  
         dclambda = DCMPLX ( - a / c, 0.d0)  
!
!           move to new position
!
         call ZAXPY (ndim, dclambda, h (1, ibnd), 1, dpsi (1, ibnd), 1)
!
!           update to get the gradient
!
!g=g+lam
         call ZAXPY (ndim, dclambda, t(1, ibnd), 1, g (1, ibnd), 1)
      endif
   enddo
enddo
100 continue  
deallocate(eu)  
deallocate(auxr)  
deallocate(rho)  
deallocate(rhoold)  
deallocate(conv)  
deallocate(aux)  
deallocate(aux1)  
deallocate(hold)  
deallocate(h)  
deallocate(t)  
deallocate(gp)  
deallocate(g)  

return  
end subroutine cgsolve_all
!
!-----------------------------------------------------------------------
!
subroutine dyndia
!>
!>   This routine diagonalizes the dynamical matrix. 
!>   The frequencies are written on output by this routine.
use structure, only : nats, atoms
use lapack_wrap, only: cdiagh
implicit none  

real(kind=DP), allocatable :: w2 (:)  !   the frequencies square
integer :: nmodes, nta, ntb, mu, nu, na, nb
real(kind=DP) :: rydthz, rydcm1, w1
! conversion from a.u. to terahertz
! conversion from a.u. to cm^-1
! the frequency
complex(kind=DP), allocatable :: z(:,:)  

nmodes=3*nats
allocate(z(nmodes, nmodes))
allocate(w2(nmodes))
!>
!> The dynamical matrix must be exactly hermitian: 

do mu = 1, nmodes  
   do nu = 1, mu  
      dyn (mu, nu)=0.5d0*(dyn(mu,nu)+conjg(dyn(nu,mu)))
      dyn (nu, mu)=conjg(dyn(mu, nu))  
   enddo
enddo
!>
!> Divide the dynamical matrix by the square root of the masses:
do mu = 1, nmodes  
   na = (mu - 1) / 3 + 1  
   nta = atoms(na)%itype 
   do nu = 1, nmodes  
      nb = (nu - 1) / 3 + 1  
      ntb = atoms(nb)%itype  
      dyn(mu, nu)=dyn(mu,nu)/sqrt(amass(nta)*amass(ntb))
   enddo
enddo
!>
!> Diagonalize the dynamical matrix and finds phonon frequencies
!> and displacements.
call cdiagh (dyn, w2, z)  
!>
!> Conversion factors  ryd=>thz e ryd=>1/cm:
rydthz = 13.6058d0 * 241.796d0  
!
!  1 Ry = 13.6058 eV, Planck constant h^-1= 241.796 10^12 1/(eV sec) 
!
rydcm1 = 13.6058d0 * 8065.5d0  
!
!  lambda = wavelenght, lambda^-1 = \nu / c where c=29979245800 cm/sec
!  241.796 10^12 / 29979245800 = 8065.5 
!
!>
!>  Writes on output the frequencies.
write(6,9000) (q(mu), mu=1,3)  

9000 format(/,5x,'Diagonalizing the dynamical matrix', &
               //,5x,'q = ( ',3f14.9,' ) ',//,1x,74('*'))
dyn=(0.d0,0.d0)
do mu = 1, nmodes  
   w1 = sqrt(abs(w2(mu)))  
   if (w2 (mu) .lt.0.d0) w1 = - w1  
   write (6, 9010) mu, w1 * rydthz, w1 * rydcm1  
9010 format   (5x,'omega(',i2,') =',f15.6,' [THz] =',f15.6,' [cm-1]')  
enddo
write (6, '(1x,74("*"))')  
deallocate(z,w2)
return  
end subroutine dyndia

end module phonon_mod
