quantum-espresso/PH/solve_linter.f90

!
! 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 .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
subroutine solve_linter (irr, imode0, npe, drhoscf)
  !-----------------------------------------------------------------------
  !
  !    Driver routine for the solution of the linear system which
  !    defines the change of the wavefunction due to a lattice distorsion
  !    It performs the following tasks:
  !     a) computes the bare potential term Delta V | psi > 
  !        and an additional term in the case of US pseudopotentials
  !     b) adds to it the screening term Delta V_{SCF} | psi >
  !     c) applies P_c^+ (orthogonalization to valence states)
  !     d) calls cgsolve_all to solve the linear system
  !     e) computes Delta rho, Delta V_{SCF} and symmetrizes them
  !
  USE ions_base,            ONLY : nat
  USE io_global,            ONLY : stdout, ionode
  USE io_files,             ONLY : prefix, iunigk
  USE check_stop,           ONLY : time_max => max_seconds
  USE wavefunctions_module, ONLY : evc
  USE constants,            ONLY : degspin
  USE kinds,                ONLY : DP
  USE control_flags,        ONLY : reduce_io
  USE becmod,               ONLY : becp  
  use pwcom
  USE uspp_param,           ONLY : nhm
  USE control_ph,           ONLY : irr0, niter_ph, nmix_ph, elph, tr2_ph, &
                                   alpha_pv, lgamma, convt, nbnd_occ, alpha_mix
  USE nlcc_ph,              ONLY : nlcc_any
  USE units_ph,             ONLY : iudrho, lrdrho, iudwf, lrdwf, iubar, lrbar, &
                                   iuwfc, lrwfc, iunrec, iudvscf
  USE output,               ONLY : fildrho, fildvscf
  USE phus,                 ONLY : int1, int2, int3
  USE efield,               ONLY : epsilon, zstareu, zstarue, zstareu0, zstarue0
  USE dynmat,               ONLY : dyn, dyn00
  USE eqv,                  ONLY : dvpsi, dpsi, evq
  USE qpoint,               ONLY : npwq, igkq, nksq
  USE partial,              ONLY : comp_irr, done_irr, ifat
  USE modes,                ONLY : npert, u
  !
  implicit none

  integer :: irr, npe, imode0
  ! input: the irreducible representation
  ! input: the number of perturbation
  ! input: the position of the modes

  complex(kind=DP) :: drhoscf (nrxx, nspin, npe)
  ! output: the change of the scf charge

  real(kind=DP) , allocatable :: h_diag (:,:),eprec (:)
  ! h_diag: diagonal part of the Hamiltonian
  ! eprec : array for preconditioning
  real(kind=DP) :: thresh, anorm, averlt, dr2
  ! thresh: convergence threshold
  ! anorm : the norm of the error
  ! averlt: average number of iterations
  ! dr2   : self-consistency error
  real(kind=DP) :: dos_ef, wg1, w0g, wgp, wwg, weight, deltae, theta, &
       aux_avg (2)
  ! Misc variables for metals
  ! dos_ef: density of states at Ef
  real(kind=DP), external :: w0gauss, wgauss
  ! functions computing the delta and theta function

  complex(kind=DP), pointer :: dvscfin(:,:,:), dvscfins (:,:,:)
  ! change of the scf potential (input): complete, smooth part only
  complex(kind=DP), allocatable :: drhoscfh (:,:,:), dvscfout (:,:,:)
  ! change of rho / scf potential (output)
  ! change of scf potential (output)
  complex(kind=DP), allocatable :: ldos (:,:), ldoss (:,:),&
       dbecsum (:,:,:,:), auxg (:), aux1 (:), ps (:,:)
  ! Misc work space
  ! ldos : local density of states af Ef
  ! ldoss: as above, without augmentation charges
  ! dbecsum: the derivative of becsum
  complex(kind=DP) :: ZDOTC
  ! the scalar product function

  logical :: conv_root,  & ! true if linear system is converged
             exst,       & ! used to open the recover file
             lmetq0        ! true if xq=(0,0,0) in a metal

  integer :: kter,       & ! counter on iterations
             iter0,      & ! starting iteration
             ipert,      & ! counter on perturbations
             ibnd, jbnd, & ! counter on bands
             iter,       & ! counter on iterations
             lter,       & ! counter on iterations of linear system
             ltaver,     & ! average counter
             lintercall, & ! average number of calls to cgsolve_all
             ik, ikk,    & ! counter on k points
             ikq,        & ! counter on k+q points
             ig,         & ! counter on G vectors
             ir,         & ! counter on mesh points
             is,         & ! counter on spin polarizations
             nrec, nrec1,& ! the record number for dvpsi and dpsi
             ios,        & ! integer variable for I/O control
             mode          ! mode index

  real(kind=DP) :: tcpu, get_clock ! timing variables

  character (len=256) :: flmixdpot ! name of the file with the mixing potential

  external ch_psi_all, cg_psi
  !
  call start_clock ('solve_linter')
  allocate (ps (nbnd, nbnd))
  allocate (dvscfin ( nrxx , nspin , npe))    
  if (doublegrid) then
     allocate (dvscfins ( nrxxs , nspin , npe))    
  else
     dvscfins => dvscfin
  endif
  allocate (drhoscfh ( nrxx , nspin , npe))    
  allocate (dvscfout ( nrxx , nspin , npe))    
  allocate (auxg (npwx))    
  allocate (dbecsum ( (nhm * (nhm + 1))/2 , nat , nspin , npe))    
  allocate (aux1 ( nrxxs))    
  allocate (h_diag ( npwx , nbnd))    
  allocate (eprec ( nbnd))
  !
  if (irr0 > 0) then
     ! restart from Phonon calculation
     read (iunrec) iter0, convt, dr2
     read (iunrec) dvscfin
     if (okvan) read (iunrec) int3
     close (unit = iunrec, status = 'keep')
     ! reset irr0 to avoid trouble at next irrep
     irr0 = 0
     if (doublegrid) then
        do is = 1, nspin
           do ipert = 1, npe
              call cinterpolate (dvscfin(1,is,ipert), dvscfins(1,is,ipert), -1)
           enddo
        enddo
     endif
  else
    iter0 = 0
    convt = .false.
  endif
  !
  ! if q=0 for a metal: allocate and compute local DOS at Ef
  !

  lmetq0 = degauss.ne.0.d0.and.lgamma
  if (lmetq0) then
     allocate ( ldos ( nrxx  , nspin) )    
     allocate ( ldoss( nrxxs , nspin) )    
     call localdos ( ldos , ldoss , dos_ef )
  endif
  !
  if (reduce_io) then
     flmixdpot = ' '
  else
     flmixdpot = 'mixd'
  endif
  !
  IF (ionode .AND. fildrho /= ' ') THEN
     INQUIRE (UNIT = iudrho, OPENED = exst)
     IF (exst) CLOSE (UNIT = iudrho, STATUS='keep')
     CALL DIROPN (iudrho, TRIM(fildrho)//'.u', lrdrho, exst)
  end if
  !
  !   The outside loop is over the iterations
  !
  do kter = 1, niter_ph
     iter = kter + iter0

     ltaver = 0

     lintercall = 0
     drhoscf(:,:,:) = (0.d0, 0.d0)
     dbecsum(:,:,:,:) = (0.d0, 0.d0)
     !
     if (nksq.gt.1) rewind (unit = iunigk)
     do ik = 1, nksq
        if (nksq.gt.1) then
           read (iunigk, err = 100, iostat = ios) npw, igk
100        call errore ('solve_linter', 'reading igk', abs (ios) )
        endif
        if (lgamma) then
           ikk = ik
           ikq = ik
           npwq = npw
        else
           ikk = 2 * ik - 1
           ikq = ikk + 1
        endif
        if (lsda) current_spin = isk (ikk)
        if (.not.lgamma.and.nksq.gt.1) then
           read (iunigk, err = 200, iostat = ios) npwq, igkq
200        call errore ('solve_linter', 'reading igkq', abs (ios) )

        endif
        call init_us_2 (npwq, igkq, xk (1, ikq), vkb)
        !
        ! reads unperturbed wavefuctions psi(k) and psi(k+q)
        !
        if (nksq.gt.1) then
           if (lgamma) then
              call davcio (evc, lrwfc, iuwfc, ikk, - 1)
           else
              call davcio (evc, lrwfc, iuwfc, ikk, - 1)
              call davcio (evq, lrwfc, iuwfc, ikq, - 1)
           endif

        endif
        !
        ! compute the kinetic energy
        !
        do ig = 1, npwq
           g2kin (ig) = ( (xk (1,ikq) + g (1, igkq(ig)) ) **2 + &
                          (xk (2,ikq) + g (2, igkq(ig)) ) **2 + &
                          (xk (3,ikq) + g (3, igkq(ig)) ) **2 ) * tpiba2
        enddo
        !
        ! diagonal elements of the unperturbed hamiltonian
        !
        do ipert = 1, npert (irr)
           mode = imode0 + ipert
           nrec = (ipert - 1) * nksq + ik
           !
           !  and now adds the contribution of the self consistent term
           !
           if (iter == 1) then
              !
              !  At the first iteration dvbare_q*psi_kpoint is calculated
              !  and written to file
              !
              call dvqpsi_us (ik, mode, u (1, mode),.false. )
              call davcio (dvpsi, lrbar, iubar, nrec, 1)
           else
              !
              ! After the first iteration dvbare_q*psi_kpoint is read from file
              !
              call davcio (dvpsi, lrbar, iubar, nrec, - 1)
              !
              ! calculates dvscf_q*psi_k in G_space, for all bands, k=kpoint
              ! dvscf_q from previous iteration (mix_potential)
              !
              call start_clock ('vpsifft')
              do ibnd = 1, nbnd_occ (ikk)
                 aux1(:) = (0.d0, 0.d0)
                 do ig = 1, npw
                    aux1 (nls (igk (ig) ) ) = evc (ig, ibnd)
                 enddo
                 call cft3s (aux1, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, + 2)
                 do ir = 1, nrxxs
                    aux1 (ir) = aux1 (ir) * dvscfins (ir, current_spin, ipert)
                 enddo
                 call cft3s (aux1, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, - 2)
                 do ig = 1, npwq
                    dvpsi(ig,ibnd) = dvpsi(ig,ibnd) + aux1(nls(igkq(ig)))
                 enddo
              enddo
              call stop_clock ('vpsifft')
              !
              !  In the case of US pseudopotentials there is an additional 
              !  selfconsist term which comes from the dependence of D on 
              !  V_{eff} on the bare change of the potential
              !
              call adddvscf (ipert, ik)
           endif
           !
           ! Ortogonalize dvpsi to valence states: ps = <evq|dvpsi>
           !
           call start_clock ('ortho')
           !
           if (degauss > 0.d0) then
              !
              !  metallic case
              !
              CALL ZGEMM( 'C', 'N', nbnd, nbnd_occ (ikk), npwq, &
                   (1.d0,0.d0), evq(1,1), npwx, dvpsi(1,1), npwx, &
                   (0.d0,0.d0), ps(1,1), nbnd )
              !
              do ibnd = 1, nbnd_occ (ikk)
                 wg1 = wgauss ((ef-et(ibnd,ikk)) / degauss, ngauss)
                 w0g = w0gauss((ef-et(ibnd,ikk)) / degauss, ngauss) / degauss
                 do jbnd = 1, nbnd
                    wgp = wgauss ( (ef - et (jbnd, ikq) ) / degauss, ngauss)
                    deltae = et (jbnd, ikq) - et (ibnd, ikk)
                    theta = wgauss (deltae / degauss, 0)
                    wwg = wg1 * (1.d0 - theta) + wgp * theta
                    if (jbnd <= nbnd_occ (ikq) ) then
                       if (abs (deltae) > 1.0d-5) then
                          wwg = wwg + alpha_pv * theta * (wgp - wg1) / deltae
                       else
                          !
                          !  if the two energies are too close takes the limit
                          !  of the 0/0 ratio
                          !
                          wwg = wwg - alpha_pv * theta * w0g
                       endif
                    endif
                    !
                    ps(jbnd,ibnd) = wwg * ps(jbnd,ibnd)
                    !
                 enddo
                 call DSCAL (2*npwq, wg1, dvpsi(1,ibnd), 1)
              enddo
           else
              !
              !  insulators
              !
              ps (:,:) = (0.d0, 0.d0)
              CALL ZGEMM( 'C', 'N', nbnd_occ(ikq), nbnd_occ (ikk), npwq, &
                   (1.d0,0.d0), evq(1,1), npwx, dvpsi(1,1), npwx, &
                   (0.d0,0.d0), ps(1,1), nbnd )
           end if
#ifdef __PARA
           call reduce (2 * nbnd * nbnd_occ(ikk), ps)
#endif
           !
           !!CALL ZGEMM( 'N', 'N', npwq, nbnd_occ(ikk), nbnd, &
           !!    (1.d0,0.d0), evq(1,1), npwx, ps(1,1), nbnd, (0.d0,0.d0), &
           !!     dpsi(1,1), npwx )
           !
           !!call ccalbec (nkb, npwx, npwq, nbnd_occ (ikk), becp, vkb, dpsi)
           !!call s_psi (npwx, npwq, nbnd_occ (ikk), dpsi, spsi)
           !!call DAXPY (2 * npwx * nbnd_occ (ikk), -1.0d0, spsi, 1, dvpsi, 1)
           !!call DSCAL (2 * npwx * nbnd_occ (ikk), -1.0d0,dvpsi, 1)
           !
           ! dpsi is used as work space to store S|evc>
           !
           CALL ccalbec (nkb, npwx, npwq, nbnd_occ(ikk), becp, vkb, evq)
           CALL s_psi (npwx, npwq, nbnd_occ(ikk), evq, dpsi)
           !
           ! |dvspi> = - (|dvpsi> - S|evq><evq|dvpsi>)
           !  note the change of sign!
           !
           CALL ZGEMM( 'N', 'N', npwq, nbnd_occ(ikk), nbnd, &
               ( 1.d0,0.d0), dpsi(1,1), npwx, ps(1,1), nbnd, (-1.0d0,0.d0), &
                dvpsi(1,1), npwx )
           call stop_clock ('ortho')
           !
           if (iter == 1) then
              !
              !  At the first iteration dpsi and dvscfin are set to zero
              !
              dpsi(:,:) = (0.d0, 0.d0) 
              dvscfin (:, :, ipert) = (0.d0, 0.d0)
              !
              ! starting threshold for iterative solution of the linear system
              !
              thresh = 1.0d-2
           else
              !
              ! starting value for delta_psi is read from iudwf
              !
              nrec1 = (ipert - 1) * nksq + ik
              call davcio ( dpsi, lrdwf, iudwf, nrec1, -1)
              !
              ! threshold for iterative solution of the linear system
              !
              thresh = min (1.d-1 * sqrt (dr2), 1.d-2)
           endif

           !
           ! iterative solution of the linear system (H-eS)*dpsi=dvpsi,
           ! dvpsi=-P_c^+ (dvbare+dvscf)*psi , dvscf fixed.
           !
           do ibnd = 1, nbnd_occ (ikk)
              do ig = 1, npwq
                 auxg (ig) = g2kin (ig) * evq (ig, ibnd)
              enddo
              eprec (ibnd) = 1.35d0 * ZDOTC (npwq, evq (1, ibnd), 1, auxg, 1)
           enddo
#ifdef __PARA
           call reduce (nbnd_occ (ikk), eprec)
#endif
           do ibnd = 1, nbnd_occ (ikk)
              do ig = 1, npwq
                 h_diag(ig,ibnd)=1.d0/max(1.0d0,g2kin(ig)/eprec(ibnd))
              enddo
           enddo
           conv_root = .true.

           call cgsolve_all (ch_psi_all, cg_psi, et(1,ikk), dvpsi, dpsi, &
                             h_diag, npwx, npwq, thresh, ik, lter, conv_root, &
                             anorm, nbnd_occ(ikk) )

           ltaver = ltaver + lter
           lintercall = lintercall + 1
           if (.not.conv_root) WRITE( stdout, '(5x,"kpoint",i4," ibnd",i4,  &
                &              " solve_linter: root not converged ",e10.3)') &
                &              ik , ibnd, anorm
           !
           ! writes delta_psi on iunit iudwf, k=kpoint,
           !
           nrec1 = (ipert - 1) * nksq + ik
           !               if (nksq.gt.1 .or. npert(irr).gt.1)
           call davcio (dpsi, lrdwf, iudwf, nrec1, + 1)
           !
           ! calculates dvscf, sum over k => dvscf_q_ipert
           !
           weight = wk (ikk)
           call incdrhoscf (drhoscf(1,current_spin,ipert), weight, ik, &
                            dbecsum(1,1,current_spin,ipert), mode)
           ! on perturbations
        enddo
        ! on k-points
     enddo
#ifdef __PARA
     !
     !  The calculation of dbecsum is distributed across processors (see addusdbec)
     !  Sum over processors the contributions coming from each slice of bands
     !
     call reduce (nhm * (nhm + 1) * nat * nspin * npe, dbecsum)
#endif

     if (doublegrid) then
        do is = 1, nspin
           do ipert = 1, npert (irr)
              call cinterpolate (drhoscfh(1,is,ipert), drhoscf(1,is,ipert), 1)
           enddo
        enddo
     else
        call ZCOPY (npe*nspin*nrxx, drhoscf, 1, drhoscfh, 1)
     endif
     !
     !    Now we compute for all perturbations the total charge and potential
     !

     call addusddens (drhoscfh, dbecsum, irr, imode0, npe, 0)
#ifdef __PARA
     !
     !   Reduce the delta rho across pools
     !
     call poolreduce (2 * npe * nspin * nrxx, drhoscf)
     call poolreduce (2 * npe * nspin * nrxx, drhoscfh)
#endif
     !
     ! q=0 in metallic case deserve special care (e_Fermi can shift)
     !

     if (lmetq0) call ef_shift(drhoscfh, ldos, ldoss, dos_ef, irr, npe, .false.)
     !
     !   After the loop over the perturbations we have the linear change 
     !   in the charge density for each mode of this representation. 
     !   Here we symmetrize them ...
     !
#ifdef __PARA
     call psymdvscf (npert (irr), irr, drhoscfh)
#else
     call symdvscf (npert (irr), irr, drhoscfh)
#endif
     ! 
     !   ... save them on disk and 
     !   compute the corresponding change in scf potential 
     !
     do ipert = 1, npert (irr)
        if (fildrho.ne.' ') call davcio_drho (drhoscfh(1,1,ipert), lrdrho, &
                                              iudrho, imode0+ipert, +1)
        call ZCOPY (nrxx*nspin, drhoscfh(1,1,ipert), 1, dvscfout(1,1,ipert), 1)
        call dv_of_drho (imode0+ipert, dvscfout(1,1,ipert), .true.)
     enddo
     !
     !   And we mix with the old potential
     !
     call mix_potential (2*npert(irr)*nrxx*nspin, dvscfout, dvscfin, &
                         alpha_mix(kter), dr2, npert(irr)*tr2_ph, iter, &
                         nmix_ph, flmixdpot, convt)
     if (lmetq0.and.convt) &
         call ef_shift (drhoscf, ldos, ldoss, dos_ef, irr, npe, .true.)
     if (doublegrid) then
        do ipert = 1, npe
           do is = 1, nspin
              call cinterpolate (dvscfin(1,is,ipert), dvscfins(1,is,ipert), -1)
           enddo
        enddo
     endif
     !
     !     with the new change of the potential we compute the integrals
     !     of the change of potential and Q
     !
     call newdq (dvscfin, npe)
#ifdef __PARA
     aux_avg (1) = dble (ltaver)
     aux_avg (2) = dble (lintercall)
     call poolreduce (2, aux_avg)
     averlt = aux_avg (1) / aux_avg (2)
#else
     averlt = dble (ltaver) / lintercall
#endif
     tcpu = get_clock ('PHONON')

     WRITE( stdout, '(/,5x," iter # ",i3," total cpu time : ",f7.1, &
          &      " secs   av.it.: ",f5.1)') iter, tcpu, averlt
     dr2 = dr2 / npert (irr)
     WRITE( stdout, '(5x," thresh=",e10.3, " alpha_mix = ",f6.3, &
          &      " |ddv_scf|^2 = ",e10.3 )') thresh, alpha_mix (kter) , dr2
     !
     !    Here we save the information for recovering the run from this poin
     !
     CALL flush_unit( stdout )
     !
     call start_clock ('write_rec')
     call seqopn (iunrec, 'recover', 'unformatted', exst)
     !
     ! irr: state of the calculation
     ! irr > 0: irrep up to irr done
     !
     write (iunrec) irr
     !
     ! partially calculated results
     !
     write (iunrec) dyn, dyn00, epsilon, zstareu, zstarue, zstareu0, zstarue0
     !
     ! info on what to do with various irreps (only if irr > 0)
     !
     write (iunrec) done_irr, comp_irr, ifat
     !
     ! info on current iteration (iter=0 potential mixing not available)
     !
     if (reduce_io) then
        write (iunrec) 0, convt, dr2
     else
        write (iunrec) iter, convt, dr2
     endif
     write (iunrec) dvscfin
     if (okvan) write (iunrec) int3
     close (unit = iunrec, status = 'keep')

     call stop_clock ('write_rec')
     if (convt.or.tcpu.gt.time_max) goto 155

  enddo
155 iter0=0
  if (tcpu.gt.time_max.and..not.convt) then
     WRITE( stdout, '(/,5x,"Stopping for time limit ",2f10.0)') tcpu, time_max
     call stop_ph (.false.)
  endif
  !
  !    There is a part of the dynamical matrix which requires the integral
  !    self consistent change of the potential and the variation of the ch
  !    due to the displacement of the atoms. We compute it here because ou
  !    this routine the change of the self-consistent potential is lost.
  !
  if (convt) then
     call drhodvus (irr, imode0, dvscfin, npe)
     !!! if (fildvscf.ne.' ') write (iudvscf) dvscfin
     if (fildvscf.ne.' ') then
        do ipert = 1, npert (irr)
           call davcio_drho ( dvscfin(1,1,ipert),  lrdrho, iudvscf, &
                              imode0 + ipert, +1 )
        end do
        if (elph) call elphel (npe, imode0, dvscfins)
     end if
  endif
  if (convt.and.nlcc_any) call addnlcc (imode0, drhoscfh, npe)
  if (lmetq0) deallocate (ldoss)
  if (lmetq0) deallocate (ldos)
  deallocate (eprec)
  deallocate (h_diag)
  deallocate (aux1)
  deallocate (dbecsum)
  deallocate (auxg)
  deallocate (dvscfout)
  deallocate (drhoscfh)
  if (doublegrid) deallocate (dvscfins)
  deallocate (dvscfin)
  deallocate (ps)

  call stop_clock ('solve_linter')
  return
end subroutine solve_linter