module ewald
  use constants, only : dp, zero, one
  use utilities, only : erfc, error, hpsort

  implicit none
  
contains

!-----------------------------------------------------------------------
  function ewald_energy() 
!-----------------------------------------------------------------------

    !> \large This routine computes the ion-ion interaction energy with the
    !> Ewald method.
    !>
    !> \centerline{\includegraphics*[width=17cm]{ewald0.png}}
    !>
    !> A Gaussian charge distribution is added and subtracted to each 
    !> atomic site:
    !> \[ \rho^z_i({\bf r}) = Z_i \kappa^3 e^{-\kappa^2r^2/\pi^{3/2}}. \]
    !>
    !> \centerline{\includegraphics*[width=17cm]{ewald.png}} 
    !>
    !> The effect of $\rho^z$ is to screen the point charge and to reduce
    !> the range of the electrostatic ion-ion interaction. The remaining terms 
    !> (arising from the periodic gaussian charge distributions)
    !> are easily calculated in reciprocal space. The explicit form of 
    !> $E_{\rm ion-ion}$ in the Ewald method is therefore: 
    !> \begin{eqnarray}
    !>  E_{\rm Ewald}=&  \frac{1}{2} \sum_{i \ne j} \sum_{\bf R} 
    !>  Z_i Z_j \frac{{\rm erfc}(2\sqrt{\alpha} \left\|{\bf R_{ij}+R}\right\|)}
    !>  {\left\|{\bf R_{ij}+R}\right\|} & {\rm Real-space \,\, term} 
    !>  \nonumber \\
    !>  +& \frac{4\pi}{\Omega} \sum_{\bf G \ne 0} \frac{e^{-G^2/4\alpha}}{G^2} 
    !>  \, \left\{ \mid \sum_i Z_i \cos({\bf G\cdot R_i}) \mid^2 +
    !>  \mid \sum_i Z_i \sin({\bf G\cdot R_i}) \mid^2 \right\} 
    !>  & {\rm Reciprocal-space \,\, term}  \nonumber \\
    !>  -&  \frac{4\sqrt{\alpha}}{\sqrt{\pi}} \, \sum_i Z_i^2 
    !> & {\rm Self-energy} \nonumber  \\
    !> -& \frac{4\pi}{\Omega} \frac{1}{4\alpha} \left( 
    !> \sum _i Z_i \right)^2 & {\rm Charged-system \,\, term} \nonumber 
    !> \end{eqnarray} 
    !> The parameter $\alpha$ is related to the width of the Gaussian 
    !> ($\kappa=2\sqrt{\alpha}$). A similar method is used to calculate the
    !> ionic contirbution to the forces (see 
    !> \hyperlink{force_ew}{\tt force\_ew})

    use constants, only : half, e2, two, alat, tpiba2, tpi
    use structure, only : nats, atoms, species, at, bg, ntyp, omega
    use reciprocal_lattice, only: gg, gcutm, ngm, structure_factor

    implicit none

    !   first the dummy variables

    real(DP)    ::  ewald_energy  ! output: the ewald energy
    complex(DP) ::  rhon

    !    here the local variables

    integer, parameter :: mxr=50  ! maximum number of R vectors included 
                                  ! in r sum
    integer::  &
         ng,  &        ! counter over reciprocal G vectors
         nr,  &        ! counter over direct vectors
         na,  &        ! counter on atoms
         nb,  &        ! counter on atoms
         nt,  &        ! counter on atomic types
         nrm, &        ! number of R vectors included in r sum
         ipol          ! counter on polarization
    real(DP) :: &
         charge, &     ! total ionic charge in the cell
         ewaldg, &     ! ewald energy computed in reciprocal space
         ewaldr, &     ! ewald energy computed in real space
         dtau(3), &    ! the difference tau_s - tau_s'
         alpha,   &    ! alpha term in ewald sum
         r(3,mxr),&    ! input of the rgen routine ( not used here )
         r2(mxr), &    ! the square modulus of R_j-tau_s-tau_s'
         rmax,    &    ! the maximum radius to consider real space sum
         rr,      &    ! buffer variable
         upperbound   ! used to optimize alpha

    !> Calculate the total charge $\sum_i Z_i^2$

    charge = ZERO
    do na=1,nats
       charge = charge + species(atoms(na)%itype)%zv
    end do

    alpha = 2.9d0; upperbound = ONE
    do while(upperbound > 1.0d-7)
       alpha=alpha-0.1d0
       
       !> choose alpha in order to have convergence in the sum over G 
       !> upperbound is a safe upper bound for the error in the sum over G

       if(alpha.le.0.d0) call error('ewald','optimal alpha not found',1)
       upperbound=2.d0*charge**2*sqrt(2.d0*alpha/tpi)* &
            erfc(sqrt(tpiba2*gcutm/4.d0/alpha))
    end do

    !> Charged-system term $4\pi/\Omega 
    !>  /(4\alpha) \left( \sum _i Z_i \right)^2$ 

    ewaldg=-charge**2 /alpha/4.d0

    !> Reciprocal-space term

    do ng = 2, ngm
       rhon = (ZERO,ZERO)
       do nt = 1,ntyp
          rhon = rhon + species(nt)%zv*conjg(structure_factor(ng,nt))*omega
       enddo
       ewaldg= ewaldg + abs(rhon)**2*exp(-gg(ng) &
            * tpiba2/alpha/4.d0)/gg(ng)/tpiba2
    enddo
    ewaldg = TWO *tpi/omega*ewaldg

    !> Self-interaction term $4\sqrt{\alpha}/\sqrt{\pi} \, \sum_i Z_i^2$

    do na=1, nats
       ewaldg= ewaldg - species(atoms(na)%itype)%zv**2 * &
            sqrt(8.d0/tpi * alpha)
    enddo

    !> Real-space term

    ewaldr = ZERO
    rmax = 4.d0/sqrt(alpha)/alat

    !> With this choice terms up to $Z_i Z_j {\rm erfc}(4)$ are counted 
    !> $({\rm erfc}(4)=2 \times 10^{-8})$

    do na=1, nats
       do nb=1, nats
          dtau(:)=atoms(na)%tau(:)-atoms(nb)%tau(:)

          !> Generate nearest-neighbors shells $\cdots$

          call rgen(dtau,rmax,mxr,at,bg,r,r2,nrm)

          !> $\cdots$ and sum to the real space part  

          do nr=1, nrm
             rr=sqrt(r2(nr))*alat
             ewaldr = ewaldr + species(atoms(na)%itype)%zv* &
                               species(atoms(nb)%itype)%zv &
                              * erfc(sqrt(alpha)*rr)/rr
          end do
       end do
    end do

    !> Sum all contributions

    ewald_energy= HALF * e2 * ( ewaldg+ewaldr )

    return
  end function ewald_energy

  !-----------------------------------------------------------------------
  subroutine ewald_force ( forceion )

    !>  \large This routine computes the ionic contribution to the forces
    !>  with the Ewald method (For a description of the Ewald method 
    !>  see \hyperlink{ewald}{\tt ewald}. 
    !>
    !> A Gaussian charge distribution is added and subtracted to each 
    !> atomic site:
    !> \[ \rho^z_i({\bf r}) = Z_i \kappa^3 e^{-\kappa^2r^2/\pi^{3/2}}. \]
    !> The effect of the $\rho^z$ is to screen the point charge and to reduce
    !> the range of the electrostatic ion-ion interaction. The remaining terms 
    !> (arising from the periodic distribution of gaussian charge distributions
    !> are easily calculated in reciprocal space. The explicit form of the
    !> ionic component of the force on atom $i$ is obtained by differentiating
    !> the  Ewald expression for  the ion-ion energy 
    !> (\hyperlink{ewald}{E$_{\rm ion}$}):
    !> \begin{eqnarray}
    !> {\bf F_i^{ion}} =& - \frac{\partial E_{\rm Ewald}}{\partial \bf R_i} 
    !> & \nonumber \\
    !> =& - \frac{1}{2} \sum_{i \ne j} \sum_{\bf R} Z_i Z_j \left\{
    !> \frac{{\rm erfc}(2\sqrt{\alpha} \left\|{\bf R_{ij}+R}\right\|)}
    !>  {\left\|{\bf R_{ij}+R}\right\|} + \sqrt{\frac{4\alpha}{\pi}} 
    !> e^{-\alpha\left\|{\bf R_{ij}+R}\right\|^2} \right\} 
    !> \frac{\bf R_{ij}+R}{\left\|{\bf R_{ij}+R}\right\|^2}
    !> & {\rm Real-space} \nonumber \\
    !> -& \frac{4 (2\pi)^2}{\Omega} \sum_{\bf G \ne 0} 
    !> Z_i \, \frac{e^{-G^2/4\alpha}}{G^2} \left\{ \cos({\bf G \cdot R_i})
    !> \left[ \sum_j Z_j \sin({\bf G\cdot R_j}) \right] -\sin({\bf G\cdot R_i})
    !> \left[ \sum_j Z_j \cos({\bf G\cdot R_j}) \right] \right\} {\bf G}
    !> & {\rm Reciprocal-space}  \nonumber
    !> \end{eqnarray}
    !> The parameter $\alpha$ is related to the width of the Gaussian 
    !> ($\kappa=2\sqrt{\alpha}$).

!-----------------------------------------------------------------------
    use constants, only : dp, zero, tpiba2, half, e2, tpi, two
    use structure, only : nats, atoms, species, omega, at, bg, alat, ntyp
    use reciprocal_lattice, only : gcutm, g, gg, structure_factor, ngm

    implicit none

    !   First the dummy variables

    real(DP) :: factor,  &
                forceion(3,nats)    ! output: the ewald part of the forces

!  Three parameters

    integer, parameter ::  mxr=50 ! the maximum number of R vectors
            
    integer ::  ig,  &           ! counter on G vectos
                n,   &           ! counter on r vectors
                na,  &           ! counter on atoms
                nb,  &           ! counter on atoms
                nt,  &           ! counter on atomic types
                nrm, &           ! the number of R vectors for real space sum
                ipol             ! counter on polarization

    real(DP) ::  sumnb,  &        ! auxiliary variable for speed
                 arg,    &        ! the argument of the exponential
                 alpha,  &        ! the alpha parameter 
                 dtau(3),&        ! the difference of two tau
                 r(3,mxr), &      ! the position of the atoms in the shell
                 r2(mxr),  &      ! the square of r      
                 rmax,     &      ! the maximum r
                 rr,       &      ! the modulus of the r vectors
                 charge,   &      ! the total charge  
                 upperbound       ! used to determine alpha

    complex(DP) :: aux(ngm)          ! auxiliary space

    forceion = ZERO
    charge   = ZERO
    do na=1, nats
       charge = charge +species(atoms(na)%itype)%zv
    end do

    !> Get $\alpha$ choose $\alpha$ in order to have convergence in 
    !> the sum over G {\tt upperbound} is a safe upper bound for the 
    !> error ON THE ENERGY

    alpha=1.1d0; upperbound = ONE
    do while( upperbound > 1.0d-6)
       alpha=alpha-0.1d0
       if(alpha.eq.0.d0) call error('force_ew','optimal alpha not found',1)
       upperbound=e2*charge**2*sqrt(2.d0*alpha/tpi)* &
            erfc(sqrt(tpiba2*gcutm/4.d0/alpha))
    end do

    !> RECIPROCAL SPACE

    aux=(ZERO,ZERO)
    
    !> Reciprocal-space: \[ Z_j \sum_j {\rm e}^{i{\bf G \cdot R_j}} = 
    !>  Z_j\left( \cos({\bf G\cdot R_j})+i\sin({\bf G\cdot R_j})\right) \]

    do nt=1,ntyp
       aux(:) = aux(:) + species(nt)%zv &
            *conjg(structure_factor(:,nt))*omega
    end do
    
    !> Reciprocal-space coefficient 

    do ig=2,ngm
       aux(ig)=aux(ig)*exp(-gg(ig)*tpiba2/alpha/4.d0)/(gg(ig)*tpiba2)
    end do

    !> Complete reciprocal-space term 
    !> \[ \frac{4 (2\pi)^2}{\Omega} \sum_{\bf G \ne 0} 
    !> Z_i \, \frac{e^{-G^2/4\alpha}}{G^2} \left\{ \cos({\bf G \cdot R_i})
    !> \left[ \sum_j Z_j \sin({\bf G\cdot R_j}) \right] -\sin({\bf G\cdot R_i})
    !> \left[ \sum_j Z_j \cos({\bf G\cdot R_j}) \right] \right\} \]

    do na=1,nats
       do ig=1,ngm
          arg = tpi * dot_product(g(:,ig),atoms(na)%tau)
          sumnb = cos(arg)*DIMAG(aux(ig))-sin(arg)*real(aux(ig))
          forceion(:,na) = forceion(:,na) + g(:,ig)*sumnb
       end do
       forceion(:,na) =  -species(atoms(na)%itype)%zv* &
            TWO *e2*tpi**2/omega /alat*forceion(:,na)
    end do

    !> REAL SPACE

    rmax=5.d0/(sqrt(alpha)*alat)

    !> with this choice terms up to $Z_i Z_j {\rm erfc}(5)$ are counted 
    !> (${\rm erfc}(5)=2\times 10^{-12}$)

    outer: do na=1, nats
       inner: do  nb=1, nats
          if( nb == na ) cycle inner
          dtau(:)=atoms(na)%tau(:)-atoms(nb)%tau(:)
          
          !> generates nearest-neighbors shells, {\tt r(i)=R(i)-dtau(i)}

          call rgen(dtau,rmax,mxr,at,bg,r,r2,nrm)

          !> Complete real-space term 
          !> \[ \frac{1}{2} \sum_{i \ne j} \sum_{\bf R} Z_i Z_j \left\{
          !> \frac{{\rm erfc}(2\sqrt{\alpha} \left\|{\bf R_{ij}+R}\right\|)}
          !>  {\left\|{\bf R_{ij}+R}\right\|} + \sqrt{\frac{4\alpha}{\pi}} 
          !> e^{-\alpha\left\|{\bf R_{ij}+R}\right\|^2} \right\} 
          !> \frac{\bf R_{ij}+R}{\left\|{\bf R_{ij}+R}\right\|^2} \]

          do n=1, nrm
             rr=sqrt(r2(n))*alat
             factor = species(atoms(na)%itype)%zv*&
                  species(atoms(nb)%itype)%zv*e2/rr**2* &
                  ( erfc(sqrt(alpha)*rr)/rr +           &
                  sqrt(8.0d0*alpha/tpi)*exp(-alpha*rr**2) ) * alat 
             forceion(:,na) = forceion(:,na) - factor*r(:,n)
          end do
       end do inner
    end do outer

    !> Back to subroutine \hyperlink{htforceion}{\tt forces}

    return
  end subroutine ewald_force

  !-----------------------------------------------------------------------
  subroutine rgen(dtau,rmax,mxr,at,bg,r,r2,nrm)
  !-----------------------------------------------------------------------
    !   generates neighbour shells (in units of alat) with length
    !   less than rmax,and returns them in order of increasing length.
    !      r=i*a1+j*a2+k*a3-dtau,
    !   where a1,a2,a3 are the vectors defining the lattice

    implicit none

    !    first the dummy variables
    
    integer   ::  nrm, &       ! output: the number of vectors in the sphere
                  mxr          ! input: the maximum number of vectors
    real(DP) ::  r(3,mxr), &   ! output: coordinates of vectors R+tau\_s-tau\_s'
                 r2(mxr), &    ! output: square modulus of vectors 
                               ! R+tau\_s-tau\_s' 
                 at(3,3), &    ! input: direct lattice vectors
                 bg(3,3), &    ! input: reciprocal lattice vectors
                 dtau(3), &    ! input: the vector tau\_s-tau\_s'
                 rmax          ! input: the radius of the sphere in real space

    !    and here the local variables

    integer, allocatable  :: irr(:) ! index on R vectors for order
    integer               :: nm1, & !
                             nm2, & !  maximum values for trial vectors
                             nm3, & !
                             i,   & !  
                             j,   & !  counters on trial vectors
                             k,   & ! 
                             ipol,& ! counter on polarizations
                             ir,  & ! counter on R vectors
                             indsw,&! index of swapping
                             iswap  ! used for swapping
    real(DP)              :: t(3), &! buffer contains the actual r
                             tt,   &! buffer cotains the modulus of actual r
                             swap, &! used for swapping
                             DNRM2  ! function to find the norm of a vector

    external DNRM2
    allocate(irr(mxr))

    nrm = 0
    if( rmax .eq. ZERO ) return
    nm1= int(DNRM2(3,bg(1,1),1)*rmax) + 2
    nm2= int(DNRM2(3,bg(1,2),1)*rmax) + 2
    nm3= int(DNRM2(3,bg(1,3),1)*rmax) + 2
 
    do i=-nm1,nm1
       do j=-nm2,nm2
          do k=-nm3,nm3
             tt = ZERO
             do ipol=1,3
                t(ipol)=i*at(ipol,1)+j*at(ipol,2)+k*at(ipol,3) - dtau(ipol)
                tt  = tt + t(ipol)*t(ipol)
             end do
             if(tt.le.rmax**2.and.abs(tt).gt.1.d-10) then
                nrm = nrm + 1
                if(nrm > mxr) call error('rgen','too many r-vectors',nrm)
                do ipol=1,3
                   r(ipol,nrm) = t(ipol)
                end do
                r2(nrm)  = tt
             end if
          end do
       end do
    end do

    !   reorder the vectors in order of increasing magnitude
    !   initialize the index inside sorting routine

    irr(1)=0
    if (nrm.gt.1) call hpsort ( r2(1:nrm), irr )
    do ir=1, nrm-1
20     indsw=irr(ir)
       if(indsw.ne.ir) then
          do ipol=1,3
             swap=r(ipol,indsw)
             r(ipol,indsw)=r(ipol,irr(indsw))
             r(ipol,irr(indsw))=swap
          end do
          iswap=irr(ir)
          irr(ir)=irr(indsw)
          irr(indsw)=iswap
          go to 20
       end if
    end do

    deallocate(irr)
    return
  end subroutine rgen

!
! Copyright (C) 2001 PWSCF group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!-----------------------------------------------------------------------

subroutine d2ionq ( q, dyn)
  !-----------------------------------------------------------------------
  !
  !    This routine computes the contribution of the ions to the
  !    dynamical matrix. Both the real and reciprocal space terms
  !    are included.
  !
  use constants, only : dp, zero, tpiba2, half, two
  use structure, only : nats, atoms, species, omega, at, bg, alat, ntyp
  use reciprocal_lattice, only : gcutm, g, gg, structure_factor, ngm

  implicit none  
  !
  !  first the dummy variables
  !

  integer :: nat
  ! input: the number of atoms
  ! input: the number of types of atoms
  ! input: the number of G vectors
  ! input: the type of each atom
  ! input: the number of modes

  real(kind=DP) ::  q(3)
  ! input: the positions of the atoms
  ! input: the coordinates of g vectors
  ! input: the modulus of g vectors
  ! input: the charge of each type
  ! input: the direct lattice vectors
  ! input: the reciprocal lattice vectors
  ! input: the volume of the unit cell
  ! input: the length scale
  ! input: cut-off of g vectors
  ! input: the q vector
  complex(kind=DP) :: dyn (3*nats,3*nats)  
  ! output: the ionic part of the dyn. mat
  ! input: the pattern of the modes
  !
  !   three parameters
  !

  integer :: mxr  
  ! the maximum number of r shells

  real(kind=DP) :: e2, tpi  
  ! the electron charge
  ! twp times pi

  parameter (mxr = 100, e2 = 2.d0, tpi = 2.d0 * 3.14159265358979d0)  

  integer :: nu_i, nu_j, na, nb, nta, ntb, ng, nrm, nr, icart, &
       jcart, na_icart, na_jcart, nb_icart, nb_jcart, nmodes
  ! counter on the modes
  ! counter on the modes
  ! counter on atoms
  ! counter on atoms
  ! the type of atom na
  ! the type of atom nb
  ! counter on G vectors
  ! the real number of R shells
  ! counter on r shells
  ! counter on cartesian coordinates
  ! counter on cartesian coordinates
  ! counter on the modes
  ! counter on the modes
  ! counter on the modes
  ! counter on the modes
  real(kind=DP) :: arg, fpi, argq, alpha, r (3, mxr), r2 (mxr), &
       dtau (3), rmax, rr, upperbound, charge, fac, df, d2f, ar, &
       gtq2, gt2, facq, qrg
  ! the argument of the phase
  ! 4 times pi
  ! the argument of the phase
  ! two pi / alat
  ! the parameter alpha used to converge the summ
  ! the  parameter
  ! the square of this parameter
  ! delta tau
  ! the maximum r on real space summations
  ! the rmax
  ! an estimate of the error in the real term
  ! the total charge
  ! the phase factor
  ! auxiliary variable
  ! auxiliary variable
  !
  ! the modulus of |q+G|
  ! the modulus of G
  ! a phase factor
  !


  complex(kind=DP), allocatable :: dy1(:,:), dy2(:, :), dy3(:, :)

  complex(kind=DP) :: facg, fnat, work
  ! the first term dynamical matrix
  ! the second dynamical matrix
  ! the third term of the dynamical matrix
  ! a phase with g
  ! a phase with the atoms
  ! working space

  nat=nats
  nmodes=3*nat
  tpiba2 = (tpi / alat) **2  

  fpi = 2.d0 * tpi  
  charge = 0.d0  
  do na = 1, nat  
     charge = charge+species(atoms(na)%itype)%zv   
  enddo
  !
  ! choose alpha in order to have convergence in the sum over G
  ! upperbound is an upper bound for the error in the sum over G
  ! estimated for the energy (empirical trust!)
  !
  alpha = 2.9d0  

11 alpha = alpha - 0.1d0  

  if (alpha.eq.0.d0) call error ('d2ion', 'optimal alpha not found', &
       1)

  upperbound = 2.d0 * charge**2 * sqrt (2.d0 * alpha / tpi) * erfc ( &
       sqrt (tpiba2*gcutm/4.d0/alpha) )

  if (upperbound.gt.1.d-9) goto 11  

  write (6, '(/5x,"Alpha used in Ewald sum = ",f8.4)') alpha  
  allocate(dy1(3*nats,3*nats), dy2(3*nats,3*nats), dy3(3*nats,3*nats))

  dy1=(0.d0,0.d0)
  dy2=(0.d0,0.d0)
  dy3=(0.d0,0.d0)
  !
  ! G-space sums here
  !
  do ng = 1, ngm  
     !
     !     The reciprocal space term has two contributions. The first one
     !
     gtq2 = ( (g (1, ng) + q (1) ) **2 + (g (2, ng) + q (2) ) **2 + &
          (g (3, ng) + q (3) ) **2) * tpiba2
     if (abs (gtq2) .gt.1.d-8) then  
        facq = - e2 * fpi * tpiba2 / omega * exp ( - gtq2 / alpha / &
             4.d0) / gtq2
     else  
        facq = 0.d0  
     endif
     do na = 1, nat  
        nta = atoms(na)%itype  
        do nb = 1, nat  
           ntb = atoms(nb)%itype 
           argq = tpi*((g(1,ng)+q(1))*(atoms(na)%tau(1)-atoms(nb)%tau(1))+&
                       (g(2,ng)+q(2))*(atoms(na)%tau(2)-atoms(nb)%tau(2))+&
                       (g(3,ng)+q(3))*(atoms(na)%tau(3)-atoms(nb)%tau(3)) )
           facg = facq * species(nta)%zv * species(ntb)%zv * &
                 cmplx(cos(argq), sin(argq)) 
           do icart = 1, 3  
              nu_i = 3 * (na - 1) + icart  
              do jcart = 1, 3  
                 nu_j = 3 * (nb - 1) + jcart  
                 dy1 (nu_i, nu_j) = dy1 (nu_i, nu_j) + facg * (q (icart) + g ( &
                      icart, ng) ) * (q (jcart) + g (jcart, ng) )
              enddo
           enddo
        enddo
     enddo
     !
     !   the second term
     !

     gt2 = gg (ng) * tpiba2  
     if (abs (gt2) .gt.1.d-8) then  
        fac = - e2 * fpi * tpiba2 / omega * exp ( - gt2 / alpha / 4.d0) &
             / gt2
     else  
        fac = 0.d0  

     endif
     do na = 1, nat  
        nta = atoms(na)%itype
        fnat = (0.d0, 0.d0)  
        do nb = 1, nat  
           ntb = atoms(nb)%itype 
           arg = tpi*((g(1,ng))*(atoms(na)%tau(1)-atoms(nb)%tau(1))+&
                      (g(2,ng))*(atoms(na)%tau(2)-atoms(nb)%tau(2))+&
                      (g(3,ng))*(atoms(na)%tau(3)-atoms(nb)%tau(3)) )
           facg = fac*species(nta)%zv*species(ntb)%zv*cmplx(cos(arg), 0.d0)  
           fnat = fnat + facg  

        enddo
        do icart = 1, 3  
           nu_i = 3 * (na - 1) + icart  
           do jcart = 1, 3  
              nu_j = 3 * (na - 1) + jcart  
              dy2 (nu_i, nu_j) = dy2 (nu_i, nu_j) + fnat * g (icart, ng) &
                   * g (jcart, ng)
           enddo
        enddo
     enddo

  enddo
  do nu_i = 1, nmodes  
     do nu_j = 1, nmodes  
        dy3 (nu_i, nu_j) = dy3 (nu_i, nu_j) + dy1 (nu_i, nu_j) - dy2 ( &
             nu_i, nu_j)
     enddo
  enddo
  !
  !  Then there is also a part in real space which is computed here.
  !
  rmax = 5.d0 / sqrt (alpha) / alat  
  !
  ! with this choice terms up to ZiZj*erfc(5) are counted (erfc(5)=2x10^-1
  !
  do na = 1, nat  
     nta = atoms(na)%itype
     do nb = 1, nat  
        ntb = atoms(nb)%itype
        dtau (:) = atoms(na)%tau(:)-atoms(nb)%tau(:)  
        !
        ! generates nearest-neighbors shells r(i)=R(i)-dtau(i)
        !
        call rgen (dtau, rmax, mxr, at, bg, r, r2, nrm)  
        do nr = 1, nrm  
           rr = sqrt (r2 (nr) ) * alat  
           ar = sqrt (alpha) * rr  
           qrg = tpi * (q (1) * (r (1, nr) + dtau (1) ) + q (2) * (r (2, nr) &
                + dtau (2) ) + q (3) * (r (3, nr) + dtau (3) ) )
           d2f = (3.d0 * erfc (ar) + sqrt (8.d0 / tpi) * ar * (3.d0 + 2.d0 * &
                ar**2) * exp ( - ar**2) ) / rr**5
           df = ( - erfc (ar) - sqrt (8.d0 / tpi) * ar * exp ( - ar**2) ) &
                / rr**3
           do icart = 1, 3  
              na_icart = 3 * (na - 1) + icart  
              nb_icart = 3 * (nb - 1) + icart  
              do jcart = 1, 3  
                 nb_jcart = 3 * (nb - 1) + jcart  
                 na_jcart = 3 * (na - 1) + jcart  
                 dy3(na_icart,nb_jcart)=dy3(na_icart,nb_jcart)+e2 &
                         *species(nta)%zv &
                   *species(ntb)%zv*cmplx(cos(qrg),sin(qrg))*(d2f*alat* &
                      r(icart,nr)*alat*r(jcart,nr))
                 dy3(na_icart,na_jcart)=dy3(na_icart,na_jcart)-e2 &
                            *species(nta)%zv*species(ntb)%zv*&
                           (d2f*alat*r(icart,nr)*alat*r(jcart,nr))
              enddo
              dy3(na_icart, nb_icart)=dy3(na_icart,nb_icart)+e2* &
                   species(nta)%zv*species(ntb)%zv* &
                   cmplx(cos(qrg), sin(qrg))*df
              dy3(na_icart, na_icart)=dy3(na_icart,na_icart)-e2* &
                      species(nta)%zv* &
                      species(ntb)%zv*df
           enddo
        enddo
     enddo

  enddo
  call dcopy(3*nat*3*nat*2,dy3,1,dyn,1)
  call dscal(3*nat*3*nat*2,-1.d0,dyn,1)

  deallocate(dy1,dy2,dy3)
  return  
end subroutine d2ionq

end module ewald
