program dfpt

!> \centerline{\LARGE \bf 0) SPECIFICATION STATEMENTS } 
  use constants,            only: dp, tpiba, tpiba2, four, zero, one, eps
  use pw_types,             only: field, k_point, construct, destroy, &
                                  assignment(=), axpy, direct_space
  use structure,            only: latgen, bg, atoms, atom, nelec, ntyp,&
                                  setup_elements, set_electron_nmbr
  use reciprocal_lattice,   only: ggen, ngm, set_fft, set_structure_factor
  use lapack_wrap,          only: cdiagh
  use appelbaum_and_hamann, only: set_ah_tables, fill_ah_vatom, fill_ahq_vatom
  use energy_bands,         only: c_bands, sum_bands, unit_wvfct, &
                                  unit_wvfct_aux, first
  use scf,                  only: Vscf, v_of_rho, linear_mixing, broyden, &
                                  delta_v, rho, eband, tot_ene, forces
  use phonon_mod,           only: amass, xkq, wkq, q, nks, nbnd, phonon
  use utilities,            only: error

  implicit none
  character (len=15) :: lattice, material, label
  real(dp)           :: celldm(6) = zero, &
                        xk1(3), xk2(3),   &
                        kmax=zero,        &
                        ecut,             &
                        gcut,             &
                        x

  real(dp),allocatable :: xk(:,:), wk(:)
  real(dp)             :: wksum

  integer              :: nats, na, nb, nt
  real(dp),allocatable,target :: tau(:,:)

  type(field)          :: v_in, v_out, vbare, velec
  type(k_point), allocatable, dimension(:) :: kvect, kvectq

  integer            :: iter, maxter=20
  logical            :: conv

  real(dp)           :: tr2, tol=1.0d-12, beta = 0.7, ethr

  integer            :: npoints, ios, i, n, npw
  
  integer            :: ik1,ik2,ik3,nk1,nk2,nk3
  integer            :: n_iter=4, isolve=1

  character (len=3)  :: reply

  !> \centerline{\LARGE \bf 1) PRELIMINARIES} 
  !> \centerline{\includegraphics*[width=16cm]{flux1.png}}

  !> \large Read in the first three lines of the input file: 
  !> a label ({\tt material}), the Bravais lattice ({\tt lattice}), 
  !> and a vector describing the simulation cell ({\tt celldm}).
  write(*,advance='no',fmt='(" material > ")')
  read(*,*) material
  write(*,*) material
  write(*,*)

  write(*,fmt='("Read structural information >> ")')

  write(*,advance='no',fmt='(" Bravais lattice (sc/bcc/fcc) > ")')
  read(*,*) lattice
  write(*,*) lattice

  write(*,advance='no',fmt='(" celldm(1:6) > ")')
  read(*,*) celldm
  write(*,fmt='(6f7.3)') celldm

  !> The subroutine {\tt latgen} sets up the lattice parameter ({\tt alat}),
  !> the basis vectors of the Bravais lattice ({\tt at}), the basis vectors 
  !> of the reciprocal lattice ({\tt bg}), and the volume of the unit cell 
  !> ({\tt omega}).
  call latgen(lattice,celldm)

  !> Read in the number of independent atoms ({\tt nats}) and the atomic 
  !> coordinates ({\tt tau}).
  write(*,advance='no',fmt='(" # of atoms > ")')
  read(*,*) nats
  write(*,*) nats
  allocate(tau(3,nats),atoms(nats))
  write(*,fmt='(" atom coordinates and label > ")')
  do na=1,nats
     read(*,*) tau(:,na), atoms(na)%label
     write(*,fmt='(3f8.4,2x,a)') tau(:,na), atoms(na)%label 
     atoms(na)%tau => tau(:,na)
  enddo

  !> Setup atomic variables: number of atoms ({\tt nats}), number of atomic 
  !> types ({\tt ntyp}), and the species label.
  call setup_elements
  write(*,fmt='("Read atomic masses >> ")')
  allocate(amass(ntyp))
  read(*,*) (amass(nt), nt=1,ntyp)
  write(*,*)


  !> Read in parameters controlling the simulation: the kinetic-energy cutoff
  !> ({\tt ecut}), the coefficient governing the broyden mixing ({\tt
  !> beta}), the tolerance threshold for convergence ({\tt tol}), the 
  !> diagonalization scheme ({\tt isolve}).
  write(*,fmt='(/"Read control parameters >> ")')


  read(*,*) ecut
  write(*,*) ecut
  write(*,advance='no',fmt='(" mixing fraction (0 < beta < 1) > ")') 
  read(*,*) beta
  write(*,*) beta
  write(*,advance='no',fmt='(" scf threshold (roughly (dV)**2) > ")') 
  read(*,*) tol
  write(*,*) tol
  write(*,advance='no',fmt='(" isolve 0 (lapack) 1 (Davidson) > ")') 
  read(*,*) isolve
  write(*,*) isolve



  !> Read in variables for the generation of the k-point grid.

  write(*,advance='no',fmt='(" nk1,nk2,nk3  > ")')
  read(*,*) nk1,nk2,nk3
  write(*,*) nk1,nk2,nk3
  if (nk1*nk2*nk3==0) then
     write(*,advance='no',fmt='(a)') ' enter the number of k-points > '
     read(*,*) nks
     allocate(xk(3,nks),wk(nks))
     do i=1,nks
        write(*,advance='no',fmt='(a)') ' enter k-point and weight > '
        read(*,*) xk(:,i), wk(i)
     end do
  else
    nks = nk1*nk2*nk3
    write(*,advance='no',fmt='(" number of k-points > ",i5)') nks
    allocate(xk(3,nks),wk(nks))
    i = 0
    wk(:) = one
    do ik1=0,nk1-1
       do ik2=0,nk2-1
          do ik3=0,nk3-1
             i=i+1
             xk(:,i) = float(ik1)/nk1 * bg(:,1) +  &
                       float(ik2)/nk2 * bg(:,2) +  &
                       float(ik3)/nk3 * bg(:,3) 
          end do
       end do
    end do
  end if
  write(*,*)
  wksum = sum(wk(:))
  if ( any( wk < 0 ) .or. wksum==0 ) call error('main', &
      ' k point weights must be positive numbers ',1)
  wk(:) = wk(:)/wksum
  write(*,advance='no',fmt='(a)') ' enter q-point > '
        read(*,*) q(:)
  write(6,'(3f20.8)') q(:)

  kmax = 0.d0
  do i=1,nks
     kmax = max( kmax, sqrt(dot_product(xk(:,i),xk(:,i))) )
  end do

  !> The energy threshold {\tt ecut} toghether with the longhest k-vector
  !> {\tt kmax}  allowed in the Brillouin Zone limits the set of 
  !> reciprocal-space {\bf G}-vectors that is necessary to consider. 
  !> The cutoff in the reciprocal-space vectors {\tt gcut} is determined 
  !> by the formula 
  !> \[ \mid  {\bf k}_{max} + {\bf G} \mid^2 \le E_{cut}. \]
  gcut = ( sqrt(ecut/tpiba2) + kmax ) **2 + eps
  gcut = max(gcut,FOUR*ecut/tpiba2)

  !> \centerline{\includegraphics*[width=16cm]{flux2.png}}

  !> The subroutine {\tt ggen} sets the arrays of {\bf G}-vectors {\tt g} and 
  !> the corresponding squared norm {\tt gg} such that 
  !> $ \mid{\bf G}\mid^2 \le {\tt gcut}$. The {\bf G}-vectors are stored  
  !> in order of increasing norm.
  call ggen(gcut)

!> The subroutine {\tt set\_fft} sets the dimensions of the Fast Fourier 
!> Transform ({\tt mr1,mr2,mr3}), and the pivot arrays ({\tt ig1,ig2,ig3,
!> nl}).  
  call set_fft

  allocate(kvect(nks))
  call construct(kvect(1:nks),xk(:,1:nks),ecut,wk(1:nks))

!> The following subroutines build the {\it Appelbaum and Hamann} 
!> pseudopotential for the given atom (Si).
  call set_ah_tables
  call fill_ah_vatom
  call fill_ahq_vatom

!> Calculate the electronic charge in the unit cell
  call set_electron_nmbr 
  nbnd = nelec/2

!> Print out a summary of the work done so far (see output file).
  call summary(kvect, nks, ecut,lattice)

  !> \centerline{\includegraphics*[width=16cm]{flux3.png}}

  !> The subroutine {\tt set\_structure\_factor} calculates the atomic 
  !> structure factor for each atomic {\tt species}: \[{1\over \Omega} 
  !> S({\bf G}) = \sum_{\tau} {\rm e}^{-i{\bf G}\cdot \tau},\] 
  !> where the sum is extended to all the atoms (with coordinates $\tau$) 
  !> in the unit cell of the given species, and $\Omega$ is the volume of
  !> the unit cell.
  call set_structure_factor

  !> Calculate the starting potential V$_{in}$ as a superposition  of 
  !> pseudopotentials.
  call set_vbare(vbare)

  open(unit=unit_wvfct,form='unformatted',status='scratch')
  open(unit=unit_wvfct_aux,form='unformatted',status='scratch')

  call construct(v_in,  DIRECT_SPACE)
  call construct(v_out, DIRECT_SPACE)
  call construct(velec, DIRECT_SPACE)

  vscf = vbare

  tr2  = one
  iter = 1
  conv=.false.

  ethr = sqrt(tol)/100.0

  !> \centerline{\LARGE \bf 2) SELF-CONSISTENT LOOP} 
  !> \centerline{\includegraphics*[width=16cm]{flux4.png}}
  ITERATE: do while(iter <= maxter .and. .not.conv)
     write(6,'(/,78(''*''))')
     write(6,'(5x,'' Iteration  '',i5,'' ecut='',f7.2,'' beta='',f7.2)') &
                     iter,ecut,beta
     write(6,'(78(''*''))')

  !> The new potential is updated
     v_in = vscf

     !> The Kohn-Sham equation, expressed in form of an eigenvalue equation, 
     !> \[ \sum_{\bf G^\prime} {\cal H}_{\bf k+G,k+G^\prime} \, 
     !> \tilde{\psi}_{{\bf G^\prime},\nu} ({\bf k}) = \epsilon_{{\bf k},\nu} 
     !> \, \tilde{\psi}_{{\bf G},\nu}({\bf k}), \]
     !> is solved for each {\bf k}-point in the subroutine {\tt c\_bands}.
     call c_bands(kvect,nbnd,isolve)
     !> The eigenvalues $\epsilon_{{\bf k},\nu}$ ($\Rightarrow$ energy bands)
     !> and the eigenvectors $\tilde{\psi}_{{\bf G},\nu}({\bf k})$  are then
     !> used in the subroutine {\tt sum\_bands} to calculate the new electron 
     !> density \[ \rho_{out}({\bf r}) = \sum_{{\bf k}\nu} 
     !> \mid\psi_{{\bf k}\nu}({\bf r})\mid^2 \, w_{\bf k}, \] 
     !> and the band energy E$_{\rm band}$: \[ E_{\rm band} =
     !> \sum_{{\bf k},\nu} \epsilon_{{\bf k},\nu}. \]
     write(*,*)
     call sum_bands(kvect,nbnd,nelec)
     !> The functionals of the density (the Hartree potential $V_{\rm H}$
     !> and the exchange-correlation potential $\mu_{\rm xc}$ and energy 
     !> $\varepsilon_{\rm xc})$ are calculated in subroutine {\tt v\_of\_rho}. 
     !> \[ V_{\rm H}[\rho({\bf r})] = e^2 \int \frac{\rho_{\rm out}({\bf r}
     !> ^\prime)}
     !> {\mid{\bf r-r^\prime}\mid} {\rm d \bf r^\prime} \] 
     call v_of_rho(rho,velec)
     !> The effective potential $V_{\rm out}$ is updated:
     !> \[ V_{\rm out}({\bf r}) = V_{\rm ions}({\bf r}) + V_{\rm H}({\bf r}) +
     !> \mu_{\rm xc}[\rho_{out}({\bf r})] .\]
     v_out = vbare
     call axpy(ONE,velec,v_out)
     !> To improve convergence, the potential for the next iteration is 
     !> obtained by mixing $V_{\rm in}$ and $V_{\rm out}$. In this example the
     !> Broyden mixing method is employed. The potential $V_{\rm in}$ is then 
     !> updated.
!     conv = linear_mixing(v_in,v_out,beta,tol,tr2)
     conv = broyden(v_in,v_out,beta,iter,n_iter,tol,tr2)
     vscf    = v_out
     delta_v = v_in

!> The total energy $E_{\rm tot}$ is finally calculated in subroutine 
!> {\tt tot\_ene}: \[ E_{\rm tot} = E_{\rm band} - \frac{1}{2}
!> \int \rho({\bf r}) V_{\rm H}[\rho({\bf r})] {\rm d \bf r} +
!> \int \rho({\bf r}) \left( \varepsilon_{\rm xc}[
!> \rho({\bf r})] - \mu_{\rm xc}[\rho({\bf r})]
!> \right) {\rm d \bf r}. \]
     call tot_ene(conv)
     write(6,'(5x,''tr2 ='',e22.2)') tr2
     iter=iter+1
  !> Endo of the self-consistent loop.
  end do ITERATE

  if (conv) then
     write(*,'(a)')  ' Convergence has been achieved '
  else
     write(*,'(a,i6)') &
          ' Maximum number of iteration exceeded. maxter = ', maxter
     write(*,'(a)')  ' Convergence has not been achieved '
     stop
  end if
!  call forces()
!>
!> In order to compute phonon frequencies we must know the wavefunctions
!> at ${\bf k}$ and ${\bf k+q}$. We compute here the wavefunctions with
!> the current self-consistent potential. 
!>

 allocate(xkq(3,2*nks),wkq(2*nks))
 wkq=0.d0
 do i=1,nks
    xkq(:,2*i-1)=xk(:,i)
    wkq(2*i-1)=wk(i)
    xkq(:,2*i)=xk(:,i)+q(:)
 enddo
 allocate(kvectq(2*nks))
 call construct(kvectq(1:2*nks),xkq(:,1:2*nks),ecut,wkq(1:2*nks))
  
 first=.true.
 call c_bands(kvectq,nbnd,isolve)
!>
!> The subroutine phonon calculates the phonon frequencies. It solves the 
!> linear system, computes the dynamical matrix and diagonalizes it.
!>
 call phonon(ecut)
!
 call destroy(kvect)
 deallocate(kvect)
 call destroy(kvectq)
 deallocate(kvectq)

 close(unit=unit_wvfct)
 close(unit=unit_wvfct_aux)

stop

end program dfpt
