! FDMNES subroutines
! Calculation of the potential

! Potsup makes the superposition of the atomic potential and density

subroutine Potsup(alfpot,Axe_atom_gr,Bulk_atom_done,Cal_xanes,Chargat,Chargat_init,Chargat_self, &
            Counter_ato,Counter_dip,Counter_ion,Counter_linear,Delta_helm,Delta_z_lin,dExc_ex_nex,drho_ex_nex,dV_ex_nex, &
            dVc_ex_nex, E_moment, E_moment_axis, Exc_abs_i, Excato, Full_atom, Full_pot, Green, &
            Helm_cos,Helm_lin,Helm_mix,Hybrid,i_self,ia_eq_inv,ia_eq_inv_self,iaabs,iaproto,iaprotoi,iapot,icheck,igreq,igroup, &
            igroup_ato,igroup_dip,igroup_ion,Image_charge,iprabs_nonexc,ipr1,itab,itypei,itypep,itypepr,Lmax_pot,Lvval,Magnetic, &
            mpirank0,n_atom_0,n_atom_0_self,n_atom_ind,n_atom_ind_self,n_atom_proto,n_atom_proto_bulk,n_counter_ato,n_counter_dip, &
            n_counter_ion,natome,natome_self,natomeq,natomeq_self,natomp,natomp_ato,natomp_dip,natomp_ion,nb_test,neqm,ngroup_m, &
            ngroup_nonsph,nhybm,nlat,nlatm,nlm_pot,Nonexc,Nonsph,norbv,normrmt,npoint,npoint_ns,npsom,nrato,nrm,nrm_self,nspin, &
            ntype,Numat,One_SCF_surf,Overlap,pop_nonsph,popatm,popatv,Pos,Pos_ato,Pos_dip,Pos_ion,Posi,Proto_calculated,psival, &
            Rato,rho,rho_self,rhoato,rhoato_init,rhoato_out,rhoit,rhons, &
            Rmt,Rmtg,Rmtimp,Rmtg0,Rmtsd,Rot_atom,Rot_atomp,Rot_Atom_nsph,Rot_cluster, &
            rs,rsato,Rsort,SCF,Self_nonexc,Spin_axis_free,Sym_2D,Test_case,V_abs_i,V_helm,V_intmax,V_surf,Vc_abs_i,Vcato, &
            Vcato_init,Vh,Vhns,Vsphere,Vxc,Vxcato,V0bdcFimp,Width_helm,Wigner_one_half,xyz)

  use declarations
  implicit none

  integer, parameter:: nthetam = 60

  integer:: i, i_cycle, i_self, ia, iaabs, iapr, iapr0, iaprabs, index, iprabs_nonexc, iaprex, icheck_10, icheck_11, icheck_12, &
    icheck_13, igr, ipr, ipr1, ir, ispin, it, itab, Lm, Lmax_pot, mpirank0, n_atom_0, n_atom_0_self, n_atom_ind, &
    n_atom_ind_self, n_atom_proto, n_atom_proto_bulk, n_counter_ato, n_counter_dip, n_counter_ion, &
    n_iapr, n_index_ato, n_ipr_useful, n_theta, natome, natome_self, natomeq, natomeq_self, natomp, &
    natomp_ato, natomp_dip, natomp_ion, nb_test, neqm, ngroup_m, ngroup_nonsph, nhybm, nlatm, nlm_pot, normrmt, npoint, &
    npoint_ns, npsom, nr_counter_ato, nrm, nrm_self, nspin, ntype, nv_grad, Z_top

  integer, dimension(30):: icheck
  integer, dimension(natomp):: iapr_p, iaproto, igroup, itypep
  integer, dimension(natomp_ato):: igroup_ato
  integer, dimension(natomp_dip):: igroup_dip
  integer, dimension(natomp_ion):: igroup_ion
  integer, dimension(natome):: iaprotoi, itypei
  integer, dimension(natomeq):: ia_eq_inv
  integer, dimension(natomeq_self):: ia_eq_inv_self
  integer, dimension(0:ntype):: nlat, nrato, Numat
  integer, dimension(0:ngroup_nonsph):: norbv
  integer, dimension(0:n_atom_proto):: iapot, itypepr
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(0:ntype,nlatm):: lvval

  integer, dimension(:), allocatable:: ipr_useful

  complex(kind=db), dimension(nhybm,16,ngroup_nonsph):: hybrid
  complex(kind=db), dimension(2,2,natome):: Wigner_one_half

  logical:: Bulk_atom_done, Cal_xanes, Counter_linear, Do_init, Full_atom, Green, Helm_cos, Helm_lin, Helm_mix, &
    Image_charge, Magnetic, Nonexc, Nonsph, One_SCF_surf, SCF, Self_nonexc, Spin_axis_free, Sym_2D, Ylm_comp

  logical, dimension(nb_test):: Test_case
  logical, dimension(0:n_atom_proto):: Proto_calculated
  logical, dimension(n_atom_0:n_atom_ind):: Full_pot

  real(kind=db):: alfpot, Delta_helm, Delta_z_lin, E_moment, f_integr3, Helm_fac, Overlap, Orig_helm, Rayint, &
    Rsort, Surf_0, V_helm, V_intmax, V0bdcFimp, Vsphere, Width_helm, z, z_bulk, z_max, z_surf, z_surf_eval

  real(kind=db), dimension(3):: Ang, E_moment_axis, V_surf
  real(kind=db), dimension(n_atom_0_self:n_atom_ind_self,nspin):: chargat_init, chargat_self
  real(kind=db), dimension(npoint):: rs, Vh
  real(kind=db), dimension(npoint_ns):: rhons, Vhns
  real(kind=db), dimension(0:ntype):: Rmt, Rmtimp
  real(kind=db), dimension(0:n_atom_proto):: Chargat, Rmtg, Rmtg0, Rmtsd
  real(kind=db), dimension(3,natome):: Posi
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(3,natomp_ato):: Pos_ato
  real(kind=db), dimension(3,natomp_dip):: Pos_dip
  real(kind=db), dimension(3,natomp_ion):: Pos_ion
  real(kind=db), dimension(3,ngroup_m):: Axe_atom_gr
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(6,n_counter_dip):: Counter_dip
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion
  real(kind=db), dimension(0:nrm_self,nlm_pot,nspin,n_atom_0_self:n_atom_ind_self):: rho_self
  real(kind=db), dimension(0:nrm_self,nspin,n_atom_0_self:n_atom_ind_self):: rhoato_init, rhoato_out
  real(kind=db), dimension(nrm):: dExc_ex_nex, dvc_ex_nex, Exc_abs, Exc_abs_i, Vc, Vc_abs_i
  real(kind=db), dimension(nrm,nspin):: drho_ex_nex, dV_ex_nex, dVxc_ex_nex, V_abs_i, Vxc_a
  real(kind=db), dimension(0:nrm_self,nlm_pot,n_atom_0_self:n_atom_ind_self):: Vcato_init
  real(kind=db), dimension(npoint,nspin):: Vxc, rho
  real(kind=db), dimension(3,3):: Rot_cluster, Rot_E_moment
  real(kind=db), dimension(n_atom_0:n_atom_ind):: Rho_cato
  real(kind=db), dimension(nrm,n_atom_0:n_atom_ind):: Excato
  real(kind=db), dimension(nhybm,ngroup_nonsph) :: pop_nonsph
  real(kind=db), dimension(0:ntype,nlatm) :: popatv
  real(kind=db), dimension(4,npsom):: xyz
  real(kind=db), dimension(3,3,natome):: Rot_Atom
  real(kind=db), dimension(3,3,natomp):: Rot_Atomp
  real(kind=db), dimension(3,3,ngroup_nonsph):: Rot_Atom_nsph
  real(kind=db), dimension(0:nrm,n_atom_0:n_atom_ind):: drhoato, rsato
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: dVcato, Vcato
  real(kind=db), dimension(0:nrm,nspin,n_atom_0:n_atom_ind):: rhoato, rho_no_sup
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind):: Vxcato
  real(kind=db), dimension(0:n_atom_proto,nlatm,nspin):: popatm
  real(kind=db), dimension(0:nrm,0:ntype):: Rato, rhoit
  real(kind=db), dimension(0:nrm,nlatm,0:ntype):: psival
  real(kind=db), dimension(0:nrm):: rhr2
  real(kind=db), dimension(n_atom_0:n_atom_ind):: ch

  real(kind=db), dimension(:), allocatable:: Delta_Vcato_ns, r, r_counter_ato, Rhonspr, Vcmft, Vhnspr
  real(kind=db), dimension(:,:), allocatable:: Counter_index_ato, Grad_rho_mft, rho_counter_ato, Rhomft, Vato, Vh_counter_ato, &
                                               Vxcmft, Z_index
  real(kind=db), dimension(:,:,:), allocatable:: rhoigr, rhoigr_int

  allocate( rhonspr(0:n_atom_proto) )
  allocate( Vcmft(0:n_atom_proto) )
  allocate( Vhnspr(0:n_atom_proto) )
  allocate( Grad_rho_mft(0:n_atom_proto,2) )
  allocate( rhomft(0:n_atom_proto,nspin) )
  allocate( Vxcmft(0:n_atom_proto,nspin) )
  allocate( Delta_Vcato_ns(n_atom_0:n_atom_ind) )
  Delta_Vcato_ns(:) = 0._db

! We use a real expansion of potential in spherical harmonics. It is eventually changed in a complex one in mod_V rounine (in sphere.f90)
  Ylm_comp = .false.

! Rotation matrix of the Electric moment case contribution
  Rot_E_moment(:,:) = 0._db
  Rot_E_moment(1,1) = 1._db; Rot_E_moment(2,2) = 1._db; Rot_E_moment(3,3) = 1._db
  if( abs( E_moment ) > eps10 ) then
    if( abs( E_moment_axis(3) ) < 1._db - eps10 ) then
      Ang(1) = datan2( E_moment_axis(2), E_moment_axis(1) )
      Ang(2) = acos( E_moment_axis(3) )
      Ang(3) = 0._db
      call Mat_Euler( Ang, Rot_E_moment )
      Rot_E_moment = matmul( transpose( Rot_cluster ), Rot_E_moment )
! We take the inverse rotation to bring back the FDM points towards Electric moment direction
      Rot_E_moment = transpose( Rot_E_moment )
    else
      Rot_E_moment(:,:) = Rot_cluster(:,:)
    endif
  endif

  if( Cal_xanes ) then
    icheck_10 = icheck(10)
    icheck_11 = icheck(11)
    icheck_12 = icheck(12)
    icheck_13 = icheck(13)
  elseif( icheck(27) > 1 ) then
    icheck_10 = min( icheck(10), icheck(27) )
    icheck_11 = min( icheck(11), icheck(27) )
    icheck_12 = min( icheck(12), icheck(27) )
    icheck_13 = min( icheck(13), icheck(27) )
  else
    icheck_10 = 0
    icheck_11 = 0
    icheck_12 = 0
    icheck_13 = 0
  endif

! Calculation of the superposed potential of the atoms in the cluster
! It is calculated for all non equivalent atoms 1) of the ponctual group when "Full_atom"
!                                               2) of the space group when not "Full_atom"
  if( Cal_xanes ) then
    iapr0 = n_atom_0
    n_iapr = n_atom_ind
  else
    iapr0 = n_atom_0_self
    n_iapr = n_atom_ind_self
  endif

! When not full_tom, and in the case of a large number of non-equivalent atoms, one limits the number of atoms to calculate
! to the ones inside or close to the cluster of calculation
  n_ipr_useful = 1
  do i_cycle = 1,2
    allocate( ipr_useful(0:n_ipr_useful) )
    call Cal_ipr_useful( i_cycle, iaproto, ipr_useful, iprabs_nonexc, n_ipr_useful, natomp )
    if( i_cycle == 1 ) deallocate( ipr_useful )
  end do

  allocate( rhoigr(0:nrm,nspin,0:n_ipr_useful) )
  allocate( rhoigr_int(0:nrm,nspin,0:n_ipr_useful) )
  allocate( Vato(0:nrm,0:n_ipr_useful) )

  if( i_self == 1 ) then
    dExc_ex_nex(:) = 0._db
    drho_ex_nex(:,:) = 0._db
    dVc_ex_nex(:) = 0._db
    dV_ex_nex(:,:) = 0._db
    rhoato_init(:,:,:) = 0._db
    Vcato_init(:,:,:) = 0._db
  endif
  rhonspr(:) = 0._db
  Vhnspr(:) = 0._db
  Orig_helm = 0._db
  z_bulk = - 1000._db
  z_surf = - 1000._db
! V_surf is the direction perpendicular to the surface in the rotated cluster basis
  V_surf(1:3) = Rot_cluster(3,1:3)

! Z_top, the atomic number of the surface atom, is used for the potential of the image charge in Pot0
  z_max = -1000._db
  do ia = 1,natome
    z = sum( V_surf(1:3) * Posi(1:3,ia) )
    if( z < z_max + eps10 ) cycle
    z_max = z
    Z_top = Numat( itypei( ia ) )
  end do

  do it = 0,ntype
    call Potato( iaprotoi, icheck_10, ipr_useful, it, itypepr, n_atom_proto, n_ipr_useful, natome, nlat, nlatm, nrato, &
           nrm, nspin, ntype, Numat, Popatm, Popatv, psival, Rato, rhoigr, rhoigr_int, rhoit, Spin_axis_free, Vato, &
           Wigner_one_half )
  end do

  if( Nonsph ) call Orbval( Delta_Vcato_ns, E_moment_axis, Full_atom, Hybrid, iaproto, iapot, icheck_11, igreq, igroup, &
        ipr_useful, itypepr, Lvval, mpirank0, n_atom_0, n_atom_ind, n_atom_proto, n_ipr_useful, natome, natomp, neqm, &
        ngroup_nonsph, nhybm, nlat,  nlatm, norbv, npoint, npoint_ns, npsom, nrato, nrm, ntype, pop_nonsph, Pos, Posi, Psival, &
        Rato, Rhons, Rhonspr, Rot_Atom_nsph, Rot_cluster, Vhns, Vhnspr, xyz )

  z_surf = z_surf_eval(iaproto,n_atom_proto,n_atom_proto_bulk,natomp,Pos,V_surf)

! Some preliminary works on Helmholtz potential
  if( abs( V_helm ) > eps10 ) &
    call Prepare_Helmholtz(Cal_xanes,Delta_helm,Helm_fac,Helm_lin,Helm_mix,iaproto,icheck_13,n_atom_proto, &
                         n_atom_proto_bulk,Orig_helm,Pos,Surf_0,Sym_2D,V_surf,natomp,Width_helm,z_bulk,z_surf)

! At the first iteration, one calculates both the excited and non excited absorbing atom potential
!  if( i_self == 1 ) iapr0 = 0   ! index for excited atom

  if( Full_atom ) then
    if( ( Cal_xanes .and. .not. nonexc ) .or. ( .not. Cal_xanes .and. .not. self_nonexc ) ) then
      iaprabs = 0
      do ia = 1,n_atom_ind
        if( iaprotoi(ia) == 0 ) exit
      end do
      iaprex = ia  ! index of the absorbing atom in the symmetrized cluster (before excitation)
    else
      do iaprabs = 1,n_atom_ind
        if( iaprotoi(iaprabs) == iprabs_nonexc ) exit
      end do
      iaprex = 0   ! when the absorbing atom is not excited, iaprex is the index of the excited one
    endif
  else
    iaprabs = iprabs_nonexc
    iaprex = 0
  endif

  do ia = 1,natomp
    if( Full_atom .and. ia > natomeq_self ) then
      iapr_p(ia) = -1
    elseif( Full_atom ) then
      iapr_p(ia) = ia_eq_inv_self(ia)
    else
      iapr_p(ia) = iaproto(ia)
    endif
  end do

! Calculation of the difference excited - not excited
  if( i_self == 1 ) then
    do index = 0,n_ipr_useful
      if( ipr_useful(index) == iprabs_nonexc ) exit
    end do
    drho_ex_nex(1:nrm,:) = rhoigr(1:nrm,:,0) - rhoigr(1:nrm,:,index)
    dVc_ex_nex(1:nrm) = Vato(1:nrm,0) - Vato(1:nrm,index)
  endif

  if( icheck(13) > 2 ) write(3,110) i_self, Full_atom, iapr0, n_iapr

  if( nlm_pot > 1 ) then
    n_theta = nthetam
  else
    n_theta = 1
  endif

! Calculation of the atomic Coulomb potential
  call Atom_Coulomb( Bulk_atom_done, Cal_xanes, drho_ex_nex, drhoato, dVc_ex_nex, dVcato, Full_atom, i_self, ia_eq_inv_self, &
          iapot, iapr0, iaprotoi, icheck_13, ipr_useful, iprabs_nonexc, itypepr, Lmax_pot, n_atom_0, n_atom_proto, &
          n_atom_proto_bulk, n_atom_0_self, n_atom_ind, n_atom_ind_self, n_iapr, n_ipr_useful, natome, natome_self, natomeq, &
          natomeq_self, natomp, nlm_pot, Nonexc, nrato, nrm, nrm_self, nspin, ntype, Numat, Pos, Posi, Rato, rho_self, rhoato, &
          rhoato_init, rhoigr, rhonspr, Rmtsd, SCF, Self_nonexc, Vato, Vcato, Vcato_init, Vhnspr, Vsphere )

  n_index_ato = 0

  Rho_cato(:) = 0._db

! Preparation of counter atoms
  if( natomp_ato > 0 ) then

    allocate( Z_index(4,100) )
    Z_index(1,1) = Counter_ato(4,1)
    Z_index(2,1) = Counter_ato(5,1)
    Z_index(3,1) = Counter_ato(7,1)
    Z_index(4,1) = Counter_ato(8,1)
    n_index_ato = 1
    Loop_igr: do igr = 2,n_counter_ato
      do i = 1,n_index_ato
        if(       abs( Counter_ato(4,igr) - Z_index(1,i) ) < eps10 &
            .and. abs( Counter_ato(5,igr) - Z_index(2,i) ) < eps10 &
            .and. abs( Counter_ato(7,igr) - Z_index(3,i) ) < eps10 &
            .and. abs( Counter_ato(8,igr) - Z_index(4,i) ) < eps10 ) cycle Loop_igr
      end do
      n_index_ato = n_index_ato + 1
      Z_index(1,n_index_ato) = Counter_ato(4,igr)
      Z_index(2,n_index_ato) = Counter_ato(5,igr)
      Z_index(3,n_index_ato) = Counter_ato(7,igr)
      Z_index(4,n_index_ato) = Counter_ato(8,igr)
    end do Loop_igr
    allocate( Counter_index_ato(4,n_index_ato) )
    do i = 1,n_index_ato
      Counter_index_ato(:,i) = Z_index(:,i)
    end do
    deallocate( Z_index )

    nr_counter_ato = nrm
  else
    n_index_ato = 0
    nr_counter_ato = 0
    allocate( Counter_index_ato(4,n_index_ato) )
  endif

  allocate( r_counter_ato(0:nr_counter_ato) )
  allocate( Rho_counter_ato(0:nr_counter_ato,n_index_ato) )
  allocate( Vh_counter_ato(0:nr_counter_ato,n_index_ato) )

  if( natomp_ato > 0 ) &
    call Counter_atom_pot(icheck_13,Counter_ato,Counter_index_ato,n_index_ato,n_counter_ato,nr_counter_ato,r_counter_ato, &
                            Rho_counter_ato,Vh_counter_ato)

! Addition of counter atoms potential and electron density
  if( natomp_ato > 0 .and. ( i_self == 1 .or. ( Cal_xanes .and. .not. SCF ) ) ) &
    call Atom_counter_atom(Bulk_atom_done,Cal_xanes,Counter_ato,Counter_index_ato,Full_atom,ia_eq_inv,ia_eq_inv_self, &
        iapot,iapr0,iaprotoi,icheck_13,igroup_ato,iprabs_nonexc,itypei, &
        n_atom_0,n_atom_ind,n_atom_proto,n_atom_proto_bulk,n_counter_ato,n_iapr,n_index_ato,natome,natome_self, &
        natomeq,natomeq_self,natomp,natomp_ato,nlm_pot,nrato,nrm,ntype,Nonexc,nr_counter_ato,Numat,Pos, &
        Pos_ato,Posi,r_counter_ato,Rato,Rho_cato,Rho_counter_ato,SCF,Self_nonexc,Vcato,Vh_counter_ato)

! Addition of counter ions potential
  if( natomp_ion > 0 .and. ( i_self == 1 .or. ( Cal_xanes .and. .not. SCF ) ) ) &
    call Atom_counter_ion(Bulk_atom_done,Cal_xanes,Counter_ion,Counter_linear,Delta_z_lin,Full_atom,ia_eq_inv,ia_eq_inv_self, &
        iapot,iapr0,iaprotoi, &
        icheck_13,igroup_ion,iprabs_nonexc,itypei,Lmax_pot,n_atom_0,n_atom_ind,n_atom_proto,n_atom_proto_bulk,n_counter_ion, &
        n_iapr,n_theta,natome,natome_self,natomeq,natomeq_self,natomp,natomp_ion,nlm_pot,nrato,nrm,ntype,Nonexc,Numat,Pos, &
        Pos_ion,Posi,Rato,SCF,Rot_Atom,Rot_cluster,Self_nonexc,V_surf,Vcato,Ylm_comp,z_surf)

! Addition of counter dipoles potential
  if( natomp_dip > 0 .and. ( i_self == 1 .or. ( Cal_xanes .and. .not. SCF ) ) ) &
   call Atom_counter_dip(Bulk_atom_done,Cal_xanes,Counter_dip,Counter_linear,delta_z_lin,Full_atom,ia_eq_inv, &
        ia_eq_inv_self,iapot,iapr0,iaprotoi, &
        icheck_13,igroup_dip,iprabs_nonexc,itypei,n_atom_0,n_atom_ind,n_atom_proto,n_atom_proto_bulk,n_counter_dip, &
        n_iapr,natome,natome_self,natomeq,natomeq_self,natomp,natomp_dip,nlm_pot,nrm,ntype,Nonexc,Numat,Pos, &
        Pos_dip,Posi,Rot_cluster,SCF,Self_nonexc,Vcato,V_surf,z_surf)

! Addition of the Helmholtz potential
  if( abs( V_helm ) > eps10 .and. ( i_self == 1 .or. ( Cal_xanes .and. .not. SCF ) ) ) &
    call Atom_Helmholtz(Cal_xanes,Full_atom,Helm_cos,Helm_fac,Helm_lin,Helm_mix,ia_eq_inv,ia_eq_inv_self,iapot,iapr0,iaprotoi, &
        icheck_13,iprabs_nonexc,itypei,Lmax_pot,n_atom_0,n_atom_ind,n_atom_proto,n_atom_proto_bulk,n_iapr,n_theta,natome, &
        natome_self,natomeq,natomeq_self,natomp,nlm_pot,nrato,nrm,ntype,Nonexc,Numat,Orig_helm,Pos,Posi,Rato,SCF,Rot_Atom, &
        Self_nonexc,Surf_0,Sym_2D,V_helm,V_surf,Vcato,Width_helm,z_bulk,z_surf)

  if( i_self == 1 ) rho_no_sup(:,:,:) = rhoato(:,:,:)

! Superposition of the potential inside the atoms
  call Pot0muffin( alfpot, Bulk_atom_done, Cal_xanes, Chargat, chargat_init, chargat_self, Delta_Vcato_ns, dExc_ex_nex, &
        drho_ex_nex, dVc_ex_nex, dVcato, dVxc_ex_nex, E_moment, Excato, Full_atom, i_self, ia_eq_inv, ia_eq_inv_self, &
        iaproto, iapot, iapr_p, &
        iapr0, iaprex, iaprotoi, icheck_13, ipr_useful, iprabs_nonexc, itypep, itypepr, Lmax_pot, Magnetic, &
        n_atom_0, n_atom_0_self, n_atom_ind, n_atom_ind_self, n_atom_proto, n_atom_proto_bulk, n_iapr, n_ipr_useful, natome, &
        natome_self, natomeq, natomeq_self, natomp, nb_test, nlm_pot, Nonexc, nrato, nrm,nrm_self, nspin, ntype, Numat, &
        One_SCF_surf, Pos, Posi, Rato, Rho_cato, rho_self, rhoato, rhoato_out, Rhoigr, Rot_atom, Rot_atomp, Rot_E_moment, &
        rsato, SCF, Self_nonexc, Test_case, Vato, Vcato, Vxcato, Ylm_comp )

  Full_pot(:) = .false.
  if( nlm_pot > 1 ) then
    Loop_iapr: do iapr = n_atom_0,n_atom_ind
      if( Full_atom ) then
        ipr = iaprotoi(iapr)
      else
        ipr = iapr
      endif
      it = itypepr(ipr)
      do ir = 10,nrato(it),10
        do Lm = 2,nlm_pot
          if( abs( Vcato(ir,Lm,iapr) ) > 1.e-8_db .or. abs( Vxcato(ir,Lm,1,iapr) ) > 1.e-8_db ) then
            Full_pot(iapr) = .true.
            cycle Loop_iapr
          endif
        end do
      end do
    end do Loop_iapr
    if( icheck_13 > 0 ) write(3,115) Full_pot(:)
  endif

  if( .not. Cal_xanes .or. i_self == 1 ) then
    allocate( r(nrm) )

    if( Self_nonexc .or. ( Cal_xanes .and. Nonexc ) ) then

      Vc(1:nrm) = Vcato(1:nrm,1,iaprabs)
      Vxc_a(1:nrm,1:nspin) = Vxcato(1:nrm,1,1:nspin,iaprabs)
      Exc_abs(:) = Excato(:,iaprabs)
      r(1:nrm) = rato(1:nrm,itab)
      call mod_V_abs(Exc_abs,Exc_abs_i,icheck_13,nrm,nspin,r,V_abs_i,Vc,Vc_abs_i,Vxc_a)

    else

      do ispin = 1,nspin
        dV_ex_nex(:,ispin) = dVc_ex_nex(:) + dVxc_ex_nex(:,ispin)
      end do

      Vc(1:nrm) = Vcato(1:nrm,1,iaprex) - dVc_ex_nex(1:nrm)
      do ispin = 1,nspin
        Vxc_a(1:nrm,ispin) = Vxcato(1:nrm,1,ispin,iaprex) - dVxc_ex_nex(1:nrm,ispin)
      end do
      Exc_abs(:) = Excato(:,iaprex) - dExc_ex_nex(:)
      r(1:nrm) = rato(1:nrm,itab)
      call mod_V_abs(Exc_abs,Exc_abs_i,icheck_13,nrm,nspin,r,V_abs_i,Vc,Vc_abs_i,Vxc_a)

    endif

    deallocate( r )
  endif

! Storage of the potential and electronic density
  if( i_self == 1 ) then
    do iapr = n_atom_0_self,n_atom_ind_self
      if( iapr < n_atom_0 .or. iapr > n_atom_ind ) cycle
      rhoato_init(:,:,iapr) = rhoato(:,:,iapr)
      Vcato_init(:,:,iapr) = Vcato(:,:,iapr)
    end do
  endif

  if( Full_atom ) then
    Do_init = i_self == 1 .and. .not. Cal_xanes
    call Force_pot_eq(Do_init,drhoato,dVcato,Excato,iaprotoi,n_atom_0,n_atom_0_self,n_atom_ind,n_atom_ind_self, &
                   natome,nlm_pot,nrm,nrm_self,nspin,Posi,rho_no_sup,rhoato,rhoato_init,rhoato_out,rsato,Vcato,Vcato_init,Vxcato)
  endif

! Calculation of the muffin-tin atomic radius
  call Raymuf(Cal_xanes,Chargat,Full_atom,i_self,iapot,iaproto,iaprotoi,icheck_13,iprabs_nonexc, &
        ipr1,itab,itypei,itypep,itypepr,n_atom_0,n_atom_ind,n_atom_proto,natome,natomeq,natomp,nlm_pot, &
        normrmt,nrato,nrm,nspin,ntype,Numat,Overlap,Pos,Rato,rhoato,Rmtg,Rmtg0,Rmtimp, &
        Rmtsd,Rsort,V0bdcFimp,Vcato,Vxcato)

  if( i_self == 1 .and. icheck(13) > 2 ) then
    it = itab
    if( nspin == 1 ) then
      write(3,120) iaprabs
    else
      write(3,125) iaprabs
    endif
    do ir = 1,nrato(it)
      write(3,130) Rato(ir,it)*bohr, quatre_pi * Rato(ir,it)**2 * drho_ex_nex(ir,:), dV_ex_nex(ir,:)*Rydb, dVc_ex_nex(ir)*Rydb
    end do

! Writing: the atom charge is integrated up to Rmtsd, here before any superposition
    allocate( r(0:nrm) )
    ch(:) = 0._db
    write(3,'(/A)') ' Before superposing the electronic densities'
    write(3,'(/A)') '    ia      charge '
    do iapr = n_atom_0,n_atom_ind
      if( Full_atom ) then
        ipr = iaprotoi(iapr)
      else
        ipr = iapr
        if( ( ipr == 0 .and. ipr1 == 1 ) .or. .not. Proto_calculated(ipr) ) cycle
      endif
      it = itypepr(ipr)
      r(:) = Rato(:,it)
      rayint = Rmtsd(ipr)
      do ispin = 1, nspin
        rhr2(:) = rho_no_sup(:,ispin,iapr) * r(:)**2
        ch(iapr) = ch(iapr) + quatre_pi * f_integr3(r,rhr2,0,nrm,rayint)
      end do
      write(3,160) iapr, ch(iapr)
    end do
    deallocate( r )
  end if

! Calculation of the potential and density at the muffin-tin radius without Overlap
  call Potrmt(Full_atom,Grad_rho_mft,iaprotoi,ipr1,iprabs_nonexc,itypepr,n_atom_0,n_atom_ind,n_atom_proto,natome,nlm_pot, &
                  nrato,nrm,nspin,ntype,Numat,Rato,rhoato,rhomft,Rmtg0,Vcato,Vcmft,Vxcato,Vxcmft,iapot)

! Polynomial approximation of rhoigr at R > Rmtg

  if( Green .or. abs( alfpot + 2._db ) > eps10 ) then
    nv_grad = 0
  else ! neighbor points for the calculation of PBE96
    nv_grad = 18
  endif

! Calculation of the intersitial potential, on the FDM grid of points
  call Pot0( alfpot, Axe_atom_gr, Bulk_atom_done, Cal_xanes, Chargat, Counter_ato, Counter_index_ato, Counter_dip, &
        Counter_ion, Counter_linear, delta_z_lin, drhoato, dVcato, E_moment, Helm_cos, Helm_fac, Helm_lin, Helm_mix, i_self, &
        iaabs, iapr_p, iaproto, icheck_12, igreq, igroup, igroup_ato, igroup_dip, igroup_ion, Image_charge, ipr_useful, itypep, &
        Lmax_pot, Magnetic, n_atom_0, n_atom_ind, n_atom_ind_self, n_atom_proto, n_atom_proto_bulk, n_counter_ato, &
        n_counter_dip, n_counter_ion, n_index_ato, n_ipr_useful, natomeq, natomp, natomp_ato, natomp_dip, natomp_ion, nb_test, &
        neqm, ngroup_m, nlm_pot, Nonsph, npoint, npoint_ns, npsom, nr_counter_ato, nrato, nrm, nspin, ntype, nv_grad, &
        One_SCF_surf, Orig_helm, Pos, Pos_ato, Pos_dip, Pos_ion, R_counter_ato, Rato, rho, Rho_counter_ato, rhons, Rot_cluster, &
        Rot_E_moment, rs, rhoigr_int, Rmt, Rmtg0, Rmtsd, Rot_Atomp, SCF, Surf_0, Sym_2D, Test_case, V_helm, V_intmax, V_surf, &
        Vato, Vh, Vh_counter_ato, Vhns, Vsphere, Vxc, Width_helm, xyz, Ylm_comp, z_bulk, z_surf, Z_top )

  deallocate( Counter_index_ato, Delta_Vcato_ns, ipr_useful, r_counter_ato, Rho_counter_ato, rhoigr, rhoigr_int, Vato, &
              Vh_counter_ato )
  deallocate( Grad_rho_mft, Rhomft, rhonspr, Vcmft, Vhnspr, Vxcmft )

  return
  110 format(/' i_self =',i3,', Full_atom =',l2,/ ' iapr0 =',i2,', n_iapr =',i3)
  115 format(/' Full potential by atom:',100L3)
  120 format(/' Difference of charge and potential between excited and non excited atom (iapr =',i3,') :',/ &
          '       r      4*pi*r2*drho   dV_ex_nex   dVc_ex_nex')
  125 format(/' Difference of charge and potential between excited and non excited atom (iapr =',i3,') :',/ &
          '       r    4*pi*r2*drho(up) 4*pi*r2*drho(dn)  dV_ex_nex(up)  dV_ex_nex(dn) dVc_ex_nex')
  130 format(1p,10e13.5)
  160 format(2x,i3,f9.3)
end

!***********************************************************************

! Calculation of ipr index usefull to calculate the potential

subroutine Cal_ipr_useful( i_cycle, iaproto, ipr_useful, iprabs_nonexc, n_ipr_useful, natomp )

  use declarations
  implicit none

  integer:: i_cycle, ia, ib, index, ipr, iprabs_nonexc, n_ipr_useful, natomp

  integer, dimension(natomp):: iaproto
  integer, dimension(0:n_ipr_useful):: ipr_useful

  ipr_useful(0) = 0
  ipr_useful(1) = iprabs_nonexc

  index = 1

  Loop_ia: do ia = 1,natomp
    ipr = iaproto(ia)
    if( ipr == 0 .or. ipr == iprabs_nonexc ) cycle
    do ib = 1,ia-1
      if( ipr == iaproto(ib) ) cycle Loop_ia
    end do
    index = index + 1
    if( i_cycle == 2 ) ipr_useful( index ) = ipr
  end do Loop_ia

  if( i_cycle == 1 ) n_ipr_useful = index

  return
end

!***********************************************************************

! Calculation of the atomic potential

subroutine Potato( iaprotoi, icheck_10, ipr_useful, it, itypepr, n_atom_proto, n_ipr_useful, natome, nlat, nlatm, nrato, &
           nrm, nspin, ntype, Numat, Popatm, Popatv, psival, Rato, rhoigr, rhoigr_int, rhoit, Spin_axis_free, Vato, &
           Wigner_one_half )

  use declarations
  implicit none

  integer:: ia, DeuxZ, icalcul, icheck_10, index, ipr, ir, isp, isq, it, L, n_atom_proto, n_ipr_useful, natome, nl, nlatm,&
            nr, nrm, nspin, ntype

  integer, dimension(natome):: iaprotoi
  integer, dimension(0:ntype):: nlat, nrato, Numat
  integer, dimension(0:n_atom_proto):: itypepr
  integer, dimension(0:n_ipr_useful):: ipr_useful

  complex(kind=db), dimension(2,2):: Wigner
  complex(kind=db), dimension(2,2,natome):: Wigner_one_half

  logical:: Spin_axis_free

  real(kind=db):: dp_new, facspin, p1, p2, Pop_new, qpi

  real(kind=db), dimension(nspin):: dp, Pop
  real(kind=db), dimension(0:nrm):: r
  real(kind=db), dimension(0:nrm,0:n_ipr_useful):: Vato
  real(kind=db), dimension(0:ntype,nlatm):: Popatv
  real(kind=db), dimension(0:nrm,nspin,0:n_ipr_useful):: Rhoigr, Rhoigr_int
  real(kind=db), dimension(0:n_atom_proto,nlatm,nspin):: Popatm
  real(kind=db), dimension(0:nrm,0:ntype):: Rato, Rhoit
  real(kind=db), dimension(0:nrm,nlatm,0:ntype):: Psival

  real(kind=db), dimension(:), allocatable:: Rho, Vh, Vhato
  real(kind=db), dimension(:,:), allocatable:: Rhoval, Vhval

  if( icheck_10 > 1 .and. it == 0 ) write(3,110)

  allocate( rho(0:nrm) )
  allocate( rhoval(0:nrm,nlatm) )
  allocate( vh(0:nrm) )
  allocate( vhato(0:nrm) )
  allocate( Vhval(0:nrm,nlatm) )

! Cas des spheres vides
  if( Numat(it) == 0 ) then
    nrato(it) = nrato(0)
    nr = nrato(0)
    Rato(0:nr,it) = Rato(0:nr,0)
    do index = 0,n_ipr_useful
      ipr = ipr_useful(index)
      if( itypepr(ipr) /= it ) cycle
      Rhoigr(0:nr,:,index) = 0._db
      Vato(:,index) = 0._db
    end do
    return
  endif

  nr = nrato(it)
  nl = nlat(it)
  r(0:nr) = Rato(0:nr,it)
  r(0) = 0._db

! Extrapolation at the center of the atom
  p1 = r(2) / ( r(2) - r(1) )
  p2 = 1 - p1
  rhoit(0,it) = p1 * rhoit(1,it) + p2 * rhoit(2,it)
  if( nl > 0 ) psival(0,1:nl,it) = 0._db

! Wave functions psival are in fact: sqrt(4*pi)*r*psi.
! rhoval is the density of the valence orbitals
  qpi = 0.25_db / pi
  do L = 1,nl
    rhoval(1:nr,L) = qpi * ( psival(1:nr,L,it) / r(1:nr ) )**2
    rhoval(0,L) = p1 * rhoval(1,L) + p2 * rhoval(2,L)
  end do

! Calculation of the atomic Hartree potential
  do icalcul = 1,1+nl
    L = icalcul - 1
    if( icalcul == 1 ) then
      rho(0:nr) = rhoit(0:nr,it)
    else
      rho(0:nr) = rhoval(0:nr,L)
    endif

    call Poisson(nr,nrm,r,rho,Vh)

    if( icalcul == 1 ) then
      DeuxZ = 2 * Numat(it)
      Vhato(0) = - Numat(it) * 100000._db / rydb
      Vhato(1:nr) = Vh(1:nr) - DeuxZ / r(1:nr)
    else
      Vhval(0:nr,L) = Vh(0:nr)
    endif

    if( icheck_10 > 2 ) then
      if( icalcul == 1 ) then
        write(3,120) it, Numat(it), icalcul
        do ir = 1,nr
          write(3,130) r(ir)*bohr, vhato(ir)*rydb
        end do
      else
        write(3,140) it, Numat(it), icalcul
        do ir = 1,nr
          write(3,130) r(ir)*bohr, vhval(ir,L)*rydb
        end do
      endif
    endif

  end do
  facspin = 1._db / nspin

  do index = 0,n_ipr_useful

    ipr = ipr_useful(index)
    if( itypepr(ipr) /= it ) cycle

    Vato(0:nr,index) = Vhato(0:nr)
    do isp = 1,nspin
      Rhoigr(0:nr,isp,index) = Rhoit(0:nr,it) * facspin
    end do
    if( nl == 0 ) Rhoigr_int(:,:,index) = rhoigr(:,:,index)

! rhoit: the real density

! Here, dp take eventualy into account the magnetism for the calculation of the potential
    do L = 1,nl
      Pop(:) = Popatm(ipr,L,:)
      dp(:) = Pop(:) - popatv(it,L) * facspin

      if( Spin_axis_free ) then
        do ia = 1,natome
          if( iaprotoi(ia) == ipr ) exit
        end do
        if( ia <= natome ) then

          Wigner(:,:) = Wigner_one_half(:,:,ia)
          Wigner = Transpose( Wigner )

          do isp = 1,nspin
            isq = nspin + 1 - isp
            Pop_new = Pop(isp) * abs( Wigner(isp,isp) )**2 + 2 * sqrt( Pop(isp) * Pop(isq) ) * &
                    real( Wigner(isp,isp)*Wigner(isp,isq), db ) + Pop(isq) * abs( Wigner(isp,isq) )**2
            dp_new = Pop_new - popatv(it,L) * facspin
            Rhoigr_int(0:nr,isp,index) = Rhoigr(0:nr,isp,index) + dp_new * Rhoval(0:nr,L)
          end do

        else

          do isp = 1,nspin
            Rhoigr_int(0:nr,isp,index) = Rhoigr(0:nr,isp,index) + dp(isp) * Rhoval(0:nr,L)
          end do

        endif

      endif

      do isp = 1,nspin
        Vato(0:nr,index) = Vato(0:nr,index) + dp(isp) * Vhval(0:nr,L)
        Rhoigr(0:nr,isp,index) = Rhoigr(0:nr,isp,index) + dp(isp) * Rhoval(0:nr,L)
      end do

    end do

    if( .not. Spin_axis_free ) Rhoigr_int(:,:,:) = Rhoigr(:,:,:)

    if( icheck_10 > 1 ) then
      if( .not. Spin_axis_free ) then
        write(3,150) it, ipr
        do ir = 0,nr
          write(3,130) r(ir)*bohr, Vato(ir,index)*rydb, Rhoigr(ir,1:nspin,index)
        end do
      else
        write(3,160) it, ipr
        do ir = 0,nr
          write(3,130) r(ir)*bohr, Vato(ir,index)*rydb, Rhoigr(ir,1:nspin,index), Rhoigr_int(ir,1:nspin,index)
        end do
      endif
    endif

  end do

  deallocate( Rho, Rhoval, Vh, Vhato, Vhval )

  return
  110 format(/' ---- Potato -------',100('-'))
  120 format(/5x,'Rato        Vhato(it)        it =',i3,', Z =',i3,', icalcul =',i3)
  130 format(1p,9e13.5)
  140 format(/5x,'Rato          Vhval          it =',i3,', Z =',i3,', icalcul =',i3)
  150 format(/5x,'Rato        Vato         rhoato(ispin=1,nspin)  it =',i3,', ipr =',i3)
  160 format(/5x,'Rato        Vato        rhoato_up    rhoato_dn  rhoato_int_u rhoato_int_d  it =',i3,', ipr =',i3)
end

!********************************************************************

! Le potentiel de Hartree est calcule a l'aide de la formulation integrale de l'equation de Poisson.
! Il y a 2 integrales a calculer pour chaque rayon r.
! Toutes deux sont obtenues par integration du troisieme degree.
! Resolution de l'equation de Poisson spherique
!       Laplacien(V) = - 8 * pi * rho (en u.a.).

subroutine Poisson(nr,nrm,r,rho,Vh)

  use declarations
  implicit none

  integer:: ir, j, nr, nrm

  real(kind=db):: prim
  real(kind=db), dimension(0:nrm):: r, rho, Vh

  real(kind=db), dimension(:), allocatable:: a, b, c, ch, cx, d, r2, rds

  allocate( a(nrm) )
  allocate( b(nrm) )
  allocate( c(nrm) )
  allocate( d(nrm) )
  allocate( ch(0:nrm) )
  allocate( cx(0:nrm) )
  allocate( r2(0:nrm) )
  allocate( rds(0:nrm) )

  r2(0:nr) = r(0:nr)**2
  rds(0:nr) = huit_pi * r2(0:nr) * rho(0:nr)

! Calcul de la charge interieure en fonction du rayon.
  ch(0) = 0._db
  call coefpol3(r,rds,a,b,c,d,nr,nrm)
  do ir = 1,nr
    if( ir == 1 ) then
      j = ir
    elseif( ir < nr ) then
      j = ir - 1
    else
      j = ir - 2
    endif
    prim = a(j) * ( r(ir) + r(ir-1) )*( r2(ir-1) + r2(ir) ) / 4 + b(j) * ( r2(ir) + r(ir)*r(ir-1) + r2(ir-1) ) / 3
    prim = ( prim +  c(j) * ( r(ir) + r(ir-1) ) / 2 + d(j) ) * ( r(ir) - r(ir-1) )
    ch(ir) = ch(ir-1) + prim
  end do

! Calcul de l'integrale exterieure en fonction du rayon.

  rds(1:nr) = huit_pi * r(1:nr) * rho(1:nr)

  cx(nr) = 0._db
  call coefpol3(r,rds,a,b,c,d,nr,nrm)
  do ir = nr-1,0,-1
    if( ir == nr-1 ) then
      j = nr - 2
    elseif( ir == 0 ) then
      j = 1
    else
      j = ir
    endif
    prim = a(j) * ( r(ir) + r(ir+1) ) * ( r2(ir) + r2(ir+1) ) / 4 + b(j) * ( r2(ir) + r(ir) * r(ir+1) + r2(ir+1) ) / 3
    prim = ( prim + c(j) * ( r(ir) + r(ir+1) ) / 2 + d(j) ) * ( r(ir+1) - r(ir) )
    cx(ir) = cx(ir+1) + prim
  end do

  Vh(0) = cx(0)
  Vh(1:nr) = ch(1:nr) / r(1:nr) + cx(1:nr)

  deallocate( a, b, c, d, ch, cx, r2, rds )

  return
end

!********************************************************************

! Resolution de l'equation de Poisson pour L /= 0
! On resoud d2/dr2 U_L - L(L+1)/r2 U_L = - 8 pi r rho_L

subroutine Poisson_lm(lmax_pot,nlm_pot,nr,r,rho_lm,Rmtsd,Vc_lm)

  use declarations
  implicit none

  integer:: icheck, ir, L, L0, lm, lmax_pot, lmp, m, nlm_pot, nm, nr, nrmtsd

  real(kind=db):: dr, r0, rap, rm, Rmtsd, rp
  real(kind=db), dimension(nr):: clapl0, claplm, claplp, diag, f2, r
  real(kind=db), dimension(nr,nlm_pot):: rho_lm, Vc_lm
  real(kind=db), dimension(:,:), allocatable:: Sm, Sol

  icheck = 1

! Coefficients du Laplacien
  do ir = 1,nr
    if( ir == 1 ) then
      rm = 0._db
    else
      rm = r(ir-1)
    endif
    r0 = r(ir)
    if( ir == nr ) then
      rp = 2 * r0 - rm
    else
      rp = r(ir+1)
    endif
    dr = 0.5_db * ( rp - rm )
    claplm(ir) = 1 / ( ( r0 - rm ) * dr )
    claplp(ir) = 1 / ( ( rp - r0 ) * dr )
    clapl0(ir) = - claplm(ir) - claplp(ir)
  end do

  f2(1:nr) = 1 / r(1:nr)**2

  if( icheck > 2 ) then
    write(3,110)
    do ir = 1,nr
      write(3,120) r(ir)*bohr, claplm(ir), clapl0(ir), claplp(ir), f2(ir)
    end do
  endif

  if( icheck > 2 ) then
    L0 = 0
  else
    L0 = 1
  endif

  do ir = 1,nr
    if( r(ir) > Rmtsd ) exit
  end do
  nrmtsd = min( ir, nr )

  do L = L0,lmax_pot

    nm = 2*L + 1

    Diag(1:nr) = - L * ( L + 1 ) * f2(1:nr) + clapl0(1:nr)

    allocate( Sm(nr,nm) )
    allocate( Sol(nr,nm) )

    do m = -L,L
      lm = L + 1 + m
      lmp = L**2 + L + 1 + m
      Sm(1:nrmtsd,lm) = - huit_pi * r(1:nrmtsd)*rho_lm(1:nrmtsd,lmp)
    end do
    Sm(nrmtsd+1:nr,:) = 0._db

    if( icheck > 2 ) then
      write(3,130) L
      do ir = 1,nr
        write(3,120) r(ir)*bohr, Diag(ir), Sm(ir,:)
      end do
    endif

! Triangularisation
    do ir = nr-1,1,-1
      rap = claplp(ir) / diag(ir+1)
      Diag(ir) = Diag(ir) - rap * claplm(ir+1)
      Sm(ir,:) = Sm(ir,:) - rap * Sm(ir+1,:)
    end do

! Resolution
    Sol(1,:) = Sm(1,:) / Diag(1)
    do ir = 2,nr
      Sol(ir,:) = (Sm(ir,:) - claplm(ir) * Sol(ir-1,:)) / Diag(ir)
    end do

    if( L > 0 ) then
      do m = -L,L
        lm = L + 1 + m
        lmp = L**2 + L + 1 + m
        Vc_lm(1:nr,lmp) = Sol(1:nr,lm) / r(1:nr)
      end do
    endif

    if( icheck > 2 ) then
      write(3,140)
      do ir = 1,nr
        write(3,120) r(ir)*bohr, Rydb * Sol(ir,:) / r(ir)
      end do
    endif

    Deallocate( Sol, Sm )

  end do

  110 format(/' Poisson_lm',//5x, 'Radius       claplm       clapl0       claplp        f2')
  120 format(1p,100e13.5)
  130 format(/' L =',i2,/ 5x,'Radius',7x,'Diag',8x,'Sm(1)',8x,'Sm(2)',8x,'Sm(3)...')
  140 format(/5x,'Radius',7x,'Vc(1)',8x,'Vc(2)',8x,'Vc(3)...')

  return
end

!********************************************************************

subroutine coefpol3(x,y,a,b,c,d,nr,nrm)

  use declarations
  implicit none

  integer:: i, nr, nrm

  real(kind=db):: deter, xa, xb, xba, xc, xca, xcb, xd, xda, xdb, xdc, y1, y2, y3, ya, yb, yc, yd

  real(kind=db), dimension(0:nrm) :: x, y
  real(kind=db), dimension(nrm) :: a, b, c, d

  do i = 1,nr-2

    xa = x(i-1)
    xb = x(i)
    xc = x(i+1)
    xd = x(i+2)
    ya = y(i-1)
    yb = y(i)
    yc = y(i+1)
    yd = y(i+2)
    xdc = xd - xc
    xdb = xd - xb
    xda = xd - xa
    xcb = xc - xb
    xca = xc - xa
    xba = xb - xa

    deter = xdc * xdb * xda * xcb * xca * xba
    a(i) = - ya * xdc * xdb * xcb + yb * xdc * xda * xca - yc * xdb * xda * xba + yd * xcb * xca * xba
    a(i) = a(i) / deter
    y1 = ya - a(i) * xa**3
    y2 = yb - a(i) * xb**3
    y3 = yc - a(i) * xc**3
    b(i) = y1 / ( xba * xca ) - y2 / ( xba * xcb ) + y3 / ( xcb * xca )
    y1 = y1 - b(i) * xa**2
    y2 = y2 - b(i) * xb**2
    c(i) = ( y2 - y1 ) / xba
    d(i) = y1 - c(i) * xa

  end do

  return
end

!*********************************************************************

! Calculation of the electronic density on the FDM grid of point coming from the non spherical valence orbital

subroutine Orbval( Delta_Vcato_ns, E_moment_axis, Full_atom, Hybrid, iaproto, iapot, icheck_11, igreq, igroup, &
        ipr_useful, itypepr, Lvval, mpirank0, n_atom_0, n_atom_ind, n_atom_proto, n_ipr_useful, natome, natomp, neqm, &
        ngroup_nonsph, nhybm, nlat, nlatm, norbv, npoint, npoint_ns, npsom, nrato, nrm, ntype, pop_nonsph, Pos, Posi, Psival, &
        Rato, Rhons, Rhonspr, Rot_Atom_nsph, Rot_cluster, Vhns, Vhnspr, xyz )

  use declarations
  implicit none

  integer, parameter:: Lmaxval = 3
  integer, parameter:: Lmx2 = ( 2 * Lmaxval + 1 )**2

  real(kind=db), parameter:: One_over_sqrt_4pi = 1._db / sqrt( 4._db * pi )

  integer:: i, ia, iapr, ib, icheck_11, igr, index, index_b, io, ipr, iprb, iprt, ir, it, iter, jr, L, Lm, Lmaxv, Lmp, Lmpp, Lp, &
    Lpp, m, mp, mpirank0, mpp, n_atom_0, n_atom_ind, n_atom_proto, n_ipr_useful, natome, natomp, neqm, ngroup_nonsph, &
    nhybm, nlatm, nlmc, nlmr, np, npoint, npoint_ns, npp, npsom, nr, nrm, ntype

  integer, dimension(0:ngroup_nonsph):: norbv
  integer, dimension(natomp):: iaproto, igroup
  integer, dimension(0:n_atom_proto):: iapot, itypepr
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(0:ntype):: nlat, nrato
  integer, dimension(0:ntype,nlatm):: Lvval
  integer, dimension(0:n_ipr_useful):: ipr_useful

  complex(kind=db), dimension(nhybm,16,ngroup_nonsph) :: hybrid
  complex(kind=db), dimension(:), allocatable :: ylmc

  logical:: Full_atom
  logical, dimension(:), allocatable:: rho_nul

  real(kind=db):: aap, Atom_electric_field, dr, g, Gaunt_r, p1, p2, r0, rm, rp

  real(kind=db), dimension(3):: E_moment_axis, V
  real(kind=db), dimension(0:n_atom_proto):: Rhonspr, Vhnspr
  real(kind=db), dimension(3,3):: rot, Rot_cluster
  real(kind=db), dimension(3,3,ngroup_nonsph):: Rot_Atom_nsph
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(3,natome):: Posi
  real(kind=db), dimension(nhybm,ngroup_nonsph):: Pop_nonsph
  real(kind=db), dimension(4,npsom):: xyz
  real(kind=db), dimension(0:nrm,0:ntype):: Rato
  real(kind=db), dimension(0:nrm,nlatm,0:ntype):: Psival
  real(kind=db), dimension(npoint_ns):: Rhons, Vhns
  real(kind=db), dimension(n_atom_0:n_atom_ind):: Delta_Vcato_ns

  real(kind=db), dimension(:), allocatable :: cdiag, claplm, claplp, clapl0, com, cop, dist, f2, r, Rho_atom_ns, V_atom_ns, &
                                              Vdiag, Ylmr
  real(kind=db), dimension(:,:), allocatable :: Rholm, Vlm, Ylm

  if( icheck_11 > 0 ) write(3,110)

  allocate( cdiag(0:nrm) )
  allocate( claplm(0:nrm) )
  allocate( claplp(0:nrm) )
  allocate( clapl0(0:nrm) )
  allocate( com(0:nrm) )
  allocate( cop(0:nrm) )
  allocate( dist(npoint) )
  allocate( f2(0:nrm) )
  allocate( r(0:nrm) )
  allocate( rho_nul(Lmx2) )
  allocate( Rholm(0:nrm,Lmx2) )
  allocate( vdiag(0:nrm) )
  allocate( Vlm(0:nrm,Lmx2) )

  rhons(:) = 0._db
  vhns(:) = 0._db

  do index = 0,n_ipr_useful

    ipr = ipr_useful(index)

    Rholm(:,:) = 0._db
    rho_nul(:) = .true.

    it = itypepr(ipr)
    igr = igreq(ipr,1)
    if( norbv(igr) == 0 ) cycle

    nr = nrato(it)
    r(:) = Rato(:,it)
    do ir = 1,nr
      rm = r(ir-1)
      r0 = r(ir)
      if( ir == nr ) then
        rp = 2 * r0 - rm
      else
        rp = r(ir+1)
      endif
      dr = 0.5_db * ( rp - rm )
      claplm(ir) = 1 / ( ( r0 - rm ) * dr )
      claplp(ir) = 1 / ( ( rp - r0 ) * dr )
      clapl0(ir) = - claplm(ir) - claplp(ir)
      f2(ir) = 1 / r(ir)**2
    end do

    Lm = 0
    do L = 0,2*Lmaxval
      do m = -L,L
        Lm = Lm + 1

! Calculation of the radial electronic density
        do io = 1,norbv(igr)

          Lmp = 0
          do Lp = 0,Lmaxval
            do mp = -Lp,Lp
              Lmp = Lmp + 1
              if( abs( hybrid(io,Lmp,igr) ) < eps10 ) cycle
              do np = 1,nlat(it)
                if( Lvval(it,np) == Lp ) exit
              end do
              if( np == nlat(it) + 1 .and. mpirank0 == 0 ) then
                call write_error
                do iprt = 6,9,3
                  write(iprt,120) Lp
                end do
                stop
              endif

              Lmpp = 0
              do Lpp = 0,Lmaxval
                do mpp = -Lpp,Lpp
                  Lmpp = Lmpp + 1
                  if( abs(hybrid(io,Lmpp,igr)) < eps10 ) cycle

                  g = Gaunt_r(L,m,Lp,mp,Lpp,mpp)
                  if( abs( g ) < eps10 ) cycle

                  do npp = 1,nlat(it)
                    if( Lvval(it,npp) == Lpp ) exit
                  end do

                  if( npp == nlat(it) + 1 .and. mpirank0 == 0 ) then
                    call write_error
                    do iprt = 6,9,3
                      write(iprt,120) Lpp
                    end do
                    stop
                  endif

                  rho_nul(lm) = .false.
                  aap = g * pop_nonsph(io,igr) * real( conjg(hybrid(io,Lmp,igr)) * hybrid(io,Lmpp,igr), db )

                  Rholm(1:nr,Lm) = Rholm(1:nr,Lm) + aap * psival(1:nr,np,it) * psival(1:nr,npp,it) / r(1:nr)**2
                end do
              end do

! Substraction of the isotropical average
              aap = One_over_sqrt_4pi * pop_nonsph(io,igr) * real( conjg(hybrid(io,Lmp,igr)) * hybrid(io,Lmp,igr) , db )
              Rholm(1:nr,1) = Rholm(1:nr,1) - aap * psival(1:nr,np,it)**2 / r(1:nr)**2

            end do
          end do

        end do

! Resolution of the spherical Poisson equation de get the Coulomb potential
!       Laplacien(V) = - 8*pi*rho (en u.a.).

        if( rho_nul(Lm) ) cycle

        cdiag(:) = ( clapl0(:) - L * ( L + 1 ) * f2(:) )
        com(:) = claplm(:) / cdiag(:)
        cop(:) = claplp(:) / cdiag(:)
        vdiag(:) = - 8 * pi * Rholm(:,Lm) / cdiag(:)

        Vlm(0:nr,Lm) = 0._db
        do iter = 1,10*nr
          do ir = nr-1,1,-1
            Vlm(ir,Lm) = vdiag(ir) - com(ir) * Vlm(ir-1,Lm) - cop(ir) * Vlm(ir+1,Lm)
          end do
        end do

        if( icheck_11 > 2 .and. Lm > 1 ) then
          write(3,130) ipr, L, m
          do ir = 0,nr
            write(3,140) r(ir)*bohr, Rholm(ir,Lm), Vlm(ir,Lm)*rydb
          end do
        endif

      end do
    end do

! Calculation of Coulomb potential electronic density on the FDM grid points

! Electronic density

    Lm = 0
    Lmaxv = 0
    do L = 0,2*Lmaxval
      do m = -L,L
        Lm = Lm + 1
        if( .not. rho_nul(Lm) ) Lmaxv = L
      end do
    end do

    nlmr = ( Lmaxv + 1 )**2
    nlmc = ( ( Lmaxv + 1 ) * ( Lmaxv + 2 ) ) / 2

    allocate( ylmc(nlmc) )
    allocate( ylmr(nlmr) )
    allocate( ylm(npoint,nlmr) )

    boucle_ia: do ia = 1,natomp

      if( iaproto(ia) /= ipr ) cycle

      igr = igroup(ia)
      rot(:,:) = Rot_Atom_nsph(:,:,igr)
      rot = matmul( transpose( Rot_cluster ), rot )

      if( icheck_11 > 2 ) then
        write(3,150) ipr
        write(3,160) ( rot(i,1:3), i = 1,3 )
      endif
! We take the inverse rotation to bring back the FDM points towards the orbital
      rot = transpose( rot )

      do i = 1,npoint
        v(1:3) = xyz(1:3,i) - Pos(1:3,ia)
        v = matmul( rot, v )
        dist(i) = sqrt( sum( v(:)**2 ) )
        call cylm(Lmaxv,v,dist(i),ylmc,nlmc)
        call ylmcr(Lmaxv,nlmc,nlmr,ylmc,ylmr)
        ylm(i,:) = ylmr(:)
      end do

! Effect of the non spherical potential onto the FDM grid points
      do i = 1,npoint

        do ir = 1,nrato(it)
          if( Rato(ir,it) > dist(i) ) exit
        end do
        if( ir > nrato(it) ) cycle

        p1 = ( Rato(ir,it) - dist(i) ) / ( Rato(ir,it) - Rato(ir-1,it) )
        p2 = 1 - p1

! We do not consider the spherical part (which is set to zero)
        Lm = 1
        do L = 1,Lmaxv
          do m = -L,L
            Lm = Lm + 1
            if( rho_nul(Lm) ) cycle

            rhons(i) = rhons(i) + ylm(i,Lm) * ( p1 * Rholm(ir-1,Lm) + p2 * Rholm(ir,Lm) )
            vhns(i) = vhns(i) + ylm(i,Lm) * ( p1 * Vlm(ir-1,Lm) + p2 * Vlm(ir,Lm) )

          end do
        end do

      end do

! Effect of the non spherical potential onto the atoms

      if( sum( abs( E_moment_axis(:) ) ) > eps10 ) then

        do iapr = n_atom_0, n_atom_ind

          if( iapr == 0 ) then
            V(1:3) = Pos(1:3,iapot(0)) - Pos(1:3,ia)
          elseif( Full_atom ) then
            V(1:3) = Posi(1:3,iapr) - Pos(1:3,ia)
          else
            V(1:3) = Pos(1:3,iapr) - Pos(1:3,ia)
          endif
          V = matmul( Rot, V )
          dr = sqrt( sum( V(:)**2 ) )
          call cylm(Lmaxv,V,dr,Ylmc,nlmc)
          call ylmcr(Lmaxv,nlmc,nlmr,Ylmc,Ylmr)

          do ir = 1,nrato(it)
            if( Rato(ir,it) > dr ) exit
          end do
          if( ir > nrato(it) ) cycle

          p1 = ( Rato(ir,it) - dr ) / ( Rato(ir,it) - Rato(ir-1,it) )
          p2 = 1 - p1

          Lm = 1
          do L = 1,Lmaxv
            do m = -L,L
              Lm = Lm + 1
              if( rho_nul(Lm) ) cycle
              Delta_Vcato_ns(iapr) = Delta_Vcato_ns(iapr) + Ylmr(Lm) * ( p1 * Vlm(ir-1,Lm) + p2 * Vlm(ir,Lm) )
            end do
          end do

        end do

      else

        do index_b = 0,n_ipr_useful

          iprb = ipr_useful(index_b)

          if( iapot(iprb) == 0 ) cycle
          ib = iapot(iprb)
          V(1:3) = Pos(1:3,ib) - Pos(1:3,ia)
          V = matmul( Rot, V )
          dr = sqrt( sum( V(:)**2 ) )
          call cylm(Lmaxv,V,dr,ylmc,nlmc)
          call ylmcr(Lmaxv,nlmc,nlmr,ylmc,ylmr)

          do ir = 1,nrato(it)
            if( Rato(ir,it) > dr ) exit
          end do
          if( ir > nrato(it) ) cycle

          p1 = ( Rato(ir,it) - dr ) / ( Rato(ir,it) - Rato(ir-1,it) )
          p2 = 1 - p1

          Lm = 1
          do L = 1,Lmaxv
            do m = -L,L
              Lm = Lm + 1
              if( rho_nul(Lm) ) cycle

              Rhonspr(iprb) = Rhonspr(iprb) + ylmr(Lm) * ( p1 * Rholm(ir-1,Lm) + p2 * Rholm(ir,Lm) )
              Vhnspr(iprb) = Vhnspr(iprb) + ylmr(Lm) * ( p1 * Vlm(ir-1,Lm) + p2 * Vlm(ir,Lm) )

            end do
          end do
        end do

      endif

    end do boucle_ia

    deallocate( ylmc )
    deallocate( ylmr )
    deallocate( ylm )

    if( icheck_11 > 2 ) then

  ! Calculation of the radial potential and electronic density along the z direction

      nlmr = ( Lmaxv + 1 )**2
      nlmc = ( ( Lmaxv + 1 ) * ( Lmaxv + 2 ) ) / 2

      allocate( ylmc(nlmc) )
      allocate( ylmr(nlmr) )
      allocate( Ylm(2,nlmr) )

      V(1:2) = 0._db
      V(3) = 1._db
      call cylm(Lmaxv,V,V(3),Ylmc,nlmc)
      call Ylmcr(Lmaxv,nlmc,nlmr,ylmc,ylmr)
      Ylm(1,:) = Ylmr(:)
      V(3) = -1._db
      call cylm(Lmaxv,V,1._db,Ylmc,nlmc)
      call Ylmcr(Lmaxv,nlmc,nlmr,ylmc,ylmr)
      Ylm(2,:) = Ylmr(:)

      allocate( Rho_atom_ns(-nr:nr) )
      allocate( V_atom_ns(-nr:nr) )
      Rho_atom_ns(:) = 0._db
      V_atom_ns(:) = 0._db

      Lm = 1
      do L = 1,Lmaxv
        do m = -L,L
          Lm = Lm + 1
          if( Rho_nul(Lm) ) cycle

          do ir = -nr,-1
            jr = abs(ir)
            Rho_atom_ns(ir) = Rho_atom_ns(ir) + Ylm(2,Lm) * Rholm(jr,Lm)
            V_atom_ns(ir) = V_atom_ns(ir) + Ylm(2,Lm) * Vlm(jr,Lm)
          end do
          do ir = 0,nr
            Rho_atom_ns(ir) = Rho_atom_ns(ir) + Ylm(1,Lm) * Rholm(ir,Lm)
            V_atom_ns(ir) = V_atom_ns(ir) + Ylm(1,Lm) * Vlm(ir,Lm)
          end do

        end do
      end do

! give zero !
      Atom_electric_field = ( V_atom_ns(nr) - V_atom_ns(-nr) ) / ( 2 * r(nr) )

      write(3,'(/A)') ' Cut along the atom z axis:'
      write(3,'(/A)') '     Radius   V_coulomb(eV)     Rho'
      do ir = -nr,-1
        write(3,'(1p,3e13.5)') - r(-ir)*bohr, V_atom_ns(ir)*Rydb, Rho_atom_ns(ir)
      end do
      do ir = 0,nr
        write(3,'(1p,3e13.5)') r(ir)*bohr, V_atom_ns(ir)*Rydb, Rho_atom_ns(ir)
      end do

      deallocate( Ylm, Ylmc, Ylmr )
      deallocate( Rho_atom_ns, V_atom_ns )

    endif

  end do

  if( icheck_11 > 1 ) then
    if( sum( abs( E_moment_axis(:) ) ) > eps10 ) then
      write(3,'(/A)') ' iapr     Posx      Posy      Posz     Delta_Vcato_ns'
      do iapr = n_atom_0, n_atom_ind
        write(3,'(i4,2x,3f10.5,2x,1p,2e13.5)') iapr, Posi(:,iapr), Delta_Vcato_ns(iapr)*rydb
      end do
    else
      write(3,'(/A)') '  ipr     Posx      Posy      Posz         Rhonspr        Vnspr'
      do ipr = 0,n_atom_proto
        if( iapot(ipr) == 0 ) cycle
        write(3,'(i4,2x,3f10.5,2x,1p,2e13.5)') ipr, Pos(1:3,iapot(ipr))*bohr, Rhonspr(ipr), Vhnspr(ipr)*rydb
      end do
    endif
  endif

  if( icheck_11 > 2 ) then
    write(3,190)
    do i = 1,npoint
      v(1:3) = abs( xyz(1:3,i) )
      if( icheck_11 > 2 .or. ( (v(1) < eps10 .and. v(2) < eps10 ) .or. (v(1) < eps10 .and. v(3) < eps10 ) .or. &
           (v(2) < eps10 .and. v(3) < eps10 ) ) ) write(3,200) xyz(1:3,i)*bohr, rhons(i), vhns(i)*rydb
    end do
  endif

  deallocate( cdiag, claplm, claplp, clapl0, com, cop, dist, f2, r, rho_nul, Rholm, vdiag, Vlm )

  return
  110 format(/' ---- Orbval -------',100('-'))
  120 format(///' Problem found when calculating the non spherical atomic potential.', &
                ' This one is not possible because the orbital L =',i3, &
                ' is not defined in the indata file under Atom or Atom_conf keywords !'///)
  130 format(/'   igr =',i3,',  L =',i2,', m =',i2,/ '   Radius       Rholm         Vlm')
  140 format(f10.7,1p,2e13.5)
  150 format(/' Matrix rotation of the atom',i2,' :')
  160 format(3f8.4)
  170 format(/'  ipr    posx    posy    posz     rhonspr        Vnspr')
  180 format(i4,2x,3f8.4,1p,2e13.5)
  190 format(/'    x       y       z        rhons         Vns')
  200 format(3f8.3,1p,2e13.5)
end

!***********************************************************************

function z_surf_eval(iaproto,n_atom_proto,n_atom_proto_bulk,natomp,Pos,V_surf)

  use declarations
  implicit none

  integer:: ia, ipr, n_atom_proto, n_atom_proto_bulk, natomp

  integer, dimension(natomp):: iaproto

  real(kind=db):: z, z_surf, z_surf_eval

  real(kind=db), dimension(3):: V_surf
  real(kind=db), dimension(3,natomp):: Pos

  z_surf = - 1000._db

  do ia = 1,natomp
    z = sum( V_surf(1:3) * Pos(1:3,ia) )
    ipr = iaproto( ia )
    if( ipr > n_atom_proto - n_atom_proto_bulk ) cycle
    z_surf = max( z_surf, z )
  end do

  z_surf_eval = z_surf

  return
end

!***********************************************************************

subroutine Prepare_Helmholtz(Cal_xanes,Delta_helm,Helm_fac,Helm_lin,Helm_mix,iaproto,icheck_13,n_atom_proto, &
                         n_atom_proto_bulk,Orig_helm,Pos,Surf_0,Sym_2D,V_surf,natomp,Width_helm,z_bulk,z_surf)

  use declarations
  implicit none

  integer:: ia, icheck_13, ipr, n_atom_proto, n_atom_proto_bulk, natomp

  integer, dimension(natomp):: iaproto

  logical:: Cal_xanes, Helm_lin, Helm_mix, Sym_2D

  real(kind=db):: alfa, Delta_helm, Dist, dx, erf_m, erf_p, Helm_fac, Orig_helm, Surf_0, V_s, Vp_s, Width_helm, Width_p, &
    x, z_bulk, z_surf

  real(kind=db), dimension(3):: V_surf
  real(kind=db), dimension(3,natomp):: Pos

  if( Sym_2D ) then
    do ia = 1,natomp
      Dist = sum( V_surf(1:3) * Pos(1:3,ia) )
      ipr = iaproto( ia )
      if( ipr > n_atom_proto - n_atom_proto_bulk ) then
        z_bulk = max( z_bulk, Dist )
      else
        z_surf = max( z_surf, Dist )
      endif
    end do
  else
    do ia = 1,natomp
      z_surf = max( z_surf, sqrt( sum( Pos(:,ia)**2 ) ) )
    end do
  endif
  Orig_helm = z_surf + Delta_helm

  if( Helm_mix .or. Helm_lin ) then
   ! alfa is such that sqrt(pi/2) * erf( alfa/sqrt(2) ) / alfa = 0.5
    alfa = 2.47304793497921_db
    Width_p = Width_helm / ( sqrt(2._db) * alfa )
    x = ( z_surf - Orig_helm ) / Width_p
    V_s = ( 1 - erfc( x ) ) / x
    dx = 0.0001_db
    erf_m = ( 1 - erfc( x - dx ) ) / ( x - dx )
    erf_p = ( 1 - erfc( x + dx ) ) / ( x + dx )
    Vp_s = ( erf_p - erf_m ) / ( 2 * dx * Width_p )

    if( Helm_mix ) then
      Surf_0 = z_surf - 2 * V_s / Vp_s
      Helm_fac = 0.25_db * Vp_s**2 / V_s
    else
      Surf_0 = z_surf - V_s / Vp_s
      Helm_fac = Vp_s
    endif
  endif

  if( icheck_13 > 0 .and. Cal_xanes ) then
    write(3,'(/A)') ' ---- Helmholtz potential ---------------------------------------------------------------------------------'
    write(3,'(/a15,f10.5,a13,f10.5,a17)') ' Z_surf_atom  =', z_surf*bohr, ', Orig_helm =', Orig_helm*bohr, ' A, (local basis)'
    if( Helm_mix .or. Helm_lin ) write(3,'(a15,f10.5,a13,1p,e11.3)') ' Surf_0 - Z_s =', ( Surf_0 - z_surf ) * bohr, &
                                                                     ',  Helm_fac =', Helm_fac
  endif

  return
end

!***********************************************************************

! Calculation of the atomic Coulomb potential resulting from the previous SCF cycle

subroutine Atom_Coulomb( Bulk_atom_done, Cal_xanes, drho_ex_nex, drhoato, dVc_ex_nex, dVcato, Full_atom, i_self, ia_eq_inv_self, &
          iapot, iapr0, iaprotoi, icheck_13, ipr_useful, iprabs_nonexc, itypepr, Lmax_pot, n_atom_0, n_atom_proto, &
          n_atom_proto_bulk, n_atom_0_self, n_atom_ind, n_atom_ind_self, n_iapr, n_ipr_useful, natome, natome_self, natomeq, &
          natomeq_self, natomp, nlm_pot, Nonexc, nrato, nrm, nrm_self, nspin, ntype, Numat, Pos, Posi, Rato, rho_self, rhoato, &
          rhoato_init, rhoigr, rhonspr, Rmtsd, SCF, Self_nonexc, Vato, Vcato, Vcato_init, Vhnspr, Vsphere )

  use declarations
  implicit none

  integer:: i_self, iapr, ia, iapr0, icheck_13, index, ipr, iprabs_nonexc, ir, isp, it, japr, jr, lm, lmax_pot, n_atom_0, &
    n_atom_proto, n_atom_proto_bulk, n_iapr, n_ipr_useful, n_atom_0_self, n_atom_ind, n_atom_ind_self, natome, natome_self, &
    natomeq, natomeq_self, natomp, nlm_pot, nr, nrm, nrm_self, nspin, ntype

  integer, dimension(natome):: iaprotoi
  integer, dimension(0:n_atom_proto):: iapot, itypepr
  integer, dimension(0:ntype):: nrato, Numat
  integer, dimension(natomeq_self):: ia_eq_inv_self
  integer, dimension(0:n_ipr_useful):: ipr_useful

  logical:: Atom_self, Bulk_atom_done, Cal_xanes, Full_atom, Nonexc, SCF, Self_nonexc, This_bulk_atom_done

  real(kind=db):: Vsphere

  real(kind=db), dimension(nrm):: dVc_ex_nex
  real(kind=db), dimension(0:n_atom_proto):: rhonspr, Rmtsd, Vhnspr
  real(kind=db), dimension(0:nrm):: drho, dVca, r
  real(kind=db), dimension(3,natome):: Posi
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(0:nrm,0:ntype):: Rato
  real(kind=db), dimension(nrm,nspin):: drho_ex_nex
  real(kind=db), dimension(0:nrm,0:n_ipr_useful):: Vato
  real(kind=db), dimension(0:nrm,n_atom_0:n_atom_ind):: drhoato
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: dVcato, Vcato
  real(kind=db), dimension(0:nrm,nspin,n_atom_0:n_atom_ind):: rhoato
  real(kind=db), dimension(0:nrm,nspin,0:n_ipr_useful):: Rhoigr
  real(kind=db), dimension(0:nrm_self,nlm_pot,n_atom_0_self:n_atom_ind_self):: Vcato_init
  real(kind=db), dimension(0:nrm_self,nspin,n_atom_0_self:n_atom_ind_self):: rhoato_init
  real(kind=db), dimension(0:nrm_self,nlm_pot,nspin,n_atom_0_self:n_atom_ind_self):: rho_self

  real(kind=db), dimension(:), allocatable:: ra
  real(kind=db), dimension(:,:), allocatable :: rho_lm, Vc_lm

  if( icheck_13 > 2 ) then
    write(3,110)
    if( Cal_xanes ) then
      write(3,'(/A)') ' Xanes calculation step'
    else
      write(3,'(/a19,i3)') ' SCF step, i_self =', i_self
    endif
  endif

  drhoato(:,:) = 0._db
  dVcato(:,:,:) = 0._db

! Loop over all the atoms ( corresponding to the small cluster )
  do iapr = iapr0,n_iapr

! Calculation of ia (of the not symmetrized cluster) and ipr
    call Convert_iapr(Cal_xanes,Full_atom,ia,iapot,iapr,iaprotoi,ipr,iprabs_nonexc,n_atom_0,n_atom_proto,natome,natomp, &
                        Nonexc,Pos,Posi,Self_nonexc)

    do index = 0,n_ipr_useful
      if( ipr_useful(index) == ipr ) exit
    end do

    if( ia == 0 ) cycle

    if( iapr > 0 ) then
      This_bulk_atom_done = Bulk_atom_done .and. ipr > n_atom_proto - n_atom_proto_bulk
    else
      This_bulk_atom_done = .false.
    endif

    Atom_self = .false.

    if( SCF .and. ( ( i_self > 1 .and. ia <= natomeq_self ) .or. This_bulk_atom_done ) ) then
      if( Full_atom .and. Cal_xanes .and. ia <= natomeq .and. ( ( ia /= iapot(0) .and. ipr /= 0 ) .or. ipr == 0 ) ) then
        do japr = 1,natome_self
          if( ia_eq_inv_self(ia) /= japr ) cycle
          Atom_self = .true.
          exit
        end do
      else
        if( Cal_xanes .and. iapr == 0 .and. Self_nonexc .and. .not. Full_atom ) then
          japr = iprabs_nonexc
        else
          japr = iapr
        endif
        Atom_self = .true.
      endif
    else
      japr = iapr
    endif

    if( .not. This_bulk_atom_done ) Vcato(:,:,iapr) = 0._db

    it = itypepr(ipr)
    nr = nrato(it)
    r(0:nr) = Rato(0:nr,it)

    if( Atom_self ) then
! Calculation of the Hartree potential by resolution of the Poisson equation
      do isp = 1,nspin
        rhoato(0:nr,isp,iapr) = rho_self(0:nr,1,isp,japr)
        do ir = 1,nr-2
          if( 4 * pi * r(ir)**2 * rhoato(ir,isp,iapr) > 1.e-08 ) exit
        end do
        if( ir > 1 ) then
          do jr = 0,ir
            rhoato(jr,isp,iapr) = rhoato(ir+1,isp,iapr)
          end do
        endif
      end do

      if( This_bulk_atom_done ) cycle

      do ir = 0,nr
        drhoato(ir,iapr) = sum( rhoato(ir,:,iapr) - rhoato_init(ir,:,japr) )
      end do
      drho(:) = drhoato(:,iapr)

      call Poisson(nr,nrm,r,drho,dVca)

      dVcato(0:nr,1,iapr) = dVca(0:nr)
      Vcato(0:nr,1,iapr) = dVca(0:nr) + Vcato_init(0:nr,1,japr)

! Adding of the difference between excited and not excited atoms
      if( Cal_xanes .and. ipr == 0 .and. Self_nonexc .and. .not. Nonexc ) then
        rhoato(1:nr,:,iapr) = rhoato(1:nr,:,iapr) + drho_ex_nex(1:nr,:)
        Vcato(1:nr,1,iapr) = Vcato(1:nr,1,iapr) + dVc_ex_nex(1:nr)
      endif

! Case of non spherical atomic potential
      if( nlm_pot > 1 ) then

        allocate( rho_lm(nr,nlm_pot) )
        allocate( Vc_lm(nr,nlm_pot) )
        allocate( ra(nr) )

        ra(1:nr) = r(1:nr)

        do lm = 1,nlm_pot
          do ir = 1,nr
            rho_lm(ir,lm) = sum( rho_self(ir,lm,:,japr) )
          end do
        end do

! All rho_lm components are mutiplied by sqrt(4pi) as well as in the output all Vc_L. Vc_0 is thus also the classical isotrope V
! as well as V_00 used in the resolution of the radial Schroedinger equation.
        call Poisson_lm(Lmax_pot,nlm_pot,nr,ra,rho_lm,Rmtsd(ipr),Vc_lm)
        do lm = 2,nlm_pot
          Vcato(0,lm,iapr) = 0._db
          Vcato(1:nr,lm,iapr) = Vc_lm(1:nr,lm) + Vcato_init(1:nr,lm,japr)
          dVcato(0,lm,iapr) = 0._db
          dVcato(1:nr,lm,iapr) = Vc_lm(1:nr,lm)
        end do

        deallocate( ra, rho_lm, Vc_lm )

      endif

    elseif( .not. This_bulk_atom_done ) then

      if( iapr >= n_atom_0 ) then
        Vcato(0:nr,1,iapr) = Vato(0:nr,index) + Vsphere + Vhnspr(ipr)
        do isp = 1,nspin
          Rhoato(0:nr,isp,iapr) = Rhoigr(0:nr,isp,index) + rhonspr(ipr)
        end do
      endif

    endif

    if( icheck_13 > 2 ) then
      write(3,120) ia, iapr, ipr, Numat(it)
      if( nlm_pot == 1 ) then
        if( nspin == 1 ) then
          write(3,130)
        else
          write(3,140)
        endif
      elseif( nlm_pot == 4 ) then
        if( nspin == 1 ) then
          write(3,150) (Lm, Lm = 2,nlm_pot), (Lm, Lm = 1,nlm_pot), (Lm, Lm = 1,nlm_pot)
        else
          write(3,160) (Lm, Lm = 2,nlm_pot), (Lm, Lm = 1,nlm_pot), (Lm, Lm = 1,nlm_pot)
        endif
      elseif( nlm_pot == 9 ) then
        if( nspin == 1 ) then
          write(3,170) (Lm, Lm = 2,nlm_pot), (Lm, Lm = 1,nlm_pot), (Lm, Lm = 1,nlm_pot)
        else
          write(3,180) (Lm, Lm = 2,nlm_pot), (Lm, Lm = 1,nlm_pot), (Lm, Lm = 1,nlm_pot)
        endif
      else
        if( nspin == 1 ) then
          write(3,190) (Lm, Lm = 2,nlm_pot), (Lm, Lm = 1,nlm_pot)
        else
          write(3,200) (Lm, Lm = 2,nlm_pot), (Lm, Lm = 1,nlm_pot)
        endif
      endif
      do ir = 1,nr
        write(3,'(1p,100e13.5)') r(ir)*bohr, quatre_pi * rhoato(ir,:,iapr) * r(ir)**2, quatre_pi * drhoato(ir,iapr) * r(ir)**2, &
                                ( sum( rho_self(ir,lm,:,japr) ), Lm = 2,nlm_pot ), Vcato(ir,:,iapr)*rydb, dVcato(ir,:,iapr)*rydb
      end do
    endif

  end do

  return
  110 format(/' ---- Atom_Coulomb ',98('-'))
  120 format(/' ia =',i3,', iapr =',i3,', ipr =',i3,', Z =',i3, ', before superposition')
  130 format(4x,'Radius     4pi*r2*rho   4pi*r2*drho     Vcato        dVcato')
  140 format(4x,'Radius    4pi*r2*rho_u 4pi*r2*rho_d  4pi*r2*drho   Vcato        dVcato')
  150 format(4x,'Radius     4pi*r2*rho   4pi*r2*drho',3(' rhoato(lm=',i1,')'),4('  Vcato(lm=',i1,')'),4(' dVcato(lm=',i1,')'))
  160 format(4x,'Radius    4pi*r2*rho_u 4pi*r2*rho_d  4pi*r2*drho',3(' rhoato(lm=',i1,')'),4('  Vcato(lm=',i1,')'), &
             4(' dVcato(lm=',i1,')'))
  170 format(4x,'Radius     4pi*r2*rho   4pi*r2*drho',8(' rhoato(lm=',i1,')'),9('  Vcato(lm=',i1,')'), &
             9(' dVcato(lm=',i1,')'))
  180 format(4x,'Radius    4pi*r2*rho_u 4pi*r2*rho_d  4pi*r2*drho',8(' rhoat(lm=',i1,')'),9('  Vcato(lm=',i1,')'), &
             9(' dVcato(lm=',i1,')'))
  190 format(4x,'Radius     4pi*r2*rho   4pi*r2*drho',8(' rhoato(lm=',i1,')'),7(' rhoat(lm=',i2,')'),9('  Vcato(lm=',i1,')'), &
             6(' Vcato(lm=',i2,')'),9(' dVcato(lm=',i1,')'),6(' dVcat(lm=',i2,')'))
  200 format(4x,'Radius    4pi*r2*rho_u 4pi*r2*rho_d  4pi*r2*drho',8(' rhoato(lm=',i1,')'),6(' rhoat(lm=',i2,')'), &
             9('  Vcato(lm=',i1,')'),6(' Vcato(lm=',i2,')'),9(' dVcato(lm=',i1,')'),6(' dVcat(lm=',i2,')'))
end

!***********************************************************************

! Calculation of ia (of the not symmetrized cluster) and ipr

subroutine Convert_iapr(Cal_xanes,Full_atom,ia,iapot,iapr,iaprotoi,ipr,iprabs_nonexc,n_atom_0,n_atom_proto,natome,natomp, &
                        Nonexc,Pos,Posi,Self_nonexc)

  use declarations
  implicit none

  integer:: ia, iapr, ipr, iprabs_nonexc, n_atom_0, n_atom_proto, natome, natomp

  integer, dimension(natome):: iaprotoi
  integer, dimension(0:n_atom_proto):: iapot

  logical:: Cal_xanes, Full_atom, Nonexc, Self_nonexc

  real(kind=db), dimension(3,natome):: Posi
  real(kind=db), dimension(3,natomp):: Pos

  if( Full_atom ) then
    if( iapr == 0 ) then
      if( ( Cal_xanes .and. Nonexc ) .or. ( .not. Cal_xanes .and. Self_nonexc ) ) then
! in self_nonexc, one needs the excited atom, to calculate the difference "excited - non-excited" to put it in the xanes excited step
        ipr = 0
      else
!
        ipr = iprabs_nonexc
      endif
    else
      ipr = iaprotoi( iapr )
    endif
  else
    ipr = iapr
  endif

! ia: index in the not symmetrized (big) cluster)
  if( iapr < n_atom_0 ) then
    ia = iapot(0)
  elseif( Full_atom ) then
    if( iapr == 0 ) then
      ia = iapot(0)
    else
      do ia = 1,natomp
        if( sum( abs( Posi(:,iapr) - Pos(:,ia) ) ) < eps10 ) exit
      end do
    endif
  else
    ia = iapot(iapr)
    if( ia == 0 .and. ipr == iprabs_nonexc ) ia = iapot(0)
  endif

  return
end

!***********************************************************************

! Routine adding the counter atoms potential

subroutine Counter_atom_pot(icheck,Counter_ato,Counter_index_ato,n_index_ato,n_counter_ato,nr_counter_ato,r_counter_ato, &
                            Rho_counter_ato,Vh_counter_ato)

  use declarations
  implicit none

  integer, parameter:: nbseuil = 1
  integer, parameter:: nb_emis = 0
  integer, parameter:: ntype = 1
  integer, parameter:: nspin = 1

  real(kind=db), parameter:: sqrt_2pi = sqrt( 2 * pi )

  integer:: i, i_index, ich, icheck, igr, ir, it, jr, Jseuil, Lqnexc, Lseuil, mpirank0, n, n_coeur, n_counter_ato, n_index_ato, &
    n_orb, n_orbexc, n_orb_rel, nlatm, nqnexc, nnlm, nr, nr_counter_ato, nrato_dirac, nrm, nseuil, Z

  integer, dimension(4):: P_Emis
  integer, dimension(2,0:ntype):: lcoeur, ncoeur
  integer, dimension(0:ntype):: nlat

  integer, dimension(:), allocatable:: Lqn, Lqn_exc, nqn, nqn_exc
  integer, dimension(:,:), allocatable:: Lvval, nvval

  Logical:: Dirac_eq, Magnetic, nonexc, Relativiste

  real(kind=db):: Alfpot, Charge, Charge_sig, Charge_val, den, dr, f, f_integr3, Fac, Integral_1, Integral_2, Integral_3, Norm, &
                  Occupancy, p, p2, Ray_max_dirac, Sigma

  real(kind=db), dimension(nr_counter_ato):: Rato
  real(kind=db), dimension(0:nr_counter_ato):: r, r_counter_ato, Rh, Rho, Rho_val, Vh
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(0:nr_counter_ato,n_index_ato):: Rho_counter_ato, Vh_counter_ato
  real(kind=db), dimension(nr_counter_ato,nbseuil):: Psii
  real(kind=db), dimension(nr_counter_ato,nb_Emis):: Psi_Emis
  real(kind=db), dimension(0:ntype):: popatc
  real(kind=db), dimension(0:nr_counter_ato,0:ntype):: rhoit, rho_coeur
  real(kind=db), dimension(nr_counter_ato,2):: psi_open_val
  real(kind=db), dimension(2):: pop_open_val
  real(kind=db), dimension(0:nr_counter_ato,2,0:ntype):: Psi_coeur
  real(kind=db), dimension(4,n_index_ato):: Counter_index_ato

  real(kind=db), dimension(:), allocatable:: nel, rqn
  real(kind=db), dimension(:,:), allocatable:: Popatv, Popexc
  real(kind=db), dimension(:,:,:), allocatable:: Popval, Psival

  Rho_counter_ato(:,:) = 0._db
  Vh_counter_ato(:,:) = 0._db

  nr = nr_counter_ato
  nrm = nr_counter_ato
  nrato_dirac = nr_counter_ato

  Alfpot = 0._db

  nnlm = 0
  do i = 1,n_index_ato
    Z = nint( Counter_index_ato(1,i) )
    n = 2 + n_orb_rel( Z )
    nnlm = max( n, nnlm )
  end do

  allocate( Lqn_exc(nnlm) )
  allocate( nqn_exc(nnlm) )
  allocate( Popexc(nnlm,nspin) )

  Magnetic = .false.
  Relativiste = .true.
  it = 1
  Jseuil = 1
  Lcoeur = 0
  Lqnexc = 0
  mpirank0 = 0
  n_orbexc = 0
  ncoeur = 1
  nqnexc = 0
  Ray_max_dirac = 10._db / bohr
  nlat(1) = 0

  do i_index = 1,n_index_ato

    do igr = 1,n_counter_ato
      if( abs( Counter_index_ato(1,i_index) - Counter_ato(4,igr) ) < eps10 .and. &
          abs( Counter_index_ato(2,i_index) - Counter_ato(5,igr) ) < eps10 .and. &
          abs( Counter_index_ato(3,i_index) - Counter_ato(7,igr) ) < eps10 .and. &
          abs( Counter_index_ato(4,i_index) - Counter_ato(8,igr) ) < eps10 ) exit
    end do
    Z = nint( Counter_ato(4,igr) )
    Sigma = Counter_ato(5,igr)
    Charge = Counter_ato(7,igr)
    if( abs( Charge ) > eps10 ) then
      nlatm = 1
    else
      nlatm = 0
    endif

    allocate( Lvval(0:ntype,nlatm) )
    allocate( nvval(0:ntype,nlatm) )
    allocate( Popval(0:ntype,nlatm,nspin) )
    allocate( Popatv(0:ntype,nlatm) )
    allocate( Psival(0:nr_counter_ato,nlatm,0:ntype) )

    if( abs( Charge ) > eps10 ) then
      allocate( Lqn(nnlm) )
      allocate( nel(nnlm) )
      allocate( nqn(nnlm) )
      allocate( rqn(nnlm) )
      Dirac_eq = .false.
  ! it is just to get the n and L of last orbital
      call config(Z,Dirac_eq,n_coeur,n_orb,nnlm,nqn,Lqn,rqn,nel)
      nlat(:) = 1
      Lvval(1,1) = Lqn(n_orb)
      nvval(1,1) = nqn(n_orb)
      Popval(1,1,1) = nel(n_orb) - Charge
      deallocate( Lqn, nel, nqn, rqn )
    endif

    ich = max( 0, icheck-1 )
    call dirgen(ich,it,0,Jseuil,Lcoeur,Lqn_exc,Lseuil,Lvval,mpirank0,n_orbexc,nb_Emis,nbseuil,ncoeur,nlat,nlatm, &
          nnlm,nonexc,nqn_exc,nr,nrato_dirac,nrm,nseuil,nspin,ntype,nvval,P_Emis,pop_open_val,popatc,popatv, &
          popexc,popval,psi_coeur,Psi_emis,psii,psi_open_val,Psival,rato,Ray_max_dirac,rho_coeur,rhoit,Z,Relativiste)

    r(0) = 0._db
    r(1:nr) = Rato(1:nr)
    r_counter_ato(:) = r(:)

    Rho(1:nr) = rhoit(1:nr,1)
    Rho(0) = Rho(1)

    if( abs( Charge ) > eps10 ) then
! Psival is in fact sqrt(4pi) * r * psi
      Rh(1:nr_counter_ato) = Psival(1:nr_counter_ato,1,1)**2
      Rh(0) = Rh(1)
      Charge_val = f_integr3(r,Rh,0,nr_counter_ato,r(nr_counter_ato))
      Rho_val(1:nr_counter_ato) = Rh(1:nr_counter_ato) / ( quatre_pi * r(1:nr_counter_ato)**2 )
      Rho_val(0) = Rho_val(1)
      Rho(:) = Rho(:) - Charge * Rho_val(:)
    endif

    call Poisson(nr,nr,r,Rho,Vh)

    Vh(1:nr) = Vh(1:nr) - 2 * Z / r(1:nr)
    Vh(0) = 2 * Vh(1)

! Convolution

    Occupancy = Counter_ato(8,igr)
    if( abs( Occupancy - 1._db ) > eps10 ) then
      Vh(:) = Occupancy * Vh(:)
      Rho(:) = Occupancy * Rho(:)
    endif

    den = - 1._db / ( 2 * Sigma**2 )

    do jr = 0,nr

      p = r(jr)

! Beyond 10 times sigma, convolution have no more effect and one gets numerical instabilities
      if( p > 10 * sigma ) then
        do ir = jr,nr
          Vh_counter_ato(ir,i_index) = Vh(ir)
          Rho_counter_ato(ir,i_index) = Rho(ir)
        end do
        exit
      endif

      p2 = p**2
      f = p / Sigma**2

      Integral_1 = 0._db
      Integral_2 = 0._db
      Integral_3 = 0._db

      do ir = 1,nr_counter_ato
        if( ir == 1 ) then
          dr = ( r(1) + r(2) ) / 2
        elseif( ir < nr ) then
          dr = 0.5_db * ( r(ir+1) - r(ir-1) )
        else
          dr = r(nr) - r(nr-1)
        endif
        if( p < eps10 ) then
          Fac = exp( den * r(ir)**2 ) * r(ir)**2 * dr
        else
          Fac = exp( den * ( p2 + r(ir)**2 ) ) * sinh( f * r(ir) ) * r(ir) * dr
        endif
        Integral_1 = Integral_1 + Fac
        Integral_2 = Integral_2 + Fac * Vh(ir)
        Integral_3 = Integral_3 + Fac * Rho(ir)
      end do
      if( p < eps10 ) then
        Norm = 2._db /  ( Sigma**3 * sqrt_2pi )
      else
        Norm = 2._db /  ( p * Sigma * sqrt_2pi )
      endif
      Integral_1 = Norm * Integral_1
      Integral_2 = Norm * Integral_2
      Integral_3 = Norm * Integral_3

      Vh_counter_ato(jr,i_index) = Vh_counter_ato(jr,i_index) + Integral_2
      Rho_counter_ato(jr,i_index) = Rho_counter_ato(jr,i_index) + Integral_3

    end do ! end of loop over jr

    if( icheck > 1 ) then
      if( i_index == 1 ) write(3,110)
      if( abs( Charge ) > eps10 ) write(3,120) nvval(1,1), Lvval(1,1), Popval(1,1,1)
      write(3,130) Z, Sigma*bohr, Occupancy
      do ir = 0,nr_counter_ato
        write(3,'(1p,5e15.5)') r(ir)*bohr, Vh(ir)*Rydb, Vh_counter_ato(ir,i_index)*Rydb, Rho(ir), Rho_counter_ato(ir,i_index)
      end do
    endif

    if( icheck > 2 ) then
      rh(0:nr_counter_ato) = Rho_counter_ato(0:nr_counter_ato,i_index) * r(0:nr_counter_ato)**2
      Charge_sig = quatre_pi * f_integr3(r,rh,0,nr_counter_ato,r(nr_counter_ato))
      rh(0:nr_counter_ato) = Rho(0:nr_counter_ato) * r(0:nr_counter_ato)**2
      Charge = quatre_pi * f_integr3(r,rh,0,nr_counter_ato,r(nr_counter_ato))
      if( abs( Charge ) < eps10 ) then
        write(3,140) Charge, Charge_sig
      else
        write(3,150) Charge, Charge_val, Charge_sig
      endif
    endif

    deallocate( Lvval, nvval, Popval, Popatv, Psival )

  end do

  deallocate( Lqn_exc, nqn_exc, Popexc )

  return
  110 format(/'--- Counter atom pot ----------------------------------------------------')
  120 format(/' Valence orbital: n =',i2,', L =',i2,', orbital occupancy =',f7.3)
  130 format(/'       Radius           Vh        Vh_counter         Rho        Rho_counter     Z =',i3,', Sigma =',f7.3, &
              ' A, Occupancy =',f7.3)
  140 format(/' Nb of elec =',f10.5,', Nb of elec =',f10.5)
  150 format(/' Nb of elec =',f10.5,', Nb of elec val (without occupancy) =',f10.5,', Nb of elec conv =',f10.5)
end

!***********************************************************************

! Routine adding the counter atoms potential
! It adds the potential directly in this routine. This one is saved in "Vcato_init" for all the iteration
! The elecron density projected on the atoms of the cluster, Rho_counter_ato, is added later in pot0muffin

subroutine Atom_counter_atom(Bulk_atom_done,Cal_xanes,Counter_ato,Counter_index_ato,Full_atom,ia_eq_inv,ia_eq_inv_self, &
        iapot,iapr0,iaprotoi,icheck_13,igroup_ato,iprabs_nonexc,itypei, &
        n_atom_0,n_atom_ind,n_atom_proto,n_atom_proto_bulk,n_counter_ato,n_iapr,n_index_ato,natome,natome_self, &
        natomeq,natomeq_self,natomp,natomp_ato,nlm_pot,nrato,nrm,ntype,Nonexc,nr_counter_ato,Numat,Pos, &
        Pos_ato,Posi,r_counter_ato,Rato,Rho_cato,Rho_counter_ato,SCF,Self_nonexc,Vcato,Vh_counter_ato)

  use declarations
  implicit none

  integer:: ia, ia_i, iapr, iapr0, icheck_13, ipr, iprabs_nonexc, it, japr, n_atom_0, n_atom_ind, n_atom_proto, &
    n_atom_proto_bulk, n_counter_ato, n_iapr, n_index_ato, natome, natome_self, natomeq, natomeq_self, natomp, &
    natomp_ato, nlm_pot, nr_counter_ato, nrm, ntype

  integer, dimension(natomp_ato):: igroup_ato
  integer, dimension(0:n_atom_proto):: iapot
  integer, dimension(natome):: iaprotoi, itypei
  integer, dimension(0:ntype):: nrato, Numat
  integer, dimension(natomeq):: ia_eq_inv
  integer, dimension(natomeq_self):: ia_eq_inv_self

  logical:: Bulk_atom_done, Cal_xanes, Full_atom, Nonexc, SCF, Self_nonexc

  real(kind=db):: rho_ato, V_ato

  real(kind=db), dimension(3):: Ps
  real(kind=db), dimension(0:nrm):: r2
  real(kind=db), dimension(0:nr_counter_ato):: r_counter_ato
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(3,natome):: Posi
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(3,natomp_ato):: Pos_ato
  real(kind=db), dimension(0:nrm,0:ntype):: Rato
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato
  real(kind=db), dimension(n_atom_0:n_atom_ind):: Rho_cato
  real(kind=db), dimension(0:nr_counter_ato,n_index_ato):: Rho_counter_ato, Vh_counter_ato
  real(kind=db), dimension(4,n_index_ato):: Counter_index_ato

  if( icheck_13 > 0 ) write(3,100)

! Loop over all the atoms
  Loop_iapr: do iapr = iapr0,n_iapr

! Calculation of ia (of the not symmetrized cluster) and ipr
    call Convert_iapr(Cal_xanes,Full_atom,ia,iapot,iapr,iaprotoi,ipr,iprabs_nonexc,n_atom_0,n_atom_proto,natome,natomp, &
                        Nonexc,Pos,Posi,Self_nonexc)

    if( ia == 0 .or. ia > natomeq ) cycle

 ! By default, bulk atoms have no counter atoms
    if( Bulk_atom_done .and. ipr > n_atom_proto - n_atom_proto_bulk ) cycle

 ! For atoms already calculated, counter atoms are already included
    if( SCF .and. Cal_xanes .and. ia <= natomeq_self .and. Full_atom .and. &
        ( ( ia /= iapot(0) .and. ipr /= 0 ) .or. ipr == 0 ) ) then
      do japr = 1,natome_self
        if( ia_eq_inv_self(ia) == japr ) cycle Loop_iapr
      end do
    endif

! ia_i index of the (small) symmetrized cluster
    ia_i = ia_eq_inv(ia)
    it = itypei(ia_i)
    r2(0:nrato(it)) = Rato(0:nrato(it),it)**2

    Ps(:) = Posi(:,ia_i)
    call Ato_potential(Counter_ato,Counter_index_ato,igroup_ato,n_counter_ato,n_index_ato,natomp_ato,nr_counter_ato,Pos_ato,Ps, &
                               r_counter_ato,Rho_ato,Rho_counter_ato,V_ato,Vh_counter_ato)

    Vcato(:,1,iapr) = Vcato(:,1,iapr) + V_ato
    Rho_cato(iapr) = Rho_cato(iapr) + Rho_ato

    if( icheck_13 > 1 .or. iapr == 1 ) write(3,*)
    if( icheck_13 > 0 ) write(3,200) Numat(it), ipr, ia_i, V_ato * rydb, Rho_ato

  end do Loop_iapr

  return
  100 format(/' ---- Atom_Counter_atom ',98('-'))
  200 format(' Z =',i3,', ipr =',i3,', ia =',i3,', Delta_Vh Counter atoms =',f10.5,' eV, Delta_Rho =',f10.5)
end

!***********************************************************************

! Potential and density coming from the counter atoms

 subroutine Ato_potential(Counter_ato,Counter_index_ato,igroup_ato,n_counter_ato,n_index_ato,natomp_ato,nr_counter_ato,Pos_ato,Ps, &
                               r_counter_ato,Rho_ato,Rho_counter_ato,V_ato,Vh_counter_ato)

  use declarations
  implicit none

  real(kind=db), parameter:: sqrt_2pi = sqrt( 2 * pi )

  integer:: i_ato, igr, index_ato, ir, n_counter_ato, n_index_ato, natomp_ato, nr_counter_ato, Z

  integer, dimension(natomp_ato):: igroup_ato

  real(kind=db):: Charge, dist, p1, Rho_ato, V_ato

  real(kind=db), dimension(3):: P, Ps
  real(kind=db), dimension(0:nr_counter_ato):: r_counter_ato
  real(kind=db), dimension(3,natomp_ato):: Pos_ato
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(0:nr_counter_ato,n_index_ato):: Rho_counter_ato, Vh_counter_ato
  real(kind=db), dimension(4,n_index_ato):: Counter_index_ato

  V_ato = 0._db
  Rho_ato = 0._db

  do i_ato = 1,natomp_ato

    igr = igroup_ato(i_ato)
    Z =  nint( Counter_ato(4,igr) )
    do index_ato = 1,n_index_ato
      if(       abs( Counter_index_ato(1,index_ato) - Counter_ato(4,igr) ) < eps10 &
          .and. abs( Counter_index_ato(2,index_ato) - Counter_ato(5,igr) ) < eps10 &
          .and. abs( Counter_index_ato(3,index_ato) - Counter_ato(7,igr) ) < eps10 &
          .and. abs( Counter_index_ato(4,index_ato) - Counter_ato(8,igr) ) < eps10 ) exit
    end do
    P(:) = Pos_ato(:,i_ato) - Ps(:)
    dist = sqrt( sum( P(:)**2 ) )

    if( dist < eps10 ) then

      V_ato = V_ato + Vh_counter_ato(0,index_ato)
      Rho_ato = Rho_ato + Rho_counter_ato(0,index_ato)

    elseif( dist > r_counter_ato(nr_counter_ato) - eps10 ) then

      Charge = Counter_ato(7,igr) * Counter_ato(8,igr)
      if( abs( Charge ) > eps10 ) V_ato = V_ato - 2 * Charge / dist

    else

      do ir = 1,nr_counter_ato
        if( r_counter_ato(ir) > dist ) exit
      end do
      p1 = ( dist - r_counter_ato(ir-1) ) / ( r_counter_ato(ir) - r_counter_ato(ir-1) )
      V_ato = V_ato + p1 * Vh_counter_ato(ir,index_ato) + ( 1 - p1 ) * Vh_counter_ato(ir-1,index_ato)
      Rho_ato = Rho_ato + p1 * Rho_counter_ato(ir,index_ato) + ( 1 - p1 ) * Rho_counter_ato(ir-1,index_ato)

    endif

  end do

  return
end

!***********************************************************************

! Routine adding the counter ions potential

! if XANES radius > SCF Radius, with SCF calculation, Helmholtz not applied to the XANES atoms between the corresponding spheres

subroutine Atom_counter_ion(Bulk_atom_done,Cal_xanes,Counter_ion,Counter_linear,Delta_z_lin,Full_atom,ia_eq_inv,ia_eq_inv_self, &
        iapot,iapr0,iaprotoi, &
        icheck_13,igroup_ion,iprabs_nonexc,itypei,Lmax_pot,n_atom_0,n_atom_ind,n_atom_proto,n_atom_proto_bulk,n_counter_ion, &
        n_iapr,n_theta,natome,natome_self,natomeq,natomeq_self,natomp,natomp_ion,nlm_pot,nrato,nrm,ntype,Nonexc,Numat,Pos, &
        Pos_ion,Posi,Rato,SCF,Rot_Atom,Rot_cluster,Self_nonexc,V_surf,Vcato,Ylm_comp,z_surf)

  use declarations
  implicit none

  real(kind=db), parameter:: sqrt_4pi = sqrt( 4 * pi )
  real(kind=db), parameter:: sqrt_2pi = sqrt( 2 * pi )

  integer:: i, i_ion, ia, ia_i, iapr, iapr0, icheck_13, igr, ipr, iprabs_nonexc, ir, it, japr, L, Lm, Lmax_pot, Lmp, m, mp, &
    n_atom_0, n_atom_ind, n_atom_proto, n_atom_proto_bulk, n_counter_ion, n_iapr, n_theta, natome, natome_self, natomeq, &
    natomeq_self, natomp, natomp_ion, nlm_pot, nrm, ntype

  integer, dimension(natomp_ion):: igroup_ion
  integer, dimension(0:n_atom_proto):: iapot
  integer, dimension(natome):: iaprotoi, itypei
  integer, dimension(0:ntype):: nrato, Numat
  integer, dimension(natomeq):: ia_eq_inv
  integer, dimension(natomeq_self):: ia_eq_inv_self

  complex(kind=db), dimension(nlm_pot):: Vlm_a, Vlm_c
  complex(kind=db), dimension(-Lmax_pot:Lmax_pot,-Lmax_pot:Lmax_pot,0:Lmax_pot):: Dlmm_ia

  logical:: Bulk_atom_done, Cal_xanes, Counter_linear, Full_atom, Full_potential, Nonexc, SCF, Self_nonexc, Write_bav, Ylm_comp

  real(kind=db):: Charge, Dab, Dab2, Dabr, Delta_V, Delta_z_lin, Dist, dtheta, Fac, Sigma, Sin_Theta_dtheta, Sqrt_2_Sigma, Theta, &
    V_ion, x, z_surf

  real(kind=db), dimension(3):: P, Ps, V_surf, Vx, Vy, Vz
  real(kind=db), dimension(0:nrm):: dVc, r2
  real(kind=db), dimension(nlm_pot):: Dlm0, Plm_a
  real(kind=db), dimension(3,3):: Mat_rot, Rot_a, Rot_cluster
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion
  real(kind=db), dimension(3,natome):: Posi
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(3,natomp_ion):: Pos_ion
  real(kind=db), dimension(0:nrm,0:ntype):: Rato
  real(kind=db), dimension(nlm_pot,n_theta):: Plm_a_i
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato
  real(kind=db), dimension(n_theta,0:Lmax_pot):: YlmSintdt
  real(kind=db), dimension(3,3,natome):: Rot_Atom

  Write_bav = icheck_13 > 2

  if( icheck_13 > 0 ) write(3,100)

  Full_potential = nlm_pot > 1

  if( Full_potential .and. .not. Counter_linear ) then

    call Ylm_Sintheta_dtheta(Lmax_pot,n_theta,YlmSintdt)
    dtheta = pi / n_theta

    do i = 1,n_theta
      Theta = ( i - 0.5_db ) * dtheta
      call Cal_Plm(Lmax_pot,Plm_a,nlm_pot,Theta)
      Plm_a_i(:,i) = Plm_a(:)
    end do

  endif

! Loop over all the atoms
  Loop_iapr: do iapr = iapr0,n_iapr

! Calculation of ia and ipr
    call Convert_iapr(Cal_xanes,Full_atom,ia,iapot,iapr,iaprotoi,ipr,iprabs_nonexc,n_atom_0,n_atom_proto,natome,natomp, &
                        Nonexc,Pos,Posi,Self_nonexc)

    if( ia == 0 .or. ia > natomeq ) cycle

 ! By default, bulk atoms have no counter_ions
    if( Bulk_atom_done .and. ipr > n_atom_proto - n_atom_proto_bulk ) cycle

 ! For atoms already calculated, counter ions are already included
    if( SCF .and. Cal_xanes .and. ia <= natomeq_self .and. Full_atom .and. &
        ( ( ia /= iapot(0) .and. ipr /= 0 ) .or. ipr == 0 ) ) then
      do japr = 1,natome_self
        if( ia_eq_inv_self(ia) == japr ) cycle Loop_iapr
      end do
    endif

    ia_i = ia_eq_inv(ia)
    it = itypei(ia_i)
    r2(0:nrato(it)) = Rato(0:nrato(it),it)**2

    if( Full_potential .and. .not. Counter_linear ) then

      Rot_a(:,:) = Rot_Atom(:,:,ia_i)
      Rot_a = Transpose( Rot_a )

      dVc(:) = 0._db

      do i_ion = 1,natomp_ion

        igr = igroup_ion(i_ion)
        Charge = Counter_ion(4,igr)
        Sigma = Counter_ion(5,igr)
        Sqrt_2_Sigma = sqrt( 2._db ) * Sigma

        P(:) = Pos_ion(:,i_ion) - Posi(:,ia_i)
        Dab = sqrt( sum( P(:)**2 ) )

! Calculation of Wigner matrices
        call Cal_Dlm0(Dab,Dlm0,Lmax_pot,nlm_pot,p)

! Local basis with z axis along the bond direction
        Vz(:) = p(:)
        Vz(:) = Vz(:) / sqrt( sum( Vz(:)**2 ) )

        if( abs( abs( Vz(3) ) - 1._db ) > eps10 ) then

          Vy(1) = - Vz(2) / sqrt( Vz(1)**2 + Vz(2)**2 )
          Vy(2) = Vz(1) / sqrt( Vz(1)**2 + Vz(2)**2 )
          Vy(3) = 0._db

          call prodvec( Vx, Vy, Vz )
          Vx(:) = Vx(:) / sqrt( sum( Vx(:)**2 ) )

        else

          Vx(1) = 1._db; Vx(2) = 0._db; Vx(3) = 0._db
          Vy(1) = 0._db; Vy(2) = 1._db; Vy(3) = 0._db

        endif

        Mat_rot(:,1) = Vx(:)
        Mat_rot(:,2) = Vy(:)
        Mat_rot(:,3) = Vz(:)

        Rot_a(:,:) = Rot_atom(:,:,ia_i)

        Rot_a = Matmul( Transpose( Rot_a ), Mat_rot )

        if( Write_bav ) then
          write(3,110) iapr, ia_i, i_ion, p(:)*bohr, Dab*bohr
          write(3,'(/18x,a7,36x,a5)') 'Mat_rot','Rot_a'
          do i = 1,3
            write(3,'(1p,2(2x,3e13.5))') Mat_rot(i,:), Rot_a(i,:)
          end do
        endif

        if( Write_bav )  write(3,'(/A)') ' Atom a'
        call Rotation_mat(Dlmm_ia,icheck_13,Rot_a,Lmax_pot,Ylm_comp)

        dab2 = Dab**2

        do ir = 0,nrato(it)

          dabr = 2 * Dab * rato(ir,it)

          Vlm_c(:) = ( 0._db, 0._db )

          do i = 1,n_theta

            Theta = ( i - 0.5_db ) * dtheta
            Sin_Theta_dtheta = Sin( Theta ) * dtheta
            dist = sqrt( dab2 + r2(ir) - dabr * cos( Theta ) )

            if( abs( dist ) < eps10 ) then
              Delta_V = - 2 * Charge * 2 / ( sqrt_2pi * Sigma )
            else
              x = dist / Sqrt_2_Sigma
              Delta_V = - 2 * Charge * ( 1 - erfc( x ) ) / dist
            endif

            Fac = 2 * pi * Delta_V * Sin_Theta_dtheta

 ! because:  Plm(1) = 1._db / sqrt( quatre_pi ) and isotrope pot includes the 1._db / sqrt( quatre_pi ) of Y(0,0)
            Vlm_c(1) = Vlm_c(1) + Fac / ( 4 * pi )
            do L = 1,Lmax_pot
              m = 0
              Lm = L**2 + L + 1 + m
!              Plm_ab = Plm_a_i(Lm,i) * sqrt_4pi  ! because V_0 = sqrt(4pi) * V
!                if( L == 0 ) Plm_ab = Plm_ab / sqrt_4pi   ! because V_0 = sqrt(4pi) * V, and we keep V
              Vlm_c(Lm) = Vlm_c(Lm) + Fac * Plm_a_i(Lm,i)
            end do

          end do ! on theta

      ! Going back to the ia atom basis
          Vlm_a(:) = ( 0._db, 0._db )
          do L = 0,Lmax_pot
            do m = -L,L
              Lm = L**2 + L + 1 + m
           ! terms with mp /= 0 are zero
              mp = 0
              Lmp = L**2 + L + 1 + mp
              Vlm_a(Lm) = Vlm_a(Lm) + Dlmm_ia(m,mp,L) * Vlm_c(Lmp)
            end do
          end do

          dVc(ir) = dVc(ir) + real( Vlm_a(1), db )
          Vcato(ir,:,iapr) = Vcato(ir,:,iapr) + real( Vlm_a(:), db )

        end do ! end of loop on ir

      end do

      if( icheck_13 > 1 ) write(3,*)
      if( icheck_13 > 0 ) write(3,200) Numat(it), ipr, ia_i, dVc(0) * rydb

      if( icheck_13 > 2 ) then
        write(3,120) ia_i, iapr, ipr, Numat(it)
        if( nlm_pot == 1 ) then
          write(3,130)
        elseif( nlm_pot == 4 ) then
          write(3,150) (Lm, Lm = 1,nlm_pot)
        elseif( nlm_pot == 9 ) then
          write(3,170) (Lm, Lm = 1,nlm_pot)
        else
          write(3,190) (Lm, Lm = 1,nlm_pot)
        endif
        do ir = 1,nrato(it)
          write(3,'(1p,100e13.5)') rato(ir,it)*bohr, Vcato(ir,1,iapr)*rydb, dVc(ir)*rydb, Vcato(ir,2:nlm_pot,iapr)*rydb
        end do
      endif

    else

      Ps(:) = Posi(:,ia_i)
      call Ion_potential(Counter_ion,Counter_linear,delta_z_lin,igroup_ion,n_counter_ion,natomp_ion,Pos_ion,Ps,Rot_cluster,V_ion, &
                         V_surf,z_surf)

      Vcato(:,1,iapr) = Vcato(:,1,iapr) + V_ion

      if( icheck_13 > 1 .or. iapr == 1 ) write(3,*)
      if( icheck_13 > 0 ) write(3,200) Numat(it), ipr, ia_i, V_ion * rydb
    endif

  end do Loop_iapr

  return
  100 format(/' ---- Atom_Counter_ion ',98('-'))
  110 format(/' iapr =',i3,', ia =',i3,', i_ion =',i3,', P =',3f9.5,', Dist_ab =',f9.5)
  120 format(/' ia =',i3,', iapr =',i3,', ipr =',i3,', Z =',i3, ', counter ions')
  130 format(4x,'Radius      Vcato           dVc')
  150 format(4x,'Radius     Vcato(lm=',i1,')   dVc(lm=1) ',3('  Vcato(lm=',i1,')'))
  170 format(4x,'Radius     Vcato(lm=',i1,')   dVc(lm=1) ',8('  Vcato(lm=',i1,')'))
  190 format(4x,'Radius     Vcato(lm=',i1,')   dVc(lm=1) ',15('  Vcato(lm=',i1,')'))
  200 format(' Z =',i3,', ipr =',i3,', ia =',i3,', Delta_V Counter ions =',f10.5,' eV')
end

!***********************************************************************

 subroutine Ion_potential(Counter_ion,Counter_linear,delta_z_lin,igroup_ion,n_counter_ion,natomp_ion,Pos_ion,Ps,Rot_cluster,V_ion, &
                          V_surf,z_surf)

  use declarations
  implicit none

  integer:: n_counter_ion, natomp_ion

  integer, dimension(natomp_ion):: igroup_ion

  logical:: Counter_linear

  real(kind=db):: delta_z, delta_z_lin, V_ion, V_S, z, z_surf

  real(kind=db), dimension(3):: Ps, V_surf
  real(kind=db), dimension(3,3):: Rot_cluster
  real(kind=db), dimension(3,natomp_ion):: Pos_ion
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion

  if( Counter_linear ) then

    z = sum( V_surf(1:3) * Ps(1:3) )

    if( z < z_surf - Delta_z_lin + eps10 ) then

      V_ion = 0._db

    elseif( z < z_surf - eps10 ) then

      Ps = Matmul( Rot_cluster, Ps )
      Ps(3) = z_surf
      Ps = Matmul( Transpose( Rot_cluster ), Ps )

      call Ion_potential_full(Counter_ion,igroup_ion,n_counter_ion,natomp_ion,Pos_ion,Ps,V_S)

      delta_z = z_surf - z

      V_ion = V_S * ( delta_z_lin - delta_z ) / delta_z_lin

    else

      call Ion_potential_full(Counter_ion,igroup_ion,n_counter_ion,natomp_ion,Pos_ion,Ps,V_ion)

    endif

  else

    call Ion_potential_full(Counter_ion,igroup_ion,n_counter_ion,natomp_ion,Pos_ion,Ps,V_ion)

  endif

  return
end

!***********************************************************************

 subroutine Ion_potential_full(Counter_ion,igroup_ion,n_counter_ion,natomp_ion,Pos_ion,Ps,V_ion)

  use declarations
  implicit none

  real(kind=db), parameter:: sqrt_2pi = sqrt( 2 * pi )

  integer:: i_ion, igr, n_counter_ion, natomp_ion

  integer, dimension(natomp_ion):: igroup_ion

  real(kind=db):: Charge, dist, Sigma, V_ion, x

  real(kind=db), dimension(3):: P, Ps
  real(kind=db), dimension(3,natomp_ion):: Pos_ion
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion

  V_ion = 0._db

  do i_ion = 1,natomp_ion

    igr = igroup_ion(i_ion)
    Charge = Counter_ion(4,igr)
    Sigma = Counter_ion(5,igr)

    P(:) = Pos_ion(:,i_ion) - Ps(:)
    dist = sqrt( sum( P(:)**2 ) )

    if( dist < eps10 ) then
      V_ion = V_ion - 2 * Charge * 2 / ( sqrt_2pi * Sigma )
    else
      x = dist / ( sqrt_2 * Sigma )
      V_ion = V_ion - 2 * Charge * ( 1 - erfc( x ) ) / dist
    endif

  end do

  return
end

!***********************************************************************

! Routine adding the counter dipoles potential

subroutine Atom_counter_dip(Bulk_atom_done,Cal_xanes,Counter_dip,Counter_linear,delta_z_lin,Full_atom,ia_eq_inv, &
        ia_eq_inv_self,iapot,iapr0,iaprotoi, &
        icheck_13,igroup_dip,iprabs_nonexc,itypei,n_atom_0,n_atom_ind,n_atom_proto,n_atom_proto_bulk,n_counter_dip, &
        n_iapr,natome,natome_self,natomeq,natomeq_self,natomp,natomp_dip,nlm_pot,nrm,ntype,Nonexc,Numat,Pos, &
        Pos_dip,Posi,Rot_cluster,SCF,Self_nonexc,Vcato,V_surf,z_surf)

  use declarations
  implicit none

  integer:: ia, ia_i, iapr, iapr0, icheck_13, ipr, iprabs_nonexc, it, japr, &
    n_atom_0, n_atom_ind, n_atom_proto, n_atom_proto_bulk, n_counter_dip, n_iapr, natome, natome_self, natomeq, &
    natomeq_self, natomp, natomp_dip, nlm_pot, nrm, ntype

  integer, dimension(natomp_dip):: igroup_dip
  integer, dimension(0:n_atom_proto):: iapot
  integer, dimension(natome):: iaprotoi, itypei
  integer, dimension(0:ntype):: Numat
  integer, dimension(natomeq):: ia_eq_inv
  integer, dimension(natomeq_self):: ia_eq_inv_self

  logical:: Bulk_atom_done, Cal_xanes, Counter_linear, Full_atom, Nonexc, SCF, Self_nonexc, Write_bav

  real(kind=db):: delta_z_lin, V_dip, z_surf

  real(kind=db), dimension(3):: Ps, V_surf
  real(kind=db), dimension(3,3):: Rot_cluster
  real(kind=db), dimension(6,n_counter_dip):: Counter_dip
  real(kind=db), dimension(3,natome):: Posi
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(3,natomp_dip):: Pos_dip
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato

  Write_bav = icheck_13 > 2

  if( icheck_13 > 0 ) write(3,100)

! Loop over all the atoms
  Loop_iapr: do iapr = iapr0,n_iapr

! Calculation of ia and ipr
    call Convert_iapr(Cal_xanes,Full_atom,ia,iapot,iapr,iaprotoi,ipr,iprabs_nonexc,n_atom_0,n_atom_proto,natome,natomp, &
                        Nonexc,Pos,Posi,Self_nonexc)

    if( ia == 0 .or. ia > natomeq ) cycle

 ! By default, bulk atoms have no counter_dip
    if( Bulk_atom_done .and. ipr > n_atom_proto - n_atom_proto_bulk ) cycle

 ! For atoms already calculated, dipoles are already included
    if( SCF .and. Cal_xanes .and. ia <= natomeq_self .and. Full_atom .and. &
        ( ( ia /= iapot(0) .and. ipr /= 0 ) .or. ipr == 0 ) ) then
      do japr = 1,natome_self
        if( ia_eq_inv_self(ia) == japr ) cycle Loop_iapr
      end do
    endif

    ia_i = ia_eq_inv(ia)
    it = itypei(ia_i)

    Ps(:) = Posi(:,ia_i)

    call Dip_potential(icheck_13,Counter_dip,Counter_linear,delta_z_lin,igroup_dip,n_counter_dip,natomp_dip,Pos_dip,Ps, &
                       Rot_cluster,V_dip,V_surf,z_surf)

    Vcato(:,1,iapr) = Vcato(:,1,iapr) + V_dip

    if( icheck_13 > 1 .or. iapr == 1 ) write(3,*)
    if( icheck_13 > 0 ) write(3,200) Numat(it), ipr, ia_i, V_dip * rydb

  end do Loop_iapr

  return
  100 format(/' ---- Atom_Counter_dip ',98('-'))
  200 format(' Z =',i3,', ipr =',i3,', ia =',i3,', V Counter dips =',f10.5,' eV')
end

!***********************************************************************

subroutine Dip_potential(icheck_13,Counter_dip,Counter_linear,delta_z_lin,igroup_dip,n_counter_dip,natomp_dip,Pos_dip,Ps, &
                         Rot_cluster,V_dip,V_surf,z_surf)

  use declarations
  implicit none

  integer:: icheck_13, n_counter_dip, natomp_dip

  integer, dimension(natomp_dip):: igroup_dip

  logical:: Counter_linear

  real(kind=db):: delta_z, delta_z_lin, V_dip, V_S, z, z_surf

  real(kind=db), dimension(3):: Ps, V_surf
  real(kind=db), dimension(3,3):: Rot_cluster
  real(kind=db), dimension(3,natomp_dip):: Pos_dip
  real(kind=db), dimension(6,n_counter_dip):: Counter_dip

  if( Counter_linear ) then

    z = sum( V_surf(1:3) * Ps(1:3) )

    if( z < z_surf - Delta_z_lin + eps10 ) then

      V_dip = 0._db

    elseif( z < z_surf - eps10 ) then

      Ps = Matmul( Rot_cluster, Ps )
      Ps(3) = z_surf
      Ps = Matmul( Transpose( Rot_cluster ), Ps )

      call Dip_potential_full(icheck_13,Counter_dip,igroup_dip,n_counter_dip,natomp_dip,Pos_dip,Ps,V_S,V_surf)

      delta_z = z_surf - z

      V_dip = V_S * ( delta_z_lin - delta_z ) / delta_z_lin

    else

      call Dip_potential_full(icheck_13,Counter_dip,igroup_dip,n_counter_dip,natomp_dip,Pos_dip,Ps,V_dip,V_surf)

    endif

  else

    call Dip_potential_full(icheck_13,Counter_dip,igroup_dip,n_counter_dip,natomp_dip,Pos_dip,Ps,V_dip,V_surf)

  endif

  return
end

!***********************************************************************

subroutine Dip_potential_full(icheck_13,Counter_dip,igroup_dip,n_counter_dip,natomp_dip,Pos_dip,Ps,V_dip,V_surf)

  use declarations
  implicit none

  integer, parameter:: n_theta = 360
  integer, parameter:: nr = 200

  integer:: i_dip, i_theta, igr, icheck_13, ir, n_counter_dip, natomp_dip

  integer, dimension(natomp_dip):: igroup_dip

  real(kind=db):: Cos_Theta_s, dr, dtdr, dtheta, dV, Fac, Fct_dip, Int_Gauss, Integral, Moment, &
    Potential_dip, Prefac, r, r2, s, s2, s2_p_r2, Sigma, Smax, sr2, Theta, V_dip

  real(kind=db), dimension(3):: P, Ps, V_surf
  real(kind=db), dimension(n_theta):: Cos_theta, Fct_theta, Sin_theta
  real(kind=db), dimension(3,natomp_dip):: Pos_dip
  real(kind=db), dimension(6,n_counter_dip):: Counter_dip

  dtheta = pi / n_theta

  Theta = - dtheta / 2
  do i_theta = 1,n_theta
    Theta = Theta + dtheta
    Sin_theta(i_theta) = sin( Theta )
    Cos_theta(i_theta) = cos( Theta )
  end do

  V_dip = 0._db
  do i_dip = 1,natomp_dip

    igr = igroup_dip(i_dip)
    Moment = Counter_dip(4,igr)
    Sigma = Counter_dip(5,igr)

    Smax = 4 * Sigma

    P(:) = Ps(:) - Pos_dip(:,i_dip)
    s = sqrt( sum( P(:)**2 ) )

    if( s < eps10 ) cycle

    Cos_Theta_s = sum( V_surf(:) * P(:) ) / s

    if( s > Smax ) then

! Far from the center, one keeps the not convoluted formula for dipole
      Fct_dip = Cos_Theta_s / s**2

    else

      Prefac = 1 / ( deux_pi**1.5_db * Sigma**3 )

      dr = Smax / nr
      dtdr = dtheta * dr

      s2 = s**2

! Point at origin
      dV = ( quatre_pi / 3._db ) * ( dr / 2 )**3
      Int_Gauss = dV
      Integral = dV / s2
 ! because remultiplied by this term further
      Integral = Integral / ( deux_pi * dtdr )

      r = 0._db

      do ir = 1,nr
        r = r + dr
        r2 = r**2
        sr2 = 2 * s * r
        s2_p_r2 = s2 + r2
        Fac = exp( -0.5 * ( r / Sigma )**2 ) * r2

        Int_Gauss = Int_Gauss + quatre_pi * dr * Fac

        Fct_theta(:) = ( s - r * Cos_theta(:) ) * Fac * Sin_theta(:) &
                     / ( s2_p_r2 - sr2 * Cos_theta(:) )**1.5_db

        Integral = Integral + sum( Fct_theta(:) )

      end do

      Integral = Integral * deux_pi * dtdr

      Integral = Integral / Int_Gauss

      Fct_dip = Cos_Theta_s * Integral

    endif

 ! Sign minus because a positive charge gives a negative potential
 ! Factor 2 is to be in Rydberg (Moment = q * a with q in number of electron, 'a' in bohr radius )
    Potential_dip = - 2 * Moment * Fct_dip
    V_dip = V_dip + Potential_dip

    if( icheck_13 > 3 ) then
      Int_Gauss = Int_Gauss * Prefac
      if( i_dip == 1 ) write(3,'(/A)') ' dip   dist    Gauss     Integral      Fct_dip    Potential'
      if( S > Smax ) then
        Write(3,'(i4,2f9.5,26x,1p,2e13.5)') i_dip, s/bohr, Cos_theta_s, Fct_dip*bohr**2, Potential_dip * Rydb
      else
        Write(3,'(i4,2f9.5,1p,4e13.5)') i_dip, s/bohr, Cos_theta_s, Int_Gauss, Integral, Fct_dip*bohr**2, Potential_dip * Rydb
      endif
    endif

  end do

  return
end

!***********************************************************************

! Routine adding the Helmholtz potential

! if XANES radius > SCF Radius, with SCF calculation, Helmholtz not applied to the XANES atoms between the corresponding spheres

subroutine Atom_Helmholtz(Cal_xanes,Full_atom,Helm_cos,Helm_fac,Helm_lin,Helm_mix,ia_eq_inv,ia_eq_inv_self,iapot,iapr0,iaprotoi, &
        icheck_13,iprabs_nonexc,itypei,Lmax_pot,n_atom_0,n_atom_ind,n_atom_proto,n_atom_proto_bulk,n_iapr,n_theta,natome, &
        natome_self,natomeq,natomeq_self,natomp,nlm_pot,nrato,nrm,ntype,Nonexc,Numat,Orig_helm,Pos,Posi,Rato,SCF,Rot_Atom, &
        Self_nonexc,Surf_0,Sym_2D,V_helm,V_surf,Vcato,Width_helm,z_bulk,z_surf)

  use declarations
  implicit none

  integer:: i, ia, ia_i, iapr, iapr0, icheck_13, ipr, iprabs_nonexc, ir, it, japr, L, Lm, Lmax_pot, m, n_atom_0, n_atom_ind, &
    n_atom_proto, n_atom_proto_bulk, n_iapr, n_theta, natome, natome_self, natomeq, natomeq_self, natomp, nlm_pot, nrm, ntype

  integer, dimension(0:n_atom_proto):: iapot
  integer, dimension(natome):: iaprotoi, itypei
  integer, dimension(0:ntype):: nrato, Numat
  integer, dimension(natomeq):: ia_eq_inv
  integer, dimension(natomeq_self):: ia_eq_inv_self

  logical:: Cal_xanes, Full_atom, Full_potential, Helm_cos, Helm_lin, Helm_mix, Nonexc, SCF, Self_nonexc, Sym_2D
  logical, dimension(:), allocatable:: Done

  real(kind=db):: alfa, Delta_V, Dist, dtheta, Fac, Helm_fac, Orig_helm, Pos_z_a, Smooth, Surf_0, Theta, V_helm, Width_helm, &
    Width_p, x, z_surf, z_bulk

  real(kind=db), dimension(3):: V_s, V_surf
  real(kind=db), dimension(nlm_pot):: Dlm0
  real(kind=db), dimension(n_theta):: Delta_V_helm
  real(kind=db), dimension(3,3):: Rot_a
  real(kind=db), dimension(3,natome):: Posi
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(0:nrm,0:ntype):: Rato
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato
  real(kind=db), dimension(n_theta,0:Lmax_pot):: YlmSintdt
  real(kind=db), dimension(3,3,natome):: Rot_Atom

  allocate( Done(iapr0:n_iapr) )

! alfa is such that sqrt(pi/2) * erf( alfa/sqrt(2) ) / alfa = 0.5
  alfa = 2.47304793497921_db

  Full_potential = nlm_pot > 1
  dtheta = pi / n_theta

  Width_p = Width_helm / ( sqrt(2._db) * alfa )

  if( Full_potential .and. Sym_2D ) then
    call Ylm_Sintheta_dtheta(Lmax_pot,n_theta,YlmSintdt)
    call Cal_Dlm0(1._db,Dlm0,Lmax_pot,nlm_pot,V_surf)
  endif

! Loop over all the atoms
  Loop_iapr: do iapr = iapr0,n_iapr

! Calculation of ia and ipr
    call Convert_iapr(Cal_xanes,Full_atom,ia,iapot,iapr,iaprotoi,ipr,iprabs_nonexc,n_atom_0,n_atom_proto,natome,natomp, &
                        Nonexc,Pos,Posi,Self_nonexc)
    if( ia == 0 .or. ia > natomeq ) cycle

 ! Bulk atoms have no Helmholtz
    if( ipr > n_atom_proto - n_atom_proto_bulk ) cycle

 ! For atoms already calculated, Helmholtz is already included
    if( SCF .and. Cal_xanes .and. ia <= natomeq_self .and. Full_atom .and. &
        ( ( ia /= iapot(0) .and. ipr /= 0 ) .or. ipr == 0 ) ) then
      do japr = 1,natome_self
        if( ia_eq_inv_self(ia) == japr ) cycle Loop_iapr
      end do
    endif

    ia_i = ia_eq_inv(ia)

    Rot_a(:,:) = Rot_Atom(:,:,ia_i)
    Rot_a = Transpose( Rot_a )

    V_s = Matmul( Rot_a, V_surf )

    it = itypei(ia_i)

    Fac = 1._db
    Smooth = 1._db

    if( Sym_2D ) then
      Pos_z_a = sum( V_s(1:3) * Posi(1:3,ia_i) )

! In case of mix or lin, the modification is done not on the shape, but at the atom center
      if( ( Helm_mix .or. Helm_lin ) .and. Pos_z_a < z_surf - eps10 .and. z_surf < Orig_helm - eps10 ) then
! With Helm_lin option, a shorter linear shape is used below the last atom
        Fac = 0.5_db * sqrt(pi) * V_helm * Helm_fac * ( Pos_z_a - Surf_0 )
! With Helm_mix option, a shorter parabolic potential shape is used below the last atom
        if( Helm_mix ) Fac = Fac * ( Pos_z_a - Surf_0 )
          x = ( Pos_z_a - Orig_helm ) / Width_p
          if( abs( x ) < eps10 ) then
            Fac = Fac / V_helm
          else
            Fac = Fac / ( 0.5_db * sqrt(pi) * V_helm * ( 1 - erfc( x ) ) / x )
          endif
        endif
      endif

! Same for smoothing, only at the atom center
    if( z_bulk > -999._db .and. z_surf > -999._db ) then
      Smooth = ( Pos_z_a - z_bulk ) / ( z_surf - z_bulk )
      Smooth = max( Smooth, 0._db )
      Smooth = min( Smooth, 1._db )
    endif

    Loop_ir: do ir = 0,nrato(it)

      Delta_V_helm(:) = 0._db

      do i = 1, n_theta
        Theta = ( i - 0.5_db ) * dtheta

! used only for the .not. Atom_self atom, but set here for the writing during the xanes step
        if( Sym_2D ) then
          if( Full_potential ) then
            Dist = Pos_z_a + rato(ir,it) * cos( Theta )
          else
            Dist = Pos_z_a
          endif
        else
          Dist = sqrt( sum( Posi(:,ia_i)**2 ) )
        endif

        if( Helm_cos ) then

          if( dist > Orig_helm - Width_helm .and. dist < Orig_helm + Width_helm ) &
            Delta_V_helm(i) = Smooth * 0.5_db * V_helm * ( 1 + cos( pi * ( dist - Orig_helm ) / Width_helm ) )

        else

          if( dist <= Surf_0 ) cycle

          x = ( dist - Orig_helm ) / Width_p

          if( abs( x ) < eps10 ) then
            Delta_V_helm(i) = V_helm
          else
            Delta_V_helm(i) = Smooth * Fac * 0.5_db * sqrt(pi) * V_helm * ( 1 - erfc( x ) ) / x
          endif
        endif

      end do

      do L = 0,Lmax_pot
        if( Full_potential .and. Sym_2D ) then
          Delta_V = sum( Delta_V_helm(1:n_theta) * YlmSintdt(1:n_theta,L) )
        else
          Delta_V = Delta_V_helm(1)
          Vcato(:,1,iapr) = Vcato(:,1,iapr) + Delta_V
          exit
        endif
        do m = -l,l
          if( L == 0 ) then
            Vcato(ir,1,iapr) = Vcato(ir,1,iapr) + Delta_V
          else
            Lm = L**2 + L + 1 + m
            Vcato(ir,Lm,iapr) = Vcato(ir,Lm,iapr) + Dlm0(Lm) * Delta_V
          endif
        end do
      end do

      if( .not. ( Full_potential .and. Sym_2D ) ) exit Loop_ir
    end do Loop_ir

    if( .not. ( Full_potential .and. Sym_2D ) ) then
      if( icheck_13 > 1 ) write(3,*)
      if( icheck_13 > 0 ) write(3,110) ia_i, ipr, Numat(it), Smooth, Delta_V * rydb
    endif

    if( Full_potential .and. icheck_13 > 2 ) then
      write(3,120) ia_i, iapr, ipr, Numat(it)
      if( nlm_pot == 1 ) then
        write(3,130)
      elseif( nlm_pot == 4 ) then
        write(3,150) (Lm, Lm = 1,nlm_pot)
      elseif( nlm_pot == 9 ) then
        write(3,170) (Lm, Lm = 1,nlm_pot)
      else
        write(3,190) (Lm, Lm = 1,nlm_pot)
      endif
      do ir = 1,nrato(it)
        write(3,'(1p,100e13.5)') rato(ir,it)*bohr, Vcato(ir,:,iapr)*rydb
      end do
    endif

  end do Loop_iapr

  return
  110 format(' ia =',i3,', ipr =',i3,', Z =',i3,', Smooth =',f6.3,', Delta_V_helmholtz =',f10.5,' eV')
  120 format(/' ia =',i3,', iapr =',i3,', ipr =',i3,', Z =',i3, ', with Helmholtz')
  130 format(4x,'Radius     Vcato')
  150 format(4x,'Radius   ',4('  Vcato(lm=',i1,')'))
  170 format(4x,'Radius   ',9(' Vcato(lm=',i1,') '))
  190 format(4x,'Radius   ',16(' Vcato(lm=',i1,') '))
end

!***********************************************************************

! Calculation of Ylm(L,0) * sin_theta * d_theta
! Components to calculate the V_(L,0) components of potential or density.
! In order to corresponds to a simple average for V_0 (as classical V), the correponding component is divided by sqrt(4pi)

subroutine Ylm_Sintheta_dtheta(Lmax_pot,n_theta,YlmSintdt)

  use declarations
  implicit none

  integer:: i, L, Lmax_pot, n_theta

  real(kind=db):: cos_theta, dtheta, ra1, ra2, ra3, sin_dTheta, sin_half_dTheta, sin_Theta, Theta, Tiers
  real(kind=db), dimension(n_theta,0:Lmax_pot):: YlmSintdt

  dtheta = pi / n_theta
  sin_dtheta = sin( dtheta )
  sin_half_dtheta = sin( dtheta / 2 )
  ra1 = sqrt(3 / quatre_pi)
  ra2 = 0.5_db * sqrt(45 / quatre_pi)
  ra3 = 0.5_db * sqrt(175 / quatre_pi)
  Tiers = 1 / 3._db

! The integral of sin(theta).dtheta.dphi is 4pi
! For L = 0, YlmSintdt is in fact (2pi/4pi) * sqrt(4.pi) * Ylm * Sin_theta * dtheta
  do i = 1,n_theta
    Theta = ( i - 0.5_db ) * dtheta
    sin_theta = sin( theta )
    if( Lmax_pot > 0 ) cos_theta = cos( theta )
    do L = 0,Lmax_pot
      select case(L)
        case(0)
!  Int(sin(theta)*dtheta)_theta-dtheta/2,theta+dtheta/2 = 2 * sin_theta * sin(dtheta/2) ( for L = 0, simple average )
!          YlmSintdt(i,L) = 0.5_db * sin_theta * dtheta
          YlmSintdt(i,L) = sin_theta * sin_half_dtheta
        case(1)
! Y(L,0)*Sin(theta)*dtheta
!  Int(cos(theta)*sin(theta)*dtheta)_theta-dtheta/2,theta+dtheta/2 = sin(theta) * cos(theta) * sin(dtheta)
!          YlmSintdt(i,L) = ra1 * cos_theta * sin_theta * dtheta
          YlmSintdt(i,L) = ra1 * cos_theta * sin_theta * sin_dtheta
        case(2)
          YlmSintdt(i,L) = ra2 * ( cos_theta**2 - Tiers ) * sin_theta * dtheta
        case(3)
          YlmSintdt(i,L) = ra3 * ( cos_theta**2 - 0.6_db ) * cos_theta * sin_theta * dtheta
        case default
          YlmSintdt(i,L) = ( sqrt(4*L**2 - 1._db) / L ) * ( cos_theta * YlmSintdt(i,L-1) &
               - ( ( L - 1._db ) / sqrt((2*L-1._db)*(2*L-3._db)) ) * YlmSintdt(i,L-2) )
      end select
    end do
  end do

  return
end

!***********************************************************************

! Routine making the superposition to calculate the Hartree (Coulomb) potential, the exchange-correlation potential and
! the electronic density in the ground state

subroutine Pot0muffin( alfpot, Bulk_atom_done, Cal_xanes, Chargat, chargat_init, chargat_self, Delta_Vcato_ns, dExc_ex_nex, &
        drho_ex_nex, dVc_ex_nex, dVcato, dVxc_ex_nex, E_moment, Excato, Full_atom, i_self, ia_eq_inv, ia_eq_inv_self, &
        iaproto, iapot, iapr_p, &
        iapr0, iaprex, iaprotoi, icheck_13, ipr_useful, iprabs_nonexc, itypep, itypepr, Lmax_pot, Magnetic, &
        n_atom_0, n_atom_0_self, n_atom_ind, n_atom_ind_self, n_atom_proto, n_atom_proto_bulk, n_iapr, n_ipr_useful, natome, &
        natome_self, natomeq, natomeq_self, natomp, nb_test, nlm_pot, Nonexc, nrato, nrm, nrm_self, nspin, ntype, Numat, &
        One_SCF_surf, Pos, Posi, Rato, Rho_cato, rho_self, rhoato, rhoato_out, Rhoigr, Rot_atom, Rot_atomp, Rot_E_moment, &
        rsato, SCF, Self_nonexc, Test_case, Vato, Vcato, Vxcato, Ylm_comp )

  use declarations
  implicit none

! number of theta values for the integration in the sphere
  integer, parameter:: nthetam = 60

  real(kind=db), parameter:: sqrt_4pi = sqrt( 4 * pi )

  integer:: i, i_self, ia, ia_i, iapr, iapr0, iaprb, iaprex, ib, icheck_13, index, ipr, iprabs_nonexc, iprb, ir, irb, isp, it, &
    itb, japr, japrb, L, Lm, Lmax_pot, Lmp, Lp, m, mp, n_atom_0, n_atom_0_self, n_atom_ind, n_atom_ind_self, n_atom_proto, &
    n_atom_proto_bulk, n_iapr, n_ipr_useful, natome, natome_self, natomeq, natomeq_self, natomp, nb_test, nlm_pot, nr, nrm, &
    nrm_self, nrmin, nspin, ntheta, ntheta1, ntype

  integer, dimension(natomeq):: ia_eq_inv
  integer, dimension(natomeq_self):: ia_eq_inv_self
  integer, dimension(natomp):: iapr_p, iaproto, itypep
  integer, dimension(0:ntype):: nrato, Numat
  integer, dimension(0:n_atom_proto):: iapot, itypepr
  integer, dimension(natome):: iaprotoi
  integer, dimension(0:n_ipr_useful):: ipr_useful

  complex(kind=db), dimension(:), allocatable:: Vlm_a, Vlm_b, Vlm_c
  complex(kind=db), dimension(:,:,:), allocatable:: Dlmm_ia, Dlmm_ib

  logical:: Atom_self, Bulk_atom_done, Cal_xanes, Full_atom, Magnetic, Nonexc, One_SCF_surf, SCF, SCF_atom, Self_nonexc, &
    This_bulk_atom_done, Write_bav, Ylm_comp

  logical, dimension(nb_test):: Test_case

  real(kind=db):: alfpot, Dab, dab2, dabr, dch, dist, drhm, dtheta, dvcm, E_moment, p1, p2, Plm_ab, Rayop, rpotmin, Theta, &
                  Theta_b, Vrop

  real(kind=db), dimension(3):: p, Vx, Vy, Vz
  real(kind=db), dimension(3,3):: Mat_rot, Rot_a, Rot_b, Rot_E_moment
  real(kind=db), dimension(nrm):: dExc_ex_nex, dVc_ex_nex
  real(kind=db), dimension(nspin):: rhoigrop
  real(kind=db), dimension(nlm_pot):: Dlm0, Plm_a, Plm_b, Vlm
  real(kind=db), dimension(nrm,nspin):: drho_ex_nex, dVxc_ex_nex
  real(kind=db), dimension(n_atom_0_self:n_atom_ind_self,nspin):: chargat_init, chargat_self
  real(kind=db), dimension(3,natome):: Posi
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(0:n_atom_proto):: Chargat
  real(kind=db), dimension(0:nrm,0:n_ipr_useful):: Vato
  real(kind=db), dimension(n_atom_0:n_atom_ind):: Delta_V_E_moment, Delta_Vcato_ns, Rho_cato
  real(kind=db), dimension(nrm,n_atom_0:n_atom_ind):: Excato
  real(kind=db), dimension(0:nrm,n_atom_0:n_atom_ind):: rsato
  real(kind=db), dimension(3,3,natome):: Rot_Atom
  real(kind=db), dimension(3,3,natomp):: Rot_Atomp
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: dVcato, Vcato
  real(kind=db), dimension(0:nrm,nspin,n_atom_0:n_atom_ind):: rhoato
  real(kind=db), dimension(0:nrm,nspin,n_atom_0_self:n_atom_ind_self):: rhoato_out
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind):: Vxcato
  real(kind=db), dimension(0:nrm,nspin,0:n_ipr_useful):: Rhoigr
  real(kind=db), dimension(0:nrm_self,nlm_pot,nspin,n_atom_0_self:n_atom_ind_self):: rho_self
  real(kind=db), dimension(0:nrm,0:ntype):: Rato

  real(kind=db), dimension(:), allocatable:: dvc, r, r2
  real(kind=db), dimension(:,:), allocatable:: drh, Plm_a_i, YlmSintdt

  Write_bav = ( icheck_13 > 1 .and. ( Cal_xanes .or. i_self == 1 ) ) .or. icheck_13 > 2
  if( Write_bav ) write(3,110)

  allocate( Dlmm_ia(-Lmax_pot:Lmax_pot,-Lmax_pot:Lmax_pot,0:Lmax_pot) )
  allocate( Dlmm_ib(-Lmax_pot:Lmax_pot,-Lmax_pot:Lmax_pot,0:Lmax_pot) )
  allocate( drh(nthetam,nspin) )
  allocate( dvc(nthetam) )
  allocate( Plm_a_i(nlm_pot,nthetam) )
  allocate( r(0:nrm) )
  allocate( r2(0:nrm) )
  allocate( Vlm_a(nlm_pot) )
  allocate( Vlm_b(nlm_pot) )
  allocate( Vlm_c(nlm_pot) )
  allocate( YlmSintdt(nthetam,0:Lmax_pot) )

  call Ylm_Sintheta_dtheta(Lmax_pot,nthetam,YlmSintdt)
  dtheta = pi / nthetam

  if( nlm_pot > 1 ) then
    do i = 1,nthetam
      Theta = ( i - 0.5_db ) * dtheta
      call Cal_Plm(Lmax_pot,Plm_a,nlm_pot,Theta)
      Plm_a_i(:,i) = Plm_a(:)
    end do
  endif

! Loop over the atoms (non equivalent in the cluster or in the space-group)
  do iapr = iapr0,n_iapr

! Calculation of ia and ipr
    call Convert_iapr(Cal_xanes,Full_atom,ia,iapot,iapr,iaprotoi,ipr,iprabs_nonexc,n_atom_0,n_atom_proto,natome,natomp, &
                        Nonexc,Pos,Posi,Self_nonexc)
    if( ia == 0 ) cycle
    it = itypepr(ipr)

    if( Bulk_atom_done .and. ipr > n_atom_proto - n_atom_proto_bulk ) then
! Complementary work
      call Comp_PotSup( alfpot, Atom_self, dExc_ex_nex, Delta_V_E_moment, Delta_Vcato_ns, drho_ex_nex, dVc_ex_nex, dVxc_ex_nex, &
               E_moment, Excato, ia, iapr, iaprex, it, Magnetic, n_atom_0, n_atom_0_self, n_atom_ind, n_atom_ind_self, nlm_pot, &
               nr, nrm, nrm_self, nspin, ntype, Numat, r, rho_self, rhoato, rhoato_out, rsato, Vcato, Vxcato, Write_bav )
      cycle
    endif

    Atom_self = .false.

    if( SCF .and. i_self > 1 .and. ia <= natomeq_self ) then
      if( Full_atom .and. Cal_xanes .and. ia <= natomeq .and. ( ( ia /= iapot(0) .and. ipr /= 0 ) .or. ipr == 0 ) ) then
        do japr = 1,natome_self
          if( ia_eq_inv_self(ia) /= japr ) cycle
          Atom_self = .true.
          exit
        end do
      else
        if( Cal_xanes .and. iapr == 0 .and. Self_nonexc .and. .not. Full_atom ) then
          japr = iprabs_nonexc
        else
          japr = iapr
        endif
        Atom_self = .true.
      endif
    endif
! ia_i atom index in the symmetrized cluster
    if( iapr < n_atom_0 ) then
      ia_i = ia_eq_inv( iapot(0) )
    elseif( Full_atom ) then
      if( iapr == 0 ) then
        ia_i = ia_eq_inv( iapot(0) )
      else
        ia_i = iapr
      endif
    else
      if( natomeq_self > natomeq ) then
        if( iapot(iapr) > natomeq_self ) then
          ia_i = 0
        else
          ia_i = ia_eq_inv_self( iapot(iapr) )
        endif
      elseif( iapot(iapr) > natomeq ) then
! The atom is not in the cluster of calculation, but in the potential one
        ia_i = 0
      else
        ia_i = ia_eq_inv( iapot(iapr) )
      endif
    endif

    nr = nrato(it)

    r(0:nr) = Rato(0:nr,it)
    r2(0:nr) = r(0:nr)**2

    rpotmin = 0.1_db / bohr

    do ir = 1,nr-1
      if( Rato(ir,it) > rpotmin ) exit
    end do
    nrmin = ir

! Loop over all the atoms including the ones in the outer-sphere
    do ib = 1,natomp

      itb = itypep(ib)
      iprb = iaproto(ib)
      if( iprb == 0 .and. self_nonexc ) iprb = iprabs_nonexc

      do index = 0,n_ipr_useful
        if( ipr_useful(index) == iprb ) exit
      end do

      if( ia_i == 0 .or. ia_i > natome ) then
        p(1:3) = Pos(1:3,ib) - Pos(1:3,iapot(iapr))
      else
        p(1:3) = Pos(1:3,ib) - Posi(1:3,ia_i)
      endif
      Dab = sqrt( sum( p(:)**2 ) )

      if( Dab < epspos ) then
! One excludes the superposition of the atom with itself...
        if( i_self == 1 .and. ib == natomeq .and. iapr <= n_atom_ind_self ) rhoato_out(:,:,iapr) = rhoato(:,:,iapr)
        cycle
      endif

      iaprb = iapr_p(ib)

      if( Cal_xanes .and. iaprb == 0 .and. Self_nonexc .and. .not. Full_atom ) then
        japrb = iprabs_nonexc
      else
        japrb = iaprb
      endif

      This_bulk_atom_done = Bulk_atom_done .and. iprb > n_atom_proto - n_atom_proto_bulk
      SCF_atom = iaprb > -1 .and. ( i_self > 1 .or. This_bulk_atom_done ) .and. SCF

! Calculation of Wigner matrices
      if( nlm_pot > 1 ) call Cal_Dlm0(Dab,Dlm0,Lmax_pot,nlm_pot,p)

      if( nlm_pot > 1 .and. SCF_atom .and. ia_i /= 0 ) then
!      if( nlm_pot > 1 .and. ib <= natomeq_self ) then
! Local basis with z axis along the bond direction
        Vz(:) = p(:)
        Vz(:) = Vz(:) / sqrt( sum( Vz(:)**2 ) )

        if( abs( abs( Vz(3) ) - 1._db ) > eps10 ) then

          Vy(1) = - Vz(2) / sqrt( Vz(1)**2 + Vz(2)**2 )
          Vy(2) = Vz(1) / sqrt( Vz(1)**2 + Vz(2)**2 )
          Vy(3) = 0._db

          call prodvec( Vx, Vy, Vz )
          Vx(:) = Vx(:) / sqrt( sum( Vx(:)**2 ) )

        else

          Vx(1) = 1._db; Vx(2) = 0._db; Vx(3) = 0._db
          Vy(1) = 0._db; Vy(2) = 1._db; Vy(3) = 0._db

        endif

        Mat_rot(:,1) = Vx(:)
        Mat_rot(:,2) = Vy(:)
        Mat_rot(:,3) = Vz(:)

        Rot_a(:,:) = Rot_atom(:,:,ia_i)
        Rot_b(:,:) = Rot_atomp(:,:,ib)

! Going to the local basis
        Rot_b = Matmul( Transpose( Mat_rot ), Rot_b )
        Rot_a = Matmul( Transpose( Rot_a ), Mat_rot )

        if( icheck_13 > 2 ) then
          write(3,120) iapr, ia_i, ib, p(:)*bohr, Dab*bohr
          write(3,'(/18x,a7,36x,a5,36x,a5)') 'Mat_rot','Rot_a','Rot_b'
          do i = 1,3
            write(3,'(1p,3(2x,3e13.5))') Mat_rot(i,:), Rot_a(i,:), Rot_b(i,:)
          end do
        endif

        if( icheck_13 > 2 )  write(3,'(/A)') ' Atom a'
        call Rotation_mat(Dlmm_ia,icheck_13,Rot_a,Lmax_pot,Ylm_comp)
        if( icheck_13 > 2 )  write(3,'(/A)') ' Atom b'
        call Rotation_mat(Dlmm_ib,icheck_13,Rot_b,Lmax_pot,Ylm_comp)

      endif

      dab2 = Dab**2
! When the atom ib is at more than 10 ua 3.17 A, one performs a less precise calculation
      if( Dab > 10._db ) then
        ntheta = 1
      else
        ntheta = nthetam
      endif

      if( Atom_self ) then

        if( .not. SCF_atom ) cycle

        if( ( .not. ( Test_case(1) .or. One_SCF_surf ) .and. ib > natomeq_self ) .or. japrb > n_atom_ind_self ) cycle

        if( nlm_pot > 1 ) then

          do ir = 0,nr

            dabr = 2 * Dab * r(ir)
            if( ir < nrmin ) then
              ntheta1 = 1
            else
              ntheta1 = ntheta
            endif

            Vlm_c(:) = ( 0._db, 0._db )

            do i = 1,ntheta1

              if( ntheta1 == 1 ) then
                dist = sqrt( dab2 + r2(ir) )
                dch = sum( chargat_self(japrb,:) - chargat_init(japrb,:) )
                dVcm = - 2 * dch / dist
                Vlm_c(1) = Vlm_c(1) + dVcm
                exit
              else
                Theta = ( i - 0.5_db ) * dtheta
                dist = sqrt( dab2 + r2(ir) - dabr * cos( Theta ) )
                Theta_b = acos( ( r(ir) * cos( Theta ) - Dab ) / dist )
                call Cal_Plm(Lmax_pot,Plm_b,nlm_pot,Theta_b)
              endif

              do irb = 1,nrato(itb)
                if( Rato(irb,itb) > dist ) exit
              end do

              if( irb > nrato(itb) ) then
                dch = sum( chargat_self(japrb,:) - chargat_init(japrb,:) )
                dVcm = - 2 * dch / dist
         !    For L = 0, simple average, to get V and not V_0
                Vlm_c(1) = Vlm_c(1) + 0.5_db * dVcm * Sin( Theta ) * dtheta
                cycle
              endif

              p1 = ( dist - Rato(irb-1,itb) ) / ( Rato(irb,itb) - Rato(irb-1,itb) )
              p2 = 1 - p1
              Vlm(:) = p1 * dVcato(irb,:,japrb) + p2 * dVcato(irb-1,:,japrb)
              Vlm_b(:) = ( 0._db, 0._db )
              do L = 0,Lmax_pot
                do m = -L,L
                  Lm = L**2 + L + 1 + m
                  do mp = -L,L
                    Lmp = L**2 + L + 1 + mp
                    Vlm_b(Lm) = Vlm_b(Lm) + Dlmm_ib(m,mp,L) * Vlm(Lmp)
                  end do
                end do
              end do

              do L = 0,Lmax_pot
                do m = -L,L
                  Lm = L**2 + L + 1 + m
                  do Lp = 0,Lmax_pot
                    if( abs(m) > Lp ) cycle
                    Lmp = Lp**2 + Lp + 1 + m
                    Plm_ab = Plm_a_i(Lm,i) * Plm_b(Lmp)
                    if( Lp == 0 ) Plm_ab = Plm_ab * sqrt_4pi   ! because V_0 = sqrt(4pi) * V
                    if( L == 0 ) Plm_ab = Plm_ab / sqrt_4pi   ! because V_0 = sqrt(4pi) * V, and we keep V
                    Vlm_c(Lm) = Vlm_c(Lm) + 2 * pi * Vlm_b(Lmp) * Plm_ab * Sin( Theta ) * dtheta
                  end do
                end do
              end do

            end do ! on theta

    ! Going back to the ia_i atom basis
            Vlm_a(:) = ( 0._db, 0._db )
            do L = 0,Lmax_pot
              do m = -L,L
                Lm = L**2 + L + 1 + m
                do mp = -L,L
                  Lmp = L**2 + L + 1 + mp
                  Vlm_a(Lm) = Vlm_a(Lm) + Dlmm_ia(m,mp,L) * Vlm_c(Lmp)
                end do
              end do
            end do

            Vcato(ir,:,iapr) = Vcato(ir,:,iapr) + real( Vlm_a(:), db )

          end do ! end of loop on ir

        elseif( ib <= natomeq_self .or. Test_case(1) .or. One_SCF_surf ) then
          if( ia_eq_inv_self(ib) <= natome_self ) then
      ! nlm_pot = 1 case
            dch = sum( chargat_self(japrb,:) - chargat_init(japrb,:) )
            dVcm = - 2 * dch / Dab
            Vcato(0:nr,1,iapr) = Vcato(0:nr,1,iapr) + dVcm
          endif
        endif

      elseif( Dab > Rato(nrato(itb),itb) ) then

        dVcm = - 2 * Chargat(iaproto(ib)) / Dab
        Vcato(0:nr,1,iapr) = Vcato(0:nr,1,iapr) + dVcm

      else

! Determination of the radius below wich the potential is taken constant
        do ir = 1,nrato(itb)
          if( Vato(ir,index) > -1._db ) exit
        end do
        ir = min(ir,nrato(itb))
        Rayop = Rato(ir,itb)
        Vrop = Vato(ir,index)
        rhoigrop(1:nspin) = rhoigr(ir,1:nspin,index)

        do ir = 0,nr

          dabr = 2 * Dab * r(ir)
          if( ir < nrmin ) then
            ntheta1 = 1
          else
            ntheta1 = ntheta
          endif

          do i = 1,ntheta1
            if( ntheta1 == 1 ) then
              dist = sqrt( dab2 + r2(ir) )
            else
              Theta = ( i - 0.5_db ) * dtheta
              dist = sqrt( dab2 + r2(ir) - dabr * cos( theta ) )
            endif
            if( dist > Rato(nrato(itb),itb) ) then
              dVc(i) = - 2 * Chargat(iprb) / dist
              drh(i,1:nspin) = 0._db
            elseif( dist < Rayop ) then
              dVc(i) = Vrop
              drh(i,1:nspin) = rhoigrop(1:nspin)
            else
              do irb = 1,nrato(itb)
                if( Rato(irb,itb) > dist ) exit
              end do
              p1 = ( dist - Rato(irb-1,itb) ) / ( Rato(irb,itb) - Rato(irb-1,itb) )
              p2 = 1 - p1
              dVc(i) = p1 * Vato(irb,index) + p2 * Vato(irb-1,index)
              drh(i,:) = p1 * Rhoigr(irb,:,index) + p2 * Rhoigr(irb-1,:,index)
            endif
            if( Magnetic ) then
              drh(i,1) = 0.5_db * sum( drh(i,1:nspin) )
              drh(i,nspin) = drh(i,1)
            endif

          end do
          do L = 0,Lmax_pot
            if( ntheta1 == 1 ) then
              if( L > 0 ) cycle
              dVcm = dVc(1)
            else
              dVcm = sum( dVc(1:ntheta1) * YlmSintdt(1:ntheta1,L) )
            endif

            do m = -L,L
              if( L == 0 ) then
                Vcato(ir,1,iapr) = Vcato(ir,1,iapr) + dVcm
              else
                Lm = L**2 + L + 1 + m
                Vcato(ir,Lm,iapr) = Vcato(ir,Lm,iapr) + Dlm0(Lm) * dVcm
              endif
            end do
          end do

          do isp = 1,nspin
            if( ntheta1 == 1 ) then
              drhm = drh(1,isp)
            else
              drhm = sum( drh(1:ntheta1,isp) * YlmSintdt(1:ntheta1,0))
            endif
            rhoato(ir,isp,iapr) = rhoato(ir,isp,iapr) + drhm
          end do

        end do ! end of loop on ir

      endif

! We save the electronic density without the overlap from possible atoms in the outer sphere
! natomeq = number of atoms in the cluster (not symmetrized)
      if( i_self == 1 .and. ib == natomeq .and. iapr <= n_atom_ind_self ) rhoato_out(:,:,iapr) = rhoato(:,:,iapr)

    end do  ! end of loop on ib (superposition)

! Adding the possible counter atoms contribution
! Only for i_self == 1, because in the other cases, already added via rhoato_out in rho_self at the begining of each SCF iteration
    if( i_self == 1 .and. iapr <= n_atom_ind_self ) then
      if( nspin == 1 ) then
        rhoato(:,1,iapr) = rhoato(:,1,iapr) + Rho_cato(iapr)
      else
        do isp = 1,nspin
          rhoato(:,isp,iapr) = rhoato(:,isp,iapr) + 0.5_db * Rho_cato(iapr)
        end do
      endif
    endif

! Storage of density coming from the outer sphere and the possible counter atoms
    if( i_self == 1 .and. iapr <= n_atom_ind_self ) then
      rhoato_out(:,:,iapr) = rhoato(:,:,iapr) - rhoato_out(:,:,iapr)
      if( nspin == 1 ) then
        rhoato_out(:,1,iapr) = rhoato_out(:,1,iapr) + Rho_cato(iapr)
      else
        do isp = 1,nspin
          rhoato_out(:,isp,iapr) = rhoato_out(:,isp,iapr) + 0.5_db * Rho_cato(iapr)
        end do
      endif
    endif

! Electric moment contribution
    if( abs( E_moment ) > eps10 ) then
! origin at the center of the cluster (thus not necessarily at the center of the outer sphere)
      if( ia_i == 0 .or. ia_i > natome ) then
        p(1:3) = Pos(1:3,iapot(iapr))
      else
        p(1:3) = Posi(1:3,ia_i)
      endif
      p = matmul( Rot_E_moment, p )
   ! E = Grav(V) (not minus because, energy potential of electron)
      Delta_V_E_moment(iapr) = p(3) * E_moment
      Vcato(:,1,iapr) = Vcato(:,1,iapr) + p(3) * Delta_V_E_moment(iapr)
    endif

! Effect of the non spherical potential (calculated in Orbval)
    if( abs( Delta_Vcato_ns(iapr) ) > eps10 ) Vcato(:,1,iapr) = Vcato(:,1,iapr) + Delta_Vcato_ns(iapr)

! Complementary work
    call Comp_PotSup( alfpot, Atom_self, Delta_V_E_moment, Delta_Vcato_ns, dExc_ex_nex, drho_ex_nex, dVc_ex_nex, dVxc_ex_nex, &
               E_moment, Excato, ia_i, iapr, iaprex, it, Magnetic, n_atom_0, n_atom_0_self, n_atom_ind, n_atom_ind_self, nlm_pot, &
               nr, nrm, nrm_self, nspin, ntype, Numat, r, rho_self, rhoato, rhoato_out, rsato, Vcato, Vxcato, Write_bav )

  end do

  deallocate( Dlmm_ia, Dlmm_ib, drh, dvc, Plm_a_i, r, r2, Vlm_a, Vlm_b, Vlm_c, YlmSintdt )

  return
  110 format(/' ---- Pot0muffin ',98('-'))
  120 format(/' iapr =',i3,', ia =',i3,', ib =',i3,', P =',3f9.5,', Dist_ab =',f9.5)
end

!***********************************************************************

subroutine Comp_PotSup( alfpot, Atom_self, Delta_V_E_moment, Delta_Vcato_ns, dExc_ex_nex, drho_ex_nex, dVc_ex_nex, dVxc_ex_nex, &
               E_moment, Excato, ia_i, iapr, iaprex, it, Magnetic, n_atom_0, n_atom_0_self, n_atom_ind, n_atom_ind_self, nlm_pot, &
               nr, nrm, nrm_self, nspin, ntype, Numat, r, rho_self, rhoato, rhoato_out, rsato, Vcato, Vxcato, Write_bav )

  use declarations
  implicit none

  integer:: ia_i, iapr, iaprex, index, ir, isp, it, Lm, n_atom_0, n_atom_0_self, n_atom_ind, n_atom_ind_self, &
            nlm_pot, nr, nrm, nrm_self, nspin, ntype

  integer, dimension(0:ntype):: Numat

  logical:: Atom_self, Magnetic, Write_bav

  real(kind=db):: alfpot, E_moment, f, Tiers

  real(kind=db), dimension(nrm):: dExc_ex_nex, dVc_ex_nex, Exc, Vc_nex
  real(kind=db), dimension(nspin):: dVc
  real(kind=db), dimension(0:nrm):: r, r2
  real(kind=db), dimension(n_atom_0:n_atom_ind):: Delta_V_E_moment, Delta_Vcato_ns
  real(kind=db), dimension(nrm,nspin):: drho_ex_nex, dVxc_ex_nex, Vxc_nex
  real(kind=db), dimension(0:nrm,n_atom_0:n_atom_ind):: rsato
  real(kind=db), dimension(0:nrm,nspin,n_atom_0:n_atom_ind):: rhoato
  real(kind=db), dimension(nrm,n_atom_0:n_atom_ind):: Excato
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind):: Vxcato
  real(kind=db), dimension(0:nrm_self,nspin,n_atom_0_self:n_atom_ind_self):: rhoato_out

  real(kind=db), dimension(:), allocatable:: df, df2, fct, Fct_xc, Grad_rho, rr, rst, Vr, Vrp
  real(kind=db), dimension(:,:), allocatable:: rhot, Vxct
  real(kind=db), dimension(0:nrm_self,nlm_pot,nspin,n_atom_0_self:n_atom_ind_self):: rho_self

  rhoato(:,:,iapr) = max( rhoato(:,:,iapr), 1.e-12_db )

! Calculation of Seitz radius
  f = 0.75_db / pi
  Tiers = 1._db / 3._db

  allocate( df(nr) )
  allocate( df2(nr) )
  allocate( fct(nr) )
  allocate( Fct_xc(nr) )
  allocate( Grad_rho(nr) )
  allocate( rhot(nr,nspin) )
  allocate( rr(nr) )
  allocate( rst(nr) )
  allocate( Vxct(nr,nspin) )

  rr(1:nr) = r(1:nr)

  if( nspin == 1 ) then
    rsato(:,iapr) = ( f / rhoato(:,1,iapr) )**Tiers
  else
    rsato(:,iapr) = ( f / ( rhoato(:,1,iapr) + rhoato(:,2,iapr) ) )**Tiers
  endif

  do index = 1,2

    if( index == 1 ) then
      rhot(1:nr,:) = rhoato(1:nr,:,iapr)
    else
 ! correspond to the non excited atom
      rhot(1:nr,:) = rhoato(1:nr,:,iapr) - drho_ex_nex(1:nr,:)
    endif

    if( nspin == 1 ) then
      fct(1:nr) = rhot(1:nr,1)
    else
      fct(1:nr) = rhot(1:nr,1) + rhot(1:nr,2)
    endif
    call Derivation(df,fct,nr,rr)
    do ir = 1,nr
      if( fct(ir) < eps10 ) then
        Grad_rho(ir) = 0._db
      else
        Grad_rho(ir) = abs( df(ir) ) / fct(ir)
        Grad_rho(ir) = min( 10000._db, Grad_rho(ir) )
      endif
    end do

! Second derivative
    call Derivation(df2,df,nr,rr)
    do ir = 1,nr
      if( fct(ir) < eps15 ) then
        Fct_xc(ir) = 0._db
      else
        Fct_xc(ir) = df2(ir) / fct(ir)
      endif
    end do

! Exchange-correlation potential
    if( index == 1 ) then
      rst(1:nr) = rsato(1:nr,iapr)
    else
      if( nspin == 1 ) then
        rst(:) = ( f / rhot(:,1) )**Tiers
      else
        rst(:) = ( f / ( rhot(:,1) + rhot(:,2) ) )**Tiers
      endif
   endif

    if( index == 1 ) then
      call Potxc(Exc,Fct_xc,Grad_rho,Magnetic,nr,nrm,nspin,alfpot,rhot,rst,Vxct)
      Excato(:,iapr) = Exc(:)
      if( ia_i == iaprex) Vc_nex(1:nrm) = Vcato(1:nrm,1,iapr) - dVc_ex_nex(1:nrm)
    else
      call Potxc(dExc_ex_nex,Fct_xc,Grad_rho,Magnetic,nr,nrm,nspin,alfpot,rhot,rst,Vxc_nex)
      dExc_ex_nex(:) = Excato(:,iapr) - dExc_ex_nex(:)
      dVxc_ex_nex(:,:) = Vxct(:,:) - Vxc_nex(:,:)
    endif

    if( index == 1 ) then
      do isp = 1,nspin
        Vxcato(1:nr,1,isp,iapr) = Vxct(1:nr,isp)
        if( Atom_self .and. nlm_pot > 1 ) then
! Rho_self and Rhoato are both mutiplied by sqrt(4pi) in comparison to the true multipolar components
          do Lm = 2,nlm_pot
             Vxcato(1:nr,lm,isp,iapr) = Vxct(1:nr,isp) * rho_self(1:nr,Lm,isp,iapr) / ( 3 * rhoato(1:nr,isp,iapr) )
          end do
        endif
      end do
    endif

! Potential must be increasing
    if( Numat(it ) /= 0 ) then
      allocate( Vrp(nspin), Vr(nspin) )

      if( index == 1 ) then

        Vrp(:) = Vcato(1,1,iapr) + Vxcato(1,1,:,iapr)
        do ir = 2,nr
          Vr(:) = Vcato(ir,1,iapr) + Vxcato(ir,1,:,iapr)
          if( Vr(1) < Vrp(1) .or. Vr(nspin) < Vrp(nspin) ) then
            Vcato(ir,1,iapr) = Vcato(ir-1,1,iapr)
            Vxcato(ir,1,:,iapr) = Vxcato(ir-1,1,:,iapr)
            rhoato(ir,:,iapr) = rhoato(ir-1,:,iapr)
            rsato(ir,iapr) = rsato(ir-1,iapr)
            Excato(ir,iapr) = Excato(ir-1,iapr)
          endif
          Vrp(:) = Vcato(ir,1,iapr) + Vxcato(ir,1,:,iapr)
        end do

      else

        Vrp(:) = Vc_nex(1) + Vxc_nex(1,:)
        do ir = 2,nr
          Vr(:) = Vc_nex(ir) + Vxc_nex(ir,:)
          if( Vr(1) < Vrp(1) .or. Vr(nspin) < Vrp(nspin) ) then
            Vc_nex(ir) = Vc_nex(ir-1)
            Vxc_nex(ir,:) = Vxc_nex(ir-1,:)
            dExc_ex_nex(ir) = dExc_ex_nex(ir-1)
          endif
          Vrp(:) = Vc_nex(ir) + Vxc_nex(ir,:)
        end do
        dVc_ex_nex(:) = Vcato(1:nrm,1,iapr) - Vc_nex(:)
        dVxc_ex_nex(:,:) = Vxcato(1:nrm,1,:,iapr) - Vxc_nex(:,:)
      endif

      deallocate( Vrp, Vr )
    endif

    if( Write_bav ) then
      r2(:) = r(:)**2
      if( index == 1 ) then
        write(3,120) ia_i, iapr
      else
        write(3,125) ia_i
      endif
      if( iapr <= n_atom_ind_self ) then
       if( sum( abs( Delta_Vcato_ns(:) ) ) > eps10 ) Write(3,'(/a17,1p,e13.5,a3)') ' Delta_Vcato_ns =', &
                                                                                            Delta_Vcato_ns(iapr) * Rydb, ' eV'
       if( abs( E_moment ) > eps10 ) Write(3,'(/a19,1p,e13.5,a3)') ' Delta_V_E_moment =', Delta_V_E_moment(iapr) * Rydb, ' eV'
        if( nspin == 1 .and. nlm_pot == 1 ) then
          write(3,130)
        elseif( nspin == 1 .and. nlm_pot > 1 ) then
          write(3,140)
        elseif( nspin == 2 .and. nlm_pot == 1 ) then
          write(3,150)
        else
          write(3,160)
        endif
        do ir = 1,nr
          dVc(:) = Vcato(ir,1,iapr) + Vxcato(ir,1,:,iapr)
          write(3,170) r(ir)*bohr, dvc(:)*rydb, Vcato(ir,1,iapr)*rydb, Vxcato(ir,1,:,iapr)*rydb, &
              quatre_pi * rhoato(ir,:,iapr) * r2(ir), Grad_rho(ir), rsato(ir,iapr), quatre_pi * rhoato_out(ir,:,iapr) * r2(ir), &
              Vcato(ir,2:nlm_pot,iapr)*rydb, ( Vxcato(ir,Lm,:,iapr)*rydb, Lm = 2,nlm_pot ), &
              ( rho_self(ir,Lm,:,iapr), Lm = 2,nlm_pot )
        end do
      else
        if( nspin == 1 .and. nlm_pot == 1 ) then
          write(3,180)
        elseif( nspin == 1 .and. nlm_pot > 1 ) then
          write(3,190)
        elseif( nspin == 2 .and. nlm_pot == 1 ) then
          write(3,200)
        else
          write(3,210)
        endif
        do ir = 1,nr
          dVc(:) = Vcato(ir,1,iapr) + Vxcato(ir,1,:,iapr)
          write(3,170) r(ir)*bohr, dvc(:)*rydb, Vcato(ir,1,iapr)*rydb, Vxcato(ir,1,:,iapr)*rydb, &
            quatre_pi * rhoato(ir,:,iapr) * r2(ir), Grad_rho(ir), rsato(ir,iapr), Vcato(ir,2:nlm_pot,iapr)*rydb, &
            ( Vxcato(ir,Lm,:,iapr)*rydb, Lm = 2,nlm_pot )
        end do
      endif
    endif

    if( iapr /= iaprex ) exit
  end do

  deallocate( df, df2, fct, Fct_xc, Grad_rho, rhot, rr, rst, Vxct )

  return
  120 format(/' ia =',i3,', iapr =',i3)
  125 format(/' ia =',i3,', non excited')
  130 format(/6x,'Rato        Vato        Vcato        Vxcato     4pi*r2*rho  Grad_rho/rho     rsato   4pi*r2*rho_out')
  140 format(/6x,'Rato        Vato        Vcato        Vxcato     4pi*r2*rho  Grad_rho/rho     rsato   4pi*r2*rho_out', &
                '     Vcato(lm=2,nlm_pot)',20x,'Vxcato(isp=1,nspin,lm=2,nlm_pot)',6x,'Rhoself(isp=1,nspin,lm=2,nlm_pot)')
  150 format(/6x,'Rato       Vato(u)      Vato(d)       Vcato      Vxcato(u)    Vxcato(d)  4pi*r2*rho(u) 4pi*r2*rho(d)', &
                ' Grad_rho/rho    rsato 4pi*r2*rho_out(u) 4pi*r2*rho_out(d)')
  160 format(/6x,'Rato       Vato(u)      Vato(d)       Vcato      Vxcato(u)    Vxcato(d)  4pi*r2*rho(u) 4pi*r2*rho(d)', &
                ' Grad_rho/rho    rsato 4pi*r2*rho_out(u) 4pi*r2*rho_out(d)     Vcato(lm=2,nlm_pot)',20x, &
                'Vxcato(isp=1,nspin,lm=2,nlm_pot)',6x,'Rhoself(isp=1,nspin,lm=2,nlm_pot)')
  170 format(1p,151e13.5)
  180 format(/6x,'Rato        Vato        Vcato        Vxcato     4pi*r2*rho  Grad_rho/rho     rsato')
  190 format(/6x,'Rato        Vato        Vcato        Vxcato     4pi*r2*rho  Grad_rho/rho     rsato    ', &
                '     Vcato(lm=2,nlm_pot)',20x,'Vxcato(isp=1,nspin,lm=2,nlm_pot)')
  200 format(/6x,'Rato       Vato(u)      Vato(d)       Vcato      Vxcato(u)    Vxcato(d)  4pi*r2*rho(u) 4pi*r2*rho(d)', &
                '  Grad_rho/rho')
  210 format(/6x,'Rato       Vato(u)      Vato(d)       Vcato      Vxcato(u)    Vxcato(d)  4pi*r2*rho(u) 4pi*r2*rho(d)', &
                '  Grad_rho/rho         rsato          Vcato(lm=2,nlm_pot)',20x,'Vxcato(isp=1,nspin,lm=2,nlm_pot)')
end

!***********************************************************************

! Calcul des matrices de rotation de Wigner quand le premier indice est nul
! Dlm0 = racine(4pi/(l+1))*Ylm

subroutine Cal_Dlm0(Dab,Dlm0,Lmax_pot,nlm_pot,p)

  use declarations
  implicit none

  integer:: L, Lm, Lmax_pot, m, nlm_pot, nlmc

  complex(kind=db), dimension(:), allocatable:: Ylmc

  real(kind=db):: Dab, r
  real(kind=db), dimension(3):: p
  real(kind=db), dimension(nlm_pot):: Dlm0, Ylmr

  nlmc = ( ( lmax_pot + 1 ) * ( lmax_pot + 2 ) ) / 2

  allocate( Ylmc(nlmc) )

  call cylm(lmax_pot,p,Dab,Ylmc,nlmc)
  call ylmcr(lmax_pot,nlmc,nlm_pot,Ylmc,Ylmr)

  deallocate( Ylmc )

  lm = 0
  do L = 0,lmax_pot
    r = sqrt( quatre_pi / (2*L + 1 ) )
    do m = -L,L
      Lm = Lm + 1
      Dlm0(Lm) = r * Ylmr(Lm)
    end do
  end do

  return
end

!***********************************************************************

! Force the atom equivalent in the space group and at the same distance from the center of the sphere of calculation
! to have the same potential

subroutine Force_pot_eq(Do_init,drhoato,dVcato,Excato,iaprotoi,n_atom_0,n_atom_0_self,n_atom_ind,n_atom_ind_self, &
                   natome,nlm_pot,nrm,nrm_self,nspin,posi,rho_no_sup,rhoato,rhoato_init,rhoato_out,rsato,Vcato,Vcato_init,Vxcato)

  use declarations
  implicit none

  integer:: i, ia, ib, n_at_eq, n_atom_0, n_atom_0_self, n_atom_ind, n_atom_ind_self, natome, nlm_pot, nrm, nrm_self, nspin

  integer, dimension(natome):: iaprotoi, index_at_eq

  logical:: Do_init, First_couple

  logical, dimension(natome):: Done

  real(kind=db):: Dist
  real(kind=db), dimension(3,natome):: posi

  real(kind=db), dimension(nrm,n_atom_0:n_atom_ind):: Excato
  real(kind=db), dimension(0:nrm,n_atom_0:n_atom_ind):: drhoato, rsato
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: dVcato, Vcato
  real(kind=db), dimension(0:nrm,nspin,n_atom_0:n_atom_ind):: rhoato, rho_no_sup
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind):: Vxcato

  real(kind=db), dimension(0:nrm_self):: Vca_init
  real(kind=db), dimension(0:nrm_self,nspin):: rho_ch, rho_init
  real(kind=db), dimension(0:nrm_self,nlm_pot,n_atom_0_self:n_atom_ind_self):: Vcato_init
  real(kind=db), dimension(0:nrm_self,nspin,n_atom_0_self:n_atom_ind_self):: rhoato_init, rhoato_out

  real(kind=db), dimension(:), allocatable:: Exc, dVc, drh, rsa
  real(kind=db), dimension(:,:), allocatable:: rho, rho_no, Vca
  real(kind=db), dimension(:,:,:), allocatable:: Vxc

! We are necessarily with  n_atom_0 = 1
!                          n_atom_ind = natome
  allocate( drh(0:nrm) )
  allocate( dVc(0:nrm) )
  allocate( Exc(nrm) )
  allocate( rho(0:nrm,nspin) )
  allocate( rho_no(0:nrm,nspin) )
  allocate( rsa(0:nrm) )
  allocate( Vca(0:nrm,nlm_pot) )
  allocate( Vxc(0:nrm,nlm_pot,nspin) )

  Done(:) = .false.
  index_at_eq(:) = 0

  do ia = 1,natome

    if( Done(ia) ) cycle

    Done(ia) = .true.
    Dist = sum( posi(:,ia)**2 )
    First_couple = .true.
    n_at_eq = 0

    do ib = ia + 1,natome
      if( Done(ib) ) cycle
      if( iaprotoi(ia) /= iaprotoi(ib) ) cycle
      if( abs( sum( posi(:,ib)**2 ) - Dist ) > eps10 ) cycle
      Done(ib) = .true.
      if( First_couple ) then
        First_couple = .false.
        n_at_eq = 1
        index_at_eq(1) = ia
      endif
      n_at_eq = n_at_eq + 1
      index_at_eq(n_at_eq) = ib
    end do

    if( n_at_eq == 0 ) cycle

    Exc(:) = 0._db
    dVc(:) = 0._db
    drh(:) = 0._db
    rsa(:) = 0._db
    Vca(:,:) = 0._db
    rho(:,:) = 0._db
    rho_no(:,:) = 0._db
    Vxc(:,:,:) = 0._db
    Vca_init(:) = 0._db
    rho_init(:,:) = 0._db
    rho_ch(:,:) = 0._db
    do i = 1,n_at_eq
      ib = index_at_eq(i)
      Exc(:) = Exc(:) + Excato(:,ib) / n_at_eq
      dVc(:) = dVc(:) + dVcato(:,1,ib) / n_at_eq
      drh(:) = dVc(:) + drhoato(:,ib) / n_at_eq
      rsa(:) = rsa(:) + rsato(:,ib) / n_at_eq
      Vca(:,:) = Vca(:,:) + Vcato(:,:,ib) / n_at_eq
      rho(:,:) = rho(:,:) + rhoato(:,:,ib) / n_at_eq
      rho_no(:,:) = rho_no(:,:) + rho_no_sup(:,:,ib) / n_at_eq
      Vxc(:,:,:) = Vxc(:,:,:) + Vxcato(:,:,:,ib) / n_at_eq
      if( Do_init ) then
        Vca_init(:) = Vca_init(:) + Vcato_init(:,1,ib) / n_at_eq
        rho_init(:,:) = rho_init(:,:) + rhoato_init(:,:,ib) / n_at_eq
        rho_ch(:,:) = rho_ch(:,:) + rhoato_out(:,:,ib) / n_at_eq
      endif
    end do
    do i = 1,n_at_eq
      ib = index_at_eq(i)
      Excato(:,ib) = Exc(:)
      dVcato(:,1,ib) = dVc(:)
      drhoato(:,ib) = drh(:)
      rsato(:,ib) = rsa(:)
      Vcato(:,:,ib) = Vca(:,:)
      rhoato(:,:,ib) = rho(:,:)
      rho_no_sup(:,:,ib) = rho_no(:,:)
      Vxcato(:,:,:,ib) = Vxc(:,:,:)
      if( Do_init ) then
        Vcato_init(:,1,ib) = Vca_init(:)
        rhoato_init(:,:,ib) = rho_init(:,:)
        rhoato_out(:,:,ib) = rho_ch(:,:)
      endif
    end do

  end do

  deallocate( drh, dVc, Exc, rho, rho_no, rsa, Vca, Vxc )

  return
end

!***********************************************************************

! Modification of the superposed potential of the non excited absorbing atom
! to have it increasing up to zero at r(nr)
! When becoming constant, we use V(r) = a / r + b
! Used to calculated Epsii

subroutine mod_V_abs(Exc,Exc_abs_i,icheck,nr,nspin,r,V_abs_i,Vc,Vc_abs_i,Vxc)

  use declarations
  implicit none

  integer:: i, icheck, ir, j, nr, nspin

  real(kind=db):: a, b
  real(kind=db), dimension(nr):: Exc, Exc_abs_i, r, V, Vc, Vc_abs_i
  real(kind=db), dimension(nr,nspin):: V_abs_i, Vxc

  do j = 1,2+nspin

    select case(j)
      case(1)
        V(:) = Vc(:)
      case(2)
        V(:) = Exc(:)
      case(3)
        V(:) = Vc(:) + Vxc(:,1)
      case(4)
        V(:) = Vc(:) + Vxc(:,nspin)
    end select

    do ir = 3,nr
      if( V(ir) < V(ir-1) + eps10 ) exit
    end do
    if( ir < nr ) then
      i = ir - 2
      a = V(i) * r(i) * r(nr) / ( r(nr) - r(i) )
      b =  - a / r(nr)
      do ir = i + 1, nr
        V(ir) = a / r(ir) + b
      end do
    endif

    select case(j)
      case(1)
        Vc_abs_i(:) = V(:)
      case(2)
        Exc_abs_i(:) = V(:)
      case(3)
        V_abs_i(:,1) = V(:)
      case(4)
        V_abs_i(:,2) = V(:)
    end select

  end do

  if( icheck > 2 ) then
    write(3,'(/A)') '   Non excited absorbing atom potential, for the calculation of Epsii'
    if( nspin == 1 ) then
      write(3,'(/A)') '     Radius        V           Vc           Exc'
    else
      write(3,'(/A)') '     Radius       V_up        V_dn           Vc          Exc'
    endif
    do ir = 1,nr
      write(3,'(f13.8,1p,4e13.5)') r(ir)*bohr, V_abs_i(ir,:)*rydb, Vc_abs_i(ir)*rydb, Exc_abs_i(ir)*rydb
    end do
  endif

  return
end

!************************************************************************************

subroutine Raymuf(Cal_xanes,Chargat,Full_atom,i_self,iapot,iaproto,iaprotoi,icheck,iprabs, &
        ipr1,itab,itypei,itypep,itypepr,n_atom_0,n_atom_ind,n_atom_proto,natome,natomeq,natomp,nlm_pot, &
        normrmt,nrato,nrm,nspin,ntype,Numat,Overlap,pos,Rato,rhoato,Rmtg,Rmtg0,Rmtimp, &
        Rmtsd,Rsort,V0bdcFimp,Vcato,Vxcato)

  use declarations
  implicit none

  integer:: i_self, ia, iapr, iaprb, ib, icheck, ipr, ipr1, ipra, iprabs, iprb, ir, ira, irb, it, ita, itab, itb, &
    n_atom_0, n_atom_ind, n_atom_proto, natome, natomeq, natomp, nlm_pot, normrmt, nr, nra, nrb, nrm, nspin, ntype, Z

  integer, dimension(natomp):: iaproto, itypep
  integer, dimension(natome):: iaprotoi, itypei
  integer, dimension(0:ntype):: nrato, Numat
  integer, dimension(0:n_atom_proto):: iapot, iaproxp, itypepr

  logical:: Cal_xanes, Full_atom

  real(kind=db):: a1, a2, b1, b2, chtot, dab_ov, dist, Overlap, p1, rb, rm, Rsort, V0bdcFimp, Vr, Vr1, Vrop, &
                  Vropmax

  real(kind=db), dimension(3):: ps
  real(kind=db), dimension(0:nrm):: r, rhr2, vra, vrb
  real(kind=db), dimension(0:ntype):: Rmtimp
  real(kind=db), dimension(0:n_atom_proto):: Chargat, Dab, Rayop, Rdem, Rmtg, Rmtg0, Rmtsd, Rn, Rnorm, RV0
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato
  real(kind=db), dimension(0:nrm,nspin,n_atom_0:n_atom_ind):: rhoato
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind) :: Vxcato
  real(kind=db), dimension(0:nrm,0:ntype):: Rato
  real(kind=db), dimension(3,natomp):: pos

  if( Cal_xanes .or. i_self == 1 ) then

  if( icheck > 0 ) write(3,110)

  iaproxp(:) = 0
  Rmtg(:) = 0._db
  Rmtg0(:) = 0._db

  if( natomp == 1 ) then
    if( normrmt == 4 ) then
      rm = Rmtimp( 1 )
!      rm = min( Rsort, Rmtimp( 1 ) )
    else
      rm = min( Rsort, 2.5_db / bohr )
    endif
    Dab(:) = 0._db
    Rdem(:) = rm
    Rnorm(:) = rm
    Rn(:) = rm
    Rayop(:) = rm
    Rmtg(:) = rm
    Rmtg0(:) = rm
    RV0(:) = rm
    Vrop = 0._db

  else

! Norman radius
    do ipr = ipr1,n_atom_proto
      Rnorm(ipr) = 0._db
      if( iapot(ipr) == 0 ) cycle
      it = itypepr(ipr)
      if( Numat(it) == 0 ) cycle
      if( Full_atom ) then
        do ia = n_atom_0,n_atom_ind
          if( iaprotoi(ia) == ipr ) exit
        end do
        if( ia > n_atom_ind ) then
          do ib = 1,n_atom_ind
            if( Numat( itypei(ib) ) == Numat( it ) ) exit
          end do
          if( ib > n_atom_ind ) then
            Rnorm(ipr) = 0._db
            cycle
          else
            iapr = ib
          endif
        else
          iapr = ia
        endif
      else
        iapr = ipr
      endif
      nr = nrato(it)
      r(0:nr) = Rato(0:nr,it)
      do ir = 0,nr
        rhr2(ir) = sum( rhoato(ir,1:nspin,iapr) ) * r(ir)**2
      end do
      chtot = Numat(it) - Chargat(ipr)
      call rnorman(r,rhr2,nr,Rnorm(ipr),chtot,nrm)
    end do

    Rn(:) = 0._db

    do ipr = ipr1, n_atom_proto
      if( natomp < 2 ) then
        Rn(ipr) = Rsort
      else
        do ia = 1,natomp
          if( iaproto(ia) == ipr ) exit
        end do
        if( ia == natomp + 1 ) then
          iaproxp(ipr) = 0
          Dab(ipr) = Dab(0)
          Rdem(ipr) = Rdem(0)
          Rn(ipr) = Rn(0)
        else
          Dab(ipr) = 100000._db
          do ib = 1,natomp
            if( Numat(itypep(ib)) == 0 ) cycle
            ps(1:3) = pos(1:3,ia) - pos(1:3,ib)
            dist = sqrt( sum( ps(:)**2 ) )
            if( dist < Dab(ipr) - epspos .and. dist > epspos ) then
              iaproxp(ipr) = ib
              Dab(ipr) = dist
              Rdem(ipr) = 0.5_db * Dab(ipr)
            endif
          end do
          ib = iaproxp(ipr)
          iprb = iaproto(ib)
          if( Rnorm(ipr) > eps10 .and. Rnorm( iprb ) > eps10 ) then
            Rn(ipr) = min( 0.75_db * Dab(ipr), Dab(ipr) / ( 1 + Rnorm(iprb) / Rnorm(ipr) ) )
          else
            Rn(ipr) = min( 0.75_db * Dab(ipr), Rnorm(ipr) )
          endif
        endif
      endif
    end do

    do ipr = ipr1,n_atom_proto
      if( iaproxp(ipr) /= 0 ) cycle
      iaproxp(ipr) = natomp + 1
      Dab(ipr) = Dab(iprabs)
      Rdem(ipr) = Rdem(iprabs)
      Rn(ipr) = Rn(iprabs)
    end do

! Optimized radius

    Vropmax = 0._db

    if( n_atom_proto == 1 ) then

      Rayop(ipr1:1) = 0.5_db * ( 1 + Overlap ) * Dab(1)
      Vrop = 0._db

    else

      vra(:) = 0._db; vrb(:) = 0._db

! Calculation of the cutting potential
      if( ipr1 == 0 ) then
        ipra = ipr1
      else
        ipra = iprabs
      endif
      if( Full_atom ) then
        do ia = n_atom_0,n_atom_ind
          if( itypei(ia) == itab ) exit
        end do
        iapr = ia
      else
        iapr = ipra
      endif
      ita = itab
      nra = nrato( ita )
      do ir = 1,nra
        Vra(ir) = Vcato(ir,1,iapr) + sum(Vxcato(ir,1,1:nspin,iapr)) / nspin
        if( ir == 1 ) cycle
        if( Vra(ir) < Vra(ir-1) ) Vropmax = vra(ir-1) - eps6
      end do
      iprb = iaproto( iaproxp(ipra) )
      if( Full_atom ) then
        do ia = n_atom_0,n_atom_ind
          if( iaprotoi(ia) == iprb ) exit
        end do
        if( ia > n_atom_ind ) then ! case with only 1 atom
          iaprb = iapr
        else
          iaprb = ia
        endif
      else
        iaprb = iprb
      endif
      itb = itypepr(iprb)
      nrb = nrato( itb )
      do ir = 1,nrb
        Vrb(ir) = Vcato(ir,1,iaprb) + sum( Vxcato(ir,1,1:nspin,iaprb) ) / nspin
        if( vrb(ir) < vrb(ir-1) ) Vropmax = min( Vrb(ir-1)-eps6, Vropmax )
      end do

      dab_ov = ( 1 + Overlap ) * Dab(ipra)

      do ira = 2,nra-1
        rb = dab_ov - Rato(ira,ita)
        do irb = nrb,2,-1
          if( Rato(irb,itb) < rb ) exit
        end do
        if( Vrb( irb ) < Vra( ira ) ) exit
      end do
      a1 = ( Vra(ira+1) - Vra(ira) ) / ( Rato(ira+1,ita) - Rato(ira,ita) )
      a2 = ( Vrb(irb) - Vrb(irb-1) ) / ( Rato(irb-1,itb) - Rato(irb,itb) )
      b1 = Vra(ira) - a1 * Rato(ira,ita)
      b2 = Vrb(irb) - a2 * ( dab_ov - Rato(irb,itb) )
      if( abs(a1) < eps10 ) then
        Vrop = vra(ira)
      else
        Vrop = ( b1*a2 - b2*a1 ) / ( a2 - a1 )
      endif
      Vrop = min( Vrop, Vropmax )

      if( icheck > 3 ) then
        write(3,120) dab_ov*bohr, Numat(ita), ita, iapr, Numat(itb), itb, iaproxp(ipra), iaprb, Vropmax*rydb, ira, irb
        write(3,125)
        do ir = 1,min(nra,nrb)
          write(3,130) Rato(ir,ita)*bohr, Vra(ir)*rydb, (dab_ov - Rato(ir,itb))*bohr, Vrb(ir)*rydb
        end do
      endif

      boucle_ia: do ipr = ipr1, n_atom_proto
        Rayop(ipr) = 0._db
        if( iapot(ipr) == 0 ) cycle
        it = itypepr(ipr)
        if( Full_atom ) then
          do ia = n_atom_0,n_atom_ind
            if( iaprotoi(ia) == ipr ) exit
          end do
          if( ia > n_atom_ind ) then
            do ib = 1,n_atom_ind
              if( Numat( itypei(ib) ) == Numat( it ) ) exit
            end do
            if( ib > n_atom_ind ) then
              iapr = 1
            else
              iapr = ib
            endif
          else
            iapr = ia
          endif
        else
          iapr = ipr
        endif
        if( Numat(it) == 0 ) cycle
        vra(1) = Vcato(1,1,iapr) + sum( Vxcato(1,1,1:nspin,iapr) ) / nspin
        do ir = 2,nrato( it )
          vra(ir) = Vcato(ir,1,iapr) + sum(Vxcato(ir,1,1:nspin,iapr)) / nspin
          if( vra(ir) > vrop - eps10 ) exit
          if( vra(ir) < vra(ir-1) + eps10 ) then
            Rayop(ipr) = Rato(ir-1,it)
            cycle boucle_ia
          endif
        end do
        p1 = ( vra(ir) - vrop ) / ( vra(ir) - vra(ir-1) )
        Rayop(ipr) = p1 * Rato(ir-1,it) + ( 1 - p1 ) * Rato(ir,it)

        Rayop(ipr) = min( Rayop(ipr), Dab(ipr) )
      end do boucle_ia

    endif

! Hydrogen case
    do ipr = ipr1,n_atom_proto
      if( iapot(ipr) == 0 .or. Rn(ipr) < eps10 ) cycle
      Z = Numat( itypepr(ipr)  )
      if( Z /= 1 ) cycle
      if( Rayop(ipr) > 0.45_db*Rdem(ipr) .and. Rayop(ipr) < 1.75_db*Rdem(ipr) ) cycle
      Rayop(ipr) = min( (1 + Overlap) * Rdem(ipr), 0.8_db / bohr )
    end do

    do ipr = ipr1,n_atom_proto
      RV0(ipr) = 0._db
      if( iapot(ipr) == 0 ) cycle
      it = itypepr(ipr)
      if( Full_atom ) then
        do ia = n_atom_0,n_atom_ind
          if( iaprotoi(ia) == ipr ) exit
        end do
        if( ia > n_atom_ind ) then
          do ib = 1,n_atom_ind
            if( Numat( itypei(ib) ) == Numat( it ) ) exit
          end do
          if( ib > n_atom_ind ) then
            iapr = 1
          else
            iapr = ib
          endif
        else
          iapr = ia
        endif
      else
        iapr = ipr
      endif
      Vr1 = Vcato(1,1,iapr) + sum( Vxcato(1,1,1:nspin,iapr) ) / nspin
      do ir = 2,nrato( it )
        Vr = Vcato(ir,1,iapr) + sum( Vxcato(ir,1,1:nspin,iapr) )/nspin
        if( ir == nrato(it) ) then
          RV0(ipr) = Rato(ir,it)
          exit
        elseif( Rato(ir,it) > Dab(ipr) .and. natomp > 1 ) then
          RV0(ipr) = Dab(ipr)
          exit
        elseif( Vr < Vr1 .and. Numat(it) /= 0 ) then
          RV0(ipr) = Rato(ir-1,it)
          exit
        elseif( ( Vr - V0bdcFimp )*( vr1 - V0bdcFimp ) <= 0._db ) then
          p1 = ( Vr - V0bdcFimp ) / ( Vr - vr1 )
          RV0(ipr) = p1 * Rato(ir-1,it) + ( 1 - p1 ) * Rato(ir,it)
          exit
        endif
        Vr1 = Vr
      end do
    end do

    do ipr = ipr1,n_atom_proto
      if( iapot(ipr) == 0 .or. ( Numat(itypepr(ipr)) == 0 .and. normrmt /= 4 ) ) then
        Rmtg0(ipr) = Rdem(ipr)
        Rmtg(ipr) = (1 + Overlap) * Rmtg0(ipr)
        cycle
      elseif( Rn(ipr) < eps10 ) then
        Rmtg0(ipr) = 0._db
        Rmtg(ipr) = 0._db
        cycle
      endif
      select case(normrmt)
        case(1)
          Rmtg(ipr) = Rayop(ipr)
          Rmtg0(ipr) = Rmtg(ipr) / ( 1 + Overlap )
        case(2)
          Rmtg0(ipr) = Rn(ipr)
          Rmtg(ipr) = (1 + Overlap) * Rmtg0(ipr)
        case(3)
          ! Suppressed
        case(4)
          if( Rmtimp( itypepr(ipr) ) < eps10 ) then
            if( Rayop(ipr) > 0.25_db*Rdem(ipr) .and. Rayop(ipr) < 1.5_db*Rdem(ipr) ) then
              Rmtg(ipr) = Rayop(ipr)
              Rmtg0(ipr) = Rmtg(ipr) / ( 1 + Overlap )
            else
              Rmtg0(ipr) = Rn(ipr)
              Rmtg(ipr) = (1 + Overlap) * Rmtg0(ipr)
            endif
          else
            Rmtg0(ipr) = Rmtimp( itypepr(ipr) )
            Rmtg(ipr) = Rmtg0(ipr)
          endif
        case(5)
          Rmtg0(ipr) = RV0(ipr)
          Rmtg(ipr) = Rmtg0(ipr)
      end select
    end do

    do ipr = ipr1,n_atom_proto
      it = itypepr(ipr)
      Rmtg(ipr) = min( Rmtg(ipr), Rato(nrato(it),it) )
      Rmtg0(ipr) = min( Rmtg0(ipr), Rato(nrato(it),it) )
    end do

! When optimized radius are not ok, one uses Normann criterion
    if( normrmt == 1 ) then
      do ipr = ipr1,n_atom_proto
        if( iapot(ipr) == 0 .or. Rn(ipr) < eps10 ) cycle
        Z = Numat( itypepr(ipr)  )
        if( Z < 2 ) cycle
        ia = iaproxp(ipr)
        if( ia > natomp ) cycle
        Z = Numat( itypep(ia) )
        if( ( Z == 1 .and. ( Rayop(ipr) > 0.99_db*Rdem(ipr) .and. Rayop(ipr) < 1.75_db*Rdem(ipr) ) ) &
            .or. ( Z /= 1 .and. ( Rayop(ipr) > 0.25_db*Rdem(ipr) .and. Rayop(ipr) < 1.5_db*Rdem(ipr) ) ) ) then
          cycle
        elseif( ( Z == 1 .and. ( Rn(ipr) > 0.99_db*Rdem(ipr) .and. Rn(ipr) < 1.75_db*Rdem(ipr) ) ) &
            .or. ( Z /= 1 .and. ( Rn(ipr) > 0.25_db*Rdem(ipr) .and. Rn(ipr) < 1.5_db*Rdem(ipr) ) ) ) then
          if( iapot(ipr) <= natomeq ) then
            Rmtg0(:) = Rn(:)
            Rmtg(:) = (1 + Overlap) * Rmtg0(:)
          else
            Rmtg0(ipr) = Rn(ipr)
            Rmtg(ipr) = (1 + Overlap) * Rmtg0(ipr)
          endif
        else
          Rmtg0(ipr) = Rdem(ipr)
          Rmtg(ipr) = (1 + Overlap) * Rmtg0(ipr)
        endif
      end do
    endif

  endif ! arriving when natomp = 1

! Case of atoms outside the sphere
! Give an effect for the potential calculation inside the MT radius of the corresponding atoms overlaping with the outersphere.
! One artificially chooses the potential of the nonexcited absorbing atom.
  do ipr = ipr1,n_atom_proto
    if( Rmtg(ipr) > eps10 ) cycle
    Rmtg(ipr) = Rmtg(iprabs)
    Rmtg0(ipr) = Rmtg0(iprabs)
  end do

  Rmtsd(:) = Rmtg(:)
  if( ipr1 == 1 ) Rmtsd(0) = Rmtsd(iprabs)

  if( icheck > 0 ) then
    if( .not. n_atom_proto == 1 ) write(3,140) Vrop*rydb
    write(3,150)
    write(3,160)
    do ipr = ipr1,n_atom_proto
      if( iapot(ipr) == 0 .or. Rmtg0(ipr) < eps10 ) cycle
      Z = Numat( itypepr(ipr) )
      write(3,170) ipr, iapot(ipr), Z, Rn(ipr)*bohr, Rnorm(ipr)*bohr, Dab(ipr)*bohr, Rdem(ipr)*bohr, iaproxp(ipr), &
              Rayop(ipr)*bohr, RV0(ipr)*bohr, Rmtsd(ipr)*bohr, Rmtg(ipr)*bohr
    end do
  endif

  endif  ! arriving when i_self /= 1 and not cal_xanes

  return
  110 format(/' ---- Raymuf -------',100('-'))
  120 format(/' Vrop calculation: dab_ov =',f6.3,/ &
              '  Central atom: Z =',i3,', ita =',i2,', iapr  =',i2,/ &
              ' Neighbor atom: Z =',i3,', itb =',i2,', iaprb =',i3,', ib =',i3, / &
              ' Vrop_max =',f8.3,' eV, ira =',i4,', irb =',i4)
  125 format(/'     Rato          vra      dab_ov-Rato     vrb')
  130 format(1p,4e13.5)
  140 format(/' Vrop = ',f10.3,' eV',/)
  150 format(' Rmtg : muffin-tin radius',/ &
             ' Rmtsd : Radius for the density of state calculation'/)
  160 format('  ipr ia   Z     Rn     Rnorm     Dab     Rdem  iaprox  Rayop     RV0     Rmtsd     Rmtg')
  170 format(3i4,4f9.5,i5,4f9.5)
end

!***********************************************************************

! Calculation of the potential and density at the muffin-tin radius without Overlap

subroutine Potrmt(Full_atom,Grad_rho_mft,iaprotoi,ipr1,iprabs,itypepr,n_atom_0,n_atom_ind,n_atom_proto,natome,nlm_pot,nrato,nrm, &
                  nspin,ntype,Numat,Rato,rhoato,rhomft,Rmt,Vcato,Vcmft,Vxcato,Vxcmft,iapot)

  use declarations
  implicit none

  integer:: iapr, ipr, ipr1, iprabs, iprb, ir, it, n_atom_0, n_atom_ind, n_atom_proto, natome, nlm_pot, nrm, nrmtg0, nspin, ntype

  logical:: Full_atom

  integer, dimension(natome):: iaprotoi
  integer, dimension(0:ntype):: nrato, Numat
  integer, dimension(0:n_atom_proto):: iapot, itypepr

  real(kind=db):: a, b, c, d0m, der, der2, dp0, dpm, f0, fm, fp, p1, r0, rho, rm, rp

  real(kind=db), dimension(0:n_atom_proto):: Vcmft
  real(kind=db), dimension(0:n_atom_proto,2):: Grad_rho_mft
  real(kind=db), dimension(0:n_atom_proto,nspin):: rhomft, Vxcmft
  real(kind=db), dimension(0:ntype):: Rmt
  real(kind=db), dimension(0:nrm,0:ntype):: Rato
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato
  real(kind=db), dimension(0:nrm,nspin,n_atom_0:n_atom_ind):: rhoato
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind):: Vxcato

  Vcmft(:) = 0._db
  rhomft(:,:) = 0._db
  vxcmft(:,:) = 0._db

  do ipr = ipr1,n_atom_proto

    if( Full_atom ) then
      do iapr = n_atom_0,n_atom_ind
        if( ipr == iaprotoi(iapr) ) exit
      end do
      if( iapr > n_atom_ind ) cycle
    else
      iapr = ipr
    endif

    it = itypepr(ipr)
    do ir = 2,nrato(it)-1
      if( Rato(ir,it) > Rmt(it) - eps10 ) exit
    end do
    nrmtg0 = ir

    p1 = (Rmt(it) - Rato(nrmtg0-1,it)) / ( Rato(nrmtg0,it) - Rato(nrmtg0-1,it) )
    Vcmft(ipr) = p1 * Vcato(nrmtg0,1,iapr) + ( 1-p1 ) * Vcato(nrmtg0-1,1,iapr)
    Vxcmft(ipr,1:nspin) = p1 * Vxcato(nrmtg0,1,1:nspin,iapr) + ( 1 - p1 ) * Vxcato(nrmtg0-1,1,1:nspin,iapr)
    rhomft(ipr,1:nspin) = p1 * rhoato(nrmtg0,1:nspin,iapr) + ( 1 - p1 ) * rhoato(nrmtg0-1,1:nspin,iapr)

! Calculation of drivative ans second derivative using second order polynomia
    rho = sum( rhomft(ipr,1:nspin) )

    rp = Rato(nrmtg0,it)
    r0 = Rato(nrmtg0-1,it)
    rm = Rato(nrmtg0-2,it)
    fp = sum( rhoato(nrmtg0,:,iapr) )
    f0 = sum( rhoato(nrmtg0-1,:,iapr) )
    fm = sum( rhoato(nrmtg0-2,:,iapr) )

    dp0 = rp - r0
    dpm = rp - rm
    d0m = r0 - rm

    a = ( fm * dp0 - f0 * dpm + fp * d0m ) / ( d0m * dp0 * dpm )
    b = ( f0 - fm ) / d0m - a * ( r0 + rm )
    c = f0 - a * r0**2 - b * r0

    der = a * Rmt(it) + b
    der2 = 2*a

    if( rho < eps15 ) then
      Grad_rho_mft(ipr,:) = 0._db
    else
      Grad_rho_mft(ipr,1) = abs( der ) / rho
      Grad_rho_mft(ipr,2) = der2 / rho
    endif

  end do

  do ipr = ipr1,n_atom_proto

    if( abs( Vcmft(ipr) ) > eps10 ) cycle

! Search of an atom of same Z
    if( Full_atom .and. .not. iapot(ipr) == 0 ) then
      do iapr = n_atom_0,n_atom_ind
        iprb = iaprotoi(iapr)
        if( ipr == iprb ) exit
      end do
      if( iapr > n_atom_ind ) then
        do iapr = n_atom_0,n_atom_ind
          iprb = iaprotoi(iapr)
          if( Numat( itypepr( ipr ) ) == Numat( itypepr( iprb ) ) ) exit
        end do
      endif
      if( iprb <= n_atom_ind ) then
        Vcmft(ipr) = Vcmft(iprb)
        Vxcmft(ipr,1:nspin) = Vxcmft(iprb,1:nspin)
        rhomft(ipr,1:nspin) = rhomft(iprb,1:nspin)
        Grad_rho_mft(ipr,:) = Grad_rho_mft(iprb,:)
        cycle
      endif
   endif

    Vcmft(ipr) = Vcmft(iprabs)
    Vxcmft(ipr,1:nspin) = Vxcmft(iprabs,1:nspin)
    rhomft(ipr,1:nspin) = rhomft(iprabs,1:nspin)
    Grad_rho_mft(ipr,:) = Grad_rho_mft(iprabs,:)

  end do

  return
end

!***********************************************************************

! Calculation of Norman radius such that
!       integral(0..Rnorm)(4*pi*r2*rho*dr) = Z

subroutine Rnorman(r,rh,nr,Rnorm,z,nrm)

  use declarations
  implicit none

  integer:: ir, nr, nrm

  real(kind=db):: a, b, c, ch1, ch2, Charge, dcharge, p, r1, r2, Rnorm, x1, x2, z, zs4pi

  real(kind=db), dimension(nrm):: r, rh

  charge = 0._db
  zs4pi = z / quatre_pi

  do ir = 2,nr-1
    x1 = ( rh(ir+1) - rh(ir) ) / ( r(ir+1) - r(ir) )
    x2 = ( rh(ir-1) - rh(ir) ) / ( r(ir-1) - r(ir) )
    a = (  x1 - x2  ) / ( r(ir+1) - r(ir-1) )
    b = x1 - a * ( r(ir+1) + r(ir) )
    c = rh(ir) - a*r(ir)**2 - b*r(ir)
    if(ir == 2) then
      r2 = 0.5_db * ( r(ir+1) + r(ir) )
      r1 = 0._db
    elseif(ir == nr-1) then
      r2 = r(nr)
      r1 = 0.5_db * ( r(ir) + r(ir-1) )
    else
      r2 = 0.5_db * ( r(ir+1) + r(ir) )
      r1 = 0.5_db * ( r(ir) + r(ir-1) )
    endif
    dcharge = (a/3) * (r2**3 - r1**3) + (b/2) * (r2**2 - r1**2) + c * (r2 - r1)
    charge = charge + dcharge
    if( charge > zs4pi ) exit
  end do
  if( ir < nr-1 ) then
    ch2 = quatre_pi * charge
    ch1 = quatre_pi * ( charge - dcharge )
    p = ( z - ch1 ) / ( ch2 - ch1 )
    Rnorm = p * r(ir) + ( 1 - p ) * r(ir-1)
  else
    Rnorm = r(nr)
  endif

  return
end

!***********************************************************************

! Subprogramm calculating by superposition the total Hartree potential, the total exchange-correlation potential, and the total
! electronic density.

subroutine Pot0( alfpot, Axe_atom_gr, Bulk_atom_done, Cal_xanes, Chargat, Counter_ato, Counter_index_ato, Counter_dip, &
        Counter_ion, Counter_linear, delta_z_lin, drhoato, dVcato, E_moment, Helm_cos, Helm_fac, Helm_lin, Helm_mix, i_self, &
        iaabs, iapr_p, iaproto, icheck_12, igreq, igroup, igroup_ato, igroup_dip, igroup_ion, Image_charge, ipr_useful, itypep, &
        Lmax_pot, Magnetic, n_atom_0, n_atom_ind, n_atom_ind_self, n_atom_proto, n_atom_proto_bulk, n_counter_ato, &
        n_counter_dip, n_counter_ion, n_index_ato, n_ipr_useful, natomeq, natomp, natomp_ato, natomp_dip, natomp_ion, nb_test, &
        neqm, ngroup_m, nlm_pot, Nonsph, npoint ,npoint_ns, npsom, nr_counter_ato, nrato, nrm, nspin, ntype, nv_grad, &
        One_SCF_surf, Orig_helm, Pos, Pos_ato, Pos_dip, Pos_ion, R_counter_ato, Rato, rho, Rho_counter_ato, rhons, Rot_cluster, &
        Rot_E_moment, rs, rhoigr_int, Rmt, Rmtg0, Rmtsd, Rot_Atomp, SCF, Surf_0, Sym_2D, Test_case, V_helm, V_intmax, V_surf, &
        Vato, Vh, Vh_counter_ato, Vhns, Vsphere, Vxc, Width_helm, xyz, Ylm_comp, z_bulk, z_surf, Z_top )

  use declarations
  implicit none

  real(kind=db), parameter:: sqrt_2pi = sqrt( 2 * pi )
  real(kind=db), parameter:: sqrt_4pi = sqrt( 4 * pi )

  integer:: i, i_self, ia, iaabs, iaprb, ib, icheck_12, iga, igr, index, ipr, ir, isp, ispin, it, itm, j, kgr, L, Lm, Lmax_pot, &
    Lmp, m, mp, n_atom_0, n_atom_ind, n_atom_ind_self, n_atom_proto, n_atom_proto_bulk, n_counter_ato, n_counter_dip, &
    n_counter_ion, n_index_ato, n_ipr_useful, natomeq, natomp, natomp_ato, natomp_dip, natomp_ion, nb_test, neqm, ngroup_m, &
    nlm_pot, npoint, npoint_ns, npsom, nr_counter_ato, nrm, nspin, ntype, nv_grad, Z_top

  integer, dimension(nspin):: ispp
  integer, dimension(natomp):: iaproto, iapr_p, igroup, itypep
  integer, dimension(natomp_ato):: igroup_ato
  integer, dimension(natomp_dip):: igroup_dip
  integer, dimension(natomp_ion):: igroup_ion
  integer, dimension(0:ntype):: nrato
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(0:n_ipr_useful):: ipr_useful

  integer, dimension(:), allocatable:: ia_close

  logical:: Bulk_atom_done, Cal_xanes, Counter_linear, Found, Helm_cos, Helm_lin, Helm_mix, Image_charge, Magnetic, Nonsph, &
    One_SCF_surf, SCF, SCF_atom, Sym_2D, This_bulk_atom_done, Write_c_ato, Write_c_dip, Write_c_ion, Write_helm, Write_pot, &
    Ylm_comp

  logical, dimension(nb_test):: Test_case
  logical, dimension(:), allocatable:: iok

  complex(kind=db), dimension(:), allocatable:: Vlm_a, Ylmc
  complex(kind=db), dimension(:,:,:), allocatable:: Dlmm_ia

  real(kind=db):: alfa, alfpot, Atom_radius, cder, cosang, d2n_dxdy, d2n_dxdz, d2n_dydz, Delta_V_helm, delta_z_lin, ddr, dist, &
    dist_min, dr, dr2, drh_t, drho, drr2, dv, E_moment, f, f_interp2, fac, Fct_xc_a, Grad_rho_a, Helm_fac, Orig_helm, p1, p2, &
    R_m, Rho_ato, Smooth, Surf_0, Tiers, V_a, V_ato, V_dip, V_helm, V_image, V_intmax, V_ion, Vsphere, Weight, Width_helm, &
    Width_p, x, z, z_bulk, z_surf, z0

  real(kind=db), dimension(3):: Grad, Ps, V, V_surf, W
  real(kind=db), dimension(3,3):: Rot_a, Rot_cluster, Rot_E_moment
  real(kind=db), dimension(nspin):: drh, Rho_a
  real(kind=db), dimension(0:nr_counter_ato):: r_counter_ato
  real(kind=db), dimension(npoint):: rs, Vh
  real(kind=db), dimension(0:ntype):: Rmt
  real(kind=db), dimension(npoint_ns):: rhons, Vhns
  real(kind=db), dimension(npoint,nspin):: Vxc, rho
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(3,natomp_ato):: Pos_ato
  real(kind=db), dimension(3,natomp_dip):: Pos_dip
  real(kind=db), dimension(3,natomp_ion):: Pos_ion
  real(kind=db), dimension(3,ngroup_m):: Axe_atom_gr
  real(kind=db), dimension(4,npsom):: xyz
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(6,n_counter_dip):: Counter_dip
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion
  real(kind=db), dimension(n_index_ato):: Counter_index_ato
  real(kind=db), dimension(0:n_atom_proto):: Chargat, Rmtg0, Rmtsd
  real(kind=db), dimension(0:nrm,n_atom_0:n_atom_ind):: drhoato
  real(kind=db), dimension(3,3,natomp):: Rot_Atomp
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: dVcato
  real(kind=db), dimension(0:nrm,0:n_ipr_useful):: Vato
  real(kind=db), dimension(0:nrm,nspin,0:n_ipr_useful):: rhoigr_int
  real(kind=db), dimension(0:nrm,0:ntype):: Rato
  real(kind=db), dimension(0:nr_counter_ato,n_index_ato):: Rho_counter_ato, Vh_counter_ato

  real(kind=db), dimension(:), allocatable:: Exc, Fct_xc, Grad_rho, Laplac_rho, rst, Vlm, Ylm
  real(kind=db), dimension(:,:), allocatable:: rho_n, rhot, Vxct

  Write_Helm = Cal_xanes .and. icheck_12 > 1 .and. abs( V_helm ) > eps10
  Write_c_ato = Cal_xanes .and. icheck_12 > 1 .and. abs( natomp_ato ) > eps10
  Write_c_ion = Cal_xanes .and. icheck_12 > 1 .and. abs( natomp_ion ) > eps10
  Write_c_dip = Cal_xanes .and. icheck_12 > 1 .and. abs( natomp_dip ) > eps10
  if( icheck_12 > 2 .or. Write_Helm .or. Write_c_dip .or. Write_c_ion .or. Write_c_ato ) write(3,110)

  allocate( Dlmm_ia(-Lmax_pot:Lmax_pot,-Lmax_pot:Lmax_pot,0:Lmax_pot) )
  allocate( Exc(npoint) )
  allocate( Fct_xc(npoint) )
  allocate( Grad_rho(npoint) )
  allocate( ia_close(npoint) )
  allocate( iok(npoint) )
  allocate( Laplac_rho(npoint) )
  allocate( Vlm(nlm_pot) )
  allocate( Vlm_a(nlm_pot) )
  allocate( Ylm(nlm_pot) )
  allocate( Ylmc(nlm_pot) )

  Vh(:) = 0._db
  Vxc(:,:) = 0._db
  rs(:) = 1.0e+05_db
  rho(:,:) = 0._db
  Fct_xc(:) = 0._db
  Laplac_rho(:) = 0._db
  Grad_rho(:) = 0._db
  iok(:) = .false.

! When SCF, looking for the closest atom
  ia_close(:) = 0
  if( i_self > 1 .and. SCF ) then
    do i = 1,npoint
      dist_min = 10000._db
      do ia = 1,natomeq
        ipr = iaproto(ia)
        v(1:3) = xyz(1:3,i) - pos(1:3,ia)
        dist = sqrt( sum( v(:)**2 ) )
        if( dist > dist_min .or. dist > Rmtsd(ipr) ) cycle
        ia_close(i) = ia
      end do
    end do
  endif

! Calculation of Hartree potential and electronic density and its gradient
  dr = 0.01_db / bohr
  drr2 = dr / sqrt( 2._db )

  allocate( rho_n(npoint,0:nv_grad) )
  rho_n(:,:) = 0._db

  Loop_ib: do ib = 1,natomp

    it = itypep(ib)
    ipr = iaproto(ib)

    do index = 0,n_ipr_useful
      if( ipr_useful(index) == ipr ) exit
    end do

    This_bulk_atom_done = Bulk_atom_done .and. ipr > n_atom_proto - n_atom_proto_bulk

    iaprb = iapr_p(ib)

    SCF_atom = iaprb > -1 .and. ( i_self > 1 .or. This_bulk_atom_done ) .and. SCF

    if( SCF_atom .and. nlm_pot > 1 ) then
      Rot_a(:,:) = Rot_atomp(:,:,ib)
      call Rotation_mat(Dlmm_ia,icheck_12,Rot_a,Lmax_pot,Ylm_comp)
    endif

    itm = 1
    if( nspin == 2 ) then
      igr = igroup(ib)
      iga = igroup(iaabs)
      kgr = igreq(ipr,1)

      cosang = sum( Axe_atom_gr(:,kgr) * Axe_atom_gr(:,igr) )
      cosang = cosang * abs( sum( Axe_atom_gr(:,iga) * Axe_atom_gr(:,igr) ) )
      if( abs(cosang - 1) < eps4 ) then
        ispp(1) = 1
        ispp(nspin) = nspin
      elseif( abs(cosang + 1) < eps4 ) then
        ispp(1) = nspin
        ispp(nspin) = 1
      else
        itm = 0
      endif
    else
      ispp(1) = 1
    endif

    Loop_i: do i = 1,npoint
      if( iok(i) ) cycle
      W(1:3) = xyz(1:3,i) - pos(1:3,ib)

      do j = 0,nv_grad
        v(:) = w(:)
        select case(j)
          case(1)
            v(1) = v(1) + dr
          case(2)
            v(1) = v(1) - dr
          case(3)
            v(2) = v(2) + dr
          case(4)
            v(2) = v(2) - dr
          case(5)
            v(3) = v(3) + dr
          case(6)
            v(3) = v(3) - dr
          case(7)
            v(1) = v(1) + drr2
            v(2) = v(2) + drr2
          case(8)
            v(1) = v(1) - drr2
            v(2) = v(2) - drr2
          case(9)
            v(1) = v(1) + drr2
            v(2) = v(2) - drr2
          case(10)
            v(1) = v(1) - drr2
            v(2) = v(2) + drr2
          case(11)
            v(1) = v(1) + drr2
            v(3) = v(3) + drr2
          case(12)
            v(1) = v(1) - drr2
            v(3) = v(3) - drr2
          case(13)
            v(1) = v(1) + drr2
            v(3) = v(3) - drr2
          case(14)
            v(1) = v(1) - drr2
            v(3) = v(3) + drr2
          case(15)
            v(2) = v(2) + drr2
            v(3) = v(3) + drr2
          case(16)
            v(2) = v(2) - drr2
            v(3) = v(3) - drr2
          case(17)
            v(2) = v(2) + drr2
            v(3) = v(3) - drr2
          case(18)
            v(2) = v(2) - drr2
            v(3) = v(3) + drr2
        end select
        dist = sqrt( sum( v(:)**2 ) )

! When the point is in an outer atom, one keeps its potential at the muffin-tin radius
        if( ib > natomeq .and. j == 0 ) then
          if( dist < Rmt(it) ) then
            iok(i) = .true.
            cycle Loop_i
          endif
        endif

        do ir = 3,nrato(it)
          if( Rato(ir,it) > dist ) exit
        end do
        if( j == 0 .and. ir > nrato(it) ) then
          Vh(i) = Vh(i) - 2 * Chargat(ipr) / dist
          cycle Loop_i
        endif

        ir = min(ir,nrato(it))

        do ispin = 1,nspin
          drh(ispin) = f_interp2(dist,Rato(ir-2,it),Rato(ir-1,it),Rato(ir,it),rhoigr_int(ir-2,ispin,index), &
                       rhoigr_int(ir-1,ispin,index),rhoigr_int(ir,ispin,index))
        end do

        if( j == 0 ) then
          f = f_interp2(dist,Rato(ir-2,it),Rato(ir-1,it),Rato(ir,it),Vato(ir-2,index),Vato(ir-1,index),Vato(ir,index))
          Vh(i) = Vh(i) + f
          if( itm == 1 ) then
            do ispin = 1,nspin
              isp = ispp(ispin)
              rho(i,ispin) = rho(i,ispin) + drh(isp)
            end do
          else
            rho(i,:) = rho(i,:) + 0.5_db * ( drh(1) + drh(nspin) )
          endif
        endif

        drh_t = sum( drh(:) )
        rho_n(i,j) = rho_n(i,j) + sum( drh(:) )

! Difference potential between SCF and initial atoms
        if( SCF_atom .and. ( Test_case(1)  .or. One_SCF_surf .or. ib <= natomeq ) .and. iaprb <= n_atom_ind_self ) then
!        if( SCF_atom .and. ( ib <= natomeq .or. Test_case(1) .or. One_SCF_surf ) ) then

          p1 = ( dist - Rato(ir-1,it) ) / ( Rato(ir,it) - Rato(ir-1,it))
          p2 = 1 - p1

          if( j == 0 ) then
            Vh(i) = Vh(i) + p1*dVcato(ir,1,iaprb) + p2*dVcato(ir-1,1,iaprb)

            if( nlm_pot > 1 ) then
              if( Ylm_comp ) then
                call Cal_Ylmc(Lmax_pot,W,dist,Ylmc,nlm_pot)
              else
                call Cal_Ylmr(Lmax_pot,W,dist,Ylm,nlm_pot)
              endif

              Vlm(:) = p1*dVcato(ir,:,iaprb) + p2*dVcato(ir-1,:,iaprb)
              Vlm_a(:) = ( 0._db, 0._db )
              do L = 1,Lmax_pot
                do m = -L,L
                  Lm = L**2 + L + 1 + m
                  do mp = -L,L
                    Lmp = L**2 + L + 1 + mp
                    Vlm_a(Lm) = Vlm_a(Lm) + Dlmm_ia(m,mp,L) * Vlm(Lmp)
                  end do
                end do
              end do
              do Lm = 2,nlm_pot
                if( Ylm_comp ) then
                  Vh(i) = Vh(i) + sqrt_4pi * real( Vlm_a(Lm) * Ylmc(Lm), db )
                else
                  Vh(i) = Vh(i) + sqrt_4pi * real( Vlm_a(Lm) * Ylm(Lm), db )
                endif
              end do
            endif

          endif

! One does not superimpose the densities inside the closest atom
          if( ia_close(i) == ib ) then
            drho = ( p1*drhoato(ir,iaprb) + p2*drhoato(ir-1,iaprb) ) / nspin
            if( j == 0 ) rho(i,:) = rho(i,:) + drho
            drh_t = nspin * drho
            rho_n(i,j) = rho_n(i,j) + drh_t
          endif

        endif

      end do ! end of loop on j

    end do Loop_i
  end do Loop_ib

  if( nv_grad == 18 ) then
! Normalized gradient calculation
    ddr = 2 * dr
    dr2 = dr**2
    cder = 4._db * drr2**2
    do i = 1,npoint
      if( rho_n(i,0) < eps15 ) cycle
      if( iok(i) ) cycle

      Grad(1) = ( rho_n(i,1) - rho_n(i,2) ) / ddr
      Grad(2) = ( rho_n(i,3) - rho_n(i,4) ) / ddr
      Grad(3) = ( rho_n(i,5) - rho_n(i,6) ) / ddr

      Grad_rho(i) = sqrt( sum( Grad(:)**2 ) ) / rho_n(i,0)

! Laplacian
      Fct_xc(i) = ( sum( rho_n(i,1:6) ) - 6._db * rho_n(i,0) ) / dr2
      Laplac_rho(i) = Fct_xc(i) / rho_n(i,0)

      d2n_dxdy = ( rho_n(i,7) + rho_n(i,8) - rho_n(i,9) - rho_n(i,10) ) / cder
      d2n_dxdz = ( rho_n(i,11) + rho_n(i,12) - rho_n(i,13) - rho_n(i,14) ) / cder
      d2n_dydz = ( rho_n(i,15) + rho_n(i,16) - rho_n(i,17) - rho_n(i,18) ) / cder
      V(1) = Grad(2) * d2n_dxdy + Grad(3) * d2n_dxdz
      V(2) = Grad(1) * d2n_dxdy + Grad(3) * d2n_dydz
      V(3) = Grad(1) * d2n_dxdz + Grad(2) * d2n_dydz

      Fct_xc(i) = Laplac_rho(i) + sum( Grad(:) * V(:) )  / rho_n(i,0)

    end do
  endif

  deallocate( rho_n )

! One possibly adds the non spherical contribution of the valence orbitals
  if( Nonsph ) then
    do i = 1,npoint
      if( iok(i) ) cycle
      rho(i,1:nspin) = rho(i,1:nspin) + rhons(i)
      vh(i) = vh(i) + vhns(i)
    end do
  endif

! Electric moment case
  if( abs( E_moment ) > eps10 ) then
    do i = 1,npoint
      if( iok(i) ) cycle
      V(1:3) = xyz(1:3,i) ! origin at the center of the cluster (thus not necessarily at the center of the outer sphere)
      V = matmul( Rot_E_moment, V )
   ! E = Grav(V) (not minus because, energy potential of electron)
      Vh(i) = Vh(i) + V(3) * E_moment
    end do
  endif

! One adds the contribution from the outer-sphere
  do i = 1,npoint
    if( iok(i) ) cycle
    vh(i) = vh(i) + Vsphere
  end do

! Counter ion effect
  if( natomp_ion > 0 ) then

    if( Write_c_ion ) write(3,'(/A,/A)') ' Counter ions potential','       z        V_ion       V'

    do i = 1,npoint

      if( iok(i) ) cycle

      Ps(:) = xyz(1:3,i)
      call Ion_potential(Counter_ion,Counter_linear,delta_z_lin,igroup_ion,n_counter_ion,natomp_ion,Pos_ion,Ps,Rot_cluster,V_ion, &
                         V_surf,z_surf)

      Vh(i) = Vh(i) + V_ion

      if( Write_c_ion .and. abs( xyz(1,i) ) < eps10 .and. abs( xyz(2,i) ) < eps10 ) &
        write(3,'(2f11.5,1p,e13.5)') xyz(3,i)*bohr, V_ion*rydb, Vh(i)*rydb

    end do

  endif

  if( natomp_ato > 0 ) then

    if( Write_c_ato ) write(3,'(/A,/A)') ' Counter atoms potential and density','       z        V_ato       V         Rho_ato'

    do i = 1,npoint

      if( iok(i) ) cycle

      Ps(:) = xyz(1:3,i)
      call Ato_potential(Counter_ato,Counter_index_ato,igroup_ato,n_counter_ato,n_index_ato,natomp_ato,nr_counter_ato,Pos_ato,Ps, &
                               r_counter_ato,Rho_ato,Rho_counter_ato,V_ato,Vh_counter_ato)

      Vh(i) = Vh(i) + V_ato

      do isp = 1,nspin
        rho(i,isp) = rho(i,isp) + Rho_ato / nspin
      end do

      if( Write_c_ato .and. abs( xyz(1,i) ) < eps10 .and. abs( xyz(2,i) ) < eps10 ) &
        write(3,'(2f11.5,1p,e13.5,f11.5)') xyz(3,i)*bohr, V_ato*rydb, Vh(i)*rydb, Rho_ato

    end do

  endif

! Counter dipole effect
  if( natomp_dip > 0 ) then

    if( Write_c_dip ) write(3,'(/A,/A)') ' Counter dips potential','       z        V_dip       V'

    do i = 1,npoint

      if( iok(i) ) cycle

      Ps(:) = xyz(1:3,i)

      call Dip_potential(icheck_12,Counter_dip,Counter_linear,delta_z_lin,igroup_dip,n_counter_dip,natomp_dip,Pos_dip,Ps, &
                         Rot_cluster,V_dip,V_surf,z_surf)

      Vh(i) = Vh(i) + V_dip

      if( Write_c_dip .and. abs( xyz(1,i) ) < eps10 .and. abs( xyz(2,i) ) < eps10 ) &
                      write(3,'(2f11.5,1p,e13.5)') xyz(3,i)*bohr, V_dip*rydb, Vh(i)*rydb

    end do

  endif

! Helmholtz potential
  if( abs( V_helm ) > eps10 ) then

    if( .not. Helm_cos ) then
    ! alfa is such that sqrt(pi/2) * erf( alfa/sqrt(2) ) / alfa = 0.5
      alfa = 2.47304793497921_db
      Width_p = Width_helm / ( sqrt(2._db) * alfa )
      fac = 0.5_db * sqrt(pi) * V_helm
    endif

    if( Write_Helm ) write(3,'(/A,/A)') ' Helmholtz potential','       z         V_H        V'
    do i = 1,npoint

      if( Sym_2D ) then
        dist = sum( V_surf(1:3) * xyz(1:3,i) )
        if( z_bulk > -999._db .and. z_surf > -999._db .and. Dist < z_surf ) then
          Smooth = ( Dist - z_bulk ) / ( z_surf - z_bulk )
          Smooth = max( Smooth, 0._db )
          Smooth = min( Smooth, 1._db )
        else
          Smooth = 1._db
        endif
      else
        Smooth = 1._db
        dist = xyz(4,i)
      endif

      Write_pot = Write_helm .and. abs( xyz(1,i) ) < eps10 .and. abs( xyz(2,i) ) < eps10

      if( Helm_cos ) then

        if( dist > Orig_helm - Width_helm .and. dist < Orig_helm + Width_helm ) then
          Delta_V_helm = Smooth * 0.5_db * V_helm * ( 1 + cos( pi * ( dist - Orig_helm ) / Width_helm ) )
          Vh(i) = Vh(i) + Delta_V_helm
          if( Write_pot ) write(3,'(2f11.5,1p,e13.5)') xyz(3,i)*bohr, Delta_V_helm*rydb, Vh(i)*rydb
        endif

      else

        if( Helm_mix .and. dist < z_surf - eps10 .and. z_surf < Orig_helm - eps10 ) then
! With Helm_mix option, a shorter parabolic potential shape is used
          if( dist > Surf_0 ) then
            Delta_V_helm = Smooth * fac * Helm_fac * ( dist - Surf_0 )**2
            Vh(i) = Vh(i) + Delta_V_helm
          if( Write_pot ) write(3,'(2f11.5,1p,e13.5)') xyz(3,i)*bohr, Delta_V_helm*rydb, Vh(i)*rydb
          endif

        elseif( Helm_lin .and. dist < z_surf - eps10 .and. z_surf < Orig_helm - eps10 ) then
! With Helm_mix option, a shorter linear potential shape is used
          if( dist > Surf_0 ) then
            Delta_V_helm = Smooth * fac * Helm_fac * ( dist - Surf_0 )
            Vh(i) = Vh(i) + Delta_V_helm
            if( Write_pot ) write(3,'(2f11.5,1p,e13.5)') xyz(3,i)*bohr, Delta_V_helm*rydb, Vh(i)*rydb
          endif

        else

          x = ( dist - Orig_helm ) / Width_p
          if( abs( x ) < eps10 ) then
            Delta_V_helm = V_helm
          else
            Delta_V_helm = Smooth * fac * ( 1 - erfc( x ) ) / x
          endif
          Vh(i) = Vh(i) + Delta_V_helm
          if( Write_pot ) write(3,'(2f11.5,1p,e13.5)') xyz(3,i)*bohr, Delta_V_helm*rydb, Vh(i)*rydb

        endif

      endif
    end do
  endif

! Points close to the outer sphere and inside an outer-sphere atom
  do ia = natomeq+1,natomp
    it = itypep(ia)
    ipr = iaproto(ia)
    R_m = max( Rmtg0(ipr), Rmt(it) + 0.25_db / bohr + eps10 )

    V_a = 10000._db
    Rho_a(:) = 0._db
    Grad_rho_a = 0._db
    Fct_xc_a = 0._db

    Found = .false.

    do i = 1,npoint
      W(1:3) = xyz(1:3,i) - pos(1:3,ia)
      dist = sqrt( sum( W(:)**2 ) )
      if( .not. ( dist > Rmt(it) .and. dist < R_m ) ) cycle

      if( Vh(i) < V_a ) then
        Found = .true.
        V_a = Vh(i)
        Rho_a(:) = rho(i,:)
        Grad_rho_a = Grad_rho(i)
        Fct_xc_a = Fct_xc(i)
      endif
    end do

    if( .not. Found ) cycle

    do i = 1,npoint
      if( .not. iok(i) ) cycle
      W(1:3) = xyz(1:3,i) - Pos(1:3,ia)
      dist = sqrt( sum( W(:)**2 ) )
      if( dist > Rmt(it) ) cycle

      Vh(i) = V_a
      rho(i,:) = Rho_a(:)
      Grad_rho(i) = Grad_rho_a
      Fct_xc(i) = Fct_xc_a
    end do

  end do

! Calculation of the Fermi radius, rs
  f = 0.75_db / pi
  do isp = 1,nspin
    do i = 1,npoint
      rho(i,isp) = max( rho(i,isp), eps10 )
    end do
  end do
  tiers = 1.0_db / 3.0_db
  do i = 1,npoint
    rs(i) = ( f / sum( rho(i,1:nspin) ) )**tiers
  end do

  allocate( rhot(npoint,nspin) )
  allocate( Vxct(npoint,nspin) )
  allocate( rst(npoint) )

  do isp = 1,nspin
    rhot(1:npoint,isp) = rho(1:npoint,isp)
  end do
  rst(1:npoint) = rs(1:npoint)

! Calculation of the exchange-correlation potential in the ground state.
  call Potxc(Exc,Fct_xc,Grad_rho,Magnetic,npoint,npoint,nspin,alfpot,rhot,rst,Vxct)

  do isp = 1,nspin
    Vxc(1:npoint,isp) = Vxct(1:npoint,isp)
  end do

  deallocate( rhot )
  deallocate( Vxct )
  deallocate( rst )

  if( Image_charge ) then
    z0 = 0.5_db * Atom_radius(Z_top)
    if( icheck_12 > 1 ) then
      write(3,'(/a22,i3)') ' Image charge, Z_top =',Z_top
      write(3,'(a5,f10.5)') ' z0 =',z0*bohr
      write(3,'(a9,f10.5)') ' z_surf =',z_surf*bohr
      write(3,'(a9,3f10.5)') ' V_surf =',V_surf(1:3)
      write(3,'(/A)') '       z         Vxc      V_ch_im'
    endif
    do i = 1,npoint
      z = sum( V_surf(1:3) * xyz(1:3,i) )
      if( z < z_surf + 2 * z0 ) cycle
      V_image = - 1._db / ( z - z_surf - z0 )
      Fac = Vxc(i,1)
      if( z < z_surf + 3 * z0 ) then
        Weight = ( z - z_surf - 2 * z0 ) / z0
        Vxc(i,:) = Weight * V_image + ( 1._db - Weight ) * Vxc(i,:)
      else
        Vxc(i,:) = V_image
      endif
      if( icheck_12 > 1 .and. abs( xyz(1,i) ) < eps10 .and. abs( xyz(2,i) ) < eps10 )&
        write(3,'(3f11.5)')  xyz(3,i)*bohr, Fac*rydb, Vxc(i,1)*Rydb
    end do
  endif

  if( V_intmax < 1000._db ) then
    do isp = 1,nspin
      do i = 1,npoint
        dv = V_intmax - Vh(i) - Vxc(i,isp)
        if( dv < 0._db ) Vh(i) = Vh(i) + dv
      end do
    end do
  endif

  if( icheck_12 > 2 ) then
    if( Nonsph ) then
      write(3,120)
      do i = 1,npoint
        write(3,130) i, xyz(1:3,i)*bohr, Vh(i)*rydb, Vhns(i)*rydb, rhons(i), rs(i), Vxc(i,1:nspin)*rydb, Grad_rho(i), &
                     Laplac_rho(i), Fct_xc(i)
      end do
    else
      if( nspin == 1 ) then
        write(3,140)
      else
        write(3,145)
      endif
      do i = 1,npoint
        write(3,130) i, xyz(1:3,i)*bohr, Vh(i)*rydb, rs(i), Vxc(i,1:nspin)*rydb, Grad_rho(i), Laplac_rho(i), Fct_xc(i)
      end do
    endif
  endif

  deallocate( Dlmm_ia, Exc, Fct_xc, Grad_rho, ia_close, iok, Laplac_rho, Vlm, Vlm_a, Ylm, Ylmc )

  return
  110 format(/' ---- Pot0 ----------',100('-'))
  120 format(/4x,'i    x      y      z      Vh_(eV)     Vhns_(eV)     rhons       rs_(ua)',8x,'Vxc(1,nspin)_(eV) Grad_rho/rho',&
                                                                                          '  Laplac/rho',6x,'Fct_xc')
  130 format(i5,3f7.3,1p,9e13.5)
  140 format(/4x,'i    x      y      z      Vh_(eV)      rs_(ua)      Vxc_(eV)   Grad_rho/rho  Laplac/rho',6x,'Fct_xc')
  145 format(/4x,'i    x      y      z      vh_(eV)      rs_(ua)    Vxc_up_(eV)  Vxc_dn_(eV)  Grad_rho/rho',&
                                                                                          '  Laplac/rho',6x,'Fct_xc')
end

!***********************************************************************

subroutine Potxc(Exc,Fct_xc,Grad_rho,Magnetic,np,npm,nspin,alfpot,rhot,rst,Vxct)

  use declarations
  implicit none

  real(kind=db), parameter:: tiers = 1._db / 3._db

  integer:: np, npm, nspin

  logical:: Magnetic

  real(kind=db):: alfpot, f, fac

  real(kind=db), dimension(np):: Fct_xc, Grad_rho, rst
  real(kind=db), dimension(np,nspin):: rhot, Vxct
  real(kind=db), dimension(npm):: Exc

! Vxct = Exchange-correlation potential
! Exc = Exchange-correlation energy per particule

  fac = ( (18*pi)**tiers ) / pi

  if( alfpot >= eps4 ) then

! X_alpha potential
    f = - 1.5_db * alfpot * fac
    Vxct(1:np,1) = f / rst(1:np)
    if( Magnetic ) Vxct(1:np,nspin) = Vxct(1:np,1)
    Exc(1:np) = 0.75_db * Vxct(1:np,1)

  elseif( abs( alfpot ) < eps4 ) then

! Hedin and Lundqvist potential
    call Hedin_Lundqvist_XC(Exc,np,npm,nspin,rhot,rst,Vxct)

  elseif( abs( alfpot + 1._db ) < eps4 ) then

! Perdew and Wang potential
    call Perdew_Wang_XC(Exc,Magnetic,np,npm,nspin,rhot,rst,Vxct)

  else

! GGA Perdew, Burke and Ernrerhof (PBE96) potential
    call PBE96_XC(Exc,Fct_xc,Grad_rho,Magnetic,np,npm,nspin,rhot,rst,Vxct)

  endif

  return
end

!***********************************************************************

! Hedin and Lundqvist potential,
! J. Phys. C: Solid State Phys., 4, 2064 (1971)
! Von Barth and Hedin, J. Phys. C: Solid State Phys., 5, 1629 (1972)

! Vxct = Exchange-correlation potential
! Exc = Exchange-correlation energy per particule

subroutine Hedin_Lundqvist_XC(Exc,np,npm,nspin,rhot,rst,Vxct)

  use declarations
  implicit none

  real(kind=db), parameter:: tiers = 1._db / 3._db
  real(kind=db), parameter:: qtiers = 4 * tiers

  integer:: ip, np, npm, nspin

  real(kind=db):: a, alpha0, c_f, c_p, e_cf, e_cp, ect, ex, f_vonbarth, f1, f2, fac, fx, gamma, mu_cf, mu_cp, mu_xp, nu_c, &
    r_f, r_p, tau_c, x

  real(kind=db), dimension(np):: rst
  real(kind=db), dimension(np,nspin):: rhot, Vxct
  real(kind=db), dimension(npm):: Exc

  fac = ( (18*pi)**tiers ) / pi
  alpha0 = -0.75_db * (18/pi**2)**tiers

  a = (1 / 2._db)**tiers
  gamma = qtiers * a / ( 1 - a )
! Pour les valeurs de c_p et r_p on garde les valeurs non polarise
! choisie aussi par Moruzzi Janak et William (1978). Pour r_f et c_f
! on prend aussi leurs parametres plutot que les originaux de Von Barth
! qui sont : c_p = 0.0504, r_p = 30., c_f = 0.0254, r_f = 75.
  c_p = 0.045_db
  r_p = 21._db
  c_f = c_p / 2
  r_f = 2._db**qtiers * r_p   ! = 52.9166841

  do ip = 1,np

    mu_xp = - fac / rst(ip)
    mu_cp = - c_p * log( 1 + r_p / rst(ip) )
    e_cp = - c_p * f_vonbarth( rst(ip) / r_p )

    if( nspin == 1 ) then

      Vxct(ip,1) = mu_xp + mu_cp

      ex = alpha0 / rst(ip)
      ect = e_cp
      Exc(ip) = ex + ect

    else

      e_cf = - c_f * f_vonbarth( rst(ip) / r_f )
      nu_c = gamma * ( e_cf - e_cp )
      mu_cf = - c_f * log( 1 + r_f / rst(ip) )
      tau_c = mu_cf - mu_cp - qtiers * ( e_cf - e_cp )

      x = rhot(ip,1) / sum( rhot(ip,1:nspin) )
      fx = ( x**qtiers + (1-x)**qtiers - a ) / ( 1 - a )

      f1 = mu_xp + nu_c
      f2 = mu_cp  - nu_c + tau_c * fx
      Vxct(ip,1) = f1 * ( 2 * x )**tiers + f2
      Vxct(ip,nspin) = f1 * ( 2 - 2 * x )**tiers + f2

      ex = alpha0 / rst(ip) + mu_xp * fx / gamma
      ect = e_cp + fx * nu_c / gamma
      Exc(ip) = ex + ect
    endif

  end do

  return
end

!***********************************************************************

function f_vonbarth(x)

  use declarations
  implicit none
  real(kind=db):: f_vonbarth, x

  f_vonbarth = (1 + x**3) * log(1 + 1/x) + x / 2 - x**2 - 1/3._db

  return
end

!***********************************************************************

! Perdew and Wang potential
! Phys Rev. B, 45, 13244 (1992-I)

subroutine Perdew_Wang_XC(Exc,Magnetic,np,npm,nspin,rhot,rst,Vxct)

  use declarations
  implicit none

  real(kind=db), parameter:: tiers = 1._db / 3._db
  real(kind=db), parameter:: qtiers = 4 * tiers

  integer:: ip, np, npm, nspin

  logical:: Magnetic

  real(kind=db):: depsilon_c_rs, dzeta, epsilon_c, fac, mu_xp, Rs, Vcdn, Vcup, x

  real(kind=db), dimension(np):: rst
  real(kind=db), dimension(np,nspin):: rhot, Vxct
  real(kind=db), dimension(npm):: Exc

! In Hartree
  fac = 0.5_db * ( (18*pi)**tiers ) / pi

  do ip = 1,np

    if( Magnetic ) then
      dzeta = ( rhot(ip,1) - rhot(ip,nspin) ) / sum( rhot(ip,:) )
    else
      dzeta = 0._db
    endif
    Rs = rst(ip)
    call Cor_Perdew(depsilon_c_rs,dzeta,epsilon_c,Rs,Vcup,Vcdn)

! Adding the exchange
    mu_xp = - fac / rst(ip)
    if( nspin == 1 ) then
      Vxct(ip,1) = Vcup + mu_xp
    else
      x = rhot(ip,1) / sum( rhot(ip,1:nspin) )
      Vxct(ip,1) = Vcup + mu_xp * ( 2 * x )**tiers
      Vxct(ip,nspin) = Vcdn + mu_xp * ( 2 - 2 * x )**tiers
    endif

    Exc(ip) = 0.75_db * mu_xp + epsilon_c

  end do

! Convertion from Hartree to Rydberg
  Vxct(:,:) = 2 * Vxct(:,:)
  Exc(:) = 2 * Exc(:)

  return
end

!***********************************************************************

! Perdew and Wang correlation potential, PRB, 45, 13244 (1992-I)

subroutine Cor_Perdew(depsilon_c_rs,dzeta,epsilon_c,Rs,Vcup,Vcdn)

  use declarations
  implicit none

  real(kind=db), parameter:: tiers = 1._db / 3._db
  real(kind=db), parameter:: qtiers = 4 * tiers

  real(kind=db):: alf, alfac, dalf, dalfac, dEc_dz, depsilon_c_rs, dEp_rs, dEu_rs, df, dzeta, dzeta4, epsilon_c, Ep, Eu, f, fs0, &
    gamma, Rs, Vcdn, Vcom, Vcup

  data gamma, fs0 / 0.5198421_db, 1.709921_db /

  f = ( (1 + dzeta)**QTiers + (1 - dzeta)**QTiers - 2 ) / gamma

  call G_cor(0.0310907_db,0.21370_db,7.5957_db,3.5876_db,1.6382_db, 0.49294_db,1.00_db,Rs,Eu,dEu_rs)
  call G_cor(0.01554535_db,0.20548_db,14.1189_db,6.1977_db, 3.3662_db,0.62517_db,1.00_db,Rs,Ep,dEp_rs)
  call G_cor(0.0168869_db,0.11125_db,10.357_db,3.6231_db,0.88026_db, 0.49671_db,1.00_db,Rs,alf,dalf)

  alfac = - alf
  dalfac = - dalf

  dzeta4 = dzeta**4
  epsilon_c = Eu * ( 1 - f*dzeta4 ) + Ep * f * dzeta4 + alfac * f * ( 1 - dzeta4 ) / fs0

  depsilon_c_rs = dEu_rs * ( 1 - f * dzeta4 ) + dEp_rs * f * dzeta4 + dalfac * f * ( 1 - dzeta4 ) / fs0
  df = QTiers * ( (1+dzeta)**Tiers - (1-dzeta)**Tiers ) / gamma
  dEc_dz = 4 * (dzeta**3) * f * ( Ep - Eu - alfac / fs0 ) + df * ( dzeta4*Ep - dzeta4*Eu + ( 1 - dzeta4 )*alfac/fs0)
  Vcom = epsilon_c - Rs * depsilon_c_rs / 3 - dzeta * dEc_dz
  Vcup = Vcom + dEc_dz
  Vcdn = Vcom - dEc_dz

  return
end

!***********************************************************************

subroutine G_cor(A,A1,B1,B2,B3,B4,P,Rs,GG,G_Rs)

  use declarations
  implicit none

  real(kind=db):: A, A1, B1, B2, B3, B4, G_Rs, GG, P, P1, Q0, Q1, Q2, Q3, Rs, Rs12, Rs32, RsP

  P1 = P + 1._db
  Q0 = - 2 * A * ( 1 + A1 * Rs )
  Rs12 = sqrt( Rs )
  Rs32 = Rs12**3
  RsP = Rs**P
  Q1 = 2 * A * ( B1 * Rs12 + B2 * Rs + B3 * Rs32 + B4 * Rs * RsP )
  Q2 = log( 1 + 1 / Q1 )
  GG = Q0 * Q2
  Q3 = A * ( B1 / Rs12 + 2 * B2 + 3 * B3 * Rs12 + 2 * B4 * P1 * RsP)

  G_Rs = - 2 * A * A1 * Q2 - Q0 * Q3 / ( Q1**2 + Q1 )

  return
end

!***********************************************************************

! Perdew Burke and Ernzerhof exchange-correlationpotential
! Phys. Rev. Lett, 77, 3865 (1996)
! Derivations to get potential from YJ

! Grad_rho = abs( grad(n) ) / n
! Fct_xc = ( d( abs( grad(n) ) ) / dr )  * ( 1 / n )

subroutine PBE96_XC(Exc,Fct_xc,Grad_rho,Magnetic,np,npm,nspin,rhot,rst,Vxct)

  use declarations
  implicit none

  real(kind=db), parameter:: tiers = 1._db / 3._db
  real(kind=db), parameter:: dtiers = 2 * tiers
  real(kind=db), parameter:: qtiers = 4 * tiers

  integer:: ip, isp, np, npm, nspin

  logical:: Magnetic

  real(kind=db):: A, A_p, At124, At2, beta, beta_on_gamma, den, depsilon_c_rs, dF_x_ds, dzeta, epsilon_x, f, epsilon_c, F_x, &
    f1, f2, f3, f4, fac, Fxc_n, gamma, H, H_p, k_F, k_s, kappa, Lg, mu, mu_on_kappa, mu_xp, phi, Rs, s, s2, t, t_p, Vcdn, Vcup, x

  real(kind=db), dimension(np):: Fct_xc, Grad_rho, rst
  real(kind=db), dimension(np,nspin):: rhot, V_c, V_x, Vxct
  real(kind=db), dimension(npm):: Exc

! In Hartree, factor for epsilon_x, exchange energy per electron
  fac = 0.5_db * 0.75_db * ( (18*pi)**tiers ) / pi
  f = ( 9._db * pi / 4._db )**tiers
  f4 = 0._db

  beta = 0.066725_db
  gamma = ( 1._db - log(2._db) ) / pi**2
  beta_on_gamma = beta / gamma

  kappa = 0.804_db
  mu = beta * pi**2 / 3  ! = 0.219516
  mu_on_kappa = mu / kappa

! Exchange
  do ip = 1,np

    k_F = f / rst(ip)
    s = grad_rho(ip) / ( 2 * k_F )
    s2 = s**2

    epsilon_x = - fac / rst(ip)
    den = 1._db / ( 1._db + mu_on_kappa * s2 )
    F_x = 1._db + kappa * ( 1 - den )
    dF_x_ds = 2 * mu * den**2  ! d(F_x)/ds * 1/s

    den = ( 2 * k_F )**2
    if( den > eps15 ) then
      Fxc_n = Fct_xc(ip) / den
    else
      Fxc_n = 0._db
    endif
!    Fxc_n = 0._db

    mu_xp = epsilon_x * ( qtiers * F_x + dF_x_ds * ( Fxc_n  - qtiers * s**2 ) )

    if( nspin == 1 ) then
      V_x(ip,1) = mu_xp
    else
      x = rhot(ip,1) / sum( rhot(ip,1:nspin) )
      V_x(ip,1) = mu_xp * ( 2 * x )**tiers
      V_x(ip,nspin) = mu_xp * ( 2 - 2 * x )**tiers
    endif

  end do

! Correlation
  do ip = 1,np

    if( Magnetic ) then
      dzeta = ( rhot(ip,1) - rhot(ip,nspin) ) / sum( rhot(ip,:) )
      phi = 0.5_db * ( ( 1._db + dzeta )**dtiers + ( 1._db - dzeta )**dtiers )
    else
      dzeta = 0._db
      phi = 1._db
    endif
    Rs = rst(ip)

    call Cor_Perdew(depsilon_c_rs,dzeta,epsilon_c,Rs,Vcup,Vcdn)

    k_F = f / Rs
    k_s = sqrt( 4 * k_F / pi )

    t = grad_rho(ip) / ( 2 * phi * k_s )

    A = beta_on_gamma / ( exp( - epsilon_c / ( gamma * phi**3 ) ) - 1._db )
    At2 = A * t**2
    At124 = 1._db + At2 + At2**2

    Lg = 1._db + beta_on_gamma * t**2 * ( 1._db + At2 ) / At124

    H = gamma * phi**3 * log( Lg )

! Calculation of derivative
    if( Grad_rho(ip) > eps15 ) then
      Fxc_n = - 3 * Fct_xc(ip) / Grad_rho(ip)**2
    else
      Fxc_n = 0._db
    endif

    t_p = ( Fxc_n  + 3.5_db ) * ( t / Rs )
    A_p = ( 1 / ( gamma * phi**3 ) ) * ( A / beta_on_gamma + 1._db ) * A * depsilon_c_rs

    f1 = 2 * t * t_p
    f2 = - 2 * A * t**5 * ( A_p * t + 3 * A * t_p ) / At124
    f3 = A**2 * t**7 * ( A_p * t + 2 * A * t_p ) * ( 1 + 2 * At2 ) / At124**2

    H_p = gamma * phi**3 * beta_on_gamma * ( f1 + f2 + f3 ) / Lg

    if( Magnetic ) f4 = ( ( 1._db + dzeta )**(-tiers) - ( 1._db - dzeta )**(-tiers) ) / phi
    do isp = 1,nspin
      if( isp == 1 ) then
        V_c(ip,isp) = Vcup + H - tiers * Rs * H_p
        if( Magnetic ) V_c(ip,isp) = V_c(ip,isp) - ( dzeta - 1._db ) * f4 * H
      else
        V_c(ip,isp) = Vcdn + H - tiers * Rs * H_p - ( dzeta + 1._db ) * f4 * H
      endif
    end do

    Exc(ip) = epsilon_x + epsilon_c

  end do

  Vxct(:,:) = V_x(:,:) + V_c(:,:)

! Convertion from Hartree to Rydberg
  Vxct(:,:) = 2 * Vxct(:,:)
  Exc(:) = 2 * Exc(:)

  return
end

!***********************************************************************

! Routine of projection of the potentials coming from FLAPW Wien2k, on the FDM grid and in the atomic sphere.

subroutine Potlapw(axyz,Chargat,Coupelapw,deccent,Exc_abs_i,Flapw_new,Full_atom,iapot, &
            iaproto,iaprotoi,icheck,igroup,iprabs,ipr1,itabs,its_lapw,itypei,itypep,itypepr,Magnetic,mpinodes0, &
            mpirank,n_atom_0,n_atom_ind,n_atom_proto,natome,natomeq,natomp,ngroup,ngroup_lapw,nklapw,nlm_pot, &
            nlmlapwm,nmatsym,normrmt,npoint,npsom,nrato,nrato_lapw,nrm,nslapwm,nspin,ntype, &
            Numat,Orthmat,Overlap,pos,Rato,rho,rhoato,rlapw,Rmtg,Rmtg0,Rmtimp,Rmtsd,Rot_cluster,rotloc_lapw,rs,rsato,Rsort, &
            Trace_format_wien,Trace_k,Trace_p,V_abs_i,V0bdcFimp,Vc_abs_i,Vcato,Vh,Vxc,Vxcato,Wien_file,Wien_matsym, &
            Wien_save,Wien_taulap,xyz)

  use declarations
  implicit none
  include 'mpif.h'

  integer, parameter:: ndir = 98

  integer:: i, ia, iap, icheck, idir, igr, ij1, ij2, ik, iprabs, ipr1, ir, is, isp, ispin, istat, it, itabs, j, j1, &
    j2, mpierr, mpinodes0, mpirank, n, n_atom_0, n_atom_ind, n_atom_proto, natome, natomeq, natomp, n1, n2, ndim, ngroup, &
    ngroup_lapw, nklapw, nlm_pot, nlmlapwm, nmatsym, normrmt, np, npoint, npsom, nr, nrm, ns, nslapwm, nspin, ntype, &
    Trace_k, Wien_save

  character(len=Length_name), dimension(9):: Wien_file

  complex(kind=db), dimension(nslapwm) :: taupp
  complex(kind=db), dimension(nklapw,nmatsym) :: tauk
  complex(kind=db), dimension(:), allocatable :: vcklapw
  complex(kind=db), dimension(:,:), allocatable :: rhoklapw, vxklapw

  integer, dimension(3):: kzz
  integer, dimension(0:ntype):: nlmlapw, nrato, nrato_lapw, Numat
  integer, dimension(0:n_atom_proto):: iapot, itypepr
  integer, dimension(3,nslapwm):: kkk
  integer, dimension(natomp):: iaproto, igroup, itypep
  integer, dimension(natome):: iaprotoi, itypei
  integer, dimension(ngroup_lapw):: its_lapw
  integer, dimension(3,3,nslapwm):: Wien_matsym
  integer, dimension(:), allocatable:: nksym
  integer, dimension(:,:), allocatable:: llapw, mlapw
  integer, dimension(:,:,:), allocatable:: kxyz

  logical:: Coupelapw, Flapw_new, Full_atom, Magnetic, Trace_format_wien

  real(kind=db):: ctrace, f, hj1, hj2, Overlap, pd, r4pi, Rsort, Tiers, V0bdcFimp, Vht, Vol, xlength, ylength
  real(kind=db), dimension(3):: axyz, deccent, p, ptrace, v, vectrace, vx, vy, vz, w, wx, wy, wz
  real(kind=db), dimension(6):: Trace_p
  real(kind=db), dimension(3,3):: Orthmat, Rot_cluster, rottem
  real(kind=db), dimension(3,ndir):: vdir
  real(kind=db), dimension(nspin):: rhot, Vxct
  real(kind=db), dimension(npoint):: rs, Vh
  real(kind=db), dimension(0:ntype):: Rmtimp
  real(kind=db), dimension(0:n_atom_proto):: Chargat, Rmtg, Rmtg0, Rmtsd, Vcmft
  real(kind=db), dimension(0:n_atom_proto,2):: Grad_rho_mft
  real(kind=db), dimension(0:n_atom_proto,nspin):: rhomft, Vxcmft
  real(kind=db), dimension(nrm):: Exc_abs_i, Vc_abs_i
  real(kind=db), dimension(3,nslapwm):: Wien_taulap
  real(kind=db), dimension(nrm,nspin):: V_abs_i
  real(kind=db), dimension(0:nrm,n_atom_0:n_atom_ind):: rsato
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato
  real(kind=db), dimension(0:nrm,nspin,n_atom_0:n_atom_ind):: rhoato
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind) :: Vxcato
  real(kind=db), dimension(npoint,nspin):: Vxc, rho
  real(kind=db), dimension(3,3,ngroup_lapw) :: rotloc_lapw
  real(kind=db), dimension(3,natomp):: pos
  real(kind=db), dimension(4,npsom):: xyz
  real(kind=db), dimension(0:ntype):: rlapw
  real(kind=db), dimension(0:nrm,0:ntype):: Rato
  real(kind=db), dimension(:), allocatable :: vh_plot
  real(kind=db), dimension(:,:), allocatable :: rho_plot, vxc_plot, xxx
  real(kind=db), dimension(:,:,:), allocatable :: qxyz, vclapw
  real(kind=db), dimension(:,:,:,:), allocatable :: rholapw, vxlapw

  Vcmft(:) = 0._db
  rhomft(:,:) = 0._db
  vxcmft(:,:) = 0._db

  vectrace(1:3) = Trace_p(1:3)
  ptrace(1:3) = Trace_p(4:6)

  if( Wien_save == - 1 .and. mpirank == 0 ) then

    open(8, file = Wien_file(9), status='old', iostat=istat)
    if( istat /= 0 ) call write_open_error(Wien_file(9),istat,1)
    do i = 1,npoint
      read(8,*) Vh(i), Vxc(i,1:nspin), rho(i,1:nspin), rs(i)
    end do
    do ia = 1,n_atom_proto
      do ir = 0,nrato( itypepr(ia) )
        read(8,*) Vcato(ir,:,ia), Vxcato(ir,:,1:nspin,ia), rhoato(ir,1:nspin,ia), rsato(ir,ia)
      end do
    end do
    close(8)

  elseif( mpirank == 0 ) then

    allocate( kxyz(3,nklapw,nslapwm) )
    allocate( llapw(nlmlapwm,0:ntype) )
    allocate( mlapw(nlmlapwm,0:ntype) )
    allocate( qxyz(3,nklapw,nslapwm) )
    allocate( rhoklapw(nklapw,2*nspin-1) )
    allocate( rholapw(nrm,nlmlapwm,0:ntype,2*nspin-1) )
    allocate( vcklapw(nklapw) )
    allocate( vclapw(nrm,nlmlapwm,0:ntype) )
    allocate( vxklapw(nklapw,nspin) )
    allocate( vxlapw(nrm,nlmlapwm,0:ntype,2*nspin-1) )

    call lect_pot_lapw(flapw_new,kxyz,llapw,magnetic,mlapw,nklapw,nlmlapw,nlmlapwm, &
        nrato_lapw,nrm,nslapwm,nspin,ntype,Rato,rhoklapw,rholapw,vcklapw,vclapw,vxklapw,vxlapw,Wien_file)

    vh(:) = 0._db
    Vxc(:,:) = 0._db
    rs(:) = 100000._db
    rho(:,:) = 0._db
    ns = 1 + 2 * (nspin - 1 )

    do igr = 1,ngroup
      rottem(:,:) = rotloc_lapw(:,:,igr)
      do i = 1,3
        do j = 1,3
          rotloc_lapw(i,j,igr) = sum( rottem(i,:) * Rot_cluster(:,j) )
        end do
      end do
    end do

    allocate( nksym(nklapw) )

    do ik = 1,nklapw
      kzz(1:3) = kxyz(1:3,ik,1)
      call stern(nslapwm,nksym(ik),nmatsym,Wien_matsym,kzz,Wien_taulap,kkk,taupp)
      do is = 1,nksym(ik)
        tauk(ik,is) = taupp(is)
        kxyz(1:3,ik,is) = kkk(1:3,is)
      end do
    end do

! Wave vector in the orthonomal internal basis
    vx(:) = orthmat(:,1)
    vy(:) = orthmat(:,2)
    vz(:) = orthmat(:,3)

! wx, wy, wz : basis of the reciprocal unit cell
    call prodvec(wx,vy,vz)

    vol = sum( wx(:) * vx(:) )
    wx(:) = wx(:) / vol
    call prodvec(wy,vz,vx)
    wy(:) = wy(:) / vol
    call prodvec(wz,vx,vy)
    wz(:) = wz(:) / vol

    do ik = 1,nklapw
      do is = 1,nksym(ik)
        qxyz(:,ik,is) = deux_pi * ( kxyz(1,ik,is) * wx(:) + kxyz(2,ik,is) * wy(:) + kxyz(3,ik,is) * wz(:) )
      end do
    end do

    call cal_vdir(ndir,vdir)
    pd = 1._db / ndir

    tiers = 1._db / 3._db
    f = 0.75_db / pi
    r4pi = 1 / sqrt( quatre_pi )

! Atomic part
    n = min(nlm_pot,nlmlapwm)

    boucle_ia: do ia = 1,n_atom_proto

      it = itypepr(ia)
      iap = iapot(ia)

      do ir = 1,nrato(it)
        if( Rato(ir,it) > rlapw(it) ) exit
        Vcato(ir,1:n,ia) = Vclapw(ir,1:n,it)
        Vxcato(ir,1:n,1:nspin,ia) = Vxlapw(ir,1:n,it,1:nspin)

        Vcato(ir,1,ia) = Vcato(ir,1,ia) * r4pi
        Vxcato(ir,1,1:nspin,ia) = Vxcato(ir,1,1:nspin,ia) * r4pi

        rhoato(ir,1:nspin,ia) = rholapw(ir,1,it,1:nspin)
        if( nspin == 1 ) then
          rhoato(ir,1,ia) = rholapw(ir,1,it,1)
        else
          do ispin = 1,nspin
            if( ispin == 1 ) then
              is = 1
            else
              is = - 1
            endif
            rhoato(ir,ispin,ia) = 0.5_db * ( rholapw(ir,1,it,1) + is * ( rholapw(ir,1,it,nspin) - rholapw(ir,1,it,ns) ) )

          end do
        endif
      end do
      rhoato(0,1:nspin,ia) = rhoato(1,1:nspin,ia)
      Vcato(0,:,ia) = Vcato(1,:,ia)
      Vxcato(0,:,1:nspin,ia) = Vxcato(1,:,1:nspin,ia)
      nr = ir
      do ir = nr,nrato(it)

        Vcato(ir,:,ia) = 0._db
        Vxcato(ir,:,1:nspin,ia) = 0._db
        rhoato(ir,1:nspin,ia) = 0._db
        do idir = 1,ndir
          p(1:3) = pos(1:3,iap) + vdir(1:3,idir) * Rato(ir,it)
          call calpot(axyz,deccent,iaproto,igroup,its_lapw,itypep,qxyz,llapw,mlapw,n_atom_proto, &
            natomeq,natomp,ngroup_lapw,nklapw,nksym,nlmlapw,nlmlapwm,nmatsym,nrato,nrm,nslapwm,nspin,ntype, &
            Orthmat,p,pos,Rato,rhoklapw,rholapw,rhomft,rhot,rlapw,Rmtg0,rotloc_lapw,tauk,vcklapw,vclapw,Vcmft,vht,vxcmft,Vxct, &
            vxklapw,vxlapw,.false.)
          Vcato(ir,1,ia) = Vcato(ir,1,ia) + pd * Vht
          do ispin = 1,nspin
            Vxcato(ir,1,ispin,ia) = Vxcato(ir,1,ispin,ia) + pd * Vxct(ispin)
          end do
          rhoato(ir,1:nspin,ia) = rhoato(ir,1:nspin,ia) + pd * rhot(1:nspin)
        end do

      end do

      do ir = 1,nrato(it)
        do ispin = 1,nspin
          rhoato(ir,ispin,ia) = max( eps10, rhoato(ir,ispin,ia) )
        end do
        rsato(ir,ia) = ( f / sum( rhoato(ir,1:nspin,ia) ) )**tiers
      end do
      rsato(0,ia) = rsato(1,ia)

    end do boucle_ia

  endif

  if( mpinodes0 > 1 ) then
    ndim = ( nrm + 1 ) * ( n_atom_ind - n_atom_0 + 1 )

    call MPI_Bcast(rsato,ndim,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
    ndim = ndim*nlm_pot
    call MPI_Bcast(Vcato,ndim,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
    ndim = ( nrm + 1 ) * ( n_atom_ind - n_atom_0 + 1 ) * nspin

    call MPI_Bcast(rhoato,ndim,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
    ndim = ndim*nlm_pot
    call MPI_Bcast(Vxcato,ndim,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
  endif

  call Raymuf(.true.,Chargat,Full_atom,1,iapot,iaproto,iaprotoi,icheck,iprabs, &
        ipr1,itabs,itypei,itypep,itypepr,n_atom_0,n_atom_ind,n_atom_proto,natome,natomeq,natomp,nlm_pot, &
        normrmt,nrato,nrm,nspin,ntype,Numat,Overlap,pos,Rato,rhoato,Rmtg,Rmtg0,Rmtimp, &
        Rmtsd,Rsort,V0bdcFimp,Vcato,Vxcato)

  call Potrmt(Full_atom,Grad_rho_mft,iaprotoi,ipr1,iprabs,itypepr,n_atom_0,n_atom_ind,n_atom_proto,natome,nlm_pot,nrato,nrm, &
                  nspin,ntype,Numat,Rato,rhoato,rhomft,Rmtg0,Vcato,Vcmft,Vxcato,Vxcmft,iapot)

  if( Wien_save /= - 1 .and. mpirank == 0 ) then

    if( icheck > 0 ) write(3,110)

    do   ! Loop for the cuting

      if( coupelapw ) then
        select case(Trace_k)
          case(1)
            n1 = 501
            n2 = 1
            np = n1 * n2
            allocate( xxx(np,3) )
            w(1:3) = axyz(1:3) * vectrace(1:3) / ( np - 1 )
            v(1:3) = axyz(1:3) * ptrace(1:3)
            do i = 1,np
              xxx(i,1:3) = ( i - 1 ) * w(1:3) + v(1:3)
            end do
          case(2)
            n1 = 501
            n2 = 21
            np = n1 * n2
            ctrace = ptrace(1) / bohr
            allocate( xxx(np,3) )
            do j = 3,1,-1
              if( abs( vectrace(j) ) < eps4 ) cycle
              if( j == 3 ) then
                j1 = 1
                j2 = 2
              elseif( j == 2 ) then
                j1 = 1
                j2 = 3
              else
                j1 = 2
                j2 = 3
              endif
              hj1 = axyz(j1) / ( n1 - 1 )
              hj2 = axyz(j2) / ( n2 - 1 )
              i = 0
              do ij2 = 1,n2
                do ij1 = 1,n1
                  i = i + 1
                  xxx(i,j1) = ( ij1 - 1 ) * hj1
                  xxx(i,j2) = ( ij2 - 1 ) * hj2
                  xxx(i,j) = ( ctrace - vectrace(j1) * xxx(i,j1) - vectrace(j2) * xxx(i,j2) ) / vectrace(j)
                end do
              end do
            end do
            np = i
        end select
      else
        np = npoint
        allocate( xxx(np,3) )
        do i = 1,npoint
          xxx(i,1:3) = xyz(1:3,i)
        end do
      endif

      if( Coupelapw ) then
        if( trace_format_wien ) then
          p(:) = xxx(n1,:) - xxx(1,:)
          ylength = sqrt( sum( p(:)**2 ) )
          p(:) = xxx(np,:) - xxx(n1,:)
          xlength = sqrt( sum( p(:)**2 ) )
          allocate( vh_plot(np) )
          allocate( vxc_plot(np,nspin) )
          allocate( rho_plot(np,nspin) )
        endif
        if( nspin == 1 ) then
          write(3,112)
        else
          write(3,113)
        endif
      endif

      boucle_point: do i = 1,np

        p(:) = xxx(i,:)
        call calpot(axyz,deccent,iaproto,igroup,its_lapw,itypep,qxyz,llapw,mlapw,n_atom_proto, &
            natomeq,natomp,ngroup_lapw,nklapw,nksym,nlmlapw,nlmlapwm,nmatsym,nrato,nrm,nslapwm,nspin,ntype, &
            Orthmat,p,pos,Rato,rhoklapw,rholapw,rhomft,rhot,rlapw,Rmtg0,rotloc_lapw,tauk,vcklapw,vclapw,Vcmft,vht,Vxcmft,Vxct, &
            vxklapw,vxlapw,.true.)

        if( coupelapw ) then
          write(3,115) xxx(i,1:3)*bohr, vht*rydb, Vxct(1:nspin)*rydb, rhot(1:nspin)
          if( trace_format_wien ) then
            vh_plot(i) = vht
            vxc_plot(i,1:nspin) = Vxct(1:nspin)
            rho_plot(i,1:nspin) = rhot(1:nspin)
          endif
        else
          vh(i) = vht
          Vxc(i,1:nspin) = Vxct(1:nspin)
          rho(i,1:nspin) = rhot(1:nspin)
        endif

      end do boucle_point     ! End of loop on the points

      if( coupelapw .and. trace_format_wien ) then
        write(3,116) n2, n1, xlength, ylength
        write(3,117) ( vh_plot(i), i = 1,np )
        do isp = 1,nspin
          write(3,118) isp, n2, n1, xlength, ylength
          write(3,117) ( vxc_plot(i,isp), i = 1,np )
          write(3,119) isp, n2, n1, xlength, ylength
          write(3,117) ( rho_plot(i,isp), i = 1,np )
        end do
        deallocate( vh_plot )
        deallocate( vxc_plot )
        deallocate( rho_plot )
      endif

      deallocate( xxx )

      if( Coupelapw ) then
        Coupelapw = .false.
      else
        exit
      endif

    end do  ! End of loop Coupe

    deallocate( nksym )

! Calculation of the Fermi radius, rs

    do ispin = 1,nspin
      do i = 1,npoint
        rho(i,ispin) = max( rho(i,ispin), eps10 )
      end do
    end do

    tiers = 1._db / 3._db
    f = 0.75_db / pi

    do i = 1,npoint
      rs(i) = ( f / sum( rho(i,1:nspin) ) )**tiers
    end do

    deallocate( kxyz, llapw, mlapw, qxyz, rhoklapw, rholapw, vcklapw, vclapw, vxklapw, vxlapw )

  endif   ! arriving Wien_save == - 1 .or. mpirank /= 0

  if( mpinodes0 > 1 ) then

    call MPI_Bcast(vh,npoint,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
    call MPI_Bcast(rs,npoint,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
    ndim = npoint * nspin

    call MPI_Bcast(rho,ndim,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
    call MPI_Bcast(Vxc,ndim,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
  endif

! Absorbing atom potential for calculation of Epsii

  Exc_abs_i(:) = 0._db
  Vc_abs_i(:) = 0._db
  V_abs_i(:,:) = 0._db

  nr = nrato( itypepr(iprabs) )

  Vc_abs_i(1:nr) = Vcato(1:nr,1,iprabs)
  do ispin = 1,nspin
    V_abs_i(1:nr,ispin) = Vc_abs_i(1:nr) +  Vxcato(1:nr,1,ispin,iprabs)
  end do
  if( nspin == 1 ) then
    Exc_abs_i(1:nr) = Vxcato(1:nr,1,1,iprabs)
  else
    Exc_abs_i(1:nr) = ( Vxcato(1:nr,1,1,iprabs) + Vxcato(1:nr,1,nspin,iprabs) ) / nspin
  endif

  if( icheck > 1 ) then
    if( nspin == 1 ) then
      write(3,120)
    else
      write(3,125)
    endif
    do i = 1,npoint
      write(3,130) i, vh(i)*rydb, Vxc(i,1:nspin)*rydb, rho(i,1:nspin), rs(i)
    end do
    do  ia = 1,n_atom_proto
      if( nspin == 1 ) then
        write(3,140) ia
      else
        write(3,150) ia
      endif
      it = itypepr(ia)
      do ir = 1,nrato(it)
        write(3,160) Rato(ir,it)*bohr, quatre_pi * rhoato(ir,1:nspin,ia) * Rato(ir,it)**2, &
          rsato(ir,ia), ( Vxcato(ir,i,1:nspin,ia)*rydb, Vcato(ir,i,ia)*rydb, i = 1,nlm_pot )
      end do
    end do
  endif

  if( Wien_save == 1 .and. mpirank == 0 ) then
    open(8,file = Wien_file(9))
    do i = 1,npoint
      write(8,*) vh(i), Vxc(i,1:nspin), rho(i,1:nspin), rs(i)
    end do
    do ia = 1,n_atom_proto
      do ir = 0,nrato( itypepr(ia) )
        write(8,*) Vcato(ir,:,ia), Vxcato(ir,:,1:nspin,ia), rhoato(ir,1:nspin,ia), rsato(ir,ia)
      end do
    end do
    close(8)
  endif

  return
  110 format(/' ---- Potlapw ------',100('-'))
  112 format(/6x,'x',12x,'y',12x,'z',10x,'vh(eV)',6x,'Vxc(eV)',8x,'rho')
  113 format(/6x,'x',12x,'y',12x,'z',9x,'vh(eV)      Vxc(up)',9x, 'Vxc(dn)',9x,'rho(up)',8x,'rho(dn)')
  115 format(1p,9e13.5)
  116 format(/' Format WIEN :',//, ' Potential coulombien (rydb) :'/,2i5,2f10.5)
  117 format(5e16.8)
  118 format(/' Potential d echange (rydb), ispin =',i2,' :'/, 2i5,2f10.5)
  119 format(/' Densite electronique, ispin =',i2,' :'/,2i5,2f10.5)
  120 format(/4x,'i     vh(eV)      Vxc(eV)',8x,'rho           rs(ua)')
  125 format(/4x,'i     vh(eV)    Vxc(up)(eV) Vxc(down)(eV)   rho(up)     rho(down)       rs(ua)')
  130 format(i5,1p,6e13.5)
  140 format(/'    Rato  4*pi*r2*rhoato   rsato     vxcato      vato    ia =',i3)
  150 format(/'    Rato    rhoato(up) rhoato(down)  rsato   vxcato(up) vxcato(down)   vato    ia =',i3)
  160 format(1p,70e11.3)
end

!***********************************************************************

! Calcul des vecteurs directions pour le calcul du potentiel moyen radial

subroutine cal_vdir(ndir,vdir)

  use declarations
  implicit none

  integer:: idir, jdir, k, n, ndir

  real(kind=db):: dr5, dr6, dr9, r3, rac2, ur5, ur6, ur9

  real(kind=db), dimension(3,ndir):: vdir

  r3 = 1 / sqrt( 3._db )
  rac2 = 1 / sqrt( 2._db )
  vdir(:,1:3) = 0._db
  vdir(:,4:7) = r3
  vdir(:,8:13) = rac2
  do idir = 1,3
    vdir(idir,idir) = 1._db
  end do
  do idir = 5,7
    k = idir - 4
    vdir(k,idir) = - vdir(k,idir)
  end do
  do idir = 8,10
    k = idir - 7
    vdir(k,idir) = 0._db
    jdir = idir + 3
    vdir(k,jdir) = 0._db
    k = mod(k,3) + 1
    vdir(k,jdir) = - vdir(k,jdir)
  end do
  dr5 = 2 / sqrt(5._db)
  ur5 = 1 / sqrt(5._db)
  vdir(1,14) = dr5;  vdir(2,14) = ur5;  vdir(3,14) = 0._db
  vdir(1,15) = ur5;  vdir(2,15) = dr5;  vdir(3,15) = 0._db
  vdir(1,16) = -dr5;  vdir(2,16) = ur5;  vdir(3,16) = 0._db
  vdir(1,17) = -ur5;  vdir(2,17) = dr5;  vdir(3,17) = 0._db
  do idir = 18,21
    vdir(1,idir) = vdir(3,idir-4)
    vdir(2,idir) = vdir(1,idir-4)
    vdir(3,idir) = vdir(2,idir-4)
  end do
  do idir = 22,25
    vdir(1,idir) = vdir(3,idir-4)
    vdir(2,idir) = vdir(1,idir-4)
    vdir(3,idir) = vdir(2,idir-4)
  end do
  dr6 = 2 / sqrt(6._db)
  ur6 = 1 / sqrt(6._db)
  vdir(1,26) = dr6;  vdir(2,26) = ur6;  vdir(3,26) = ur6
  vdir(1,27) = ur6;  vdir(2,27) = dr6;  vdir(3,27) = ur6
  vdir(1,28) = ur6;  vdir(2,28) = ur6;  vdir(3,28) = dr6
  dr9 = 2 / 3._db
  ur9 = 1 / 3._db
  vdir(1,29) = ur9;  vdir(2,29) = dr9;  vdir(3,29) = dr9
  vdir(1,30) = dr9;  vdir(2,30) = ur9;  vdir(3,30) = dr9
  vdir(1,31) = dr9;  vdir(2,31) = dr9;  vdir(3,31) = ur9
  do idir = 26,31
    vdir(1,idir+6) = -vdir(1,idir)
    vdir(2,idir+6) = vdir(2,idir)
    vdir(3,idir+6) = vdir(3,idir)
    vdir(1,idir+12) = vdir(1,idir)
    vdir(2,idir+12) = -vdir(2,idir)
    vdir(3,idir+12) = vdir(3,idir)
    vdir(1,idir+18) = vdir(1,idir)
    vdir(2,idir+18) = vdir(2,idir)
    vdir(3,idir+18) = -vdir(3,idir)
  end do
  n = ndir / 2
  do idir = n+1,ndir
    vdir(:,idir) = - vdir(:,idir-n)
  end do

  return
end

!***********************************************************************

! Reading routine for the potential and electronic densities coming from WIEN2k

subroutine Lect_pot_lapw(flapw_new,kxyz,llapw,magnetic,mlapw,nklapw,nlmlapw,nlmlapwm, &
        nrato_lapw,nrm,nslapwm,nspin,ntype,Rato,rhoklapw,rholapw,vcklapw,vclapw,vxklapw,vxlapw,Wien_file)

!     nlmlapwm : nombre max de termes (l,m)
!     nslapwm : nombre max d'operations de symetrie ponctuelle
!     nklapw : nombre d'ondes planes

  use declarations
  implicit none

  integer:: eof, i, ifich, ik, isp, ispin, istat, it, j, jcard, jfich, L, LL, natom, nfich, nklapw, nlmlapwm, nrm, nslapwm, ns, &
    nspin, ntype

  integer, dimension(0:ntype):: nlmlapw, nrato_lapw
  integer, dimension(nlmlapwm,0:ntype):: llapw, mlapw
  integer, dimension(3,nklapw,nslapwm):: kxyz

  character(len=Length_name):: nomvcoul, nomr2v, nomr2vdn, nomclm(2*nspin-1)
  character(len=Length_name), dimension(9):: Wien_file

! modif delphine 8/06/01 pour les structures sans centre d'inversion
! one then has to read the imaginary part of Fourrier coefficients
  complex(kind=db), dimension(nklapw) :: vcklapw
  complex(kind=db), dimension(nklapw,nspin) :: vxklapw
  complex(kind=db), dimension(nklapw,2*nspin-1) :: rhoklapw

  logical flapw_new, magnetic

  real(kind=db):: cfr, cfi
  real(kind=db), dimension(nrm):: r2
  real(kind=db), dimension(nrm,nlmlapwm,0:ntype):: vclapw
  real(kind=db), dimension(nrm,nlmlapwm,0:ntype,2*nspin-1):: rholapw, vxlapw
  real(kind=db), dimension(0:nrm,0:ntype):: Rato

! kxyz           = vecteurs du reseau reciproque
! LL             = nombre de (l,m) par atome
! ntype          = nombre d'atomes inequivalents
! nmatsym        = nombre d'op. de symetrie

! Lecture du potentiel coulombien (case.vcoul), du potentiel d'echange
! et de correlation (case.r2v) et de la densite de charge (case.clmsum)

  nomvcoul = Wien_file(2)
  nomr2v = Wien_file(3)
  nomr2vdn = Wien_file(4)
  nomclm(1) = Wien_file(5)
  if( nspin == 2 ) nomclm(2:3) = Wien_file(6:7)

! 1- atomic spheres

  if( magnetic .and. flapw_new ) then
    nfich = 6
  elseif( magnetic ) then
    nfich = 5
  else
    nfich = 3
  endif

  do ifich = 1,nfich
    jfich = ifich
    if( magnetic .and. flapw_new ) then
      if( ifich == 2 ) then
        isp = 1
      elseif( ifich == 3 ) then
        jfich = 6
        isp = 2
      else
        isp = ifich - 3
      endif
    else
      isp = ifich - 2
    endif
    select case(jfich)
      case(1)
        open(8, file = nomvcoul, status='old', iostat=istat)
        if( istat /= 0 ) call write_open_error(nomvcoul,istat,1)
      case(2)
        open(8, file = nomr2v, status='old', iostat=istat)
        if( istat /= 0 ) call write_open_error(nomr2v,istat,1)
      case(3,4,5)
        open(8, file = nomclm(isp), status='old', iostat=istat)
        if( istat /= 0 ) call write_open_error(nomclm(isp),istat,1)
      case(6)
        open(8, file = nomr2vdn, status='old', iostat=istat)
        if( istat /= 0 ) call write_open_error(nomr2vdn,istat,1)
    end select

    if( .not. (magnetic .and. Flapw_new) .and. ifich == 2 ) then
      ns = nspin
    else
      ns = 1
    endif

    do it = 1,ntype

      do i = 1,3
        read(8,*)
      end do
      read(8,'(16x,i2)') natom
      read(8,'(16x,i2)',iostat=eof) LL
      if( eof /= 0 ) then
        backspace(8)
        read(8,'(17x,i2)') LL
      endif

      nlmlapw(it) = LL

      do ispin = 1,ns
        do L = 1,LL
          read(8,*)
          read(8,*)
          read(8,'(16x,i2,5x,i2)') llapw(L,it), mlapw(L,it)
          read(8,*)

          do j = 1,nrato_lapw(it),4
            jcard = min(nrato_lapw(it),j+3)
            select case(jfich)
              case(1)
                read(8,'(3X,4E19.12)') vclapw(j:jcard,L,it)
              case(2)
                read(8,'(3X,4E19.12)') vxlapw(j:jcard,L,it,ispin)
              case(3,4,5)
                read(8,'(3X,4E19.12)') rholapw(j:jcard,L,it,ispin)
              case(6)
                read(8,'(3X,4E19.12)') vxlapw(j:jcard,L,it,nspin)
            end select
          end do
        end do
      end do

      do i = 1,3
        read(8,*)
      end do

    end do ! end of loop over atoms

! 2- interstitial reegion

    do i = 1,3
      read(8,*)
    end do

    do ispin = 1,ns
      read(8,*)
      read(8,*)
      read(8,*)
      do ik = 1,nklapw
        select case(jfich)
          case(1)
            read(8,'(3X,3I5,2E19.12)') kxyz(1:3,ik,1), cfr, cfi
            vcklapw(ik) = cmplx( cfr, cfi,db )
          case(2)
            read(8,'(3X,3I5,2E19.12)') kxyz(1:3,ik,1), cfr, cfi
            vxklapw(ik,ispin) = cmplx( cfr, cfi,db )
          case(3,4,5)
            read(8,'(3X,3I5,2E19.12)') kxyz(1:3,ik,1), cfr, cfi
            rhoklapw(ik,isp) = cmplx( cfr, cfi,db )
          case(6)
            read(8,'(3X,3I5,2E19.12)') kxyz(1:3,ik,1), cfr, cfi
            vxklapw(ik,nspin) = cmplx( cfr, cfi,db )
        end select
      end do

    end do

    close(8)
  end do

! Division par r2 et division par 4pi pour le terme lm=(0,0) de rholapw

  ns = 1 + 2 * ( nspin - 1 )
  do it = 1,ntype
    r2(1:nrato_lapw(it)) = Rato(1:nrato_lapw(it),it)**2
    do j = 1,nrato_lapw(it)
      do L = 1,nlmlapw(it)
        vclapw(j,L,it) = vclapw(j,L,it) / r2(j)
        vxlapw(j,L,it,1:nspin) = vxlapw(j,L,it,1:nspin) / r2(j)
        rholapw(j,L,it,1:ns) = rholapw(j,L,it,1:ns) / r2(j)
      enddo
      rholapw(j,1,it,1:ns) = rholapw(j,1,it,1:ns) / quatre_pi
    enddo
  enddo

  return
end

!***********************************************************************

subroutine calpot(axyz,deccent,iaproto,igroup,its_lapw,itypep,qxyz,llapw,mlapw,n_atom_proto, &
            natomeq,natomp,ngroup_lapw,nklapw,nksym,nlmlapw,nlmlapwm,nmatsym,nrato,nrm,nslapwm,nspin,ntype, &
            Orthmat,p,pos,Rato,rhoklapw,rholapw,rhomft,rhot,rlapw,Rmtg0,rotloc_lapw,tauk,vcklapw,vclapw,Vcmft,vht,vxcmft,Vxct, &
            vxklapw,vxlapw,centat)

  use declarations
  implicit none

  integer:: ia, idm, idp, idx, igr, ik, ipr, ir, is, isp, ispin, it, j, k, L, Lm, lm1, Lm2, m, minu, n_atom_proto, natomeq, &
    natomp, ngroup_lapw, nklapw, nlm, nlmlapwm, nmatsym, nrm, ns, nslapwm, nspin, ntype

  integer, dimension(natomp):: iaproto, igroup, itypep
  integer, dimension(0:ntype):: nlmlapw, nrato
  integer, dimension(ngroup_lapw):: its_lapw
  integer, dimension(nklapw):: nksym
  integer, dimension(nlmlapwm,0:ntype):: llapw, mlapw

  complex(kind=db):: coef, imag1, rhoc, tauk(nklapw,nmatsym)
! modif delphine 8/06/01 pour les structures sans centre d'inversion
! il faut alors absolument lire la partie imaginaire des coeff de Fourier.
  complex(kind=db), dimension(nklapw):: vcklapw
  complex(kind=db), dimension(nklapw,nspin):: vxklapw
  complex(kind=db), dimension(nklapw,2*nspin-1):: rhoklapw
! fin modif delphine
  complex(kind=db), dimension(:), allocatable:: ylm

  logical:: centat

  real(kind=db):: arg, dist, p1, p2, rac_2, rho1, rho2, sqin2, vht, ylm1, Ylmr

  real(kind=db), dimension(2):: vc
  real(kind=db), dimension(3):: axyz, deccent, p, v, w
  real(kind=db), dimension(2,3):: rh(2,3)
  real(kind=db), dimension(3,3):: Orthmat
  real(kind=db), dimension(nspin):: rhot, Vxct
  real(kind=db), dimension(3,natomp):: pos
  real(kind=db), dimension(3,3,ngroup_lapw) :: rotloc_lapw
  real(kind=db), dimension(3,nklapw,nslapwm):: qxyz
  real(kind=db), dimension(nrm,nlmlapwm,0:ntype) :: vclapw
  real(kind=db), dimension(nrm,nlmlapwm,0:ntype,2*nspin-1) :: rholapw, vxlapw
  real(kind=db), dimension(0:n_atom_proto):: Rmtg0, Vcmft
  real(kind=db), dimension(0:n_atom_proto,nspin):: rhomft, vxcmft
  real(kind=db), dimension(0:ntype):: rlapw
  real(kind=db), dimension(0:nrm,0:ntype):: Rato

  vht = 0._db
  Vxct(1:nspin) = 0._db
  rhot(1:nspin) = 0._db
  rac_2 = sqrt( 2._db )
  sqin2 = 1._db / rac_2
  ns = 1 + 2 * (nspin - 1 )

! Dans le premier cas, c'est pour calculer le potentiel atomique
! pour un rayon grand, il faut eviter la divergence si on s'approche
! d'un autre atome.
  if( centat ) then

! On regarde si on est dans un atome
  do ia = 1,natomp

    ipr = iaproto(ia)
    it = itypep(ia)
    igr = igroup(ia)
    v(1:3) = p(1:3) - pos(1:3,ia)
    dist = sqrt( sum( v(:)**2 ) )
    dist = max(dist,Rato(1,it))

! Si on tombe dans un atome chevauchant la frontiere exterieur,
! on prend le potentiel au niveau de son rayon muffin-tin.
! On ne peut pas le faire au debut car Rmtg0 n'est pas encore calcule.
    if( ia > natomeq .and. dist < Rmtg0(ipr) .and. centat ) then
      vht = Vcmft(ipr)
      Vxct(1:nspin) = vxcmft(ipr,1:nspin)
      rhot(1:nspin) = rhomft(ipr,1:nspin)
      return
    endif

    if( dist >= rlapw(it) ) cycle
! On est dans un atome FLAPW.

    do ir = 2,nrato(it)
      if(Rato(ir,it) > dist) exit
    end do
    p1 = ( dist - Rato(ir-1,it) ) / ( Rato(ir,it)-Rato(ir-1,it) )
    p2 = 1 - p1

    do j = 1,3
      w(j) = sum( rotloc_lapw(j,:,igr) * v(:) )
    end do

    L = abs( llapw(nlmlapw(it),it) )
    nlm = ( L + 1 )**2
    allocate( Ylm(nlm) )
    call ylmlapw(L,nlm,w,Ylm)

    do Lm = 1,nlmlapw(it)
      L = abs( llapw(Lm,it) )
      m = mlapw(Lm,it)
      lm1 = L*(L+1) + 1 + abs(m)
      minu = 1
      imag1 = ( 1._db, 0._db )
      if( llapw(Lm,it) < 0 ) then
        imag1 = - img
        minu = - 1
      endif
      if( mod(m,2) == 1 ) then
        imag1 = - imag1
        minu = - minu
      endif
      idx = L*(L+1) + 1
      if( m == 0 ) then
        Ylmr = real( Ylm(idx),db )
      else
        idp = idx + m
        idm = idx - m
        Ylmr = sqin2 * real( (Ylm(idp) + minu * Ylm(idm))*imag1, db )
      endif
      if( L == 0 ) then
        ylm1 = 1._db
      else
        ylm1 = Ylmr
      endif

      if( its_lapw(igr) > 0  .and. Lm > 1 .and. Lm < 6 ) then
        if( Lm == 2 .or. Lm == 4 ) then
          lm1 = Lm
          lm2 = Lm + 1
        else
          lm1 = Lm - 1
          lm2 = Lm
        endif
      endif

      do k = ir-1,ir
        j = k - ir + 2
        if( its_lapw(igr) > 0 .and. Lm > 1 .and. Lm < 6 ) then
          call cascfc(vc(j), vclapw(k,lm1,it),vclapw(k,lm2,it),Lm)
        else
          vc(j) = vclapw(k,Lm,it)
        endif
      end do
      vht = vht + ( p1 * vc(2) + p2 * vc(1) ) * Ylmr

      do isp = 1,nspin
        do k = ir-1,ir
          j = k - ir + 2
          if( its_lapw(igr) > 0  .and. Lm > 1 .and. Lm < 6 ) then
            call cascfc(vc(j),vxlapw(k,lm1,it,isp), vxlapw(k,lm2,it,isp),Lm)
          else
            vc(j) = vxlapw(k,Lm,it,isp)
          endif
        end do
        Vxct(isp) = Vxct(isp) + ( p1 * vc(2) + p2 * vc(1) ) * Ylmr
      end do

      do isp = 1,ns
        do k = ir-1,ir
          j = k - ir + 2
          if( its_lapw(igr) > 0 .and. Lm > 1 .and. Lm < 6 ) then
            call cascfc(rh(j,isp),rholapw(k,lm1,it,isp), rholapw(k,lm2,it,isp),Lm)
          else
            rh(j,isp) = rholapw(k,Lm,it,isp)
          endif
        end do
      end do

      if( nspin == 1 ) then
        rhot(1) = rhot(1) + ( p1 * rh(2,1) + p2 * rh(1,1) ) * ylm1
      else
        do ispin = 1,nspin
          if( ispin == 1 ) then
            rho1 = 0.5_db * ( rh(2,1) + rh(2,nspin) - rh(2,ns) )
            rho2 = 0.5_db * ( rh(1,1) + rh(1,nspin) - rh(1,ns) )
          else
            rho1 = 0.5_db * ( rh(2,1) - rh(2,nspin) + rh(2,ns) )
            rho2 = 0.5_db * ( rh(1,1) - rh(1,nspin) + rh(1,ns) )
          endif
          rhot(ispin) = rhot(ispin) + ( p1*rho1 + p2*rho2 ) * ylm1
        end do
      endif

    end do  ! fin de la boucle sur les harmoniques

    deallocate( Ylm )

    return
  end do

! On est dans la zone interstitielle FLAPW

  endif  ! fin test centat

  v(1:3) = deccent(1:3) / axyz(1:3)
  v = matmul( orthmat, v )

  v(1:3) = p(1:3) + v(1:3)

  do ik = 1,nklapw
    coef = ( 0._db, 0._db )
    do is = 1,nksym(ik)
      arg = sum( qxyz(:,ik,is) * v(:) )
      coef = coef + cmplx( cos(arg), sin(arg),db ) * tauk(ik,is)
    end do
    coef  = coef / nksym(ik)

    vht = vht + real( vcklapw(ik) * coef, db )

    Vxct(1:nspin) = Vxct(1:nspin) + real( vxklapw(ik,1:nspin) * coef, db )

    if( nspin == 1 ) then
      rhot(1) = rhot(1) + real( rhoklapw(ik,1) * coef, db )
    else
      do ispin = 1,nspin
        if( ispin == 1 ) then
          is = 1
        else
          is = - 1
        endif
        rhoc = 0.5_db * ( rhoklapw(ik,1) + is * ( rhoklapw(ik,nspin) - rhoklapw(ik,ns) ) )
        rhot(ispin) = rhot(ispin) + real( rhoc * coef,db )
      end do
    endif
  end do

  return
end

!***********************************************************************

! Routine adaptee de la routine sul dans lapw5

subroutine cascfc(vo,v1,v2,Lm)

  use declarations
  implicit none

  integer:: i, Lm

  real(kind=db):: vo, v1, v2

  real(kind=db), dimension(2) :: cf, vi

!  NOTE THIS SUBROUTINE IS ONLY FOR CUBIC FCC, NACL, CSCL OR
! ANTIFLUORIT - STRUCTUR
! K0(R)=1/SQRT(4PI)
! K4(R)=SQRT(7/12)Y40(R) + SQRT(5/24)*(Y44(R) + Y4-4(R))
! K6(R)=SQRT(2)/4*Y60(R) - SQRT(7)/4* (Y64(R) + Y6-4(R))
! K7(R)=(-I)*(Y32(R)-Y3-2(R))  FOR ME IN ANFL STRUCTUR
! CSO=SQRT(2)/4
! CFO=SQRT(7/12)
! CFF=SQRT(5/12)
! CSO=-SQRT(14)/4

  vi(1) = v1
  vi(2) = v2
  if( Lm == 2 .or. Lm == 3 ) then
    cf(1) = .763762616
    cf(2) = .645497224
  else
    cf(1) = .35355339
    cf(2) =-.93541435
  endif
  i = mod(Lm,2) + 1
  vo = cf(i) * sum( cf(:) * vi(:) )

  return
end

!***********************************************************************

subroutine ylmlapw(Lomax,nlm,v,Y)

  use declarations
  implicit none

  integer:: i, idwn, L, L1, L2, Lm, Lm2, Lomax, m, m1, nlm

  complex(kind=db), dimension(nlm):: Y

  real(kind=db):: c2l, cd, cfi, c1l, cmfi, cn, csr, cth, cyp, fpi, sfi, sgnm, smfi, sth, tcth, xy, xyz, yi, yr

  real(kind=db), dimension(3):: v
  real(kind=db), dimension(8,8):: p

! Calcul des sinus et cosinus du vecteur v

  fpi = 4._db * acos(-1.d0)
  xy = v(1)**2 + v(2)**2
  xyz = xy + v(3)**2
  if( xy > eps10 ) then
    xy = sqrt(xy)
    xyz = sqrt(xyz)
    cth = v(3) / xyz
    sth = xy / xyz
    cfi = v(1) / xy
    sfi = v(2) / xy
  else
    cth = 1._db
    if( v(3) < 0._db )  cth = - cth
    sth = 0._db
    cfi = 1._db
    sfi = 0._db
  endif

  yr = 1 / sqrt(fpi)
  Y(1) = cmplx(yr,0._db,db)

  i = 1
  p(1,1) = 1._db
  p(2,1) = cth
  c2l = cth
  tcth = cth + cth

  do L = 2,Lomax+1
    i = i + L - 1
    idwn = i + 2
    L1 = L + 1
    L2 = L - 1
    Lm = L2
    Lm2 = L
    cmfi = 1._db
    smfi = 0._db
    cd = 1._db
    c2l = c2l + tcth
    sgnm = 1._db

    do m = 1,L

      if( m < L ) then
        m1 = m + 1
        p(L1,m) = ( c2l*p(L,m) - Lm*p(L2,m) ) / Lm2
        c1l = ( Lm + 1 ) * cth
        if( abs( sth ) < eps10 ) then
          p(L,m1) = 0._db
        else
          p(L,m1) = ( c1l*p(L,m) - Lm2*p(L1,m) ) / sth
        endif
      endif

      i = i + 1
      idwn = idwn - 1
      csr = sqrt( (2*L-1._db) / (fpi*cd) )
      cyp = sgnm * csr * p(L,m)
      yr = cyp * cmfi
      yi = cyp * smfi
      Y(i) = cmplx(yr,yi,db)
      if( idwn /= i ) y(idwn) = sgnm * cmplx(yr,-yi,db)

      cn = cmfi
      cmfi = cn*cfi - sfi*smfi
      smfi = sfi*cn + smfi*cfi
      Lm2 = Lm2 - 1
      Lm = Lm + 1
      cd = cd * Lm * Lm2
      sgnm = - sgnm

    end do

  end do

  return
end

!***********************************************************************

! Stern generates the star of rec lattice vector kzz(i).
!       The star vectors are stored in kkk, the star-size in nst,
!       imat contains the symmetry-matrices.

subroutine stern(nslapwm,nst,iord,imat,kzz,Wien_taulap,kkk,taupp)

  use declarations
  implicit none

!        arguments
  integer:: iord, nslapwm, nst
  integer:: kzz(3), kkk(3,nslapwm), imat(3,3,nslapwm)

  real(kind=db):: Wien_taulap(3,nslapwm)

  complex(kind=db):: taupp(nslapwm)

!        locals
  integer:: i, j, k, L, m
  integer:: g(3), indexx(nslapwm)

  real(kind=db):: tpi, tk

!        intrinsic functions
  intrinsic atan, exp

  tpi = 8.0d+0*atan(1.0d+0)
  g(1:3) = kzz(1:3)
  nst = 0

!         start loop over all symmetry operations
  boucle_ext: do i = 1, iord
     tk = 0._db
     do j = 1, 3
       tk = tk + Wien_taulap(j,i)*g(j)*tpi
       k = 0
       do L = 1, 3
         k = imat(j,L,i)*g(L) + k
       end do
       kkk(j,i) = k
     end do
     if( nst /= 0 ) then

!        proof, if the vector kkk(j,i) is a new starmember or not
       boucle_m: do m = 1, nst
         do j = 1,3
           if( kkk(j,m) /= kkk(j,i) ) cycle boucle_m
         end do

!        kkk(j,i) is not a new starmember, it is equiv to kkk(j,m).
!        but the tauphase of kkk(j,i) can be new.  therefore the
!        already defined phase taupp(m) is averaged with the phase
!        of kkk(j,m).

         taupp(m) = taupp(m) + exp( img * tk )
         indexx(m) = indexx(m) + 1
         cycle boucle_ext
       end do boucle_m
     endif

!        new vector found
     nst = nst + 1
     do j = 1,3
       kkk(j,nst) = kkk(j,i)
     end do
     taupp(nst) = exp( img * tk )
     indexx(nst) = 1

  end do boucle_ext

  do i = 1,nst
    taupp(i) = taupp(i) / indexx(i)
  end do

  return
end

!***********************************************************************

! Complementary calculations on the potential
! Calculation of the average interstitial potential and of the the maximum kinetic energy

subroutine Potential_comp(Bulk_atom_done,Cal_xanes,distai,dV0bdcF,E_Fermi,Full_atom, &
      Green,i_range,i_self,iaabs,iapot,iaproto,iaprotoi,icheck,imoy,imoy_out,iopsymr,ipr1,isrt,itypepr,korigimp,Magnetic, &
      Moy_loc,mpirank,n_atom_0,n_atom_ind,n_atom_proto,n_atom_proto_bulk,natome,natomp,natomp_ion,nim,nlm_pot,npoint,npsom, &
      nptmoy,nptmoy_out,nrato,nrm,nsort,nsortf,nspin,ntype,Numat,Other_xanes,poidsov,poidsov_out,Pos,Pos_ion,Rato,Rchimp,rhoato, &
      Rionic_imp,Rmtg,Rmtg0,Rmtsd,rs,rsbdc,rsbdc_out,Rsort,rvol,SCF,Sym_2D,Test_case,V_abs_i,V_intmax,V_surf,V0bdcF, &
      V0bdcF_out,V0bdcFimp,V0muf,Vc_abs_i,Vcato,Vh,Vhbdc,Vhbdc_init,Vhbdc_out,Vhbdc_p,Vr,Vxc,Vxcato,VxcbdcF,VxcbdcF_out,xyz)

  use declarations
  implicit none

  integer:: i_range, i_self, iaabs, icheck, icheck_loc, ipr1, ispin, mpirank, n_atom_0, n_atom_ind, n_atom_proto, &
    n_atom_proto_bulk, natome, natomp, natomp_ion, nim, nlm_pot, npoint, npsom, nptmoy, nptmoy_out, nrm, nsort, nsortf, nspin, &
    ntype

  integer, save:: i_self_p

  integer, dimension(natomp):: iaproto
  integer, dimension(natome):: iaprotoi
  integer, dimension(npoint):: imoy, imoy_out
  integer, dimension(nsort):: isrt
  integer, dimension(nopsm):: iopsymr
  integer, dimension(0:n_atom_proto):: iapot, itypepr
  integer, dimension(0:ntype):: nrato, Numat

  logical:: Bulk_atom_done, Cal_xanes, Full_atom, Green, korigimp, Magnetic, Moy_loc, Other_xanes, SCF, Sym_2D, Test_case

  real(kind=db):: Delta_V, distai, E_Fermi, rsbdc, rsbdc_out, Rsort, V_intmax, V0muf, Vhbdc, Vhbdc_for_shift, Vhbdc_init, &
                  Vhbdc_out, Vhbdc_p

  real(kind=db), dimension(3):: V_surf
  real(kind=db), dimension(nspin):: dV0bdcF, V0bdcF, V0bdcFimp, V0bdcF_out, VmoyF, VmoyF_out, VxcbdcF, VxcbdcF_out
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(3,natomp_ion):: Pos_ion
  real(kind=db), dimension(0:n_atom_proto):: Rchrg, Rmtg, Rmtg0, Rmtsd
  real(kind=db), dimension(0:ntype):: Rchimp, Rionic_imp
  real(kind=db), dimension(nim):: rvol
  real(kind=db), dimension(nrm):: Vc_abs_i
  real(kind=db), dimension(nrm,nspin):: V_abs_i
  real(kind=db), dimension(4,npsom):: xyz
  real(kind=db), dimension(npoint):: poidsov, poidsov_out, rs, Vh
  real(kind=db), dimension(npoint,nspin):: Vxc, Vr
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato
  real(kind=db), dimension(0:nrm,0:ntype):: Rato
  real(kind=db), dimension(0:nrm,nspin,n_atom_0:n_atom_ind):: rhoato
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind):: Vxcato

! For One_SCF_surf case
  if( i_self == 1 ) i_self_p = 1

  if( i_self == 1 .or. Cal_xanes ) then
    icheck_loc = icheck
  else
    icheck_loc = max( 0, icheck - 1 )
  endif

  if( icheck_loc > 0 ) write(3,110)

  call Ptmoy(distai,Green,iaabs,iaproto,icheck,imoy,imoy_out,iopsymr,isrt,Moy_loc, &
             n_atom_proto,natomp,natomp_ion,nim,npoint,nsort,nsortf,npsom,nptmoy,nptmoy_out,poidsov,poidsov_out, &
             Pos,Pos_ion,Rmtg0,Rsort,rvol,Sym_2D,V_surf,xyz)

  if( npoint > 0 ) then
    do ispin = 1,nspin
      Vr(1:npoint,ispin) = Vh(1:npoint) + Vxc(1:npoint,ispin)
    end do
  endif

  call Cal_Vmoy(Cal_xanes,i_range,i_self,icheck,imoy,imoy_out,korigimp,Magnetic,mpirank,npoint,nptmoy,nptmoy_out,nspin, &
             poidsov,poidsov_out,rs,rsbdc,rsbdc_out,SCF,V0bdcFimp,Vh,Vhbdc,Vhbdc_out,VmoyF,VmoyF_out,Vr,VxcbdcF,VxcbdcF_out)

! One imposes to the interstitial coulomb potential to remain the same to avoid Madelung constant potential problem.
  if( i_self == 1 ) then
    Vhbdc_init = Vhbdc
    Vhbdc_p = Vhbdc
  elseif( Other_xanes ) then
! only the value of the interstial and outer sphere potentials are changed. Not the one on the grid points and in the atoms
    Delta_V = Vhbdc_init - Vhbdc
    Vhbdc = Vhbdc_init
    Vhbdc_out = Vhbdc_out + Delta_V
    VmoyF(:) = VmoyF(:) + Delta_V
    VmoyF_out(:) = VmoyF_out(:) + Delta_V
  elseif( SCF ) then
    if( .not. Cal_xanes .or. Test_case ) then
      Vhbdc_for_shift = Vhbdc
      Vhbdc_p = Vhbdc
    else
      Vhbdc_for_shift = Vhbdc_p
    endif
    call Shift_V(Bulk_atom_done,Cal_xanes,i_range,icheck_loc,korigimp,mpirank,n_atom_0,n_atom_ind,n_atom_proto,n_atom_proto_bulk, &
                 nlm_pot,npoint,nptmoy_out,nrm,nspin,rsbdc, &
                 rsbdc_out,V_abs_i,V0bdcFimp,Vc_abs_i,Vcato,Vh,Vhbdc_for_shift,Vhbdc_init,Vhbdc_out,VmoyF,VmoyF_out,Vr)
  endif

  call Writing_atom_carac(Cal_xanes,Full_atom,iapot,icheck_loc,ipr1,iaprotoi,itypepr,mpirank,n_atom_0,n_atom_ind, &
        n_atom_proto,natome,nlm_pot,nrato,nrm,nspin,ntype,Numat,Rato,Rchimp,Rchrg,rhoato,Rionic_imp, &
        Rmtg,Rmtg0,Rmtsd,V_intmax,Vcato,Vxcato,i_range)

  if( korigimp ) then
    V0bdcF(1:nspin) = V0bdcFimp(1:nspin)
    dV0bdcF(1:nspin) = V0bdcFimp(1:nspin) - VmoyF(1:nspin)
  else
    V0bdcF(1:nspin) = VmoyF(1:nspin)
    dV0bdcF(1:nspin) = 0._db
  endif
  if( Green ) then
    V0bdcF_out(:) = VmoyF(:)
    rsbdc_out = rsbdc
    VxcbdcF_out(:) = VxcbdcF(:)
    Vhbdc_out = Vhbdc
  else
    V0bdcF_out(1:nspin) = VmoyF_out(1:nspin)
  endif
! Only used in convolution to calculate the mean free path
  V0muf = ( sum( V0bdcF(1:nspin) ) / nspin ) - E_Fermi

  return
  110 format(/' ---- Potent_comp ',100('-'))
end

!***********************************************************************

! Routine making the selection of the FDM points for the calculation of the average potential in the material (muffin-tin zero)
! and at the outer sphere

subroutine Ptmoy(distai,Green,iaabs,iaproto,icheck,imoy,imoy_out,iopsymr,isrt,Moy_loc, &
             n_atom_proto,natomp,natomp_ion,nim,npoint,nsort,nsortf,npsom,nptmoy,nptmoy_out,poidsov,poidsov_out, &
             Pos,Pos_ion,Rmtg0,Rsort,rvol,Sym_2D,V_surf,xyz)

  use declarations
  implicit none

  integer:: i, i1, i2, ia, iaabs, ib, icheck, io, is, j, k, k1, k2, n_atom_proto, natomp, natomp_ion, nim, npoint, ns, nsort, &
    nsortf, npsom, nptmoy, nptmoy_out

  integer, dimension(natomp):: iaproto
  integer, dimension(npoint):: imoy, imoy_out
  integer, dimension(nsort):: isrt
  integer, dimension(nopsm):: iopsymr

  logical:: Green, Moy_loc, Sym_2D

  real(kind=db):: D_max, dcour, dist, dist_min, distai, pdmoy, pdmoy_out, R_centre, R_min_ion, Rsort, Rvmmax, z, z_max

  real(kind=db), dimension(3):: p, ps, V_surf
  real(kind=db), dimension(3,natomp):: pos
  real(kind=db), dimension(3,natomp_ion):: Pos_ion
  real(kind=db), dimension(natomp):: ray
  real(kind=db), dimension(npoint):: poidsov, poidsov_out
  real(kind=db), dimension(0:n_atom_proto):: Rmtg0
  real(kind=db), dimension(nim):: rvol
  real(kind=db), dimension(4,npsom):: xyz

  D_max = 0._db
  do ia = 1,natomp
    ray(ia) = Rmtg0( iaproto(ia) )
    D_max = max( Ray(ia), D_max )
  end do
  D_max = 2 * D_max

  do  ! boucle reduction

  nptmoy_out = 0

  if( .not. Green ) then

    pdmoy_out = 0._db
    j = 0

    boucle_ib: do ib = 1,nsortf
      i = isrt(ib)
      do ia = 1,natomp
        ps(1:3) = pos(1:3,ia) - xyz(1:3,i)
        dist = sqrt( sum( ps(:)**2 ) )
        if( dist < ray(ia) - eps6 ) cycle boucle_ib
      end do
      j = j + 1
      imoy_out(j) = i
      pdmoy_out = pdmoy_out + rvol(i)
    end do boucle_ib

    nptmoy_out = j
    do i = 1,nptmoy_out
      poidsov_out(i) = rvol(imoy_out(i))
    end do

  endif

  z_max = -1000000000._db
  if( Sym_2D ) then
    do ia = 1,natomp
      z = sum( V_surf(1:3) * Pos(1:3,ia) )
      z_max = max( z_max, z )
    end do
    z_max = z_max + eps6
  endif
 ! Moy_loc is usual false (see fdm.f90)
  if( Moy_loc ) then
    dcour = Rsort
    do ia = 1,natomp
      if( ia == iaabs ) cycle
      ps(:) = pos(:,ia) - pos(:,iaabs)
      dcour = min(dcour,sqrt( sum( ps(:)**2 ) ))
      exit
    end do
    Rvmmax = min(dcour,Rsort) + eps6
  else
    Rvmmax = Rsort + eps6
! Distai is the distance from the center for the farest atom
    if( Distai > eps6 .and. natomp > 1 ) then
      R_centre = Distai + eps6
    else
      R_centre = Rsort + eps6
    endif
  endif

  ns = 1
  ib = 0
  pdmoy = 0._db
  do i = 1,npoint
    boucle_is: do is = 1,ns
      p(1:3) = xyz(1:3,i)
      if( is > 1  ) then
        select case(is)
          case(2,3,4)
            k = is - 1
            io = 39 + k
            if( iopsymr(io) == 1 .and. abs(p(k)) > epspos ) then
              p(k) = - p(k)
            else
              cycle
            endif
          case(5,6,7)
            k = is - 4
            k1 = 1 + mod(k,3)
            k2 = 1 + mod(k+1,3)
            i1 = 39 + k1
            i2 = 39 + k2
            if( iopsymr(i1) == 1 .and. abs(p(k1)) > epspos .and. iopsymr(i2) == 1 .and. abs(p(k2)) > epspos ) then
              p(k1) = - p(k1)
              p(k2) = - p(k2)
            else
              cycle
            endif
          case(8)
            if( iopsymr(40) == 1 .and. abs(p(1)) > epspos .and. iopsymr(41) == 1 .and. abs(p(2)) > epspos &
          .and. iopsymr(42) == 1 .and. abs(p(3)) > epspos ) then
              p(1:3) = - p(1:3)
            else
              cycle
            endif
        end select
      endif

      if( Sym_2D .and. sum( V_surf(1:3) * p(1:3) ) > z_max ) cycle ! One eliminates the points beyond the surface layer
      if( Moy_loc ) then
        ps(:) = p(:) - pos(:,iaabs)
        dist = sqrt( sum( ps(:)**2 ) )
      else
        ps(:) = p(:)
        dist = sqrt( sum( ps(:)**2 ) )
        if( dist > R_centre ) cycle
      endif
      if( dist > rvmmax ) cycle
      dist_min = 10000000._db
      do ia = 1,natomp
        ps(:) = pos(:,ia) - p(:)
        dist = sqrt( sum( ps(:)**2 ) )
        if( dist < ray(ia) - eps6  ) cycle boucle_is
        dist_min = min( dist_min, dist )
      end do

      R_min_ion = 0.5_db / bohr
      do ia = 1,natomp_ion
        ps(:) = Pos_ion(:,ia) - p(:)
        dist = sqrt( sum( ps(:)**2 ) )
        if( dist < R_min_ion  ) cycle boucle_is
        dist_min = min( dist_min, dist )
      end do

      if( dist_min > D_max ) cycle
      ib = ib + 1
      imoy(ib) = i
      pdmoy = pdmoy + rvol(i)
    end do boucle_is
  end do
  nptmoy = ib

  do i = 1,nptmoy
    poidsov(i) = rvol(imoy(i))
  end do

  if( .not. ( nptmoy == 0 .or. ( nptmoy_out == 0 .and. .not. Green ) ) ) exit

! One starts again at the begining of the routine
    ray(:) = 0.9_db * ray(:)

  end do

  if( icheck > 3 ) then
    write(3,110) nptmoy, pdmoy
    write(3,120) (imoy(ib), xyz(1:4,imoy(ib))*bohr, poidsov(ib), ib = 1,nptmoy)
    if( .not. Green ) then
      write(3,130)
      write(3,110) nptmoy_out, pdmoy_out
      write(3,120) (imoy_out(ib), xyz(1:4,imoy_out(ib))*bohr, poidsov_out(ib), ib = 1,nptmoy_out)
    endif
  endif
  poidsov(1:nptmoy) = poidsov(1:nptmoy) / pdmoy
  if( .not. Green ) then
   poidsov_out(1:nptmoy_out) = poidsov_out(1:nptmoy_out) / pdmoy_out
  end if

  return
  110 format(/' nptmoy =',i6,'  pdmoy =',f13.5,/ &
              '  imoy       x         y        z         r      poidsov')
  120 format(i6,5f10.5)
  130 format(/' For the outer sphere :')
end

!***********************************************************************

! Calculation of the average potential in the interstitial area

subroutine Cal_Vmoy(Cal_xanes,i_range,i_self,icheck,imoy,imoy_out,korigimp,Magnetic,mpirank,npoint,nptmoy,nptmoy_out,nspin, &
            poidsov,poidsov_out,rs,rsbdc,rsbdc_out,SCF,V0bdcFimp,Vh,Vhbdc,Vhbdc_out,VmoyF,VmoyF_out,Vr,VxcbdcF,VxcbdcF_out)

  use declarations
  implicit none

  integer:: i_self,icheck, ipr, mpirank, npoint, nptmoy, nptmoy_out, ispin, nspin, i_range

  integer, dimension(npoint):: imoy, imoy_out

  logical:: Cal_xanes, korigimp, Magnetic, SCF

  real(kind=db):: rsbdc, rsbdc_out, Vhbdc, Vhbdc_out

  real(kind=db), dimension(nspin):: VmoyF, VmoyF_out, V0bdcFimp, VxcbdcF, VxcbdcF_out
  real(kind=db), dimension(npoint):: poidsov, poidsov_out, rs, Vh
  real(kind=db), dimension(npoint,nspin):: Vr

! Calculation of the average potential
  if( nptmoy > 0 ) then
    do ispin = 1,nspin
      VmoyF(ispin) = sum( Vr(imoy(1:nptmoy),ispin) * poidsov(1:nptmoy) )
    end do

    if( Magnetic ) then
      VmoyF(1) = 0.5_db * ( vmoyF(1) + vmoyF(nspin) )
      VmoyF(nspin) = vmoyF(1)
    endif

    Vhbdc = sum( Vh(imoy(1:nptmoy)) * poidsov(1:nptmoy) )

    VxcbdcF(:) = VmoyF(:) - Vhbdc

! The average is not performed in side the radius Rs, but on EF = ckf / rs**2, ckf constent.
    rsbdc = sum( (1/rs(imoy(1:nptmoy))**2) * poidsov(1:nptmoy) )
    rsbdc = 1 / sqrt( rsbdc )

    if( i_self == 1 .or. .not. SCF ) then
      do ipr = 3,6,3
        if( ipr == 6 .and. i_range /= 1 ) cycle
        if( icheck == 0 .and. ipr == 3 ) cycle
        if( .not. Cal_xanes .and. ipr == 6 ) cycle
        if( korigimp ) then
          write(ipr,130) V0bdcFimp(1) * rydb, Vhbdc * rydb, rsbdc
        else
          write(ipr,130) VmoyF(1) * rydb, Vhbdc * rydb, rsbdc
        endif
      end do
    endif

  endif

  if( nptmoy_out > 0 ) then
    do ispin = 1,nspin
      VmoyF_out(ispin) = sum( Vr(imoy_out(1:nptmoy_out),ispin) * poidsov_out(1:nptmoy_out) )
    end do

    if( Magnetic ) then
      VmoyF_out(1) = 0.5_db * ( vmoyF_out(1) + vmoyF_out(nspin) )
      VmoyF_out(nspin) = vmoyF_out(1)
    endif

    Vhbdc_out = sum( Vh(imoy_out(1:nptmoy_out)) * poidsov_out(1:nptmoy_out) )

    VxcbdcF_out(:) = VmoyF_out(:) - Vhbdc_out

! The average is not performed in side the radius Rs, but on EF = ckf / rs**2, ckf constent.
    rsbdc_out = sum( (1/rs(imoy_out(1:nptmoy_out))**2) * poidsov_out(1:nptmoy_out) )
    rsbdc_out = 1 / sqrt( rsbdc_out )

    if( i_self == 1 .or. .not. SCF ) then
      do ipr = 3,6,3
        if( ipr == 6 .and. ( mpirank /= 0 .or. i_range /= 1 ) ) cycle
        if( icheck == 0 .and. ipr == 3 ) cycle
        if( .not. Cal_xanes .and. ipr == 6 ) cycle
        write(ipr,150) VmoyF_out(1) * rydb,  Vhbdc_out * rydb, rsbdc_out
      end do
    endif

  endif

  return
  130 format(/'     V0bdcF =',f12.5,' eV,     Vhbdc =',f10.3,' eV,     rsbdc =',f8.3,' a.u.')
  150 format(' V0bdcF_out =',f12.5,' eV, Vhbdc_out =',f10.3,' eV, rsbdc_out =',f8.3,' a.u.')
end

!***********************************************************************

  subroutine Shift_V(Bulk_atom_done,Cal_xanes,i_range,icheck,korigimp,mpirank,n_atom_0,n_atom_ind,n_atom_proto,n_atom_proto_bulk, &
                 nlm_pot,npoint,nptmoy_out,nrm,nspin,rsbdc, &
                 rsbdc_out,V_abs_i,V0bdcFimp,Vc_abs_i,Vcato,Vh,Vhbdc,Vhbdc_init,Vhbdc_out,VmoyF,VmoyF_out,Vr)

  use declarations
  implicit none

  integer:: i_range, icheck, ipr, mpirank, n_atom_0, n_atom_ind, n_atom_proto, n_atom_proto_bulk, nlm_pot, npoint, nptmoy_out, &
            nrm, nspin

  logical:: Bulk_atom_done, Cal_xanes, korigimp

  real(kind=db):: Delta_V, rsbdc, rsbdc_out, Vhbdc, Vhbdc_init, Vhbdc_out

  real(kind=db), dimension(nspin):: V0bdcFimp, VmoyF, VmoyF_out
  real(kind=db), dimension(npoint):: Vh
  real(kind=db), dimension(nrm):: Vc_abs_i
  real(kind=db), dimension(nrm,nspin):: V_abs_i
  real(kind=db), dimension(npoint,nspin):: Vr
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato

  Delta_V = Vhbdc_init - Vhbdc

  Vhbdc = Vhbdc_init

  if( abs( Delta_V ) > eps10 ) then
    Vhbdc_out = Vhbdc_out + Delta_V
    VmoyF(:) = VmoyF(:) + Delta_V
    VmoyF_out(:) = VmoyF_out(:) + Delta_V

    Vr(:,:) = Vr(:,:) + Delta_V
    Vh(:) = Vh(:) + Delta_V
    do ipr = n_atom_0,n_atom_ind
! bulk atoms are not shifted, and we are necessarily in non Full_atom_mode in this case
      if( Bulk_atom_done .and. ipr > n_atom_proto - n_atom_proto_bulk ) exit
      Vcato(:,1,ipr) = Vcato(:,1,ipr) + Delta_V
    end do

    Vc_abs_i(:) = Vc_abs_i(:) + Delta_V
    V_abs_i(:,:) = V_abs_i(:,:) + Delta_V

    if( icheck > 0 ) write(3,110) Delta_V * rydb
  endif

  do ipr = 3,6,3
    if( ipr == 6 .and. ( mpirank /= 0 .or. i_range /= 1 ) ) cycle
    if( icheck < 1 .and. ipr == 3 ) cycle
    if( .not. Cal_xanes .and. ipr == 6 ) cycle
    if( korigimp ) then
      write(ipr,130) V0bdcFimp(1) * rydb, Vhbdc * rydb, rsbdc
    else
      write(ipr,130) VmoyF(1) * rydb, Vhbdc * rydb, rsbdc
    endif
    if( nptmoy_out > 0 ) write(ipr,150) VmoyF_out(1) * rydb,  Vhbdc_out * rydb, rsbdc_out
  end do

  return
  110 format(/' To keep the interstitial potential constant, potentials are shifted by:',f10.5,' eV')
  130 format(/'     V0bdcF =',f10.3,' eV,     Vhbdc =',f10.3,' eV,     rsbdc =',f8.3,' a.u.')
  150 format(' V0bdcF_out =',f10.3,' eV, Vhbdc_out =',f10.3,' eV, rsbdc_out =',f8.3,' a.u.')
end

!***********************************************************************

subroutine Writing_atom_carac(Cal_xanes,Full_atom,iapot,icheck,ipr1,iaprotoi,itypepr,mpirank,n_atom_0,n_atom_ind, &
        n_atom_proto,natome,nlm_pot,nrato,nrm,nspin,ntype,Numat,Rato,Rchimp,Rchrg,rhoato,Rionic_imp, &
        Rmtg,Rmtg0,Rmtsd,V_intmax,Vcato,Vxcato,i_range)

  use declarations
  implicit none

  integer:: i_range, iapr, icheck, ipr, ipr1, iprt, ir, ispin, it, mpirank, n, n_atom_0, n_atom_ind, n_atom_proto, &
            natome, nlm_pot, nr, nrm, nspin, ntype, Z

  integer, dimension(natome):: iaprotoi
  integer, dimension(0:ntype):: nrato, Numat
  integer, dimension(0:n_atom_proto):: iapot, itypepr, nrmtg

  character(len=1):: Star

  logical:: Cal_xanes, Full_atom

  real(kind=db):: f_integr3, p1, Rayion, V_intmax

  real(kind=db), dimension(:), allocatable:: r, rhr2
  real(kind=db), dimension(0:ntype):: Rchimp, Rionic_imp
  real(kind=db), dimension(0:n_atom_proto):: charge_ion, Radius_ion, Rchrg, Rmtg, Rmtg0, Rmtsd
  real(kind=db), dimension(0:n_atom_proto,nspin):: charge, VmftF
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato
  real(kind=db), dimension(0:nrm,nspin,n_atom_0:n_atom_ind):: rhoato
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind) :: Vxcato
  real(kind=db), dimension(0:nrm,0:ntype):: Rato

  do ipr = ipr1,n_atom_proto

    if( iapot(ipr) == 0 .or. Rmtg0(ipr) < eps10 ) cycle

    it = itypepr(ipr)
    Z = Numat(it)
    nr = nrato(it)

    if( abs( Rchimp(it) ) > eps10 ) then
      Rchrg(ipr) = Rchimp(it)
    else
      Rchrg(ipr) = Rmtsd(ipr)
    endif

    if( abs( Rionic_imp(it) ) > eps10 ) then
      Radius_ion(ipr) = Rionic_imp(it)
    elseif( Z > 0 ) then
      Radius_ion(ipr) = Rayion( Z ) / bohr
    else
      Radius_ion(ipr) = Rchrg(ipr)
    endif

    do ir = 2,nr-1
      if( Rato(ir,it) > Rmtg(ipr) - eps10 ) exit
    end do
    nrmtg(ipr) = ir

    charge_ion(ipr) = real( Numat(it),db)
    charge(ipr,:) = real( Numat(it),db) / nspin

    if( Full_atom ) then
      do iapr = n_atom_0,n_atom_ind
        if( ipr == iaprotoi(iapr) ) exit
      end do
      if( iapr > n_atom_ind ) cycle
    else
      iapr = ipr
    endif

    allocate( r(0:nr) )
    allocate( rhr2(0:nr) )
    r(0:nr) = Rato(0:nr,it)

    Charge_ion(ipr) = 0._db

    do ispin = 1,nspin
      rhr2(0:nr) = rhoato(0:nr,ispin,iapr) * r(0:nr)**2
      charge(ipr,ispin) = quatre_pi * f_integr3(r,rhr2,0,nr,Rchrg(ipr))
      charge(ipr,ispin) = real(Z, db) / nspin - charge(ipr,ispin)

      Charge_ion(ipr) = Charge_ion(ipr) + quatre_pi * f_integr3(r,rhr2,0,nr,Radius_ion(ipr))
    end do
    Charge_ion(ipr) = Z - Charge_ion(ipr)

! Calcul du potentiel au rayon muffintin :
    n = nrmtg(ipr)
    p1 = ( Rmtg(ipr) - r(n-1) ) / ( r(n) - r(n-1) )
    VmftF(ipr,1:nspin) = p1 * ( Vcato(n,1,iapr) + Vxcato(n,1,1:nspin,iapr) ) &
                       + ( 1 - p1 ) * ( Vcato(n-1,1,iapr) + Vxcato(n-1,1,1:nspin,iapr) )
    VmftF(ipr,:) = min( VmftF(ipr,:), V_intmax )

    deallocate( r )
    deallocate( rhr2 )

  end do

! The part below is suppressed. It was in order to have full charge in the atoms and to get neutrality in the unit cell
! It is confusing

 ! do ipr = 1,n_atom_proto
 !   if( iapot( ipr ) /= 0 .and. Rmtg0(ipr) > eps10 ) cycle
 !   All_found = .false.
 !   exit
 ! end do
 ! if( All_found ) then
 !   n_elec_tot = 0
 !   ch_ion_tot = 0._db
 !   charge_tot = 0._db
 !   do ipr = 1,n_atom_proto
 !     it = itypepr( ipr )
 !     n_elec_tot = n_elec_tot + ngreq(ipr) * Numat( it )
 !     charge_tot = charge_tot + ngreq(ipr) * sum( charge(ipr,:) )
 !     ch_ion_tot = ch_ion_tot + ngreq(ipr) * charge_ion(ipr)
 !   end do
 !   rap_ch = n_elec_tot / charge_tot
 !   rap_io = n_elec_tot / ch_ion_tot
 !   do ipr = ipr1,n_atom_proto
 !     it = itypepr( ipr )
 !     if( abs( Rchimp(it) ) < eps10 ) charge(ipr,:) = rap_ch * charge(ipr,:)
 !     charge_ion(ipr) = rap_io * charge_ion(ipr)
 !   end do
 ! endif
 ! do ipr = ipr1,n_atom_proto
 !   if( iapot(ipr) == 0 .or. Rmtg0(ipr) < eps10 ) cycle
 !   charge_ion(ipr) = Numat( itypepr(ipr) ) - charge_ion(ipr)
 ! end do

  do iprt = 3,6,3
    if( iprt == 6 .and. ( mpirank /= 0 .or. i_range /= 1 ) ) cycle
    if( icheck < 1 .and. iprt == 3 ) cycle
    if( .not. Cal_xanes .and. iprt == 6 ) cycle
    if( nspin == 1 ) then
      write(iprt,120)
    else
      write(iprt,130)
    endif
    do ipr = ipr1,n_atom_proto
      if( iapot(ipr) == 0 .or. Rmtg0(ipr) < eps10 ) cycle
      if( Full_atom ) then
        do iapr = n_atom_0,n_atom_ind
          if( ipr == iaprotoi(iapr) ) exit
        end do
        if( iapr > n_atom_ind ) cycle
      endif
      it = itypepr(ipr)
      Z = Numat( it )
      if( it > 0 ) then
        Star = ' '
      else
        Star = '*'
      endif
      write(iprt,140) ipr, Z, Star, Charge(ipr,1:nspin), Rchrg(ipr) * bohr, charge_ion(ipr),  Radius_ion(ipr) * bohr, &
                        VmftF(ipr,1:nspin) * rydb
    end do
  end do

  return
  120 format(/' ipr    Z     Atom-Charge  Atom-Radius Ionic-Charge Ionic-Radius     Vmft')
  130 format(/' ipr    Z     Atom-Ch(up)  Atom-Ch(dn)  Atom-Radius   Ionic-Ch   Ionic-Radius   Vmft(up)     Vmft(dn)')
  140 format(i4,i5,a1,7f13.3)
end

!***********************************************************************

subroutine Check_Ecmax(E_Fermi,Ecineticmax,Ecineticmax_out,Eclie,Eclie_out,Eneg,Energ_max,mpirank,nspin,V0bdcF,V0bdcF_out)

  use declarations
  implicit none

  integer:: ipr, mpirank, nspin

  logical:: Eneg

  real(kind=db):: E_Fermi, Ecineticmax, Ecineticmax_out, Eclie, Eclie_out, Energ_max
  real(kind=db), dimension(nspin):: V0bdcF, V0bdcF_out

  Ecineticmax = Energ_max + E_Fermi - min( V0bdcF(1), V0bdcF(nspin) )
  Ecineticmax_out = Energ_max + E_Fermi - min( V0bdcF_out(1), V0bdcF_out(nspin) )

! To take into account the possible decrease of Vbdc beyond Fermi, one adds 1 eV :
  Ecineticmax = Ecineticmax + 1._db / rydb

  if( .not. Eneg ) then
    Ecineticmax = max( Ecineticmax, Eclie )
    Ecineticmax_out = max( Ecineticmax_out, Eclie_out )
  endif
  if( ( Ecineticmax < eps10 .or. Ecineticmax_out < eps10 ) .and. .not. Eneg ) then
    call write_error
    do ipr = 6,9,3
      if( mpirank /= 0 .and. ipr == 3 ) cycle
      write(ipr,110) Ecineticmax * rydb, Ecineticmax_out * rydb
    end do
    close(9)
    stop
  endif

  return
  110 format(/' E_kinetic_max =',f7.3,' eV  or E_kinetic_max_out =',f7.3,' eV < 0.',/ &
              ' Start the calculation at higher energy !'///)
end

!***********************************************************************

! Calculation of potential in the excited state
! Leads to a modification of Vr

subroutine Potex(Nonsph,axyz,alfpot,dv0bdcF,Energ,Enervide,Full_atom, &
          iaabsi,iapot,iaprotoi,icheck,ie,iprabs,itypepr,Magnetic, &
          n_atom_0,n_atom_ind,n_atom_proto,n_vr_0,n_vr_ind,natome,nlm_pot,nomfich_s,Nonexc_g,npoint,npoint_ns,npsom,nptmoy, &
          nptmoy_out,nrato,nrm,nspin,ntype,Optic,Rato,rho,rhons,Rmtg,rs,rsato,rsbdc,rsbdc_out,Trace_k,Trace_p, &
          V_intmax,Vcato,Vh,Vhbdc,Vhbdc_out,Vhns,Vmft,Vr,Vxc,VxcbdcF,VxcbdcF_out,Vrato,Vxcato,V0bdc,V0bdc_out,xyz)

  use declarations
  implicit none

  integer:: i, ia, iaabsi, iapr, icheck, ie, ipr, iprabs, ir, ispin, it, Lm, n_atom_0, n_atom_ind, &
    n_atom_proto, n_vr_0, n_vr_ind, natome, nlm_pot, npoint, npoint_ns, npsom, nptmoy, nptmoy_out, nr, nrm, nspin, ntype, Trace_k

  integer, dimension(0:ntype):: nrato
  integer, dimension(natome):: iaprotoi
  integer, dimension(0:n_atom_proto):: iapot, itypepr

  character(len=Length_name):: nomfich_s

  logical:: Optic, Full_atom, magnetic, nonexc_g, Nonsph

  real(kind=db):: alfpot, Energ, Enervide, p, p1, rsbdc, rsbdc_out, V_intmax, Vhbdc, Vhbdc_out
  real(kind=db), dimension(3):: axyz
  real(kind=db), dimension(6):: Trace_p
  real(kind=db), dimension(nspin):: dV0bdcF, V0bdc, V0bdc_out, Vmftabs, VxcbdcF, VxcbdcF_out
  real(kind=db), dimension(npoint):: rs, Vh
  real(kind=db), dimension(npoint_ns):: rhons, Vhns
  real(kind=db), dimension(npoint,nspin):: rho, Vxc, Vr, Vr_td
  real(kind=db), dimension(4,npsom):: xyz
  real(kind=db), dimension(0:n_atom_proto):: Rmtg
  real(kind=db), dimension(nspin,n_vr_0:n_vr_ind):: Vmft
  real(kind=db), dimension(0:nrm,n_atom_0:n_atom_ind):: rsato
  real(kind=db), dimension(0:nrm,nlm_pot,n_atom_0:n_atom_ind):: Vcato
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_vr_0:n_vr_ind):: Vrato
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind):: Vxcato
  real(kind=db), dimension(0:nrm,0:ntype):: Rato
  real(kind=db), dimension(:), allocatable:: rst, Vct, Vrt, Vxct

  if( icheck > 1 ) then
    write(3,100)
    write(3,110) Energ * rydb
  endif

  do ispin = 1,nspin

! Calculation of atomic potential in the excited state

    do ia = n_atom_0,n_atom_ind
      if( Full_atom ) then
        ipr = iaprotoi(ia)
      else
        ipr = ia
        if( nonexc_g .and. ipr == 0 ) cycle
      endif
      if( iapot(ipr) == 0 ) cycle

      nr = nrato( itypepr(ipr) )

      if( alfpot < eps6 .and. .not. Optic ) then

        allocate( rst(nr) )
        allocate( Vct(nr) )
        allocate( Vrt(nr) )
        allocate( Vxct(nr) )

        Vct(1:nr) = Vcato(1:nr,1,ia)
        Vxct(1:nr) = Vxcato(1:nr,1,ispin,ia)
        rst(1:nr) = rsato(1:nr,ia)

        call subpotex(nr,Vrt,Vct,Vxct,rst,Enervide)

        Vrato(1:nr,1,ispin,ia) = Vrt(1:nr)

        do ir = 1,nr
          p = ( Vrt(ir) - Vcato(ir,1,ia) ) / Vxct(ir)
          Vrato(ir,2:nlm_pot,ispin,ia) = Vcato(ir,2:nlm_pot,ia) + p * Vxcato(ir,2:nlm_pot,ispin,ia)
        end do

        deallocate( rst )
        deallocate( Vct )
        deallocate( Vrt )
        deallocate( Vxct )

      else

        Vrato(1:nr,1:nlm_pot,ispin,ia) = Vcato(1:nr,1:nlm_pot,ia) + Vxcato(1:nr,1:nlm_pot,ispin,ia)

      endif

      it = itypepr(ipr)
      do ir = 1,nrato(it)
        if( Rato(ir,it) > Rmtg(ipr) ) exit
      end do
      p1 = ( Rmtg(ipr) - Rato(ir-1,it) ) / ( Rato(ir,it) - Rato(ir-1,it) )

      Vmft(ispin,ia) = p1 * Vrato(ir,1,ispin,ia) + ( 1 - p1 ) * Vrato(ir-1,1,ispin,ia)
      if( V_intmax < 1000._db ) Vmft(ispin,ia) = min( Vmft(ispin,ia), V_intmax )

    end do

    if( npoint > 0 ) then
      allocate( rst(npoint) )
      allocate( Vct(npoint) )
      allocate( Vrt(npoint) )
      allocate( Vxct(npoint) )

      Vct(1:npoint) = Vh(1:npoint)
      Vxct(1:npoint) = Vxc(1:npoint,ispin)
      rst(1:npoint) = rs(1:npoint)

      if( alfpot < eps6 .and. .not. Optic ) then
        call subpotex(npoint,Vrt,Vct,Vxct,rst,Enervide)
        Vr_td(1:npoint,ispin) = Vrt(1:npoint)
      else
        Vr_td(1:npoint,ispin) = Vct(1:npoint) + Vxct(1:npoint)
      endif

      deallocate( rst )
      deallocate( Vct )
      deallocate( Vrt )
      deallocate( Vxct )

      if( V_intmax < 1000._db ) then
        do i = 1,npoint
          Vr_td(1:npoint,ispin) = min( Vr_td(1:npoint,ispin), V_intmax )
        end do
      endif

    endif

! Pour le potentiel interstitiel, on fait l'approximation que la moyenne du potentiel excite est egale
! au potentiel fonction de la moyenne de rs (rsbdc) et VxcF (VxcbdcF).
! En fait on a pris rsbc = 1/sqrt( <1/rs**2> ), c'est donc une moyenne sur EF.
    if( nptmoy > 0 ) then
      allocate( rst(1) )
      allocate( Vct(1) )
      allocate( Vrt(1) )
      allocate( Vxct(1) )

      Vct(1) = Vhbdc
      Vxct(1) = VxcbdcF(ispin)
      rst(1) = rsbdc

      if( alfpot < eps6 .and. .not. Optic ) then
        call subpotex(1,Vrt,Vct,Vxct,rst,Enervide)
        V0bdc(ispin) = Vrt(1)
      else
        V0bdc(ispin) = Vct(1) + Vxct(1)
      endif

      deallocate( rst )
      deallocate( Vct )
      deallocate( Vrt )
      deallocate( Vxct )

      if( V_intmax < 1000._db ) V0bdc(ispin) = min( V0bdc(ispin), V_intmax )
    endif

    if( nptmoy_out > 0 ) then
      allocate( rst(1) )
      allocate( Vct(1) )
      allocate( Vrt(1) )
      allocate( Vxct(1) )

      Vct(1) = Vhbdc_out
      Vxct(1) = VxcbdcF_out(ispin)
      rst(1) = rsbdc_out

      if( alfpot < eps6 .and. .not. Optic ) then
        call subpotex(1,Vrt,Vct,Vxct,rst,Enervide)
        V0bdc_out(ispin) = Vrt(1)
      else
        V0bdc_out(ispin) = Vct(1) + Vxct(1)
      endif

      deallocate( rst )
      deallocate( Vct )
      deallocate( Vrt )
      deallocate( Vxct )

      if( V_intmax < 1000._db ) V0bdc_out(ispin) = min( V0bdc_out(ispin), V_intmax )

    else
      V0bdc_out(ispin) = V0bdc(ispin)
    endif

  end do

  V0bdc(1:nspin) = V0bdc(1:nspin) + dV0bdcF(1:nspin)

  if( Magnetic ) then
    V0bdc(1) = 0.5_db * ( V0bdc(1) + V0bdc(nspin) )
    V0bdc(nspin) = V0bdc(1)
    V0bdc_out(1) = 0.5_db * ( V0bdc_out(1) + V0bdc_out(nspin) )
    V0bdc_out(nspin) = V0bdc_out(1)
  endif

  Vr(:,:) = Vr_td(:,:)

  if( icheck > 1 ) then
    if( Full_atom ) then
      Vmftabs(:) = Vmft(:,iaabsi)
    else
      Vmftabs(:) = Vmft(:,iprabs)
    endif
    if( nspin == 1 ) then
      write(3,120) V0bdc(1) * rydb, Vmftabs(1:nspin) * rydb
    else
      write(3,125) V0bdc(1) * rydb, Vmftabs(1:nspin) * rydb
    endif
    if( nptmoy_out > 0 ) write(3,127) V0bdc_out(1) * rydb
  endif
  if( icheck > 2 ) then
    if( npoint > 0 ) then
      do ispin = 1,nspin
        write(3,130) ispin
        write(3,140) (i, Vr(i,ispin)*rydb, i = 1,npoint)
      end do
    endif
    do iapr = n_vr_0,n_vr_ind
      if( Full_atom ) then
        ipr = iaprotoi( iapr )
      else
        ipr = iapr
        if( nonexc_g .and. ipr == 0 ) cycle
        if( iapot(ipr) == 0 ) cycle
      endif
      it = itypepr(ipr)
      nr = nrato(it)
      if( nlm_pot == 1 ) then
        if( nspin == 1 ) then
          write(3,150) iapr
        else
          write(3,155) iapr
        endif
      else
        if( nspin == 1 ) then
          write(3,156) iapr
        else
          write(3,157) iapr
        endif
      endif
      do ir = 1,nr
        write(3,160) Rato(ir,it)*bohr, Vrato(ir,1,:,iapr)*rydb, Vcato(ir,1,iapr)*rydb, Vxcato(ir,1,:,iapr)*rydb, &
                                     ( Vrato(ir,Lm,:,iapr)*rydb, Lm = 2,nlm_pot )
      end do
    end do
  endif

  if( Trace_k > 0 .and. Trace_k < 4 .and. icheck > 0 .and. ie == 1 ) &
    call Trace(Nonsph,axyz,nomfich_s,npoint,npoint_ns,npsom,xyz,rhons,Trace_k,Trace_p,Vhns,nspin,Vr,rho)

  return
  100 format(/' ---- Potex --------',100('-'))
  110 format(/' Energ =',f10.5,' eV')
  120 format(/' V0bdc =',f10.5,' eV, Vmftabs =',f10.5,' eV',f10.5)
  125 format(/' V0bdc =',f10.5,' eV, Vmftabs(up) =',f10.5,' eV, Vmftabs(dn) =',f10.5,' eV')
  127 format(/' V0bdc_out =',f10.5,' eV')
  130 format(/4x,'i      Vr_(eV)     ispin = ',i2)
  140 format(5(i6,1pe13.5))
  150 format('  ipr =',i3,/7x,'rato_(A)   Vrato_(eV)   Vcato(eV)   Vxcato(eV)')
  155 format('  ipr =',i3,/7x,'rato_(A)   Vrato(up)_eV Vrato(dn)_eV    Vcato_eV Vxcato(up)_eV Vxcato(dn)_eV')
  156 format('  ipr =',i3,/7x,'rato_(A)   Vrato_(eV)   Vcato(eV)   Vxcato(eV)',7x,'Vrato(Lm>1)')
  157 format('  ipr =',i3,/7x,'rato_(A)   Vrato(up)_eV Vrato(dn)_eV    Vcato_eV Vxcato(up)_eV Vxcato(dn)_eV',7x,'Vrato(Lm>1)')
  160 format(f15.6,1p,15e13.5)
end

!***********************************************************************

! Calculation of atomic excited potential (when extracted or for RIXS)

subroutine Potex_abs(alfpot,dV0bdcF,Enervide,icheck,nlm_pot,nrato_abs,nspin,Optic,rato_abs,rsato_abs,rsbdc,V_intmax, &
                     V0bdc,Vcato,Vhbdc,Vrato,Vxcato,VxcbdcF)

  use declarations
  implicit none

  integer:: icheck,ir, isp, lm, nrato_abs, nlm_pot, nspin

  logical:: Optic

  real(kind=db):: alfpot, rsbdc, Enervide, V_intmax, Vhbdc
  real(kind=db), dimension(1):: rs, Vc, Vr, Vxc
  real(kind=db), dimension(nspin):: dV0bdcF,  V0bdc, VxcbdcF
  real(kind=db), dimension(nrato_abs):: rato_abs, rsato_abs, Vct, Vrt, Vxct
  real(kind=db), dimension(nrato_abs,nlm_pot):: Vcato
  real(kind=db), dimension(nrato_abs,nlm_pot,nspin):: Vrato, Vxcato

  if( alfpot < eps6 .and. .not. Optic )  then

    Vct(:) = Vcato(:,1)
    do isp = 1,nspin
      Vxct(:) = Vxcato(:,1,isp)
      call subpotex(nrato_abs,Vrt,Vct,Vxct,rsato_abs,Enervide)
      Vrato(:,1,isp) = Vrt(:)
      do lm = 2,nlm_pot
        Vrato(:,lm,isp) = Vcato(:,lm) + ( ( Vrt(:) - Vcato(:,1) ) / Vxct(:) ) * Vxcato(:,lm,isp)
      end do
    end do

    rs(1) = rsbdc
    Vc(1) = Vhbdc
    do isp = 1,nspin
      Vxc(1) = VxcbdcF(isp)
      call subpotex(1,Vr,Vc,Vxc,rs,Enervide)
      V0bdc(isp) = Vr(1) + dV0bdcF(isp)
    end do

  else

    do isp = 1,nspin
      do lm = 1,nlm_pot
        Vrato(:,lm,isp) = Vcato(:,lm) + Vxcato(:,lm,isp)
      end do
      V0bdc(isp) = Vhbdc + VxcbdcF(isp) + dV0bdcF(isp)
    end do

  endif

  if( V_intmax < 1000._db ) V0bdc(:) = min( V0bdc(:), V_intmax )

  if( icheck > 2 ) then
    if( nspin == 1 ) then
      write(3,'(A)') '        Radius      Vrato_abs      Vcato_abs     Vxcato_abs'
    else
      write(3,'(A)') '        Radius      Vrato_abs_up   Vrato_abs_dn   Vcato_abs     Vxcato_abs_up   Vxcato_abs_dn'
    endif
    do ir = 1,nrato_abs
      write(3,120) rato_abs(ir)*bohr, ( Vrato(ir,1,isp)*rydb, isp = 1,nspin ), Vcato(ir,1)*rydb, &
                   ( Vxcato(ir,1,isp)*rydb, isp = 1,nspin )
    end do
  endif

  return
  120 format(f15.6,1p,5e15.5)

end

!***********************************************************************

! Calculation of the potential in the excited state following Hedin, Lundqvist and Von Barth
! Lead to a modification of Vr.

subroutine subpotex(np,Vrt,Vct,Vxct,rst,Enervide)

  use declarations
  implicit none

  integer, parameter:: npkfm = 16
  integer, parameter:: nraym = 17

  real(kind=db), parameter:: fac = ( 4._db/(9._db*pi) )**(1._db/3._db)

  integer:: i, j, jj, np

  real(kind=db):: Enervide, p1, p2, pskf, Vhli, Vhlm, Vhlp

  real(kind=db), dimension(nraym,npkfm):: vhl
  real(kind=db), dimension(nraym,npkfm/2):: vhl1
  real(kind=db), dimension(nraym,npkfm/2+1:npkfm):: vhl2
  real(kind=db), dimension(npkfm):: pkf
  real(kind=db), dimension(nraym):: ray
  real(kind=db), dimension(np):: Vct, Vxct, Vrt, rst

! Table from Von Barth (Hedin et Lundqvist) normalised at the Fermi level
  data pkf/ 0.00_db, 0.20_db, 0.40_db, 0.60_db, 0.80_db, 1.00_db, 1.20_db, 1.40_db, 1.60_db, 1.80_db, &
            2.00_db, 2.20_db, 2.40_db, 2.60_db, 2.80_db, 3.00_db/

  data ray/ 0.00_db, 0.01_db, 0.02_db, 0.05_db, 0.10_db, 0.20_db, 0.30_db, 0.40_db, 0.50_db, 0.70_db, &
            1.00_db, 1.50_db, 2.00_db, 3.00_db, 4.00_db, 5.00_db, 6.00_db/

  data vhl1/ 2.0000_db,1.8564_db,1.7983_db,1.7124_db,1.5881_db,1.4398_db,1.3486_db,1.2939_db,1.2501_db,1.1624_db, &
             1.0528_db,1.0134_db,0.9716_db,0.9541_db,0.9227_db,0.9525_db,0.9545_db, &
             1.9732_db,1.8353_db,1.7687_db,1.6943_db,1.5704_db,1.4241_db,1.3333_db,1.2814_db,1.2379_db,1.1508_db, &
             1.0555_db,1.0066_db,0.9767_db,0.9595_db,0.9552_db,0.9569_db,0.9581_db, &
             1.8897_db,1.7545_db,1.7012_db,1.6225_db,1.5058_db,1.3668_db,1.2836_db,1.2371_db,1.1993_db,1.1237_db, &
             1.0528_db,1.0100_db,0.9839_db,0.9689_db,0.9666_db,0.9654_db,0.9687_db, &
             1.7395_db,1.6139_db,1.5625_db,1.4909_db,1.3851_db,1.2679_db,1.2020_db,1.1697_db,1.1427_db,1.0888_db, &
             1.0422_db,1.0134_db,0.9939_db,0.9814_db,0.9777_db,0.9785_db,0.9790_db, &
             1.4944_db,1.3774_db,1.3341_db,1.2754_db,1.2057_db,1.1376_db,1.1026_db,1.0884_db,1.0757_db,1.0504_db, &
             1.0262_db,1.0118_db,1.0000_db,0.9922_db,0.9889_db,0.9915_db,0.9896_db, &
             1.0000_db,1.0000_db,1.0000_db,1.0000_db,1.0000_db,1.0000_db,1.0000_db,1.0000_db,1.0000_db,1.0000_db, &
             1.0000_db,1.0000_db,1.0000_db,1.0000_db,1.0000_db,1.0000_db,1.0000_db, &
             0.5604_db,0.6617_db,0.7030_db,0.7904_db,0.8324_db,0.8697_db,0.8940_db,0.9207_db,0.9304_db,0.9499_db, &
             0.9762_db,0.9913_db,0.9987_db,1.0069_db,1.0055_db,1.0132_db,1.0106_db, &
             0.3856_db,0.4730_db,0.5088_db,0.5868_db,0.6645_db,0.7708_db,0.8497_db,0.8982_db,0.9142_db,0.9460_db, &
             0.9735_db,0.9948_db,1.0084_db,1.0208_db,1.0168_db,1.0261_db,1.0279_db/

  data vhl2/ 0.2852_db,0.3624_db,0.3926_db,0.4731_db,0.5294_db,0.6219_db,0.6911_db,0.7629_db,0.8086_db,0.8998_db, &
             1.0262_db,1.0236_db,1.0294_db,1.0272_db,1.0446_db,1.0478_db,1.0419_db, &
             0.2204_db,0.2876_db,0.3165_db,0.3772_db,0.4352_db,0.5172_db,0.5813_db,0.6407_db,0.6807_db,0.7607_db, &
             0.8945_db,1.0168_db,1.0516_db,1.0699_db,1.0669_db,1.0651_db,1.0595_db, &
             0.1761_db,0.2365_db,0.2628_db,0.3174_db,0.3677_db,0.4412_db,0.4986_db,0.5514_db,0.5877_db,0.6602_db, &
             0.7730_db,0.9239_db,1.0110_db,1.1157_db,1.0949_db,1.0953_db,1.0804_db, &
             0.1441_db,0.2007_db,0.2224_db,0.2694_db,0.3175_db,0.3839_db,0.4356_db,0.4835_db,0.5167_db,0.5830_db, &
             0.6675_db,0.7988_db,0.8967_db,1.0356_db,1.1340_db,1.1689_db,1.1190_db, &
             0.1200_db,0.1707_db,0.1924_db,0.2334_db,0.2794_db,0.3394_db,0.3859_db,0.4287_db,0.4582_db,0.5174_db, &
             0.6015_db,0.7230_db,0.8133_db,0.9524_db,1.0557_db,1.1343_db,1.1749_db, &
             0.1016_db,0.1466_db,0.1684_db,0.2033_db,0.2496_db,0.3031_db,0.3448_db,0.3840_db,0.4103_db,0.4629_db, &
             0.5460_db,0.6608_db,0.7438_db,0.8899_db,0.9824_db,1.0713_db,1.1073_db, &
             0.0874_db,0.1286_db,0.1492_db,0.1795_db,0.2231_db,0.2731_db,0.3121_db,0.3474_db,0.3718_db,0.4206_db, &
             0.5011_db,0.6068_db,0.6860_db,0.8269_db,0.9099_db,0.9935_db,1.0376_db, &
             0.0757_db,0.1139_db,0.1343_db,0.1614_db,0.2024_db,0.2487_db,0.2851_db,0.3172_db,0.3388_db,0.3818_db, &
             0.4643_db,0.5627_db,0.6356_db,0.7732_db,0.8373_db,0.9199_db,0.9784_db/

  do i = 1,npkfm/2
    vhl(:,i) = vhl1(:,i)
  end do
  do i = npkfm/2+1,npkfm
    vhl(:,i) = vhl2(:,i)
  end do

  Vrt(1:np) = Vct(1:np) + Vxct(1:np)

  do i = 1,np
! Outside the table pr Rs, one takes the value at the border
    if( ray(nraym) <= rst(i) ) then
      j = nraym
      rst(i) = ray(nraym)
    else
      do j = 2,nraym
        if( ray(j) > rst(i) ) exit
      end do
    endif

    if( Enervide  <=  Vrt(i) ) then
      pskf = 0._db
    else
  !    Ef = ( ( 9*pi/4 )**(1/3.)  / rs )**2
  !    pskf = sqrt( (Enervide - Vr) / Ef ) = rs * (4/(9*pi))**tiers * sqrt( (Enervide - Vr) / Ef )
      pskf = fac * rst(i) * sqrt( Enervide - Vrt(i) )
    endif

    p1 = ( ray(j) - rst(i) ) / ( ray(j) - ray(j-1) )
    p2 = 1 - p1
! Beyond the highest value of pskf in the table, one takes the VXC potential in 1/k
    if( pskf > pkf(npkfm) ) then
      Vhli = p1 * Vhl(j-1,npkfm) + p2 * Vhl(j,npkfm)
      Vhli = Vhli * pkf(npkfm) / pskf
! Below this value, interpolation in the table
    else
      do jj = 2,npkfm
        if( pkf(jj) > pskf ) exit
      end do
      jj = min( jj, npkfm )
      Vhlm = p1 * Vhl(j-1,jj-1) + p2 * Vhl(j,jj-1)
      Vhlp = p1 * Vhl(j-1,jj) + p2 * Vhl(j,jj)
      Vhli = ( (pkf(jj) - pskf) * Vhlm + (pskf - pkf(jj-1)) * Vhlp ) / ( pkf(jj) - pkf(jj-1) )
    endif
    Vrt(i) = Vct(i) + Vhli * Vxct(i)
  end do

  return
end

!***********************************************************************

! Give potential and density along planes or lines for plotting

subroutine Trace(Nonsph,axyz,nomfich_s,npoint,npoint_ns,npsom,xyz,rhons,Trace_k,Trace_p,vhns,nspin,Vr,rho)

  use declarations
  implicit none

  integer:: i, j, j_min, j1, j2, jdir, k, L, npoint, npoint_ns, npsom, nspin, ntrace, Trace_k

  integer, dimension(npoint):: itrace
  integer, dimension(:), allocatable:: jtrace

  character(len=Length_name):: File_trace, nomfich_s

  logical:: Nonsph
  logical, dimension(:), allocatable:: ok

  real(kind=db):: ctrace, fac, p, x1, x2, z_min
  real(kind=db), dimension(3):: axyz, Ptrace, v, Vectrace
  real(kind=db), dimension(6):: Trace_p
  real(kind=db), dimension(npoint_ns):: rhons, Vhns
  real(kind=db), dimension(npoint,nspin):: rho, Vr
  real(kind=db), dimension(4,npsom):: xyz

  Vectrace(1:3) = Trace_p(1:3)
  Ptrace(1:3) = Trace_p(4:6)

! Calculations of points in the FDM grids where potential and density are given
  k = 0
  if( Trace_k == 1 ) then
    do j = 1,3
      if( abs(Vectrace(j)) > eps10 ) exit
    end do
    jdir = j
    if( jdir == 1 ) then
      j1 = 2
      j2 = 3
    elseif( jdir == 2 ) then
      j1 = 1
      j2 = 3
    else
      j1 = 1
      j2 = 2
    endif
    v(1:3) = Ptrace(1:3) * axyz(1:3)
    do  i = 1,npoint
      p = ( xyz(jdir,i) - v(jdir) ) / Vectrace(jdir)
      x1 = v(j1) + p * Vectrace(j1)
      x2 = v(j2) + p * Vectrace(j2)
      if( abs(xyz(j1,i)-x1) < eps6 .and. abs(xyz(j2,i)-x2) < eps6 ) then
        k = k+1
        itrace(k) = i
      endif
    end do
  elseif( Trace_k == 2 ) then
    ctrace = Ptrace(1) / bohr
    do i = 1,npoint
      fac = sum( Vectrace(1:3) * xyz(1:3,i) )
      if( abs( fac - ctrace ) < eps6 ) then
        k = k+1
        itrace(k) = i
      endif
    end do
  elseif( Trace_k == 3 ) then
    do i = 1,npoint
      itrace(i) = i
    end do
    k = npoint
  endif
  ntrace = k

!  if( Trace_k == 1 ) then
!    write(3,110) vectrace(1:3), ptrace(1:3)
!  elseif( Trace_k == 2 ) then
!    write(3,120) vectrace(1:3), ptrace(1)
!  endif

  File_trace = nomfich_s
  L = Len_trim( File_trace )
  File_trace(L+1:L+10) = '_trace.txt'
  open(4,file = File_trace )

  if( Nonsph ) then
    if( nspin == 1 ) then
      write(4,130)
    else
      write(4,132)
    endif
  else
    if( nspin == 1 ) then
      write(4,135)
    else
      write(4,137)
    endif
  endif
  if( Trace_k == 1 ) then
    do jdir = 1,3
      if( abs( abs( Vectrace(jdir) ) - 1 ) < eps10 ) exit
    end do
    if( jdir < 4 ) then
      allocate( ok(ntrace) )
      allocate( jtrace(ntrace) )
      ok(:) = .false.
      do i = 1,ntrace
        z_min = 1000000._db
        do j = 1,ntrace
          if( ok(j) ) cycle
          if( xyz(jdir,itrace(j)) > z_min ) cycle
          j_min = j
          z_min = xyz(jdir,itrace(j))
        end do
        ok(j_min) = .true.
        jtrace(i) = itrace(j_min)
      end do
      itrace(1:ntrace) = jtrace(1:ntrace)
      deallocate( jtrace, ok )
    endif
  endif
  do j = 1,ntrace
    k = itrace(j)
    if( Nonsph ) then
      write(4,140) xyz(1:3,k)*bohr, Vr(k,:)*rydb, Vhns(k)*rydb, rho(k,:), rhons(k)
    else
      write(4,140) xyz(1:3,k)*bohr, Vr(k,:)*rydb, rho(k,:)
    endif
  end do

  Close(4)

  return
  110 format(/' Cut along the line of unitary vector =',3f7.3,/ '  and passing through  =',3f7.3)
  120 format(/'Cut along the plane : ax + by + cz = d,',/ ' with : a =',f5.2,'  b = ',f5.2,'  c = ',f5.2,'  d =',f5.2)
  130 format(3x, 'xval    yval    zval        Vr            Vhns            rho           rhons')
  132 format(3x, 'xval    yval    zval       Vr_up          Vr_dn           Vhns         rho_up         rho_dn          rhons')
  135 format(3x, 'xval    yval    zval        Vr            rho')
  137 format(3x, 'xval    yval    zval       Vr_up          Vr_dn          rho_up        rho_dn')
  140 format(3f8.4,1p,8e15.7)
end

!***********************************************************************

! Give potential and density in 3D in "cube" format for plotting

subroutine Trace_cube(Adimp,Base_hexa,iopsymr,itypep,natomeq,natomp,nomfich_s,npoint,npsom,nspin,ntype,Numat,Pos,rho,Vr,xyz)

  use declarations
  implicit none

  integer:: i, ia, is, isp, ival, ix, iy, iz, j, L, natomeq, natomp, npoint, npsom, nspin, ntype, nval

  integer, dimension(3):: nxyz
  integer, dimension(nopsm):: iopsymr
  integer, dimension(natomp):: itypep
  integer, dimension(0:ntype):: Numat

  character(len=Length_name):: File_trace, nomfich_s

  logical:: Base_hexa, Bug_chem

  real(kind=db):: Adimp, Charge, dr3, Pseudo_bohr, R_max, r3, x, y

  real(kind=db), dimension(3):: xyz_origin
  real(kind=db), dimension(3,3):: V_dir
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(npoint,nspin):: rho, Vr
  real(kind=db), dimension(4,npsom):: xyz

  real(kind=db), dimension(:,:,:,:), allocatable:: Val

  Bug_chem = .true.
  if( Bug_chem ) then
    Pseudo_bohr = 1._db
  else
    Pseudo_bohr = bohr
  endif

  r3 = 1 / sqrt(3._db)
  dr3 = 2 * r3

  R_max = xyz(4,npoint) + eps10

  if( Base_hexa ) then
    nxyz(1:2) = nint( dr3 * R_max / adimp )
    nxyz(3) = nint( R_max / adimp )
  else
    nxyz(:) = nint( R_max / adimp )
  endif

  xyz_origin(:) = - nxyz(:) * adimp

  nval = 2 * nspin

  allocate( Val(nval,-nxyz(1):nxyz(1),-nxyz(2):nxyz(2),-nxyz(3):nxyz(3)) )

  V_dir(:,:) = 0._db
  if( Base_hexa ) then
    V_dir(1,1) = adimp
    V_dir(1,2) = -0.5 * adimp; V_dir(2,2) = 0.5 * sqrt(3._db) * adimp
    V_dir(3,3) = adimp
  else
    do j = 1,3
      V_dir(j,j) = adimp
    end do
  endif

! In the outer sphere part, one sets the values of the bordest point
  do isp = 1,nspin
    Val(isp,:,:,:) = rho(npoint,isp)
    Val(nspin+isp,:,:,:) = Vr(npoint,isp) * Rydb
  end do

  do i = 1,npoint
    if( Base_hexa ) then
      x = xyz(1,i) + r3 * xyz(2,i)
      y = dr3 * xyz(2,i)
      ix = nint( x / adimp )
      iy = nint( y / adimp )
    else
      ix = nint( xyz(1,i) / adimp )
      iy = nint( xyz(2,i) / adimp )
    endif
    iz = nint( xyz(3,i) / adimp )
    Val(1:nspin,ix,iy,iz) = rho(i,1:nspin)
    Val(nspin+1:nval,ix,iy,iz) = Vr(i,1:nspin) * Rydb
    do is = 2,nopsm
      if( abs( iopsymr(is) ) == 0 ) cycle
      select case(is)
        case(18)
          Val(:,-iy,ix,iz) = Val(:,ix,iy,iz)
        case(21)
          Val(:,iy,-ix,iz) = Val(:,ix,iy,iz)
        case(22)
          Val(:,ix,-iy,-iz) = Val(:,ix,iy,iz)
        case(23)
          Val(:,-ix,iy,-iz) = Val(:,ix,iy,iz)
        case(24)
          Val(:,-ix,-iy,iz) = Val(:,ix,iy,iz)
        case(25)
          Val(:,-ix,-iy,-iz) = Val(:,ix,iy,iz)
        case(28)
          Val(:,-iy,ix,-iz) = Val(:,ix,iy,iz)
        case(31)
          Val(:,iy,-ix,-iz) = Val(:,ix,iy,iz)
        case(40)
          Val(:,-ix,iy,iz) = Val(:,ix,iy,iz)
        case(41)
          Val(:,ix,-iy,iz) = Val(:,ix,iy,iz)
        case(42)
          Val(:,ix,iy,-iz) = Val(:,ix,iy,iz)
        case(45)
          Val(:,iy,ix,-iz) = Val(:,ix,iy,iz)
        case(48)
          Val(:,-iy,-ix,-iz) = Val(:,ix,iy,iz)
        case(49) ! C3_z
          Val(:,-iy,ix-iy,iz) = Val(:,ix,iy,iz)
        case(50) ! -C3_z
          Val(:,iy-ix,-ix,iz) = Val(:,ix,iy,iz)
        case(51) ! C6_z
          Val(:,ix-iy,ix,iz) = Val(:,ix,iy,iz)
        case(52) ! -C6_z
          Val(:,iy,-ix+iy,iz) = Val(:,ix,iy,iz)
        case(53) ! S3
          Val(:,-iy,ix-iy,-iz) = Val(:,ix,iy,iz)
        case(54) ! S3
          Val(:,iy-ix,-ix,-iz) = Val(:,ix,iy,iz)
        case(55) ! S6_z
          Val(:,ix-iy,ix,-iz) = Val(:,ix,iy,iz)
        case(56) ! -S6_z
          Val(:,iy,-ix+iy,-iz) = Val(:,ix,iy,iz)
      end select
    end do
  end do

! Writing

  do ival = 1,nval

    File_trace = nomfich_s
    L = Len_trim( File_trace )
    if( ival == 1 .and. nspin == 1 ) then
      File_trace(L+1:L+9) = '_den.cube'
      open(4,file = File_trace )
      write(4,'(A)') ' DENSITY (bohr-3): file created by FDMNES'
    elseif( ival == 1 ) then
      File_trace(L+1:L+12) = '_den_up.cube'
      open(4,file = File_trace )
      write(4,'(A)') ' DENSITY up (bohr-3): file created by FDMNES'
    elseif( ival == 2 .and. nspin == 1 ) then
      File_trace(L+1:L+9) = '_pot.cube'
      open(4,file = File_trace )
      write(4,'(A)') ' POTENTIAL (eV): file created by FDMNES'
   elseif( ival == 2 ) then
      File_trace(L+1:L+12) = '_den_dn.cube'
      open(4,file = File_trace )
      write(4,'(A)') ' DENSITY dn (bohr-3): file created by FDMNES'
    elseif( ival == 3 ) then
      File_trace(L+1:L+12) = '_pot_up.cube'
      open(4,file = File_trace )
      write(4,'(A)') ' POTENTIAL up (eV): file created by FDMNES'
    else
      File_trace(L+1:L+12) = '_pot_dn.cube'
      open(4,file = File_trace )
      write(4,'(A)') ' POTENTIAL dn (eV): file created by FDMNES'
    endif

    write(4,*)
    write(4,'(i6,3f12.6,i6)') natomeq, xyz_origin(:) * Pseudo_bohr
    do j = 1,3
      write(4,'(i6,3f12.6)') 2*nxyz(j)+1, V_dir(:,j) * Pseudo_bohr
    end do

    Charge = 0._db
    ! Atom positions are in bohr...
    do ia = 1,natomeq
      write(4,'(i6,4f12.6)') Numat( itypep(ia) ), Charge, Pos(1:3,ia) * Pseudo_bohr
    end do

    do ix = -nxyz(1),nxyz(1)
      do iy = -nxyz(2),nxyz(2)
        write(4,'(6e13.5)') ( Val(ival,ix,iy,iz), iz = -nxyz(3),nxyz(3) )
      end do
    end do

  Close(4)

  end do

  deallocate( Val )

  return
end

!***********************************************************************

! FDM potential made muffin-tin. Useful only for tests

subroutine mdfmuf(Nonsph,Axe_atom_gr,axyz,Full_atom,iaabs,iaproto,iaprotoi,icheck, &
              igreq,igroup,ispin,itypep,n_atom_0,n_atom_ind,n_atom_proto,natome,natomp,neqm,ngroup_m,nlm_pot,nomfich_s, &
              npoint,npoint_ns,npsom,nrato,nrm,nspin,ntype,pos,Rato,rho,rhons,Rmtg,Trace_k,Trace_p,Vhns,Vm,Vr,Vrato,xyz)

  use declarations
  implicit none

  integer:: i, ia, iaabs, iapr, icheck, iga, igr, ipr, ir, isp, ispin, it, itm, kgr, L, n_atom_0, n_atom_ind, n_atom_proto, &
    natome, natomp, neqm, ngroup_m, nlm_pot, npoint, npoint_ns, npsom, nrm, nspin, ntype, Trace_k

  integer, dimension(natome):: iaprotoi
  integer, dimension(natomp):: iaproto, igroup, itypep
  integer, dimension(0:ntype):: nrato
  integer, dimension(0:n_atom_proto,neqm):: igreq

  character(len=Length_name):: File_name, nomfich_s

  logical:: Full_atom, Nonsph

  real(kind=db):: cosang, p1, r, Vm

  real(kind=db), dimension(3):: axyz, v
  real(kind=db), dimension(6):: Trace_p
  real(kind=db), dimension(3,natomp):: pos
  real(kind=db), dimension(3,ngroup_m):: Axe_atom_gr
  real(kind=db), dimension(npoint_ns):: rhons, vhns
  real(kind=db), dimension(npoint,nspin):: rho, Vr
  real(kind=db), dimension(4,npsom):: xyz
  real(kind=db), dimension(0:n_atom_proto) :: Rmtg
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind) :: Vrato
  real(kind=db), dimension(0:nrm,0:ntype):: Rato

  boucle_i: do i = 1,npoint
    do ia = 1,natomp

      if( nspin == 2 ) then
        igr = igroup(ia)
        iga = igroup(iaabs)
        kgr = igreq(ipr,1)

        cosang = sum( Axe_atom_gr(:,kgr) * Axe_atom_gr(:,igr) )
        cosang = cosang * abs( sum( Axe_atom_gr(:,iga) * Axe_atom_gr(:,igr) ) )
        if( abs(cosang - 1) < eps4 ) then
          itm = 1
          isp = ispin
        elseif( abs(cosang + 1) < eps4 ) then
          itm = - 1
          isp = 3 - ispin
        else
          itm = 0
        endif
      else
        itm = 1
        isp = ispin
      endif

      it = itypep(ia)
      ipr = iaproto(ia)
      v(1:3) = xyz(1:3,i) - pos(1:3,ia)
      r = sqrt( sum( v(:)**2 ) )
      if( r < Rmtg(ipr) ) then
        if( Full_atom ) then
          do iapr = 1,natome
            if( iaprotoi(iapr) == ipr ) exit
          end do
          if( iapr > natome ) cycle boucle_i
        else
          iapr = ipr
        endif
        do ir = 1,nrato(it)
          if( Rato(ir,it) > r ) exit
        end do
        p1 = ( r - Rato(ir-1,it) ) / ( Rato(ir,it) - Rato(ir-1,it) )
        if( itm == 0 ) then
          Vr(i,ispin) = 0.5_db * ( ( 1 - p1 ) * sum( Vrato(ir-1,1,:,iapr) ) + p1 * sum( Vrato(ir,1,:,iapr) ) )
        else
          Vr(i,ispin) = ( 1 - p1 ) * Vrato(ir-1,1,isp,iapr) + p1 * Vrato(ir,1,isp,iapr)
        endif
        cycle boucle_i
      endif
    end do

    Vr(i,ispin) = Vm

  end do boucle_i

  if( icheck > 1 ) then
    write(3,130)
    write(3,140) ( i, Vr(i,ispin)*rydb, i = 1,npoint )
  endif

  if( Trace_k > 0 .and. Trace_k < 4 .and. icheck > 0 .and. ispin == nspin ) then
    File_name = nomfich_s
    L = Len_trim( File_name )
    File_name(L+1:L+3) = '_MT'
    call Trace(Nonsph,axyz,File_name,npoint,npoint_ns,npsom,xyz,rhons,Trace_k,Trace_p,Vhns,nspin,Vr,rho)
  endif

  return
  130 format(/4x,'i      Vr (eV)  after muffin-tin')
  140 format(5(i6,1pe13.5))
end

!***********************************************************************

! Potential modification to make it muffin-tin, even in FDM (for testing).

subroutine modmuf(Full_atom,iaprotoi,itypepr,icheck,ispin,n_atom_0,n_atom_ind,n_atom_proto,natome,nlm_pot, &
            nrato,nrm,nspin,ntype,Rato,Rmtg,Vm,Vrato)

  use declarations
  implicit none

  integer:: iapr, icheck, ipr, ir, ispin, it, n_atom_0, n_atom_ind, n_atom_proto, natome, nlm_pot, nrm, nspin, ntype

  integer, dimension(natome):: iaprotoi
  integer, dimension(0:ntype):: nrato
  integer, dimension(0:n_atom_proto):: itypepr

  logical:: Full_atom

  real(kind=db):: p1, p2, rm, Vm
  real(kind=db), dimension(0:n_atom_proto):: Rmtg
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind) :: Vrato
  real(kind=db), dimension(0:nrm,0:ntype):: Rato

  do iapr = n_atom_0,n_atom_ind
    if( Full_atom ) then
      ipr = iaprotoi(iapr)
    else
      ipr = iapr
    endif
    it = itypepr(ipr)
    rm = 0.9_db * Rmtg(ipr)
    do ir = 1,nrato(it)
      if( Rato(ir,it) < rm ) cycle
      if( Rato(ir,it) > Rmtg(ipr) ) then
        Vrato(ir,1,ispin,iapr) = Vm
        Vrato(ir,2:nlm_pot,ispin,iapr) = 0._db
      else
        p2 = ( Rato(ir,it) - rm ) / ( Rmtg(ipr) - rm )
        p1 = 1 - p2
        Vrato(ir,1,ispin,iapr) = p1 * Vrato(ir,1,ispin,iapr) + p2*Vm
      endif
    end do
  end do

  if( icheck > 1 ) then
    write(3,110)
    do iapr = n_atom_0,n_atom_ind
      if( Full_atom ) then
        ipr = iaprotoi(iapr)
      else
        ipr = iapr
      endif
      it = itypepr(ipr)
      write(3,120) iapr, ispin
      do ir = 1,nrato(it)
        write(3,130) Rato(ir,it)*bohr, Vrato(ir,1,ispin,iapr)*rydb
      end do
    end do
  endif

  return
  110 format(/' ---- Modmuf -------',100('-'))
  120 format('     Rato (A)    Vrato (eV)    iapr =',i3,', ispin =',i2)
  130 format(f15.6,1p,e11.3)
end

!***********************************************************************

subroutine gradpot(Base_hexa,cgrad,gradvr,icheck,iord,ispin,ivois,nicm,npoint,npsom,nspin,nvois,Vr)

  use declarations
  implicit none

  integer:: i, icheck, io, iord, is, ispin, iv, iw, j, k, nicm, npoint, npsom, nspin, nvois

  integer, dimension(npsom,nvois):: ivois

  logical Base_hexa

  real(kind=db):: fac
  real(kind=db), dimension(nvois):: cgrad
  real(kind=db), dimension(npoint,nspin):: Vr
  real(kind=db), dimension(nicm,3,nspin):: gradvr

  gradvr(:,:,ispin) = 0._db

  iv = 0
  do io = 1,iord / 2
    do k = 1,3
      do is = 1,2
        iv = iv + 1
        do i = 1,npoint
          j = ivois(i,iv)
          if( j == 0 .or. j > npoint ) j = i

! Pour le calcul du gradient, on neglige la rotation eventuelle de l'axe
! de spin (y compris quand elle est due a une symetrie).
          gradvr(i,k,ispin) = gradvr(i,k,ispin) + cgrad(iv) * Vr(j,ispin)

          if( Base_hexa .and. k == 2 ) then
            iw = iv + 4
            j = ivois(i,iw)
            if( j == 0 .or. j > npoint ) j = i
            gradvr(i,k,ispin) = gradvr(i,k,ispin) + cgrad(iw) * Vr(j,ispin)
          endif

        end do
      end do
    end do
  end do

  if( icheck > 2 ) then
    write(3,130)
    fac = rydb / bohr
    write(3,140) (i, gradvr(i,1:3,ispin)*fac, i = 1,npoint)
  endif

  return
  130 format(/4x,'i     dvr/dx       dvr/dy       dvr/dz   (eV/Angstroem)')
  140 format(i6,1p,3e13.5)
end

!***********************************************************************

subroutine Potential_writing(Delta_Eseuil,dV0bdcf,E_cut,E_Fermi,Ecineticmax,Epsii, &
                             Epsii_moy,Hubb_abs,Hubb_diag_abs,Lmax_abs,m_hubb,ninitr,nlm_pot,nrato_abs,nspin,nspinp, &
                             rato_abs,rhoato_abs,Rmtg_abs,Rmtsd_abs,rsato_abs,rsbdc,V_hubb_abs,V0muf,Vcato_abs,Vhbdc,Vxcato_abs, &
                             VxcbdcF)

  use declarations
  implicit none

  integer:: i, ir, isp, jsp, Lm, Lmax_abs, m, m_hubb, ninitr, nlm_pot, nrato_abs, nspin, nspinp

  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb_abs

  logical:: Hubb_abs, Hubb_diag_abs

  real(kind=db):: Delta_Eseuil, E_cut, E_Fermi, Ecineticmax, Epsii_moy, Rmtg_abs, Rmtsd_abs, rsbdc, V0muf, Vhbdc
  real(kind=db), dimension(nspin):: dV0bdcf, VxcbdcF
  real(kind=db), dimension(ninitr):: Epsii
  real(kind=db), dimension(nrato_abs):: rato_abs, rsato_abs
  real(kind=db), dimension(nrato_abs,nspin):: rhoato_abs
  real(kind=db), dimension(nrato_abs,nlm_pot):: Vcato_abs
  real(kind=db), dimension(nrato_abs,nlm_pot,nspin):: Vxcato_abs

  write(3,110)
  write(3,'(/A)') '   nspin nspinp nrato_abs nlm_pot m_hubb lmax_abs ninitr'
  write(3,'(2i7,i9,4i7)') nspin, nspinp, nrato_abs, nlm_pot, m_hubb, lmax_abs, ninitr

  if( nspin == 2 ) then
    write(3,120)
  else
    write(3,130)
  endif
  write(3,'(1p,10e19.11)') E_cut*Rydb, E_Fermi*Rydb, V0muf*Rydb, Vhbdc*Rydb, VxcbdcF(:)*Rydb, dV0bdcf(:)*Rydb, rsbdc, &
                         Ecineticmax*Rydb

  write(3,'(/A)') '  Hubb_abs  Hubb_abs_diag'
  write(3,*) Hubb_abs, Hubb_diag_abs
  if( Hubb_abs ) then
    write(3,'(/A)') '  V_Hubb_abs'
    do isp = 1,nspinp
      do jsp = 1,nspinp
        do m = -m_hubb,m_hubb
        ! it is the transpose but also in the reading !
          write(3,'(1p,28e19.11)') V_hubb_abs(-m_hubb:m_hubb,isp,m,jsp) * Rydb
        end do
      end do
    end do
  endif

  write(3,'(/A)') '       Rmtg_abs          Rmtsd_abs'
  write(3,'(1p,5e19.11)') Rmtg_abs*bohr, Rmtsd_abs*bohr

  write(3,140) ( 'Epsii_', i, i = 1,min(ninitr,9) ), ( 'Epsii_', i, i = 10,ninitr )
  write(3,'(1p,8e19.11)') Epsii_moy*Rydb, Delta_Eseuil*Rydb, Epsii(:)*Rydb

  if( nlm_pot == 1 ) then
    if( nspin == 2 ) then
      write(3,'(/7x,A)') &
        'Radius             Vcato            Vxcato_up          Vxcato_dn            rhoato_up          rhoato_dn            Rsato'
    else
      write(3,'(/A)') '       Radius             Vcato              Vxcato              rhoato             Rsato'
    endif
  elseif( nlm_pot == 4 ) then
    if( nspin == 2 ) then
      write(3,150) ( ( Lm, Lm = 1,nlm_pot ), i = 1,1+nspin )
    else
      write(3,160) ( ( Lm, Lm = 1,nlm_pot ), i = 1,1+nspin )
    endif
  elseif( nlm_pot == 9 ) then
    if( nspin == 2 ) then
      write(3,170) ( ( Lm, Lm = 1,nlm_pot ), i = 1,1+nspin )
    else
      write(3,180) ( ( Lm, Lm = 1,nlm_pot ), i = 1,1+nspin )
    endif
  else
    if( nspin == 2 ) then
      write(3,190) ( ( Lm, Lm = 1,min(16,nlm_pot) ), i = 1,1+nspin )
    else
      write(3,200) ( ( Lm, Lm = 1,min(16,nlm_pot) ), i = 1,1+nspin )
    endif
  endif

  do ir = 1,nrato_abs
    write(3,'(1p,500e19.11)') rato_abs(ir)*bohr, Vcato_abs(ir,:)*Rydb, Vxcato_abs(ir,:,:)*Rydb, rhoato_abs(ir,:), &
                              rsato_abs(ir)
  end do

  return
  110 format(/' ---- Potential data --',100('-'))
  120 format(/'        E_cut             E_Fermi            V0muf              Vhbdc            VxbdcF_up          VxcbdcF_dn', &
              '         dV0bdcF_up         dV0bdcF_dn            rsbdc          E_kin_max')
  130 format(/'        E_cut             E_Fermi            V0muf              Vhbdc             VxcbdcF             dV0bdcF', &
              '             rsbdc           E_kin_max')
  140 format(/6x,'Epsii_moy',9x,'Delta_Eseuil',3x,9(6x,a6,i1,6x),20(5x,a6,i2,6x))
  150 format(/7x,'Radius',4(11x,'Vcato(',i1,')'),1x,4(7x,'Vxcato_up(',i1,')'),4(7x,'Vxcato_dn(',i1,')'),10x,'rhoato_up', &
              10x,'rhoato_dn',13x,'Rsato')
  160 format(/7x,'Radius',4(11x,'Vcato(',i1,')'),1x,4(10x,'Vxcato(',i1,')'),13x,'rhoato',13x,'Rsato')
  170 format(/7x,'Radius',9(11x,'Vcato(',i1,')'),1x,9(7x,'Vxcato_up(',i1,')'),9(7x,'Vxcato_dn(',i1,')'),10x,'rhoato_up', &
                10x,'rhoato_dn',11x,'Rsato')
  180 format(/7x,'Radius',9(11x,'Vcato(',i1,')'),1x,9(10x,'Vxcato(',i1,')'),13x,'rhoato',13x,'Rsato')
  190 format(/7x,'Radius',16(11x,'Vcato(',i1,')'),1x,16(7x,'Vxcato_up(',i1,')'),16(7x,'Vxcato_dn(',i1,')'), &
                10x,'rhoato_up',10x,'rhoato_dn',11x,'Rsato')
  200 format(/7x,'Radius',16(11x,'Vcato(',i1,')'),1x,16(10x,'Vxcato(',i1,')'),13x,'rhoato',13x,'Rsato')
end

