! Subroutine of the FDMNES Package
! Contain the main of the FDM-MST part of the calculation

subroutine fdm(Analyzer,Ang_borm,Bormann,Check_extract,Check_mpi,Circular,Comt,Convolution_cal,Delta_edge,E_cut_imp, &
        E_cut_man,Ecent,Elarg,Epsii_ref,Epsii_ref_man,Estart,Fit_cal, &
        Gamma_hole,Gamma_hole_man,Gamma_max,Gamma_tddft,Header,hkl_borm,icheck,ifile_notskip,indice_par,iscratch, &
        itape1,itape4,Length_line,mpinodes0,mpirank0,n_atom_proto_p,n_shift_core,nb_test,ngamh,ngroup_par,nnotskip,nnotskipm, &
        nomfich,nomfichbav,npar,nparm,Only_rixs,param,Scan_a,Shift_core,typepar,Use_FDMX,FDMX_only, &
        fdmnes_inp,cm2g,nobg,nohole,nodw,noimfp,imfp_inp,imfp_infile,elf_inp,elf_infile,dwfactor_inp,dwfactor,tdebye_inp, &
        tdebye,Test_case,tmeas_inp,tmeas,expntl,expntlA,expntlB,victoreen,victA,victB,mermrank)

  use declarations
  implicit none
  include 'mpif.h'

  integer, parameter:: n_rout = 22
  integer, parameter:: nslapw_max = 48  ! Max number of symmetry matrix for the FLAPW data

  integer:: i, igr, igr_dop, iord, ipr, ipr_dop, ir, is, iscratch, istat, it, itape1, itape4, itph, itpm, itps, &
    itype_dop, j, jgr, l, lecrantage, Length_line, Lin_gam, Lmax_DOSout, Lmax_nrixs, Lmax_pot, &
    Lmax_tddft_inp, Lmaxat0, Lmaxso_max, Lmaxso0, m_hubb_e, mermrank, mpierr, mpinodes, mpinodes0, mpirank, mpirank0, &
    multi_run, multi_run_e, multrmax, n, n_abs_rgh, n_atom_bulk, n_atom_cap, n_atom_coop, n_atom_int, n_atom_neq, n_atom_per, &
    n_atom_per_neq, n_atom_proto, n_atom_proto_bulk, n_atom_proto_int, n_atom_proto_p, n_atom_proto_uc, n_atom_sur, n_atom_uc, &
    n_counter_ato, &
    n_counter_dip, n_counter_ion, n_devide, n_file_dafs_exp, n_layer_abs, n_mat_polar, n_multi_run, n_multi_run_e, &
    natomsym_max, n_adimp, n_bulk_sup, n_proto_layer_max, n_q_rixs, n_radius, n_range, n_shift_core, n_temp, n_theta_in, &
    n_theta_rixs, n_trans, n_two_theta, n_Z_abs, nb_atom_conf_m, nb_test, nbseuil, ncolm, necrantage, neimagent, nenerg_in_rixs, &
    nenerg_s, neqm, ngamh, ngamme, ngroup, ngroup_hubb, ngroup_lapw, ngroup_m, ngroup_nonsph, ngroup_par, ngroup_pdb, &
    ngroup_taux, nhybm, nklapw, nlatm, nlm_pot, nlmlapwm, nmatsym, nnotskip, nnotskipm, norbdil, normrmt, &
    nparm, nphim, npldafs, npldafs_2d, npldafs_e, npldafs_f, nple, nplrm, nq_nrixs, nrato_dirac, nrm, nself, nself_bulk, &
    nslapwm, nspin, nspino, nspinp, ntype, ntype_bulk, ntype_conf, ntype_mod, Trace_k, Wien_save, Z_nospinorbite

  integer, dimension(3):: hkl_borm, hkl_ref
  integer, dimension(4):: P_Emis, P_seuil
  integer, dimension(8):: n_atom
  integer, dimension(12):: Tensor_imp
  integer, dimension(30):: icheck
  integer, dimension(ngroup_par):: npar
  integer, dimension(nnotskipm):: ifile_notskip
  integer, dimension(ngroup_par,nparm):: indice_par

  integer, dimension(:), allocatable:: iabsm, iabsorig, icom, icom_temp, igr_coop, igr_i, igr_is, igr_proto, itdil, itequ, &
     its_lapw, itype, Kgroup, ldil, n_bulk_sup_c, natomeq_s, ngreq, ngreqm, nlat, nlat_temp, norbv, nphi_dafs, npl_2d, &
     nrato, nrato_temp, nrato_lapw, nrato_lapw_temp, Numat, numat_temp, numat_abs, Z_bulk, Z_cap

  integer, dimension(:), allocatable:: n_proto_layer
  integer, dimension(:,:), allocatable:: igr_layer, igreq, isigpi, isymqa, lvval, lvval_temp, nvval, nvval_temp, Operation_mode
  integer, dimension(:,:,:), allocatable:: Wien_matsym

  character(len=3):: Emission
  character(len=8):: PointGroup
  character(len=9):: keyword
  character(len=132):: comt, identmot, imfp_infile, elf_infile, fdmnes_inp132, mot, nomfich132
  character(len=Length_name):: nomfich, nom_fich_extract, nomfichbav, fdmnes_inp

  character(len=6), dimension(n_rout):: Name_rout
  character(len=9), dimension(ngroup_par,nparm):: typepar
  character(len=Length_name), dimension(9):: Wien_file

  character(len=35), dimension(:), allocatable:: Com, Com_temp
  character(len=Length_name), dimension(:), allocatable:: nomfich_cal_conv, nomfich_cal_tddft_conv

  complex(kind=db), dimension(:,:), allocatable:: poldafsem, poldafssm
  complex(kind=db), dimension(:,:,:), allocatable:: hybrid

  logical:: Absauto, Abs_in_bulk, All_nrixs, Allsite, Analyzer, ATA, Atom_nonsph, Atom_occ_hubb, &
     Atomic_scr, Axe_loc, Basereel, Base_ortho_int, Base_ortho_sur, Bormann, BSC_SCF, Bulk, Bulk_atom_used, &
     Check_extract, Check_mpi, Clementi, Cap_layer, Cartesian_tensor, Center_s, Charge_free, Circular, &
     Convolution_cal, COOP, Coop_only_abs, Coop_z_along_bond, Core_energ_tot, Core_resolved, Counter_linear, Coupelapw, Dafs, &
     Dafs_bio, Density, Density_comp, Density_sp, Dipmag, Doping, Dyn_eg, Dyn_g, E_cut_man, E1E2_imp, Eneg_i, Eneg_n_i, Energphot, &
     Epsif_ref_man, Epsii_ref_man, Extract, FDM_comp, FDMX_only, Film, Fit_cal, Flapw, Flapw_new, &
     Force_ecr, Full_atom_e, Full_potential, Full_self_abs, Gamma_hole_man, Gamma_tddft, Green_bulk, &
     Green_s, Green_self, Harm_cubic, Header, Helm_cos, Helm_lin, Helm_mix, HERFD, Hubbard, Image_charge, Kern_fast, &
     key_calc, korigimp, Lmaxfree, Lmoins1, Lplus1, Mag_axis_free, Magnetic, Matper, Memory_save, Moment_conservation, Muffintin, &
     No_cluster_rotation, No_DFT, No_solsing, Noncentre, Nonexc, Normaltau, NRIXS, Occupancy_first, Octupole, One_run, One_run_s, &
     One_SCF, One_SCF_surf, Only_indirect, Only_rixs, Operation_mode_used, Optic, Overad, Pdb, PointGroup_Auto, Polarise, Powder, &
     Python, Quadmag, Quadrupole, Readfast, Relativiste, Renorm, RIXS, RPALF, Rydberg, Scan_a, &
     SCF_smooth, Self_abs, Solsing_s, Solsing_only, Space_Group_P1, Spherical_signal, Spherical_tensor, Spin_axis_free, &
     Spinorbite, State_all, State_all_out, Supermuf, Sym_2D, Symauto, Symmol, Taux, Tddft, &
     Trace_format_wien, Use_FDMX, Xan_atom, Ylm_comp_inp, &
     cm2g, nobg, nohole, nodw, noimfp, imfp_inp, elf_inp, dwfactor_inp, tdebye_inp, tmeas_inp, expntl, victoreen

  logical, dimension(2):: Cylinder_cluster
  logical, dimension(3):: hkl_film
  logical, dimension(7):: SCF_log
  logical, dimension(n_Multipole_max):: Multipole
  logical, dimension(nb_test):: Test_case

  logical, dimension(:), allocatable:: Atom_with_axe, Atom_nsph_e, Hubb, Hubb_temp, ok, Run_done, Skip, Skip_run

  real(kind=db):: alfpot, Ang_borm, Bulk_roughness, Cap_B_iso, Cap_roughness, Cap_shift, Cap_thickness, D_max_pot, &
     Delta_edge, Delta_En_conv, Delta_Epsii, Delta_Gauss_rixs, Delta_helm, Delta_plane_max, Delta_z_lin, E_cut_imp, E_moment, &
     Ecent, Eclie, Eclie_out, Elarg, Energ_loss_max, Ephot_min, Epsif_ref, Epsii_ref, Estart, Film_roughness, Film_thickness, &
     Gamma_max, Kern_fac, Overlap, p_self_max, p_self0, &
     p_self0_bulk, p_z1, p_z2, Pas_SCF, phi_0, R_rydb, R_self, R_self_bulk, Ray_max_dirac, Roverad, Rpotmax, Rtph, &
     Temp, Test_dist_min, V_helm, V_intmax, dwfactor, tdebye, tmeas, expntlA, expntlB, victA, victB, Width_helm

  real(kind=db), dimension(2):: Dist_coop, f_no_res
  real(kind=db), dimension(3):: angxyz, angxyz_bulk, angxyz_cap, angxyz_int, angxyz_sur, axyz, axyz_bulk, axyz_cap, &
                                axyz_int, axyz_sur, Centre, dpos, E_moment_axis, Vec_orig
  real(kind=db), dimension(4):: Film_shift, Interface_shift, Surface_shift
  real(kind=db), dimension(6):: Trace_p
  real(kind=db), dimension(7):: Time_loc
  real(kind=db), dimension(10):: Gamma_hole
  real(kind=db), dimension(3,3):: Mat_or, Mat_UB
  real(kind=db), dimension(n_rout):: Time_rout
  real(kind=db), dimension(ngroup_par,nparm):: param
  real(kind=db), dimension(n_shift_core):: Shift_core

  real(kind=db), dimension(:), allocatable:: Adimp_e, Angle_or, cdil, E_adimp, E_max_range, E_radius, Ecrantage, &
     Eeient, Egamme, Eimagent, Energ_rixs, r0_lapw, r0_lapw_temp, Rchimp, Rchimp_temp, &
     Rionic_imp, Rionic_imp_temp, Rlapw, rlapw_temp, Rmt, rmt_temp, Rmtimp, rmtimp_temp, Rsorte_s, Taux_cap, Taux_oc, &
     V_hubbard, V_hubbard_temp, V0bdcFimp
  real(kind=db), dimension(:,:), allocatable :: Angle_mode, angpoldafs, Axe_atom_gr, &
     hkl_dafs, Pdpolar, Polar, pop_nonsph, Posn, Posn_bulk, Posn_cap, q_nrixs, q_rixs, &
     Vecdafsem, Vecdafssm, veconde, Wien_taulap
  real(kind=db), dimension(:,:), allocatable:: Center_abs_s, Counter_ato, Counter_dip, Counter_ion, Temp_coef, Theta_rixs
  real(kind=db), dimension(:,:,:), allocatable:: Popats, Popval, Popval_temp, Rot_atom_gr, Rotloc_lapw, Rot_atom_nsph
  real(kind=db), dimension(:,:,:,:), allocatable:: occ_hubb_e

  real(kind=sg) time

  data Name_Rout/'Lectur','Symsit','FDM_gr','Potent','Ylm   ','Potex ','Sphere','Mat   ','Fillin','Triang', &
                 'Tensor','Densit','Coabs ','Radial','Chi_0 ','Kern  ','Chi   ','SCF   ','Xanes ','Optic ', &
                 'Tddft ','Total '/

  Time_rout(:) = 0._db
  if( mpirank0 == 0 ) then
    call CPU_TIME(time)
    Time_loc(1) = real(time,db)
  endif

  call Lectdim(Absauto,Atom_occ_hubb,Atom_nonsph,Axe_loc,Bormann,Bulk,Cap_layer,Dafs_bio,Doping,Emission,Extract, &
    Film,Flapw,Full_self_abs,HERFD,Hubbard,itape4,Length_line,Magnetic,Memory_save,mpinodes0,mpirank0,n_adimp,n_atom,n_atom_coop, &
    n_counter_ato,n_counter_dip,n_counter_ion,n_file_dafs_exp,n_mat_polar,n_multi_run_e,n_q_rixs,n_radius,n_range,n_temp, &
    n_theta_in,n_theta_rixs,n_two_theta,n_Z_abs,nb_atom_conf_m,ncolm,neimagent,nenerg_in_rixs,nenerg_s, &
    ngamme,ngroup,nhybm,nklapw,nlatm,nlmlapwm,nmatsym,norbdil,npldafs,npldafs_2d,npldafs_e,nple,nplrm,nq_nrixs, &
    NRIXS,nspin,nspino,nspinp,ntype,ntype_bulk,ntype_conf,Occupancy_first,Pdb,Readfast,Self_abs,Space_Group_P1,Taux,Use_FDMX, &
    Xan_atom)

  n_atom_bulk = n_atom(1); n_atom_cap = n_atom(2); n_atom_int = n_atom(3); n_atom_neq = n_atom(4); n_atom_per = n_atom(5)
  n_atom_per_neq = n_atom(6); n_atom_sur = n_atom(7); n_atom_uc = n_atom(8)

  if( Atom_nonsph ) then
    ngroup_nonsph = ngroup
  else
    ngroup_nonsph = 0
  endif
  if( Flapw ) then
    ngroup_lapw = n_atom_per
  else
    ngroup_lapw = 0
  endif
  if( Magnetic .or. Atom_nonsph ) then
    ngroup_m = ngroup
  else
    ngroup_m = 0
  endif
  if( Taux ) then
    ngroup_taux = ngroup
  else
    ngroup_taux = 0
  endif
  if( Atom_occ_hubb ) then
    m_hubb_e = 3
    ngroup_hubb = ngroup
  else
    m_hubb_e = 0
    ngroup_hubb = 0
  endif
  if( Pdb ) then
    ngroup_pdb = ngroup
  else
    ngroup_pdb = 0
  endif
  if( Flapw ) then
    nslapwm = nslapw_max
  else
    nslapwm = 0
  endif
  if( Dafs_bio ) then
    npldafs_f = npldafs
  else
    npldafs_f = 0
  endif

  allocate( Adimp_e(n_adimp) )
  allocate( Angle_mode(3,npldafs_2d) )
  allocate( Angle_or(npldafs_f) )
  allocate( Angpoldafs(3,npldafs) )
  allocate( Atom_nsph_e(ngroup) )
  allocate( Axe_atom_gr(3,ngroup_m) )
  allocate( Com(0:ntype) )
  allocate( cdil(norbdil) )
  allocate( Counter_ato(8,n_counter_ato) )
  allocate( Counter_dip(6,n_counter_dip) )
  allocate( Counter_ion(6,n_counter_ion) )
  allocate( E_adimp(n_adimp) )
  allocate( E_max_range(n_range) )
  allocate( E_radius(n_radius) )
  allocate( Ecrantage(nspin) )
  allocate( Egamme(ngamme) )
  allocate( Eeient(neimagent) )
  allocate( Eimagent(neimagent) )
  allocate( Energ_rixs(nenerg_in_rixs) )
  allocate( hkl_dafs(3,npldafs) )
  allocate( Hubb(0:ntype) )
  allocate( hybrid(nhybm,16,ngroup_nonsph) )
  allocate( iabsm(n_multi_run_e) )
  allocate( iabsorig(n_multi_run_e) )
  allocate( icom(0:ntype) )
  allocate( igr_coop(n_atom_coop) )
  allocate( isigpi(2,npldafs) )
  allocate( itdil(norbdil) )
  allocate( its_lapw(ngroup_lapw) )
  allocate( itype(ngroup) )
  allocate( Kgroup(ngroup_pdb) )
  allocate( ldil(norbdil) )
  allocate( lvval(0:ntype,nlatm) )
  allocate( natomeq_s(n_radius) )
  allocate( nlat(0:ntype) )
  allocate( norbv(0:ngroup_nonsph) )
  allocate( nphi_dafs(npldafs) )
  allocate( npl_2d(npldafs_2d) )
  allocate( nrato(0:ntype) )
  allocate( nrato_lapw(0:ntype) )
  allocate( Numat(0:ntype) )
  allocate( numat_abs(n_Z_abs) )
  allocate( nvval(0:ntype,nlatm) )
  allocate( occ_hubb_e(-m_hubb_e:m_hubb_e,-m_hubb_e:m_hubb_e,nspin,ngroup_hubb) )
  allocate( Operation_mode(5,npldafs_2d) )
  allocate( Pdpolar(nple,2) )
  allocate( Polar(3,nple) )
  allocate( poldafsem(3,npldafs_e) )
  allocate( poldafssm(3,npldafs_e) )
  allocate( pop_nonsph(nhybm,ngroup_nonsph) )
  allocate( Popats(ngroup,nlatm,nspin) )
  allocate( Popval(0:ntype,nlatm,nspin) )
  allocate( Posn(3,n_atom_uc) )
  allocate( Posn_bulk(3,n_atom_bulk) )
  allocate( Posn_cap(3,n_atom_cap) )
  allocate( q_nrixs(4,nq_nrixs) )
  allocate( q_rixs(4,n_q_rixs) )
  allocate( r0_lapw(0:ntype) )
  allocate( Rchimp(0:ntype) )
  allocate( Rionic_imp(0:ntype) )
  allocate( Rlapw(0:ntype) )
  allocate( Rmt(0:ntype) )
  allocate( Rmtimp(0:ntype) )
  allocate( Rot_Atom_gr(3,3,ngroup_m) )
  allocate( Rot_Atom_nsph(3,3,ngroup_nonsph) )
  allocate( Rotloc_lapw(3,3,ngroup_lapw) )
  allocate( Rsorte_s(n_radius) )
  allocate( Taux_cap(n_atom_cap) )
  allocate( Taux_oc(ngroup_taux) )
  allocate( Temp_coef(n_temp,ngroup) )
  allocate( Theta_rixs(n_theta_rixs,2) )
  allocate( V_hubbard(0:ntype) )
  allocate( V0bdcFimp(nspin) )
  allocate( Vecdafsem(3,npldafs_e) )
  allocate( Vecdafssm(3,npldafs_e) )
  allocate( Veconde(3,nple) )
  allocate( Wien_matsym(3,3,nslapwm) )
  allocate( Wien_taulap(3,nslapwm) )
  allocate( Z_bulk(n_atom_bulk) )
  allocate( Z_cap(n_atom_cap) )

  call Lecture(Absauto,adimp_e,alfpot,All_nrixs,Allsite,Ang_borm,Angle_mode,Angle_or, &
    Angpoldafs,Angxyz,Angxyz_bulk,Angxyz_cap,Angxyz_int,Angxyz_sur,ATA, &
    Atom_occ_hubb,Atom_nonsph,Atom_nsph_e,Atomic_scr,Axe_atom_gr,Axe_loc,axyz,axyz_bulk,axyz_cap,axyz_int, &
    axyz_sur,Basereel,Bormann,BSC_SCF,Bulk,Bulk_atom_used,Bulk_roughness,Cap_B_iso,Cap_layer,Cap_roughness,Cap_shift, &
    Cap_thickness,Cartesian_tensor,cdil,Center_s,Centre,Charge_free,Check_extract,Check_mpi,Clementi,Com,Comt,COOP, &
    Coop_z_along_bond,Core_energ_tot,Core_resolved,Counter_ato,Counter_dip,Counter_ion,Counter_linear,Coupelapw,Cylinder_cluster, &
    D_max_pot,Dafs,Dafs_bio,Delta_En_conv,Delta_Epsii,Delta_Gauss_rixs,Delta_helm,Delta_plane_max,Delta_z_lin, &
    Density,Density_comp,Density_sp,Dipmag,Dist_coop,Doping,dpos,Dyn_eg,Dyn_g,E_adimp,E_moment,E_moment_axis,E_radius, &
    E_max_range,E1E2_imp,Eclie,Eclie_out,Ecrantage,Eeient,Egamme,Eimagent,Emission,Eneg_i,Eneg_n_i,Energ_loss_max, &
    Energ_rixs,Energphot,Ephot_min,Epsif_ref,Epsif_ref_man,Extract,f_no_res,FDM_comp,FDMX_only,Film, &
    Film_roughness,Film_shift,Film_thickness,Fit_cal,Flapw,Flapw_new,Force_ecr,Full_atom_e,Full_potential,Full_self_abs, &
    Gamma_hole,Gamma_hole_man,Gamma_max,Gamma_tddft,Green_bulk,Green_s,Green_self,Harm_cubic,Helm_cos, &
    Helm_lin,Helm_mix,HERFD,hkl_borm,hkl_dafs,hkl_film,hkl_ref,Hubb,Hubbard,hybrid, &
    iabsm,iabsorig,icheck,icom,igr_coop,igr_dop,Image_charge,indice_par,Interface_shift,iscratch,isigpi,itdil,its_lapw,iord, &
    itape4,itype,itype_dop,Kern_fac,Kern_fast,Kgroup,korigimp,Lmax_DOSout,Lmax_nrixs,ldil,lecrantage,Length_line,Lin_gam, &
    Lmax_pot,Lmax_tddft_inp,Lmaxfree,Lmaxso_max,Lmaxso0,Lmaxat0,Lmoins1,Lplus1,lvval,m_hubb_e,Mag_axis_free,Magnetic,Mat_or, &
    Mat_UB,Matper,Moment_conservation,mpinodes,mpinodes0,mpirank,mpirank0,Muffintin,Multipole,multrmax,n_adimp,n_atom, &
    n_atom_bulk,n_atom_cap,n_atom_coop,n_atom_uc,n_atom_proto,n_counter_ato,n_counter_dip,n_counter_ion,n_devide,n_file_dafs_exp, &
    n_mat_polar,n_multi_run_e,n_q_rixs,n_radius,n_range,n_temp,n_theta_in,n_theta_rixs,n_trans,n_two_theta,n_Z_abs, &
    nb_atom_conf_m,nb_test,necrantage,neimagent,nenerg_in_rixs,nenerg_s,ngamh,ngamme,ngroup,ngroup_hubb,ngroup_lapw, &
    ngroup_m,ngroup_nonsph,ngroup_par,ngroup_pdb,ngroup_taux,nhybm,nlat,nlatm,No_cluster_rotation,No_DFT,No_solsing, &
    nom_fich_extract,nomfich,nomfichbav,Noncentre, &
    Nonexc,norbdil,norbv,Normaltau,normrmt,npar,nparm,nphi_dafs, &
    nphim,npl_2d,npldafs,npldafs_2d,npldafs_e,npldafs_f,nple,nq_nrixs,nrato,nrato_dirac,nrato_lapw,nrm, &
    nself,nself_bulk,nslapwm,nspin,ntype,ntype_bulk,ntype_conf,ntype_mod,Numat,numat_abs,nvval,Occ_hubb_e, &
    Occupancy_first,Octupole,One_run,One_run_s,One_SCF,One_SCF_surf,Only_indirect,Operation_mode,Operation_mode_used,Optic,Overad, &
    Overlap,P_emis,p_self_max,p_self0,p_self0_bulk,P_seuil,param,Pas_SCF,Pdpolar,phi_0,PointGroup,PointGroup_Auto,Polar,Polarise, &
    poldafsem,poldafssm, &
    pop_nonsph,Popats,Popval,Posn,Posn_bulk,Posn_cap,Powder,Python,q_nrixs,q_rixs,Quadmag,Quadrupole,R_rydb,R_self,R_self_bulk, &
    r0_lapw,Ray_max_dirac,Rchimp,Readfast,Relativiste,Renorm,Rionic_imp,RIXS,Rlapw,Rmt,Rmtimp,Rot_Atom_gr,Rot_Atom_nsph, &
    rotloc_lapw,roverad,RPALF,rpotmax,Rydberg,Rsorte_s,SCF_log,SCF_smooth,Self_abs, &
    Solsing_s,Solsing_only,Spherical_signal,Spherical_tensor,Spin_axis_free,Spinorbite,State_all,State_all_out, &
    Supermuf,Surface_shift,Symauto,Symmol,Taux,Taux_cap,Taux_oc,Tddft,Temp,Temp_coef,Tensor_imp, &
    Test_case,Test_dist_min,Theta_rixs,Trace_format_wien,Trace_k,Trace_p,Typepar,Use_FDMX,V_helm,V_hubbard,V_intmax, &
    Vec_orig,Vecdafsem,Vecdafssm,Veconde,V0bdcFimp,Width_helm,Wien_file,Wien_matsym,Wien_save,Wien_taulap, &
    Ylm_comp_inp,Z_bulk,Z_cap,Z_nospinorbite)

    allocate( Com_temp(0:ntype_mod) )
    allocate( Hubb_temp(0:ntype_mod) )
    allocate( icom_temp(0:ntype_mod) )
    allocate( lvval_temp(0:ntype_mod,nlatm) )
    allocate( nlat_temp(0:ntype_mod) )
    allocate( nrato_temp(0:ntype_mod) )
    allocate( nrato_lapw_temp(0:ntype_mod) )
    allocate( numat_temp(0:ntype_mod) )
    allocate( nvval_temp(0:ntype_mod,nlatm) )
    allocate( popval_temp(0:ntype_mod,nlatm,nspin) )
    allocate( r0_lapw_temp(0:ntype_mod) )
    allocate( rchimp_temp(0:ntype_mod) )
    allocate( Rionic_imp_temp(0:ntype_mod) )
    allocate( rlapw_temp(0:ntype_mod) )
    allocate( rmt_temp(0:ntype_mod) )
    allocate( rmtimp_temp(0:ntype_mod) )
    allocate( V_hubbard_temp(0:ntype_mod) )

    do it = 0,ntype_mod
      com_temp(it) = Com(it)
      Hubb_temp(it) = Hubb(it)
      icom_temp(it) = icom(it)
      lvval_temp(it,:) = lvval(it,:)
      nlat_temp(it) = nlat(it)
      nrato_temp(it) = nrato(it)
      nrato_lapw_temp(it) = nrato_lapw(it)
      numat_temp(it) = Numat(it)
      nvval_temp(it,:) = nvval(it,:)
      popval_temp(it,:,:) = Popval(it,:,:)
      r0_lapw_temp(it) = r0_lapw(it)
      rchimp_temp(it) = Rchimp(it)
      Rionic_imp_temp(it) = Rionic_imp(it)
      rlapw_temp(it) = Rlapw(it)
      rmt_temp(it) = Rmt(it)
      rmtimp_temp(it) = Rmtimp(it)
      V_hubbard_temp(it) = V_hubbard(it)
    end do

    deallocate( Com, Hubb, icom, lvval, nlat, nrato, nrato_lapw, Numat, nvval, Popval, r0_lapw, Rchimp, Rionic_imp, Rlapw, Rmt, &
                Rmtimp,V_hubbard )

    ntype = ntype_mod

    allocate( Com(0:ntype) )
    allocate( Hubb(0:ntype) )
    allocate( icom(0:ntype_mod) )
    allocate( itequ(0:ntype) )
    allocate( lvval(0:ntype,nlatm) )
    allocate( nlat(0:ntype) )
    allocate( nrato(0:ntype) )
    allocate( nrato_lapw(0:ntype) )
    allocate( Numat(0:ntype) )
    allocate( nvval(0:ntype,nlatm) )
    allocate( Popval(0:ntype,nlatm,nspin) )
    allocate( r0_lapw(0:ntype) )
    allocate( Rchimp(0:ntype) )
    allocate( Rionic_imp(0:ntype) )
    allocate( Rlapw(0:ntype) )
    allocate( Rmt(0:ntype) )
    allocate( Rmtimp(0:ntype) )
    allocate( V_hubbard(0:ntype) )

    com(:) = com_temp(:)
    Hubb(:) = Hubb_temp(:)
    icom(:) = icom_temp(:)
    lvval(:,:) = lvval_temp(:,:)
    nlat(:) = nlat_temp(:)
    nrato(:) = nrato_temp(:)
    nrato_lapw(:) = nrato_lapw_temp(:)
    Numat(:) = numat_temp(:)
    nvval(:,:) = nvval_temp(:,:)
    Popval(:,:,:) = popval_temp(:,:,:)
    r0_lapw(:) = r0_lapw_temp(:)
    Rchimp(:) = rchimp_temp(:)
    Rionic_imp(:) = Rionic_imp_temp(:)
    Rlapw(:) = rlapw_temp(:)
    Rmt(:) = rmt_temp(:)
    Rmtimp(:) = rmtimp_temp(:)
    V_hubbard(:) = V_hubbard_temp(:)

    deallocate( Com_temp, Hubb_temp, icom_temp, lvval_temp, nlat_temp, nrato_temp, nrato_lapw_temp, numat_temp, nvval_temp, &
                popval_temp, r0_lapw_temp, rchimp_temp, Rionic_imp_temp,rlapw_temp, rmt_temp, rmtimp_temp, V_hubbard_temp )

!*** JDB Sept. 2016
  if( FDMX_only .and. mpirank0 == 0 ) then
    if( P_seuil(1) /= 1 ) then
      write(*,*) 'ERROR: FDMX is currently only compatible with K-edge spectra'
    else
      write(*,*) 'CALLING FDMX'
      if( n_atom_uc /= ngroup ) then
        write(*,*) ' n_atom_uc /= ngroup,   contact Yves !'
        stop
      endif
      fdmnes_inp132 = fdmnes_inp
      nomfich132 = nomfich
      call fdmx(fdmnes_inp132,nomfich132,cm2g,nobg,nohole,nodw,noimfp,Gamma_hole,Gamma_hole_man,E_cut_imp*rydb,E_cut_man, &
        imfp_inp, imfp_infile, elf_inp, elf_infile, dwfactor_inp, dwfactor, tdebye_inp, tdebye, tmeas_inp, tmeas, Energphot, &
        expntl, expntlA, expntlB, victoreen, victA, victB, mermrank, ngroup, Posn, itype, ntype, Numat)
    endif
    return
  endif
!*** JDB

  Scan_a = nphim > 1

  if( mpirank0 == 0 ) then
    call CPU_TIME(time)
    Time_loc(2) = real(time,db)
    Time_rout(1) = Time_loc(2) - Time_loc(1)
  endif

  n_atom_proto = 0
  n_atom_proto_int = 0
  neqm = 0

  allocate( Atom_with_axe(0:ngroup_m) )
  allocate( igr_i(ngroup) )
  allocate( igr_is(ngroup) )
  allocate( igr_proto(ngroup) )

  Sym_2D = Film .and. n_atom_per == 0

! Evaluation of the symmetries of the (magnetic) space group
  call Symsite(Absauto,angxyz,angxyz_int,angxyz_sur,Atom_with_axe,Atom_nsph_e,Axe_atom_gr, &
        axyz,axyz_int,axyz_sur,Base_ortho_int,Base_ortho_sur,.false.,Center_s,Centre, &
        Doping,E_moment_axis,Extract,Flapw,iabsm,icheck(3),igr_i,igr_is,igr_proto,itequ,itype,Magnetic,Matper, &
        Memory_save,n_atom_int,n_atom_per,n_atom_proto,n_atom_proto_int,n_atom_sur,n_atom_uc,n_multi_run_e,n_Z_abs,neqm, &
        ngroup,ngroup_m,ngroup_taux,nlat,nlatm,Noncentre,nspin,ntype,Numat,numat_abs,Popats,Posn,Space_Group_P1,Sym_2D,Taux_oc)

  n_atom_proto_uc = n_atom_proto
  if( Doping ) n_atom_proto = n_atom_proto + 1
  n = n_atom_proto

  if( Bulk ) then
    Sym_2D = .false.
!    Center_s_L = One_SCF_Surf
    call Symsite(Absauto,angxyz_bulk,angxyz_int,angxyz_sur,Atom_with_axe,Atom_nsph_e,Axe_atom_gr, &
        axyz_bulk,axyz_int,axyz_sur,Base_ortho_int,Base_ortho_sur,Bulk,One_SCF_Surf,Centre, &
        .false.,E_moment_axis,Extract,Flapw,iabsm,icheck(3),igr_i,igr_is,igr_proto,itequ,itype,Magnetic,.true., &
        Memory_save,n_atom_int,n_atom_bulk,n_atom_proto,n_atom_proto_int,n_atom_sur,n_atom_bulk,n_multi_run_e,n_Z_abs,neqm, &
        ngroup,ngroup_m,ngroup_taux,nlat,nlatm,.false.,nspin,ntype,Numat,numat_abs,Popats,Posn_bulk,Space_Group_P1,Sym_2D,Taux_oc)
  endif

  deallocate( Atom_nsph_e )

  n_atom_proto_bulk = n_atom_proto - n

  allocate( igreq(0:n_atom_proto,neqm) )
  allocate( ngreq(0:n_atom_proto) )

  ngreq(:) = 0
  igreq(:,:) = 0

  do igr = 1,ngroup
    if( Doping .and. igr == n_atom_uc + 1 ) cycle
    ipr = igr_proto(igr)
    ngreq(ipr) = ngreq(ipr) + 1
    i = igr_i(igr)
    igreq(ipr,i) = igr
  end do

  if( Doping ) then
    igreq(n,1) = n_atom_uc + 1
    ngreq(n) = 1
  endif

  if( Absauto ) then
    multi_run = 0
    do i = 1,n_Z_abs
      do ipr = 1,n_atom_proto
        it = abs( itype(igreq(ipr,1)) )
        if( Numat( it ) /= numat_abs(i) ) cycle
        multi_run = multi_run + 1
      end do
    end do
    n_multi_run = multi_run
  else
    n_multi_run = n_multi_run_e
  endif

  if( n_multi_run > 1 .and. One_run .and. .not. nonexc .and. mpirank0 == 0 ) then
    call write_error
    do ipr = 6,9,3
      write(ipr,125)
    end do
    stop
  endif

  if( Absauto ) then
    deallocate( iabsm, iabsorig )
    allocate( iabsm(n_multi_run) )
    allocate( iabsorig(n_multi_run) )
    multi_run = 0
    do i = 1,n_Z_abs
      do ipr = 1,n_atom_proto
        it = abs( itype(igreq(ipr,1)) )
        if( Numat( it ) /= numat_abs(i) ) cycle
        multi_run = multi_run + 1
        iabsm(multi_run) = igreq(ipr,1)
        iabsorig(multi_run) = ipr
      end do
    end do
  endif

  natomsym_max = 0
  do i = 1,n_Z_abs
    do igr = 1,ngroup
      if( Doping ) then
        if( Numat( abs( itype(igr) ) ) /= Numat( abs( itype(igr_dop) ) ) ) cycle
      else
        if( Numat( abs( itype(igr) ) ) /= numat_abs(i) ) cycle
      endif
      natomsym_max = max( igr_i(igr), natomsym_max )
    end do
  end do

  allocate( isymqa(0:n_atom_proto,natomsym_max) )
  isymqa(:,:) = 0

  ipr_dop = 0

  do j = 1,n_Z_abs
    do igr = 1,ngroup

      if( Doping ) then
        if( Numat( abs( itype(igr) ) ) /= Numat( abs( itype(igr_dop) ) ) ) cycle
      else
        if( Numat( abs( itype(igr) ) ) /= numat_abs(j) ) cycle
      endif

      if( igr == igr_dop ) ipr_dop = igr_proto(igr)

      ipr = igr_proto(igr)
      i = igr_i(igr)
      if( Doping .and. igr == n_atom_uc + 1 ) then
        isymqa(n_atom_proto_uc+1,:) = isymqa(ipr_dop,:)
      else
        isymqa(ipr,i) = igr_is(igr)
      endif

    end do
  end do

  allocate( n_bulk_sup_c(n_multi_run) )
  n_bulk_sup_c(:) = 0

  Abs_in_bulk = .false.
  do multi_run = 1,n_multi_run
    if( iabsm(multi_run) > ngroup - n_atom_bulk ) then
      Abs_in_bulk = .true.
      exit
    endif
  end do

  if( Coop .and. n_atom_coop == 0 ) then
    n_atom_coop = 1
    Coop_only_abs = .true.
    deallocate( igr_coop )
    allocate( igr_coop(n_atom_coop) )
  else
    Coop_only_abs = .false.
  endif

! Determination of supplementary output files when abs in bulk with different z
  n_abs_rgh = 0
  do multi_run_e = 1,n_multi_run
    if( Abs_in_bulk ) then
      multi_run = n_multi_run + 1 - multi_run_e
    else
      multi_run = multi_run_e
    endif
    if( iabsm(multi_run) <= ngroup - n_atom_bulk  .or. .not. DAFS ) cycle
    if( Bulk_roughness > eps10 ) n_abs_rgh = n_abs_rgh + 1
    n_bulk_sup_c(multi_run) = - 1
    ipr = igr_proto( iabsm(multi_run) )
    allocate( ok( ngreq(ipr) ) )
    ok(:) = .false.
    do igr = 1,ngreq(ipr)
      if( ok(igr) ) cycle
      ok(igr) = .true.
      n_bulk_sup_c(multi_run) = n_bulk_sup_c(multi_run) + 1
      p_z1 = Posn_bulk( 3, igreq(ipr,igr) - ngroup + n_atom_bulk )
      do jgr = 1,ngreq(ipr)
        if( ok(jgr) ) cycle
        p_z2 = Posn_bulk( 3, igreq(ipr,jgr) - ngroup + n_atom_bulk )
        if( abs( p_z1 - p_z2 ) > eps10 ) cycle
        ok(jgr) = .true.
      end do
    end do
    deallocate( ok )
  end do
  n_bulk_sup = sum( n_bulk_sup_c(:) )

  deallocate( igr_i, igr_proto )

  allocate( ngreqm(n_multi_run) )

  allocate( nomfich_cal_conv(n_multi_run+n_bulk_sup+n_abs_rgh) )
  allocate( nomfich_cal_tddft_conv(n_multi_run+n_bulk_sup+n_abs_rgh) )
  allocate( Run_done(n_multi_run) )
  allocate( Skip_run(n_multi_run) )
  allocate( Skip(n_multi_run) )
  Run_done(:) = .false.
  Skip_run(:) = .false.
  Skip(:) = .false.

  boucle_m: do multi_run = 1,n_multi_run

    boucle_ipr: do ipr = 1,n_atom_proto
      do i = 1,ngreq(ipr)
        if( igreq(ipr,i) == iabsm(multi_run) ) exit boucle_ipr
      end do
    end do boucle_ipr

    ngreqm(multi_run) = ngreq(ipr)

    do j = 1,multi_run - 1
      do i = 1,ngreq(ipr)
        if( iabsm(j) /= igreq(ipr,i) ) cycle
        run_done(multi_run) = .true.
        cycle boucle_m
      end do
    end do

  end do boucle_m

  n_layer_abs = 0
  n_proto_layer_max = 0
  allocate( Center_abs_s(2,n_layer_abs) )
  allocate( igr_layer(n_proto_layer_max,n_layer_abs) )
  allocate( n_proto_layer(n_layer_abs) )

  Sym_2D = Film .and. n_atom_per == 0

  if( Sym_2D .and. One_run_s ) then
    do i = 1,3
      Call Find_layer_center(axyz,angxyz,Center_abs_s,Delta_plane_max,i,iabsm,iabsorig,icheck(3),igr_layer,igreq,isymqa,itype, &
                      n_atom_proto,n_atom_proto_bulk,n_atom_uc,n_layer_abs,n_multi_run,n_proto_layer,n_proto_layer_max,n_Z_abs, &
                      natomsym_max,neqm,ngreq,ngroup,ntype,Numat,numat_abs,Posn)

      if( i == 1 ) then
        deallocate( Center_abs_s, igr_layer, n_proto_layer )
        allocate( Center_abs_s(3,n_layer_abs) )
        allocate( n_proto_layer(n_layer_abs) )
        allocate( igr_layer(n_proto_layer_max,n_layer_abs) )
      elseif( i == 2 ) then
        deallocate( igr_layer )
        allocate( igr_layer(n_proto_layer_max,n_layer_abs) )
      endif
    end do
  endif

  if( nnotskip > 0 .and. Extract .and. n_atom_proto_p == n_atom_proto ) then
    do multi_run = 1,n_multi_run
      Skip_run(multi_run) = .true.
      do i = 1,nnotskip
        if( ifile_notskip(i) == iabsorig(multi_run) ) Skip_run(multi_run) = .false.
      end do
    end do
  endif

  n_atom_proto_p = n_atom_proto
  nlm_pot = ( Lmax_pot + 1 )**2

  if( mpirank0 == 0 ) write(6,130) n_multi_run

! ------- Calculation of all the non equivalent atoms signal ----------------------------------------

  skip(:) = Run_done(:) .or. Skip_run(:)

  if( mpirank0 == 0 ) then
    call CPU_TIME(time)
    Time_loc(3) = real(time,db)
    Time_rout(2) = Time_loc(3) - Time_loc(2)
  endif

  nbseuil = P_seuil(4)

  call Site_calculation( adimp_e, alfpot, All_nrixs, Allsite, Analyzer, Angle_mode, Angle_or, &
      Angpoldafs, Angxyz, Angxyz_bulk, Angxyz_cap, Angxyz_int, Angxyz_sur, ATA, &
      Atom_occ_hubb, Atom_nonsph, Atom_with_axe, Atomic_scr, Axe_atom_gr, axyz, axyz_bulk, axyz_cap, axyz_int, &
      axyz_sur, Base_ortho_int, Base_ortho_sur, Basereel, Bormann, BSC_SCF, Bulk, Bulk_atom_used, Bulk_roughness, Cap_B_iso, &
      Cap_layer, Cap_roughness, Cap_shift, Cap_thickness, Cartesian_tensor, cdil, Center_abs_s, Center_s, Centre, Charge_free, &
      Circular, Clementi, Com, COOP, Coop_only_abs, Coop_z_along_bond, Core_energ_tot, Core_resolved, Counter_ato, Counter_dip, &
      Counter_ion, Counter_linear, Coupelapw, Cylinder_cluster, D_max_pot, Dafs, Dafs_bio, Delta_edge, Delta_En_conv, Delta_Epsii, &
      Delta_Gauss_rixs, Delta_helm, Delta_z_lin, Density, Density_comp, Density_sp, Dist_coop, &
      Dipmag, Doping, dpos, Dyn_eg, Dyn_g, E_adimp, E_cut_imp, E_cut_man, E_moment, E_moment_axis, E_max_range, E_radius, &
      E1E2_imp, Ecent, Eclie, Eclie_out, Ecrantage, Eeient, Egamme, Eimagent, Elarg, Eneg_i, Eneg_n_i, Energ_loss_max, &
      Energ_rixs, Energphot, Ephot_min, Epsif_ref, Epsif_ref_man, Epsii_ref, Epsii_ref_man, Estart, Extract, &
      f_no_res, FDM_comp, Film, Film_roughness, Film_shift, Film_thickness, Flapw, Flapw_new, Force_ecr, Full_atom_e, &
      Full_potential, Full_self_abs, Gamma_hole, Gamma_hole_man, Gamma_max, Gamma_tddft, Green_bulk, &
      Green_s, Green_self, Harm_cubic, Header, Helm_cos, Helm_lin, Helm_mix, HERFD, hkl_dafs, hkl_film, hkl_ref, Hubb, Hubbard, &
      hybrid, iabsm, iabsorig, icheck, icom, igr_coop, igr_dop, igr_layer, igreq, Image_charge, Interface_shift, &
      ipr_dop, isigpi, itdil, its_lapw, iord, isymqa, itequ, itype, itype_dop, Kern_fac, Kern_fast, Kgroup, &
      korigimp, ldil, lecrantage, Lin_gam, Lmax_DOSout, Lmax_nrixs, Lmax_pot, Lmax_tddft_inp, Lmaxfree, &
      Lmaxso_max, Lmaxso0, Lmaxat0, Lmoins1, Lplus1, lvval, m_hubb_e, Mag_axis_free, &
      Magnetic,Mat_or,Mat_UB,Matper,Moment_conservation,mpinodes,mpinodes0,mpirank,mpirank0,Muffintin,Multipole,multrmax, &
      n_abs_rgh,n_adimp,n_atom_bulk,n_atom_cap,n_atom_coop,n_atom_int,n_atom_per,n_atom_proto,n_atom_proto_bulk,n_atom_proto_int, &
      n_atom_proto_uc, &
      n_atom_sur,n_atom_uc,n_bulk_sup,n_counter_ato,n_counter_dip,n_counter_ion,n_devide,n_layer_abs,n_mat_polar,n_multi_run, &
      n_proto_layer,n_proto_layer_max,n_q_rixs, &
      n_radius,n_range,n_rout,n_shift_core,n_temp,n_theta_rixs,n_trans,natomeq_s,natomsym_max,nb_test,nbseuil,ncolm,necrantage, &
      neimagent,nenerg_in_rixs,nenerg_s,neqm,ngamh,ngamme,ngreq,ngroup,ngroup_hubb,ngroup_lapw, &
      ngroup_m,ngroup_nonsph,ngroup_pdb,ngroup_taux,nhybm,nklapw,nlm_pot,nlmlapwm,nlat,nlatm,nmatsym,No_cluster_rotation, No_DFT, &
      No_solsing,nom_fich_extract,nomfich,nomfich_cal_conv,nomfich_cal_tddft_conv,nomfichbav,Noncentre, &
      Nonexc,norbdil,norbv,Normaltau,normrmt,nphi_dafs,nphim, &
      npl_2d,npldafs,npldafs_2d,npldafs_e,npldafs_f,nple,nplrm,nq_nrixs,nrato,nrato_dirac,nrato_lapw,NRIXS,nrm, &
      nself,nself_bulk,nslapwm,nspin,nspino,nspinp,ntype,Numat,numat_abs(1),nvval,Occ_hubb_e,Octupole, &
      One_run,One_run_s,One_SCF,One_SCF_surf,Only_indirect,Only_rixs,Operation_mode,Operation_mode_used,Optic,Overad,Overlap, &
      P_emis,p_self_max,p_self0,p_self0_bulk,P_seuil,Pas_SCF,Pdpolar,phi_0,PointGroup,PointGroup_Auto,Polar,Polarise,poldafsem, &
      poldafssm,pop_nonsph,Popats,Popval,Posn,Posn_bulk,Posn_cap,Powder,Python,q_nrixs,q_rixs,Quadrupole,R_rydb,R_self, &
      R_self_bulk,r0_lapw,Ray_max_dirac,Rchimp,Relativiste,Renorm,Rionic_imp,RIXS,Rlapw,Rmt,Rmtimp,Rot_Atom_gr,Rot_Atom_nsph, &
      rotloc_lapw,roverad,RPALF,rpotmax,Rydberg,Rsorte_s,SCF_log,SCF_smooth,Self_abs,Shift_core,Skip,Solsing_s,Solsing_only, &
      Spherical_signal,Spherical_tensor,Spin_axis_free,Spinorbite,State_all,State_all_out,Supermuf,Surface_shift,Symmol, &
      Taux,Taux_cap,Taux_oc,Tddft,Temp,Temp_coef,Tensor_imp,Test_case,Test_dist_min,Theta_rixs,Time_rout, &
      Trace_format_wien,Trace_k,Trace_p,V_helm,V_hubbard,V_intmax,Vec_orig,Vecdafsem,Vecdafssm,Veconde,V0bdcFimp,Width_helm, &
      Wien_file,Wien_matsym,Wien_save,Wien_taulap,Xan_atom,Ylm_comp_inp,Z_bulk,Z_cap,Z_nospinorbite)

! -------------------------------------------------------------------------------------------------------------------------------------------

  if( Convolution_cal .and. mpirank0 == 0 ) then

    Rewind(itape1)
    key_calc = .false.
    do l = 1,10000
      read(itape1,'(A)',iostat=istat) mot
      if( istat /= 0 ) then
        backspace(itape1)
        exit
      endif
      keyword = identmot(mot,9)
      if( keyword == 'calculati' ) key_calc = .true.
      if( keyword == 'Run_done' ) then
        backspace(itape1)
        exit
      endif
    end do

    if( key_calc ) then
      write(itape1,'(A)') ' Run_done '
      do multi_run_e = 1,n_multi_run
        if( Abs_in_bulk ) then
          multi_run = n_multi_run + 1 - multi_run_e
        else
          multi_run = multi_run_e
        endif
        do i = 0,n_bulk_sup_c(multi_run)
          if( Skip_run(multi_run) ) then
            is = 0
          else
            is = 1
          endif
          if( Run_done(multi_run) ) then
            ir = 0
          else
            ir = 1
          endif
          write(itape1,'(2i2)') ir, is
        end do
      end do
    else
      write(itape1,'(A)') ' calculation'
      n = 0
      do multi_run_e = 1,n_multi_run
        if( Abs_in_bulk ) then
          multi_run = n_multi_run + 1 - multi_run_e
        else
          multi_run = multi_run_e
        endif
        do i = 0,n_bulk_sup_c(multi_run)
          n = n + 1
          if( Run_done(multi_run) ) cycle
          write(itape1,'(A)') nomfich_cal_conv(n)
        end do
        if( iabsm(multi_run) > ngroup - n_atom_bulk .and. Bulk_roughness > eps10 ) then
          n = n + 1
          if( Run_done(multi_run) ) cycle
          write(itape1,'(A)') nomfich_cal_conv(n)
        endif
      end do
      if( Tddft .and. .not. Extract .and. ( .not. Gamma_tddft .or. Dafs  .or. n_multi_run > 1 ) ) then
        write(itape1,'(A)') ' cal_tddft'
        n = 0
        do multi_run_e = 1,n_multi_run
          if( Abs_in_bulk ) then
            multi_run = n_multi_run + 1 - multi_run_e
          else
            multi_run = multi_run_e
          endif
          do i = 0,n_bulk_sup_c(multi_run)
            n = n + 1
            if( Run_done(multi_run) ) cycle
            write(itape1,'(A)') nomfich_cal_tddft_conv(n)
          end do
          if( iabsm(multi_run) > ngroup - n_atom_bulk .and. Bulk_roughness > eps10 ) then
            n = n + 1
            if( Run_done(multi_run) ) cycle
            write(itape1,'(A)') nomfich_cal_tddft_conv(n)
          endif
        end do
      endif
    endif
  endif

  deallocate( n_bulk_sup_c, nomfich_cal_conv, nomfich_cal_tddft_conv, Run_done, Skip_run )

  if( icheck(1) > 0 .and. mpirank0 == 0 ) then
    call CPU_TIME(time)
    Time_loc(4) = real(time,db)
    Time_rout(n_rout) = Time_loc(4) - Time_loc(1)
    itph = int( Time_rout(n_rout) / 3600 )
    rtph = Time_rout(n_rout) - itph * 3600
    itpm = int( rtph / 60 )
    itps = nint( rtph - itpm * 60 )
    write(3,210)
    if( Tddft) then
      write(3,220) (Name_rout(i), Time_rout(i), i = 1,17)
    else
      write(3,220) (Name_rout(i), Time_rout(i), i = 1,13)
    endif
    if( RIXS ) write(3,220) 'RIXS  ', Time_rout(20)
    if( Optic .and. Tddft ) then
      write(3,220) Name_rout(18),  Time_rout(18), 'Taull ', Time_rout(19), ( Name_rout(i),  Time_rout(i), i = 20,21 )
    elseif( Optic ) then
      write(3,220) 'Taull ', Time_rout(19), Name_rout(20),  Time_rout(20)
    elseif( Tddft ) then
      write(3,220) ( Name_rout(i),  Time_rout(i), i = 18,19 ), Name_rout(21),  Time_rout(21)
    else
      write(3,220) ( Name_rout(i),  Time_rout(i), i = 18,19 )
    endif
    if( itph > 0 .or. itpm > 0 ) then
      write(3,240) Name_rout(n_rout), Time_rout(n_rout), itph, itpm, itps
    else
      write(3,220) Name_rout(n_rout), Time_rout(n_rout)
    endif
  endif

!*** JDB Sept. 2016
  if( Use_FDMX .and. mpirank0 == 0 ) then
    if( P_seuil(1) /= 1 ) then
      write(*,*) 'ERROR: FDMX is currently only compatible with K-edge spectra'
    else
      write(*,*) 'CALLING FDMX'
      if( n_atom_uc /= ngroup ) then
        write(*,*) ' n_atom_uc /= ngroup, contact Yves !'
        stop
      endif
      fdmnes_inp132 = fdmnes_inp
      nomfich132 = nomfich
      call fdmx(fdmnes_inp132,nomfich132,cm2g,nobg,nohole,nodw,noimfp,Gamma_hole,Gamma_hole_man,E_cut_imp*rydb,E_cut_man, &
        imfp_inp, imfp_infile, elf_inp, elf_infile, dwfactor_inp, dwfactor, tdebye_inp, tdebye, tmeas_inp, tmeas, Energphot, &
        expntl, expntlA, expntlB, victoreen, victA, victB, mermrank, ngroup, Posn, itype, ntype, Numat)
    endif
  endif
!*** JDB

  deallocate( Atom_with_axe )

! Desallocation des tables allocated before subroutine lecture
  deallocate( Adimp_e, Angle_mode, Angle_or, Angpoldafs )
  deallocate( Axe_atom_gr )
  deallocate( cdil, Center_abs_s, Com, Counter_ato, Counter_dip, Counter_ion )
  deallocate( E_adimp, E_max_range, E_radius )
  deallocate( Ecrantage )
  deallocate( Egamme,  Eeient, Eimagent, Energ_rixs )
  deallocate( hkl_dafs, Hubb, hybrid )
  deallocate( iabsm, iabsorig, icom, igr_coop, igr_is, igr_layer, isigpi, itdil, itequ, its_lapw, itype )
  deallocate( Kgroup, ldil, lvval, n_proto_layer, natomeq_s )
  deallocate( nlat, norbv, nphi_dafs, npl_2d, nrato, nrato_lapw, Numat, numat_abs, nvval )
  deallocate( Occ_hubb_e, Operation_mode )
  deallocate( Pdpolar, Polar, poldafsem, poldafssm, pop_nonsph, Popats, Popval, Posn, Posn_bulk, Posn_cap, q_nrixs, q_rixs )
  deallocate( r0_lapw, Rchimp, Rionic_imp, Rlapw, Rmt, Rmtimp, Rot_Atom_gr, Rot_Atom_nsph, Rotloc_lapw, Rsorte_s )
  deallocate( Taux_cap, Taux_oc, Temp_coef, Theta_rixs )
  deallocate( V_hubbard, V0bdcFimp, Vecdafsem, Vecdafssm, Veconde )
  deallocate( Wien_matsym, Wien_taulap, Z_bulk, Z_cap )

  return
  125 format(//' One_run process is not possible with absorbing atom in excited state !',// &
               ' Excited absorbing atom is the default for K, L1, M1, N1 edges.', // &
               ' Use non excited absorbing atom (keyword nonexc)',/ &
               ' or keep a multi run process.'//)
  130 format(/' Number of calculated non equivalent absorbing atom =', i5)
  210 format(/,1x,120('-')//' Subroutine times (s CPU)')
  220 format(4(4x,a6,' =',f12.2))
  240 format(4x,a6,' =',f12.2,' =',i4,' h',i3,' min',i3,' s CPU')
end

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

! Calculation of all the non equivalent atoms signal

subroutine Site_calculation( adimp_e, alfpot, All_nrixs, Allsite, Analyzer, Angle_mode, Angle_or, &
      Angpoldafs, Angxyz, Angxyz_bulk, Angxyz_cap, Angxyz_int, Angxyz_sur, ATA, &
      Atom_occ_hubb, Atom_nonsph, Atom_with_axe, Atomic_scr, Axe_atom_gr, axyz, axyz_bulk, axyz_cap ,axyz_int, &
      axyz_sur, Base_ortho_int, Base_ortho_sur, Basereel, Bormann, BSC_SCF, Bulk, Bulk_atom_used, Bulk_roughness, Cap_B_iso, &
      Cap_layer, Cap_roughness, Cap_shift, Cap_thickness, Cartesian_tensor, cdil, Center_abs_s, Center_s, Centre, Charge_free, &
      Circular, Clementi, Com, COOP, Coop_only_abs, Coop_z_along_bond, Core_energ_tot, Core_resolved, Counter_ato, Counter_dip, &
      Counter_ion, Counter_linear, Coupelapw, Cylinder_cluster, D_max_pot, Dafs, Dafs_bio, Delta_edge, Delta_En_conv, Delta_Epsii, &
      Delta_Gauss_rixs, Delta_helm, Delta_z_lin, Density, Density_comp, Density_sp, Dist_coop, &
      Dipmag, Doping, dpos, Dyn_eg, Dyn_g, E_adimp, E_cut_imp, E_cut_man, E_moment, E_moment_axis, E_max_range, E_radius, &
      E1E2_imp, Ecent, Eclie, Eclie_out, Ecrantage, Eeient, Egamme, Eimagent, Elarg, Eneg_i, Eneg_n_i, Energ_loss_max, &
      Energ_rixs, Energphot, Ephot_min, Epsif_ref, Epsif_ref_man, Epsii_ref, Epsii_ref_man, Estart, Extract, &
      f_no_res, FDM_comp, Film, Film_roughness, Film_shift, Film_thickness, Flapw, Flapw_new, Force_ecr, Full_atom_e, &
      Full_potential, Full_self_abs, Gamma_hole, Gamma_hole_man, Gamma_max, Gamma_tddft, Green_bulk, &
      Green_s, Green_self, Harm_cubic, Header, Helm_cos, Helm_lin, Helm_mix, HERFD, hkl_dafs, hkl_film, hkl_ref, Hubb, Hubbard, &
      hybrid, iabsm, iabsorig, icheck, icom, igr_coop, igr_dop, igr_layer, igreq, Image_charge, Interface_shift, &
      ipr_dop, isigpi, itdil, its_lapw, iord, isymqa, itequ, itype, itype_dop, Kern_fac, Kern_fast, Kgroup, &
      korigimp, ldil, lecrantage, Lin_gam, Lmax_DOSout, Lmax_nrixs, Lmax_pot, Lmax_tddft_inp, Lmaxfree, &
      Lmaxso_max, Lmaxso0, Lmaxat0, Lmoins1, Lplus1, lvval, m_hubb_e, Mag_axis_free, &
      Magnetic,Mat_or,Mat_UB,Matper,Moment_conservation,mpinodes,mpinodes0,mpirank,mpirank0,Muffintin,Multipole,multrmax, &
      n_abs_rgh,n_adimp,n_atom_bulk,n_atom_cap,n_atom_coop,n_atom_int,n_atom_per,n_atom_proto,n_atom_proto_bulk,n_atom_proto_int, &
      n_atom_proto_uc, &
      n_atom_sur,n_atom_uc,n_bulk_sup,n_counter_ato,n_counter_dip,n_counter_ion,n_devide,n_layer_abs,n_mat_polar,n_multi_run, &
      n_proto_layer,n_proto_layer_max,n_q_rixs, &
      n_radius,n_range,n_rout,n_shift_core,n_temp,n_theta_rixs,n_trans,natomeq_s,natomsym_max,nb_test,nbseuil,ncolm,necrantage, &
      neimagent,nenerg_in_rixs,nenerg_s,neqm,ngamh,ngamme,ngreq,ngroup,ngroup_hubb,ngroup_lapw, &
      ngroup_m,ngroup_nonsph,ngroup_pdb,ngroup_taux,nhybm,nklapw,nlm_pot,nlmlapwm,nlat,nlatm,nmatsym,No_cluster_rotation, No_DFT, &
      No_solsing,nom_fich_extract,nomfich,nomfich_cal_conv,nomfich_cal_tddft_conv,nomfichbav,Noncentre, &
      Nonexc,norbdil,norbv,Normaltau,normrmt,nphi_dafs,nphim, &
      npl_2d,npldafs,npldafs_2d,npldafs_e,npldafs_f,nple,nplrm,nq_nrixs,nrato,nrato_dirac,nrato_lapw,NRIXS,nrm, &
      nself,nself_bulk,nslapwm,nspin,nspino,nspinp,ntype,Numat,numat_abs_1,nvval,Occ_hubb_e,Octupole, &
      One_run,One_run_s,One_SCF,One_SCF_surf,Only_indirect,Only_rixs,Operation_mode,Operation_mode_used,Optic,Overad,Overlap, &
      P_emis,p_self_max,p_self0,p_self0_bulk,P_seuil,Pas_SCF,Pdpolar,phi_0,PointGroup,PointGroup_Auto,Polar,Polarise,poldafsem, &
      poldafssm,pop_nonsph,Popats,Popval,Posn,Posn_bulk,Posn_cap,Powder,Python,q_nrixs,q_rixs,Quadrupole,R_rydb,R_self, &
      R_self_bulk,r0_lapw,Ray_max_dirac,Rchimp,Relativiste,Renorm,Rionic_imp,RIXS,Rlapw,Rmt,Rmtimp,Rot_Atom_gr,Rot_Atom_nsph, &
      rotloc_lapw,roverad,RPALF,rpotmax,Rydberg,Rsorte_s,SCF_log,SCF_smooth,Self_abs,Shift_core,Skip,Solsing_s,Solsing_only, &
      Spherical_signal,Spherical_tensor,Spin_axis_free,Spinorbite,State_all,State_all_out,Supermuf,Surface_shift,Symmol, &
      Taux,Taux_cap,Taux_oc,Tddft,Temp,Temp_coef,Tensor_imp,Test_case,Test_dist_min,Theta_rixs,Time_rout, &
      Trace_format_wien,Trace_k,Trace_p,V_helm,V_hubbard,V_intmax,Vec_orig,Vecdafsem,Vecdafssm,Veconde,V0bdcFimp,Width_helm, &
      Wien_file,Wien_matsym,Wien_save,Wien_taulap,Xan_atom,Ylm_comp_inp,Z_bulk,Z_cap,Z_nospinorbite)

  use declarations
  implicit none

  include 'mpif.h'

  integer, parameter:: Length_n = 6
  integer, parameter:: nslapw_max = 48  ! Max number of symmetry matrix for the FLAPW data
  integer, parameter:: n_tens_dd = 9
  integer, parameter:: n_tens_dq = 15
  integer, parameter:: n_tens_qq = 25
  integer, parameter:: n_tens_dm = 9

  integer:: extract_nenerg, extract_nlmomax, i, i_adimp, i_cycle, i_layer, i_radius, i_range, i_self, ia, iaabs, iaabsfirst, &
    iabsfirst, iaabsi, iabsorbeur, &
    iapr, ip0, ip00, ipr, iaprabs, iaprabs_nonexc, ich, ie, ie_computer, ie0, igr_dop, igrph, igrpt_nomag, igrpt0, &
    index_e, initl, iord, ip_max, ipr1, ipr_dop, iprabs, iprabs_nonexc, isp1, isp2, ispin, &
    it, itab, itabs, itabs_nonexc, itype_dop, j, J_emis, je, jseuil, L, L_emis, L_hubbard, L0_nrixs, &
    l1, l2, lecrantage, lh, Lin_gam, lla_state, lla2_state, Lm1, Lm2, Lmax, Lmax_abs, Lmax_abs_a, Lmax_abs_t,  &
    Lmax_comp, Lmax_DOSout, Lmax_g, Lmax_nrixs, Lmax_pot, Lmax_print, Lmax_probe, Lmax_tddft, Lmax_tddft_inp, Lmax_max, Lmaxat0, &
    Lmaxso, Lmaxso_m, Lmaxso_max, Lmaxso0, Lseuil, m_hubb, m_hubb_e, m1, m2, &
    mpierr, mpinodee, mpinodee0, mpinodes, mpinodes0, mpirank, mpirank0, mpirank_in_mumps_group, multi_0, &
    multi_imp, multi_run, multi_run_e, multrmax, n, n_abs_bulk, n_abs_rgh, n_adimp, n_atom_0, n_atom_0_self, n_atom_bulk, &
    n_atom_cap, n_atom_coop, n_atom_ind, n_atom_ind_self, n_atom_int, n_atom_per, n_atom_proto, n_atom_proto_bulk, &
    n_atom_proto_int, &
    n_atom_proto_uc, n_atom_sur, n_atom_uc, n_bulk_sup, n_counter_ato, n_counter_dip, n_counter_ion, n_devide, n_Ec, n_Emis, &
    n_layer_abs, n_mat_polar, n_max, n_multi_run, n_oo, n_orb_rel, n_orbexc, n_proto_layer_max, n_q_rixs, n_radius, n_range, &
    n_rout, n_shift_core, n_temp, n_tens_max, n_theta_rixs, n_trans, n_V, n_vr_0, n_vr_ind, n_z_SRXRD, n_z_SRXRD_abs, &
    n_z_SRXRD_abs_max, n_z_SRXRD_max, n1, nab_coop, natome, natome_cal, natome_self, natomeq, natomeq_coh, &
    natomeq_self, natomp, natomp_ato, natomp_dip, natomp_ion, natomsym, natomsym_max, nb_Emis, nb_rep, nb_sym_op, nb_test, &
    nbm, nbm_c, nbseuil, nbtm, nbtm_fdm, ncolm, ncolr, ncolt, ndim2, &
    necrantage, neimagent, nenerg, nenerg_in_rixs, nenerg_rixs, nenerg_s, &
    nenerg_tddft, nenerg0, neqm, ngamh, ngamme, nge, ngrm, ngroup, ngroup_hubb, ngroup_lapw, ngroup_m, ngroup_nonsph, ngroup_pdb, &
    nfinal, nfinal1, nfinalr, ngroup_taux, ngrph, nhybm, nicm, nim, ninit1, ninit, ninit_tddft, ninit_out, ninitr, ninitlv, &
    nklapw, nlatm, nlm, nlm_comp, nlm_pot, nlm_probe, nlm_p_fp, nlm_rixs, &
    nlmagm, nlmamax, nlmlapwm, nlmmax, nlmomax, nlms_pr, nlmsam, nlmsamax, nlmso, nmatsym, nnlm, norbdil, normrmt, &
    nphiato, nphiato_c, nphim, npldafs, npldafs_2d, npldafs_e, npldafs_f, nple, nplr, nplrm, npoint, npoint_ns, npr, npso, npsom, &
    nptmoy, nptmoy_out, nq_nrixs, nr, nrato_abs, nrato_dirac, nrm, nrm_self, ns_dipmag, nself, nself_bulk, &
    nseuil, nslapwm, nso1, nsort, nsortf, nspin, nspino, nspinp, nspinorb, ntype, numat_abs, numat_abs_1, &
    nvois, nx, nxanout, Trace_k, Wien_save, Z, Z_nospinorbite

  integer, dimension(3):: hkl_ref, Ldip
  integer, dimension(4):: P_Emis, P_seuil
  integer, dimension(12):: Tensor_imp
  integer, dimension(3,3):: Lqua, msymdd, msymddi
  integer, dimension(3,3,3):: Loct, msymdq, msymdqi
  integer, dimension(3,3,3,3):: msymdo, msymdoi, msymqq, msymqqi
  integer, dimension(30):: icheck
  integer, dimension(n_atom_coop):: ia_coop, igr_coop
  integer, dimension(n_layer_abs):: n_proto_layer
  integer, dimension(n_multi_run):: iabsm, iabsorig
  integer, dimension(0:ntype):: icom, itequ, nlat, nrato, nrato_lapw, Numat
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(nopsm):: iopsymc, iopsymr
  integer, dimension(nrepm,2):: irep_util(nrepm,2)
  integer, dimension(2,npldafs):: isigpi
  integer, dimension(0:n_atom_proto,natomsym_max):: isymqa
  integer, dimension(norbdil):: itdil, ldil
  integer, dimension(ngroup_lapw):: its_lapw
  integer, dimension(ngroup):: itype
  integer, dimension(ngroup_pdb):: Kgroup
  integer, dimension(0:ntype,nlatm):: Lvval, nvval
  integer, dimension(0:n_atom_proto):: iapot, itypepr, Lmaxat, ngreq
  integer, dimension(0:n_atom_proto,0:mpinodes-1):: Lmax_dft
  integer, dimension(0:ngroup_nonsph):: norbv
  integer, dimension(npldafs):: nphi_dafs
  integer, dimension(npldafs_2d):: npl_2d
  integer, dimension(n_proto_layer_max,n_layer_abs):: igr_layer
  integer, dimension(5,npldafs_2d):: Operation_mode
  integer, dimension(3,3,nslapwm):: Wien_matsym
  integer, dimension(n_atom_bulk):: Z_bulk
  integer, dimension(n_atom_cap):: Z_cap
  integer, dimension(n_radius):: natomeq_s
  integer, dimension(2,0:ntype):: lcoeur, ncoeur

  integer, dimension(:), allocatable:: ia_eq_inv, ia_eq_inv_self, iaproto, iaprotoi, igroup, igroup_ato, igroup_dip, igroup_ion, &
     igroupi, imoy, imoy_out, is_f, is_g, isrt, isymeq, itypei, itypep, Lmaxa, Lval, n_zc_SRXRD, n_zc_SRXRD_abs, nb_eq, nbord, &
     nbordf, nlm_fe, nlmsa, nlmso0, numia

  integer, dimension(:,:), allocatable:: ia_eq, ibord, igr_z_SRXRD, igr_z_SRXRD_abs, index_coop, index_z_SRXRD_abs, indice, &
     iopsym_atom, is_eq, isbord, isvois, ivois, iso, Lso, m_f, m_g, mso, nb_rpr, nlmsa0

  integer, dimension(:,:,:), allocatable:: ia_rep, iato, Lato, mato, mpres, nb_rep_t

  integer, dimension(:,:,:,:), allocatable:: msymoo, msymooi

  character(len=5):: Struct
  character(len=Length_n):: Name
  character(len=8):: PointGroup
  character(len=Length_name):: nomfich, nomfichbav, nom_fich_extract, nomfich_s

  character(len=35), dimension(0:ntype):: Com
  character(len=Length_name), dimension(9):: Wien_file
  character(len=Length_name), dimension(n_multi_run+n_bulk_sup+n_abs_rgh):: nomfich_cal_conv, nomfich_cal_tddft_conv
  character(len=Length_name), dimension(:), allocatable:: File_name_rixs

  character(len=5), dimension(:), allocatable:: ltypcal
  character(len=Length_word), dimension(:), allocatable:: nomabs

  complex(kind=db):: f_avantseuil, f_cal
  complex(kind=db), dimension(npldafs,nphim):: Sum_Bragg_NR_Bulk, Sum_Bragg_NR_T, Sum_Bragg_NR_T_rgh_bulk, phdt_rgh_Bulk
  complex(kind=db), dimension(3,npldafs_e):: poldafsem, poldafssm
  complex(kind=db), dimension(nhybm,16,ngroup_nonsph):: Hybrid

  complex(kind=db), dimension(:,:), allocatable:: Bragg_abs, Bragg_rgh_bulk_abs, karact, pol, Sum_Bragg_abs_f0, &
                                                  Sum_Bragg_nonabs_f
  complex(kind=db), dimension(:,:,:), allocatable:: phdt, poldafse, poldafss, Wigner_one_half
  complex(kind=db), dimension(:,:,:,:), allocatable:: T_E1E1, T_E1E1_m, T_E1SP, T_E1SP_m, T_E1M1, T_E1M1_m, T_M1M1, T_M1M1_m, &
                                                      T_SPSP, T_SPSP_m, Taull_abs, TauLL_loc, V_hubb_abs, V_hubb_loc, V_hubb_t
  complex(kind=db), dimension(:,:,:,:,:), allocatable:: Ampl_dft, Ampl_abs, Phiato_c, rof0, S_nrixs, S_nrixs_m, &
                          T_E1E2, T_E1E2_m, T_E1M2, T_E1M2_m, Tau_ato, Tau_comp, Taull, Taull_dft, Tau_abs, Tau_abs_t, V_hubb, Ylms
  complex(kind=db), dimension(:,:,:,:,:,:), allocatable:: T_E1E3, T_E1E3_m, T_E3E3, T_E3E3_m, T_E2E2, T_E2E2_m, T_E2M2, T_E2M2_m, &
                                                          Tau_coop, Taull_stk
  complex(kind=db), dimension(:,:,:,:,:,:,:), allocatable:: Chi, RadialIntegral

  logical:: Abs_in_bulk, Abs_in_Bulk_roughness, Absorbeur, All_nrixs, Allsite, ATA, Analyzer, &
     Bulk_atom_done, Atom_comp_cal, Atom_nonsph, Atom_nonsph_loc, Atom_occ_hubb, Atomic_scr, Basereel, &
     Base_hexa, Base_ortho, Base_ortho_int, Base_ortho_sur, Bormann, BSC_SCF, Bulk, Bulk_atom_used, Bulk_step, Bulk_step_alone, &
     Circular, Clementi, Cal_xanes, Cap_layer, Cartesian_tensor, Center_s, Charge_free, Close_open_bav, Condition, COOP, &
     Coop_only_abs, Coop_z_along_bond, Core_energ_tot, Core_resolved, Counter_linear, Coupelapw, Dafs, Dafs_bio, Density, &
     Density_comp, Density_sp, Dipmag, Doping, Dyn_eg, Dyn_g, E_comp, E_cut_man, E1E1, E1E2, E1E2_imp, E1E2e, E1E3, E1M1, E1M2, &
     E2E2, E2M2, E3E3, Eneg, Eneg_i, Eneg_n_i, Energphot, Epsif_ref_man, Epsii_ref_man, Extract, &
     FDM_comp, Film, Final_optic, Final_tddft, First_E, &
     First_run, Flapw, Flapw_new, Force_ecr, Full_atom, Full_atom_e, Full_atom_gen, Full_potential, Full_self_abs, &
     Gamma_hole_man, Gamma_tddft, Green, Green_bulk, Green_int, Green_s, Green_self, Harm_cubic, Header, Helm_cos, &
     Helm_lin, Helm_mix, HERFD, Hubb_a, Hubb_abs, Hubb_d, Hubb_diag_abs, Hubbard, Image_charge, Kern_fast, korigimp, &
     Lmaxfree, Lmoins1, Lplus1, M1M1, Mag_axis_free, Magnetic, Matper, Moment_conservation, Moy_cluster, Moy_loc, Moyenne, &
     Muffintin, No_cluster_rotation, No_DFT, No_solsing, Non_resonant_bulk, Noncentre, Nonexc_g, Nonexc, Nonsph, Normaltau, &
     Not_centered, NRIXS, Octupole, One_run, One_run_L, One_run_s, One_SCF, One_SCF_surf, Only_abs, Only_indirect, Only_rixs, &
     Operation_mode_used, Optic, Optic_xanes, Other_xanes, Overad, PointGroup_Auto, Polarise, Powder, Proto_all, Python, &
     Quadrupole, Recop, Relativiste, Renorm, RIXS, RIXS_gen, RPALF, Rydberg, SCF, SCF_bulk, SCF_c, SCF_d, SCF_elecabs, &
     SCF_mag_free, SCF_smooth, Second_run, Second_SCF, Self_abs, Self_cons, Self_cons_bulk, Self_cons_c, Self_nonexc, &
     Solsing, Solsing_s, Solsing_o, Solsing_only, Spherical_signal, Spherical_tensor, Spin_axis_free, Spino, Spinorbite, &
     State_all, State_all_out, Supermuf, Sym_2D, Sym_4, Sym_cubic, Symmol, Tau_nondiag, Taux, Tddft, &
     Tddft_xanes, Trace_format_wien, Xan_atom, Ylm_comp, Ylm_comp_inp, Ylm_comp_loc

  logical, dimension(2):: Cylinder_cluster
  logical, dimension(3):: hkl_film
  logical, dimension(7):: SCF_log
  logical, dimension(n_multipole_max):: Multipole
  logical, dimension(nb_test):: Test_case
  logical, dimension(n_multi_run):: Skip
  logical, dimension(0:ntype):: Hubb
  logical, dimension(0:ngroup_m):: Atom_with_axe
  logical, dimension(0:n_atom_proto):: Proto_calculated

  logical, dimension(:), allocatable:: Atom_axe, Full_pot, Hubb_diag, Repres_comp

  real(kind=db):: Abs_cap, Abs_U_iso, adimp, alfpot, Bulk_roughness, Cal_Volume_maille, Cap_B_iso, Cap_roughness, &
    Cap_shift, Cap_thickness, Charge_ion, Chargm, Chargm_SCF, d_ecrant, D_max_pot, Delta_bulk, Delta_cap, Delta_edge, &
    Delta_En_conv, Delta_energ_s, Delta_Epsii, Delta_Eseuil,  Delta_film, Delta_Gauss_rixs, Delta_helm, Delta_int, &
    Delta_roughness_film, Delta_sur, delta_z_bottom_cap, Delta_z_lin, delta_z_top_bulk, &
    delta_z_top_cap, Delta_z_top_film, Dist_atom_min, E, E_cut, E_cut_imp, E_Fermi, E_moment, Ecent, Ecineticmax, Ecineticmax_out, &
    Eclie, Eclie_out, Ecmax, Ecmax_out, Ei0, Eii, Elarg, Em, Emission_energy, Energ_loss_max, Enervide, Ephot_min, &
    Epsif_moy, Epsii_moy, Epsif_ref, Epsii_ref, Estart, &
    Film_roughness, Film_thickness, Gamma_max, Kern_fac, Overlap, p_self, p_self_max, p_self0, p_self0_bulk, Pas_SCF, &
    phi_0, R_rydb, R_SCF_c, R_self, R_self_bulk, Ratio_S_ref_bulk, Ray_max_dirac, Rmax, Rmtg_abs, Rmtsd_abs, Roverad, Rpotmax, &
    rsbdc, rsbdc_out, Rsort, Rsorte, Surface_ref, Temp, Test_dist_min, Time_fill, Time_tria, tp_SCF_1, tp_SCF_2, tp_XANES_1, &
    tp_XANES_2, V_helm, V_helm_t, V_intmax, V0muf, Vhbdc, Vhbdc_p, Vhbdc_init, Vhbdc_out, Volume_maille, Vsphere, Vsphere_cal, &
    Width_helm

  real(kind=db), dimension(2):: Dist_coop, f_no_res, pop_open_val
  real(kind=db), dimension(3):: Angxyz, angxyz_bulk, angxyz_cap, angxyz_int, angxyz_sur, axyz, axyz_bulk, axyz_cap, &
                                axyz_int, axyz_sur, Centre, dcosxyz, deccent, deccent_bulk, dpos, E_moment_axis, Vec_orig, V_surf
  real(kind=db), dimension(4):: Film_shift, Interface_shift, Surface_shift
  real(kind=db), dimension(6):: Trace_p
  real(kind=db), dimension(7):: Time_loc
  real(kind=db), dimension(10):: Gamma_hole
  real(kind=db), dimension(3,3):: Cubmat, Mat_or, Mat_UB, Orthmat, Orthmati, Orthmatt, Rot_atom_abs, Rot_cluster, Rot_Spinor
  real(kind=db), dimension(n_rout):: Time_rout

  real(kind=db), dimension(n_adimp):: Adimp_e
  real(kind=db), dimension(npldafs_f):: Angle_or
  real(kind=db), dimension(3,npldafs):: Angpoldafs
  real(kind=db), dimension(3,npldafs_2d):: Angle_mode
  real(kind=db), dimension(3,ngroup_m):: Axe_atom_gr
  real(kind=db), dimension(3,n_layer_abs):: Center_abs_s
  real(kind=db), dimension(4,n_q_rixs):: q_rixs
  real(kind=db), dimension(0:n_atom_proto):: Chargat, Rmtg, Rmtg0, Rmtsd
  real(kind=db), dimension(norbdil):: cdil
  real(kind=db), dimension(n_adimp):: E_adimp
  real(kind=db), dimension(n_range):: E_max_range
  real(kind=db), dimension(n_radius):: E_radius
  real(kind=db), dimension(n_theta_rixs,2):: Theta_rixs
  real(kind=db), dimension(nspin):: dV0bdcF, Ecinetic, Ecinetic_e, Ecinetic_out, Ecrantage, V0bdc, V0bdc_e, &
                                    V0bdcF, V0bdcF_out, V0bdc_out, V0bdcFimp, VxcbdcF, VxcbdcF_out
  real(kind=db), dimension(neimagent):: Eeient, Eimagent
  real(kind=db), dimension(ngamme):: Egamme
  real(kind=db), dimension(nenerg_in_rixs):: Energ_rixs
  real(kind=db), dimension(npldafs):: Length_abs
  real(kind=db), dimension(n_shift_core):: Shift_core
  real(kind=db), dimension(0:ntype):: r0_lapw, Rchimp, Rionic_imp, Rlapw, Rmt, Rmtimp, V_hubbard
  real(kind=db), dimension(3,npldafs):: hkl_dafs
  real(kind=db), dimension(3,npldafs_e):: Vecdafsem, Vecdafssm
  real(kind=db), dimension(-m_hubb_e:m_hubb_e,-m_hubb_e:m_hubb_e,nspin,ngroup_hubb):: Occ_hubb_e
  real(kind=db), dimension(nple,2):: Pdpolar
  real(kind=db), dimension(3,nple):: Polar, Veconde
  real(kind=db), dimension(nhybm,ngroup_nonsph):: pop_nonsph
  real(kind=db), dimension(ngroup,nlatm,nspin):: Popats
  real(kind=db), dimension(0:ntype,nlatm):: Popatv
  real(kind=db), dimension(0:ntype,nlatm,nspin):: Popval
  real(kind=db), dimension(3,n_atom_uc):: Posn
  real(kind=db), dimension(3,n_atom_bulk):: Posn_bulk
  real(kind=db), dimension(3,n_atom_cap):: Posn_cap
  real(kind=db), dimension(4,nq_nrixs):: q_nrixs
  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(3,3,ngroup_m):: Rot_Atom_gr
  real(kind=db), dimension(3,3,ngroup_nonsph):: Rot_Atom_nsph
  real(kind=db), dimension(3,3,ngroup_lapw):: Rotloc_lapw
  real(kind=db), dimension(n_radius):: Rsorte_s
  real(kind=db), dimension(n_atom_cap):: Taux_cap
  real(kind=db), dimension(ngroup_taux):: Taux_oc
  real(kind=db), dimension(n_temp,ngroup):: Temp_coef
  real(kind=db), dimension(3,nslapwm):: Wien_taulap
  real(kind=db), dimension(nbseuil):: Eseuil
  real(kind=db), dimension(0:nrm,2,0:ntype):: Psi_coeur
  real(kind=db), dimension(nrm,nbseuil):: Psii
  real(kind=db), dimension(0:nrm,nlatm,0:ntype):: Psival
  real(kind=db), dimension(0:n_atom_proto,nlatm,nspin):: Popatm
  real(kind=db), dimension(nrm,2):: psi_open_val
  real(kind=db), dimension(0:nrm,0:ntype):: Rato, rhoit, rho_coeur
  real(kind=db), dimension(n_atom_proto):: Taux_ipr

  real(kind=db), dimension(:), allocatable:: Abs_SRXRD, Abs_SRXRD_abs, cgrad, clapl, dExc_ex_nex, dista, distai, dvc_ex_nex, &
     E_Emis, Eimag, Eimag_s, Energ, Energ_s, Enervide_t, Epsii, Epsif, Exc, Exc_abs_i, &
     poidso, poidsov, poidsov_out, Pos_z_SRXRD, Pos_z_SRXRD_abs, r, rato_abs, rsato_abs, &
     rhons, rs, rvol, sec_atom, Taux_eq, Vc, Vc_abs_i, Vh, Vhns
  real(kind=db), dimension(:,:), allocatable:: coef_f, Coef_g, Axe_atom_clu, Chargat_init, chargat_init_bulk, Chargat_self, &
     chargat_self_bulk, drho_ex_nex, dv_ex_nex, Ecinetic_a, Excato, Int_tens, pdp, poidsa, pop_orb_val_bulk, &
     Pos, Pos_ato, Pos_dip, Pos_ion, Posi, posi_self, Psi_emis, &
     rho, rhoato_abs,rsato, V_abs_i, Vcato_abs, Vcato_init_bulk, Vmft, Vr, Vxc, Vxc_a, Vec, xyz, Ylmso
  real(kind=db), dimension(:,:,:), allocatable:: gradvr, Int_statedens, rhoato, rhoato_init, rhoato_init_bulk, &
     rhoato_out, rhoato_out_bulk, Rot_atom, Rot_atom_spin, Rot_atomp, Vcato, Vcato_bulk, Vcato_init, Vecdafse, Vecdafss, Vra, &
     Vrato_e, Vxcato_abs, Ylmato
  real(kind=db), dimension(:,:,:,:), allocatable:: rho_self, rho_self_bulk, Vrato, Vxcato
  real(kind=db), dimension(:,:,:,:,:), allocatable:: Coverlap, drho_self, Phiato
  real(kind=db), dimension(:,:,:,:,:,:), allocatable:: Statedens, Statedens_i

  real(kind=sg):: time

  call MPI_Comm_Rank(MPI_COMM_MUMPS,mpirank_in_mumps_group,mpierr)

  Bulk_atom_done = .false.
  Delta_bulk = 0._db
  Delta_energ_s = 0._db
  Full_atom_gen = .true.
  ia_coop(:) = 0
! Moy_cluster is a test variable on the interatomic average potentiel calculation
! When false (and Green), the average is calculated in the close surrounding of the absorbing atom.
! Otherwise it is in all the area (cluster) of calculation
! True was found better
  Moy_cluster = .true.
  iaabsfirst = 0
  E1E2e = Multipole(2)
  SCF_elecabs = SCF_log(1); SCF_mag_free = SCF_log(2); Self_cons = SCF_log(3); Self_nonexc = SCF_log(4); SCF = SCF_log(5)
  Self_cons_bulk = SCF_log(6); SCF_bulk = SCF_log(7)
  Surface_ref = 0._db

  nseuil = P_seuil(1); Lseuil = P_seuil(2); Jseuil = P_seuil(3)
  n_Emis = P_Emis(1); L_emis = P_Emis(2); J_emis = P_emis(3); nb_Emis = P_Emis(4)

! Band structure calculation
  if( BSC_SCF ) then
!    Adimp = Adimp_e(1)
!    call Band_Structure(Adimp,alfpot,Angxyz,Axyz,iabsorig,icheck,icom,Com,Ecrantage,Hubb,igreq, &
!    itype,Jseuil,Lecrantage,Lmax_pot,Lseuil,m_hubb_e,mpinodes0,mpirank0,n_atom_proto,n_atom_uc,n_multi_run,nb_test,necrantage, &
!    neqm,ngreq,ngroup,ngroup_hubb,nlat,nlatm,nlm_pot,nomfich,nrato_dirac,nrm,nself,nseuil,nspin,ntype,Numat,nvval,Occ_hubb_e, &
!    Overlap,PointGroup,PointGroup_auto,Popats,Popval,Posn,Relativiste,Rchimp,Rionic_imp,Rmt,Rmtimp,Spinorbite,Test_case,V_hubbard)
  endif

  allocate( E_Emis(nb_Emis) )
  allocate( Psi_Emis(nrm,nb_Emis) )

  L0_nrixs = 0
  if( Dipmag ) then
    ip0 = 0
  else
    ip0 = 1
  endif
  if( Octupole ) then
    ip_max = 3
  elseif( Quadrupole .or. Multipole(13) ) then
    ip_max = 2
  else
    ip_max = 1
  endif

  do ipr = 1,n_atom_proto
    if( Taux ) then
      Taux_ipr(ipr) = sum( Taux_oc(abs( igreq(ipr,1:ngreq(ipr)) )) ) / ngreq(ipr)
    else
      Taux_ipr(ipr) = 1._db
    endif
  end do

! Lmax for density of state
  lla_state = max( 4, Lmax_pot )
  lla2_state = ( lla_state + 1 )**2

  RIXS_gen = RIXS .or. HERFD

  if( Film ) then
    ich = icheck(6)
  ! Film_thickness is reduced to be the distance between top most and botom most atoms

    call Prep_Film(angxyz,angxyz_bulk,angxyz_cap,angxyz_int,angxyz_sur,axyz,axyz_bulk,axyz_cap,axyz_int,axyz_sur, &
               Bulk_roughness,Cap_shift,Cap_roughness,Cap_thickness,Delta_bulk,Delta_cap,Delta_int,Delta_film, &
               Delta_roughness_film,Delta_sur,delta_z_bottom_cap,delta_z_top_bulk,delta_z_top_cap,delta_z_top_film, &
               Film_shift,Film_roughness,Film_thickness,hkl_film,ich,Interface_shift,itype,n_atom_bulk,n_atom_cap,n_atom_int, &
               n_atom_per,n_atom_sur,n_atom_uc,ngroup,ntype,Numat,Posn,Posn_bulk, &
               Posn_cap,Ratio_S_ref_bulk,Surface_ref,Surface_shift)
  endif

! When Extract there is no parallelization in the energy loop.
! Parallelization remains for tddft
  if( Extract ) then
    mpinodee = 1
    mpinodee0 = 1
  else
    mpinodee = mpinodes
    mpinodee0 = mpinodes0
  endif

  if( Optic ) then
    ninit1 = 0; ninit = 0
    nfinal1 = 0; nfinal = 0
  else
    call dim_init(jseuil,Lseuil,nbseuil,ninit1,ninit)
    if( HERFD ) then
      call dim_init(J_Emis,L_Emis,nb_emis,nfinal1,nfinal)
    else
      nfinal1 = 0
      nfinal = 0
    endif
  endif
  allocate( Coef_g(ninit,2) )
  allocate( m_g(ninit,2) )
  allocate( is_g(ninit) )
  allocate( coef_f(nfinal,2) )
  allocate( m_f(nfinal,2) )
  allocate( is_f(nfinal) )
  if( .not. Optic ) then
    call coef_init(Coef_g,is_g,ninit,jseuil,Lseuil,m_g,nbseuil)
    if( HERFD ) call coef_init(coef_f,is_f,nfinal,J_Emis,L_Emis,m_f,nb_Emis)
  endif

!-------------------------------------------------

  if( Extract ) then
    if( mpinodes > 1 ) then
    call MPI_Bcast(Green_s,1,MPI_LOGICAL,0,MPI_COMM_WORLD,mpierr)
    endif
  else
    allocate( Energ_s(nenerg_s) )
    allocate( Eimag_s(nenerg_s) )
    call grille_xanes(eeient,Eimag_s,eimagent,Egamme,Energ_s,icheck(4),Lin_gam,ngamme,neimagent,nenerg_s)
  endif

  if( Multipole(7) ) then
    n_oo = 9   ! E3E3
  else
    n_oo = 0
  endif
  allocate( msymoo(3,n_oo,3,n_oo) )
  allocate( msymooi(3,n_oo,3,n_oo) )

! Variable to know if an absorbing atom is in the bulk
! In that case, there is an energy dependant truncature factor calculated in coabs/convolution and not in prepdafs.
  Abs_in_bulk = .false.
  do multi_run = 1,n_multi_run
    iabsorbeur = iabsm(multi_run)
    if( iabsorbeur > ngroup - n_atom_bulk ) then
      Abs_in_bulk = .true.
      exit
    endif
  end do

  multi_0 = 0

  n_abs_bulk = 0
  do multi_run = 1,n_multi_run
    if( iabsm(multi_run) > ngroup - n_atom_bulk ) n_abs_bulk = n_abs_bulk + 1
  end do

  i_layer = 0

!- Loop over non equivalent atoms ---------------------------------------------------------------------------

  boucle_multi: do multi_run_e = 1,n_multi_run

    if( Abs_in_bulk ) then
      multi_run = n_multi_run + 1 - multi_run_e
    else
      multi_run = multi_run_e
    endif

    if( Skip(multi_run) ) then
      multi_0 = multi_0 + 1
      cycle
    endif

    if( icheck(4) > 0 ) write(3,110) iabsorig(multi_run)

    iabsorbeur = iabsm(multi_run)

    Bulk_step = Bulk .and. iabsorbeur > ngroup - n_atom_bulk
    Bulk_step_alone = Bulk_step .and. .not. One_SCF_surf

! The One-run option, when used, is not used in the bulk.
    if( Bulk_step ) then
      One_run_L = .false.
    else
      One_run_L = One_run .or. One_run_s
      if( One_run_s ) then
        Loop_layer: do i_layer = 1,n_layer_abs
          do i = 1, n_proto_layer(i_layer)
            if( igr_layer(i,i_layer) == iabsm(multi_run) ) exit Loop_layer
          end do
        end do Loop_layer
      endif
    endif

    if( Doping ) then
! Used just for the atom position
      iabsfirst = igr_dop
    elseif( One_run_L ) then
      if( One_run_s ) then
        iabsfirst = igr_layer(n_proto_layer(i_layer),i_layer)
      else
        if( Abs_in_Bulk ) then
          iabsfirst = iabsm( n_multi_run - n_abs_bulk )
        else
          iabsfirst = iabsm(1)
        endif
      endif
    else
      iabsfirst = iabsorbeur
    endif

    if( One_run_s ) then
      First_run = iabsorbeur == iabsfirst
      Second_run = .not. First_run
    else
      First_run = .not. One_run_L &
                .or. ( One_run_L .and. ( ( multi_run_e == 1 .and. .not. Abs_in_bulk ) .or. &
                        ( multi_run == n_multi_run - n_abs_bulk .and. Abs_in_bulk ) ) )
      Second_run = multi_run_e > n_abs_bulk + 1 .and. One_run_L
     endif

    Second_SCF = ( multi_run_e > n_abs_bulk + 1 .and. One_SCF ) .or. ( multi_run_e > 1 .and. One_SCF_surf )

    multi_imp = multi_run_e

    if( Spinorbite ) then
      Tau_nondiag = .true.
    else
      Tau_nondiag = .false.
    endif
    if( Doping ) then
      itabs_nonexc = abs( itype_dop )
    else
      itabs_nonexc = abs(itype(iabsorbeur))
    endif
    numat_abs = Numat( itabs_nonexc )

    call Esdata(Eseuil,icheck(4),jseuil,nbseuil,nseuil,numat_abs,mpirank0)
    do i = 1,nb_emis
      J = J_emis + i - 1
      E_emis(i) = Emission_energy(icheck(4),J,Jseuil+i-1,n_emis,nseuil,numat_abs)
    end do

! ninitr become 1 for the Tddft cycle.
    if( Core_resolved ) then
      if( Optic ) then
       ! In optics, there is one output per "l" plus the total.
        if( numat_abs_1 <= 4 ) then
          ninitr = 1
        elseif( numat_abs_1 > 4 .and. numat_abs_1 <= 20 ) then
          ninitr = 2
        elseif( numat_abs_1 > 21 .and. numat_abs_1 <= 56 ) then
          ninitr = 3
        else
          ninitr = 4
        endif
        ninitr = ninitr + 1
        nfinalr = 0
      else
        ninitr = ninit
        nfinalr = nfinal
      endif
    else
      ninitr = nbseuil
      nfinalr = nb_Emis
    endif

    allocate( Epsii(ninitr) )
    Epsii(:) = 0._db
    Epsii_moy = 0._db
    allocate( Epsif(nfinalr) )
    Epsif(:) = 0._db
    Epsif_moy = 0._db

    nomfich_s = nomfich
    Final_tddft = .false.
    Final_optic = .false.

! Maximum number of atomic orbitals
    nnlm = 0
    do it = 1,ntype
      n = n_orb_rel( Numat(it) )
      if( Numat(it) == numat_abs )then
        n = n + 2 * max( 1, nlat(it) ) + 2
      elseif( nlat(it) > 0 ) then
        n = n + 2 * nlat(it)
      endif
      nnlm = max( nnlm, n )
    end do

    Sym_2D = iabsorbeur > n_atom_per .and. .not. Bulk_step_alone .and. .not. Doping
    Abs_in_Bulk_roughness = Bulk_step .and. Bulk_roughness > eps10

    if( Bulk_step_alone ) then
      SCF_c = SCF_bulk
      Self_cons_c = Self_cons_bulk
    else
      SCF_c = SCF
      Self_cons_c = Self_cons
    endif
    if( One_SCF_surf .and. .not. Bulk_step ) then
      SCF_d = .false.
    else
      SCF_d = SCF_c
    endif

    if( Sym_2D .or. .not. Matper ) then
      V_helm_t = V_helm
    else
      V_helm_t = 0._db
    endif
    call init_run(Bulk_step,cdil,Chargat,Charge_free,Chargm,Chargm_SCF,Clementi,Com,Counter_ato,Counter_ion,Doping,Ecrantage, &
      Flapw,Force_ecr,Hubb,iabsorbeur,iabsorig(multi_run),icheck(4),icom,igreq,iprabs,iprabs_nonexc, &
      itabs,itdil,itype,itype_dop,itypepr,Jseuil,Lcoeur,Ldil,Lecrantage,Lseuil,Lvval,mpinodee0,mpirank0, &
      n_atom_bulk,n_atom_proto,n_counter_ato,n_counter_ion,n_multi_run,n_orbexc,nb_Emis,nbseuil,ncoeur, &
      necrantage,neqm,ngreq,ngroup,nlat,nlatm,nnlm,nomfich_s,Nonexc,norbdil,nrato,nrato_dirac,nrato_lapw,nrm,nseuil,nspin,ntype, &
      Numat,numat_abs,nvval,P_Emis,Pop_open_val,Popatm,Popats,Popatv,Popval,Psi_Emis,Psi_coeur,Psii,psi_open_val,psival,r0_lapw, &
      Rato,Ray_max_dirac,Rchimp,Relativiste,rho_coeur,rhoit,Rionic_imp,Rlapw,Rmt,Rmtimp,Self_nonexc,V_hubbard,Wien_file(8))

    nrato_abs = nrato(itabs)

    if( Doping ) then
      natomsym = ngreq(ipr_dop)
    else
      natomsym = ngreq(iprabs_nonexc)
    endif

    allocate( isymeq(natomsym) )
    allocate( Taux_eq(natomsym) )

    if( Doping ) then
      isymeq(1:natomsym) = isymqa(ipr_dop,1:natomsym)
    else
      isymeq(1:natomsym) = isymqa(iprabs_nonexc,1:natomsym)
    endif

    if( Taux ) then
      Taux_eq(1:natomsym) = Taux_oc( abs( igreq(iprabs_nonexc,1) ) )
    else
      Taux_eq(1:natomsym) = 1._db
    endif

    if( n_temp == 1 ) then
      Abs_U_iso = Temp_coef(1, abs( igreq(iprabs_nonexc,1) ) ) / ( 8 * pi**2 )
    elseif( n_temp > 1 ) then
      Abs_U_iso = sum( Temp_coef(1:3, abs( igreq(iprabs_nonexc,1) ) ) ) / ( 3 * 8 * pi**2 )
    else
      Abs_U_iso = 0._db
    endif

    if( Hubbard ) then
      m_hubb = 0
      do it = 0,ntype
        lh = L_hubbard(Numat(it))
        if( Hubb(it) ) m_hubb = max( m_hubb, lh)
      end do
    else
      m_hubb = 0
    endif
    allocate( V_hubb_abs(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp) )
    allocate( V_hubb_loc(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp) )

    if( Extract ) then

      allocate( rato_abs(nrato_abs) )
      allocate( rsato_abs(nrato_abs) )
      allocate( rhoato_abs(nrato_abs,nspin) )
      allocate( Vcato_abs(nrato_abs,nlm_pot) )
      allocate( Vxcato_abs(nrato_abs,nlm_pot,nspin) )
      call Potential_reading(Delta_Eseuil,dV0bdcf,E_cut,E_Fermi,Ecineticmax,Epsii,Epsii_moy,Hubb_abs,Hubb_diag_abs, &
                             m_hubb,mpinodes,mpirank0,multi_run_e,ninitr,nlm_pot,nom_fich_extract,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)

      if( multi_run_e == 1 ) then
        if( mpirank0 == 0 ) nenerg_s = extract_nenerg(multi_imp,nom_fich_extract,Optic,.false.)
        if( mpinodes > 1 ) then
          call MPI_Bcast(nenerg_s,1,MPI_INTEGER,0,MPI_COMM_WORLD,mpierr)
        endif
        allocate( Energ_s(nenerg_s) )
        allocate( Eimag_s(nenerg_s) )
        if( mpirank0 == 0 ) call extract_energ(Energ_s,Eseuil,multi_imp,nbseuil,nbseuil,nenerg_s,nom_fich_extract,Optic,.false.)
        if( mpinodes > 1 ) then
          call MPI_Bcast(Energ_s,nenerg_s,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
          call MPI_Bcast(Eimag_s,nenerg_s,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
        endif
      endif

! Just useful for iaabsi
      Rmtsd(:) = Rmtsd_abs
      Rmtg(:) = Rmtg_abs

    endif

    if( Bulk_step ) then
      call Cal_Cubmat(angxyz_bulk,Cubmat,Struct)
      Not_centered = .false.
    else
      call Cal_Cubmat(angxyz,Cubmat,Struct)
      if( One_run_s ) then
        Not_centered = .true.
        Centre(:) = Center_abs_s(:,i_layer)
      else
        Not_centered = Noncentre
      endif
    endif

    if( ( multi_run_e == 1 .and. .not. Abs_in_bulk ) .or. First_run ) then
      call init_clust(angxyz,angxyz_bulk,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho,Bulk_step,Center_s,Centre,dcosxyz,deccent, &
        Dist_atom_min,iabsfirst,multrmax,n_atom_bulk,n_atom_int,n_atom_per,n_atom_uc,n_radius,ngroup,Noncentre,One_run_s,Posn, &
        Posn_bulk,R_SCF_c,R_self,R_self_bulk,Rmax,Rpotmax,Rsorte_s)

      if( Bulk_step ) deccent_bulk(:) = deccent(:)

      d_ecrant = 1 - sum( Ecrantage(:) )
! Calculation of the number of atoms in the clusters used for potential calculation and xanes calculation
      call natomp_cal(angxyz,angxyz_bulk,angxyz_int,angxyz_sur,ATA,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho,Base_ortho_int, &
        Base_ortho_sur,Bulk,Bulk_step,Center_s,Chargat,Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster,d_ecrant,dcosxyz, &
        deccent,deccent_bulk,Delta_bulk,Delta_film,Delta_int,Delta_sur,Dist_atom_min,Doping,dpos,Film_shift,Film_thickness, &
        First_run,Flapw, &
        iabsorbeur,iabsfirst,icheck(5),igr_dop,igreq,Interface_shift,itabs,itype,Kgroup,Matper,mpirank0,n_atom_bulk,n_atom_int, &
        n_atom_per,n_atom_proto,n_atom_proto_uc,n_atom_sur,n_atom_uc,n_counter_ato,n_counter_dip,n_counter_ion,n_radius, &
        natomeq_coh,natomeq_s,natomp,natomp_ato,natomp_dip,natomp_ion,neqm,ngreq,ngroup,ngroup_pdb,ngroup_taux,Not_centered,Posn, &
        One_SCF_surf,Posn_bulk,Proto_all,R_SCF_c,rsorte_s,Rmax,Surface_shift,Sym_2D,Taux_oc)
    endif

    allocate( Axe_atom_clu(3,natomp) )
    allocate( iaproto(natomp) )
    allocate( igroup(natomp) )
    allocate( igroup_ato(natomp_ato) )
    allocate( igroup_dip(natomp_dip) )
    allocate( igroup_ion(natomp_ion) )
    allocate( itypep(natomp) )
    allocate( dista(natomp) )
    allocate( Pos(3,natomp) )
    allocate( Pos_ato(3,natomp_ato) )
    allocate( Pos_dip(3,natomp_dip) )
    allocate( Pos_ion(3,natomp_ion) )
    allocate( Rot_atom_spin(3,3,natomp) )
    allocate( karact(nopsm,nrepm) )

    ich = icheck(5)

! Elaboration of the cluster for SCF and XANES steps. Their radius can be different
    call Agregat( angxyz, angxyz_bulk, angxyz_int, angxyz_sur, ATA, Atom_with_axe, Axe_atom_clu, Axe_atom_gr, &
          axyz, axyz_bulk, axyz_int, axyz_sur, Base_hexa, Base_ortho, Base_ortho_int, Base_ortho_sur, Bulk, &
          Bulk_step, Center_s, Chargat, Charge_ion, Counter_ato, Counter_dip, Counter_ion, Cubmat, Cylinder_cluster, dcosxyz, &
          deccent, deccent_bulk, Delta_bulk, Delta_film, Delta_int, Delta_sur, Dist_atom_min, dista, Doping, dpos, &
          E_moment_axis, Film_shift, Film_thickness, First_run, &
          iaabs, iaabsfirst, iabsorbeur, iabsfirst, iaproto, iapot, ich, igr_dop, igreq, igroup, igroup_ato, igroup_dip, &
          igroup_ion, igrpt_nomag, igrpt0, Interface_shift, iopsymc, iopsymr, itabs, itype, itypep, karact, Kgroup, &
          Mag_axis_free, Magnetic, Matper, mpirank0, n_atom_bulk, n_atom_int, n_atom_per, n_atom_proto, n_atom_sur, n_atom_uc, &
          n_counter_ato, n_counter_dip, n_counter_ion, natomp, natomp_ato, natomp_dip, natomp_ion, nb_rep, nb_sym_op, neqm, ngreq, &
          ngroup, ngroup_m, ngroup_pdb, ngroup_taux, nlat, nlatm, No_cluster_rotation, Not_centered, nspin, ntype, &
          Numat, One_SCF_surf, Orthmat, Orthmati, Orthmatt, PointGroup, PointGroup_Auto, Popats, Pos, Pos_ato, Pos_dip, Pos_ion, &
          Posn, Posn_bulk, R_SCF_c, Rmax, Rot_Atom_gr, Rot_atom_spin, Rot_cluster, Rot_Spinor, Self_nonexc, Spin_axis_free, &
          Spinorbite, Struct, Surface_shift, Sym_2D, Sym_4, Sym_cubic, Symmol, Taux, Taux_oc, Test_dist_min )

    if( Ylm_comp_inp .and. .not. ( Atom_comp_cal(igrpt0) .or. igrpt_nomag <= 5 ) ) then
      if( mpirank0 == 0 ) then
        call write_error
        do ipr = 6,9,3
          write(ipr,'(//A//)') ' Complex spherical harmonics not compatible with the point group !'
        end do
      endif
      stop
    endif

    Ylm_comp = Ylm_comp_inp .or. Atom_comp_cal(igrpt0)

! nspinorb = 2 when magnetic without spin-orbit
! nspinorb = 1 when non-magnetic or spin-orbit
! nspino = 2 when spin-orbit
    if( nspin == 1 .or. Spinorbite ) then
      nspinorb = 1
    else
      nspinorb = 2
    endif

    i_radius = 1
    i_adimp = 1
    i_range = 1

!-------------------------------------------------------------------------------------------------

    if( Bulk_step ) then
      Rsorte = R_self_bulk
    else
      Rsorte = R_self
    endif
    adimp = adimp_e(1)

    if( Self_cons_c ) then
! Number of atom in the small symmetrized cluster for the SCF calculation
      natome_self = natome_cal(igrpt_nomag,iopsymr,mpirank0,natomeq_coh,natomp,Pos)
    else
      natome_self = 0
    endif

! Number of atom in the small symmetrized cluster for the XANES calculation
    natome = natome_cal(igrpt_nomag,iopsymr,mpirank0,natomeq_s(1),natomp,Pos)

! The atoms used to describe the potential can be the non-equivalent ones of the unit cell, or the non-equivalent ones
! of the cluster.
    if( multi_run_e == 1 ) then
 !   Full_atom = ( Full_atom_e  .or. ( Self_cons_c .and. .not. ( Self_nonexc .and. Proto_all ) ) &
 !                     .or. ( natome <= n_atom_proto + 1 .and. .not. Bulk_step ) &
 !                    .or. ( natome <= n_atom_proto_bulk + 1 .and. Bulk_step ) ) .and. .not. Flapw
      Full_atom = ( Full_atom_e  .or. ( Self_cons_c .and. .not. Self_nonexc ) &
                     .or. ( natome <= n_atom_proto - n_atom_proto_bulk .and. .not. Bulk_step ) &
                     .or. ( natome <= n_atom_proto_bulk .and. Bulk_step_alone ) &
                     .or. sum( abs( E_moment_axis(:) ) ) > eps10 ) &
                     .and. .not. Flapw
      Full_atom_gen = Full_atom
    else
      Full_atom = Full_atom_gen
    endif

    if( Full_atom ) then
      n_atom_0 = 1
      n_atom_ind = natome
    else
      if( Nonexc ) then
        n_atom_0 = 1
      else
        n_atom_0 = 0
      endif
      n_atom_ind = n_atom_proto
    endif

    if( Self_cons_c ) then
      if( Self_nonexc .or. Full_atom ) then
         n_atom_0_self = 1
      else
         n_atom_0_self = 0
      endif
      if( Full_atom ) then
        n_atom_ind_self = natome_self
      else
        n_atom_ind_self = n_atom_proto
      endif
      natomeq_self = natomeq_coh
      nrm_self = nrm
    else
      n_atom_0_self = 0
      n_atom_ind_self = 0
      natome_self = 0
      natomeq_self = 0
      nrm_self = 0
    endif

    allocate( ia_eq_inv_self(natomeq_self) )
    ia_eq_inv_self(:) = 0

    if( .not. Extract ) then
      if( multi_run_e == 1 .and. Self_cons_c ) then
        allocate( chargat_init_bulk(n_atom_proto-n_atom_proto_bulk+1:n_atom_proto,nspin))
        allocate( chargat_self_bulk(n_atom_proto-n_atom_proto_bulk+1:n_atom_proto,nspin))
        allocate( pop_orb_val_bulk(n_atom_proto-n_atom_proto_bulk+1:n_atom_proto,nspin) )
        allocate( rho_self_bulk(0:nrm_self,nlm_pot,nspin,n_atom_proto-n_atom_proto_bulk+1:n_atom_proto))
        allocate( rhoato_init_bulk(0:nrm_self,nspin,n_atom_proto-n_atom_proto_bulk+1:n_atom_proto) )
        allocate( rhoato_out_bulk(0:nrm_self,nspin,n_atom_proto-n_atom_proto_bulk+1:n_atom_proto))
        allocate( Vcato_bulk(0:nrm_self,nlm_pot,n_atom_proto-n_atom_proto_bulk+1:n_atom_proto) )
        allocate( Vcato_init_bulk(0:nrm_self,n_atom_proto-n_atom_proto_bulk+1:n_atom_proto) )
        chargat_init_bulk(:,:) = 0._db
        chargat_self_bulk(:,:) = 0._db
        pop_orb_val_bulk(:,:) = 0._db
        rho_self_bulk(:,:,:,:) = 0._db
        rhoato_init_bulk(:,:,:) = 0._db
        rhoato_out_bulk(:,:,:) = 0._db
        Vcato_bulk(:,:,:) = 0._db
        Vcato_init_bulk(:,:) = 0._db
      endif

      if( .not. Second_SCF ) then
        allocate( Chargat_init(n_atom_0_self:n_atom_ind_self,nspin))
        allocate( Chargat_self(n_atom_0_self:n_atom_ind_self,nspin))
        allocate( dExc_ex_nex(nrm) )
        allocate( drho_ex_nex(nrm,nspin) )
        allocate( dvc_ex_nex(nrm) )
        allocate( dv_ex_nex(nrm,nspin) )
        allocate( rho_self(0:nrm_self,nlm_pot,nspin,n_atom_0_self:n_atom_ind_self) )
        allocate( rhoato_init(0:nrm_self,nspin,n_atom_0_self:n_atom_ind_self) )
        allocate( rhoato_out(0:nrm_self,nspin,n_atom_0_self:n_atom_ind_self) )
        allocate( Vcato_init(0:nrm_self,nlm_pot,n_atom_0_self:n_atom_ind_self) )
        Chargat_init(:,:) = 0._db
        Chargat_self(:,:) = 0._db
        rho_self(:,:,:,:) = 0._db
        rhoato_init(:,:,:) = 0._db
        rhoato_out(:,:,:) = 0._db
        Vcato_init(:,:,:) = 0._db
        dExc_ex_nex(:) = 0._db
        drho_ex_nex(:,:) = 0._db
        dv_ex_nex(:,:) = 0._db
        dvc_ex_nex(:) = 0._db
      endif

      allocate( Exc_abs_i(nrm) )
      allocate( V_abs_i(nrm,nspin) )
      allocate( Vc_abs_i(nrm) )
      if( .not. ( Bulk_step .or. Full_atom .or. ( One_SCF_Surf .and. multi_run_e > 1 ) ) .and. Self_nonexc .and. Self_cons_c ) then
        do ipr = n_atom_proto-n_atom_proto_bulk+1, n_atom_proto
          Chargat_init(ipr,:) = chargat_init_bulk(ipr,:)
          Chargat_self(ipr,:) = chargat_self_bulk(ipr,:)
          rho_self(:,:,:,ipr) = rho_self_bulk(:,:,:,ipr)
          rhoato_init(:,:,ipr) = rhoato_init_bulk(:,:,ipr)
          rhoato_out(:,:,ipr) = rhoato_out_bulk(:,:,ipr)
          Vcato_init(:,1,ipr) = Vcato_init_bulk(:,ipr)
        end do
      endif
    endif

    allocate( Hubb_diag(n_atom_0_self:n_atom_ind_self) )
    Hubb_diag(:) = .true.

    allocate( Posi_self(3,natome_self) )
    allocate( V_hubb(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp,n_atom_0_self:n_atom_ind_self) )
    V_hubb(:,:,:,:,:) = (0._db, 0._db)

!------ SCF ----------------------------------------------------------------------------------------------------------------------------------

! Self_cons_c = nself_c > 0
    if( Self_cons_c .and. .not. ( Second_run .or. Second_SCF .or. BSC_SCF ) ) then

      if( mpirank0 == 0 ) then
        call CPU_TIME(time)
        tp_SCF_1 = real(time,db)
      endif

      call SCF_step( Adimp, alfpot, Atom_occ_hubb, Atom_with_axe, Axe_atom_clu, Axe_atom_gr, &
        axyz, Base_hexa, Basereel, Bulk_atom_done, Bulk_step_alone, Charge_ion, Chargm_SCF, Chargat, Chargat_init, &
        Chargat_self, Counter_ato, Counter_dip, Counter_ion, Counter_linear, D_max_pot, Delta_En_conv, Delta_helm, Delta_z_lin, &
        Density, Density_comp, Density_sp, dExc_ex_nex, Dist_coop, Doping, drho_ex_nex, dv_ex_nex, dvc_ex_nex, dista, dV0bdcF, &
        E_cut, E_moment, E_moment_axis, E_Fermi, Eclie, Eclie_out, Exc_abs_i, FDM_comp, Flapw, Full_atom, Full_potential, &
        Green_self, Helm_cos, Helm_lin, Helm_mix, Hubb, Hubb_diag, Hubbard, Hybrid, i_self, ia_eq_inv_self, iaabs, &
        iaabsfirst, iabsorbeur, iapot, iaproto, icheck, igreq, igroup, igroup_ato, igroup_dip, igroup_ion, igrpt_nomag, igrpt0, &
        Image_charge, iopsymr, iord, ipr_dop, iprabs, iprabs_nonexc, isymeq, itabs, itabs_nonexc, itequ, itype, itypep, itypepr, &
        Jseuil, karact, korigimp, Lcoeur, LLa_state, LLa2_state, Lmax_pot, Lmaxat0, Lmax_DOSout, Lmaxfree, Lmaxso_max, &
        Lmaxso0, Lseuil, Lvval, m_hubb, m_hubb_e, Mag_axis_free, Magnetic, Matper, Moy_cluster, mpirank, mpirank0, mpinodes, &
        mpinodes0, Muffintin, n_atom_0, n_atom_0_self, n_atom_ind_self, n_atom_proto, n_atom_proto_bulk, n_atom_proto_uc, &
        n_counter_ato, n_counter_dip, n_counter_ion, n_devide, n_rout, natome_self, natomeq_self, &
        natomp, natomp_ato, natomp_dip, natomp_ion, natomsym, nb_test, nb_rep, nb_sym_op, ncoeur, neqm, ngreq, ngroup, &
        ngroup_hubb, ngroup_m, ngroup_nonsph, nlat, nlatm, nlm_pot, Nomfich_s, Nonexc, norbv, Normaltau, Normrmt, nrato, nrm, &
        nrm_self, nself, nself_bulk, nseuil, nspin, nspino, nspinp, ntype, Numat, numat_abs, nhybm, Occ_hubb_e, One_SCF_Surf, &
        Optic, Orthmati, &
        Overad, Overlap, p_self, p_self_max, p_self0, p_self0_bulk, Pas_SCF, Pop_nonsph, Pop_open_val, Pop_orb_val_bulk, &
        Popatm, Popats, Popatv, Pos, Pos_ato, Pos_dip, Pos_ion, Posi_self, Proto_calculated, psi_coeur, psi_open_val, Psival, &
        R_rydb, Rato, Rchimp, Relativiste, rho_coeur, rho_self, rho_self_bulk, rhoato_init, rhoato_out, rhoit, Rionic_imp, Rmt, &
        Rmtimp, Rmtsd, Rot_Atom_gr, Rot_Atom_nsph, Rot_atom_spin, Rot_cluster, Rot_Spinor, Roverad, rsbdc, rsbdc_out, Rsorte, &
        Rydberg, SCF_c, SCF_elecAbs, &
        SCF_mag_free, SCF_smooth, Self_nonexc, Solsing_s, Spin_axis_free, Spinorbite, State_all, State_all_out, Supermuf, Sym_2D, &
        Sym_cubic, Symmol, Tddft, Test_case, Time_rout, Trace_k, Trace_p, V_abs_i, V_helm_t, V_hubb, V_hubbard, V_intmax, &
        V0bdcFimp, V0muf, Vc_abs_i, Vcato_bulk, Vcato_init, Vhbdc_init, Vhbdc_p, Width_helm, Ylm_comp, Z_nospinorbite)

      if( mpirank0 == 0 ) then
        call CPU_TIME(time)
        tp_SCF_2 = real(time,db)
        Time_rout(18) = Time_rout(18) + tp_SCF_2 - tp_SCF_1
      endif

    elseif( .not. ( Extract .or. Second_run .or. Second_SCF ) ) then

      if( Flapw ) then
        E_Fermi = 0._db
      else
        E_Fermi = -5._db / Rydb
      endif
      E_cut = E_Fermi

    endif

! For H2, N2, O2, F2, Cl2 and the rare gaz, the tabulated Edge values are versus vacuum. We shift it to be versus Fermi
    if( .not. Optic ) then
      Z = numat_abs
      if( Z == 1 .or. Z == 2 .or. Z == 7 .or. Z == 8 .or. Z == 9 .or. Z == 10 .or. Z == 17 .or. Z == 18 .or. Z == 36 &
               .or. Z == 54 .or. Z == 86 ) Eseuil(:) = Eseuil(:) + E_Fermi
    endif

!------ XANES----------------------------------------------------------------------------------------------------------------------------------

    if( mpirank0 == 0 ) then
      call CPU_TIME(time)
      tp_XANES_1 = real(time,db)
      Time_loc(1) = tp_XANES_1
    endif

    Cal_xanes = .true.
    if( Bulk_step ) then
      Green = Green_bulk
    else
      Green = Green_s
    endif
    Moy_loc = Green .and. .not. Moy_cluster

    Lmax_tddft = Lmax_tddft_inp
    if( Optic ) then
      if( Lmax_tddft_inp >= 0 ) then
        Lmax_probe = Lmax_tddft_inp
      else
        if( numat_abs < 21 ) then
          Lmax_probe = 2
        else
          Lmax_probe = 3
        endif
        if( Lmaxat0 > - 1 ) Lmax_probe = min( Lmax_probe, Lmaxat0 )
      endif
    else
      if( Octupole ) then
        Lmax_probe = Lseuil + 3
      elseif( Quadrupole .or. Multipole(13) ) then
        Lmax_probe = Lseuil + 2
      elseif( Multipole(1) .or. Multipole(4) .or. Multipole(5) .or. Multipole(10) .or. Multipole(11) .or. Multipole(12) ) then
        Lmax_probe = Lseuil + 1
      else
        Lmax_probe = Lseuil
      endif
    endif
    if( RIXS ) then
 ! used for the valence transitions
      if( numat_abs < 21 ) then
        Lmax_tddft = max( 1, Lmax_tddft_inp )
      elseif( numat_abs < 55 ) then
        Lmax_tddft = max( 2, Lmax_tddft_inp )
      else
        Lmax_tddft = max( 3, Lmax_tddft_inp )
      endif
    else
      Lmax_tddft = max( Lmax_tddft, Lmax_probe )
    endif
    nlm_probe = (Lmax_probe + 1)**2
    nlms_pr = nlm_probe * nspino

    if( .not. Self_cons_c ) i_self = 1
    Nonsph = .not. Green .and. Atom_nonsph

 ! For XANES cycle, zero energy is set at Fermi energy
 ! E_cut is different from E_Fermi when cutting is set on the absorbing atom occupancy l orbital.
    if( .not. ( Second_run .or. Second_SCF .or. Extract ) ) E_cut = E_cut - E_Fermi

    if( Tddft .or. Optic ) then
      Eneg = .false.
    elseif( Green .or. FDM_comp ) then
      Eneg = .not. Eneg_n_i
    else
      Eneg = Eneg_i
    endif

! to open and close the bav file, just for the writing
    i = size( icheck )
    n = sum( icheck(:) )
    Close_open_bav = i == n

    if( icheck(4) > 0 ) write(3,140)

    if( icheck(27) > 0 ) write(3,160) E_cut * Rydb, E_Fermi * Rydb

    Nonexc_g = Nonexc
    if( Nonexc_g ) then
      ipr1 = 1
      itab = itabs_nonexc
    else
      ipr1 = 0
      itab = itabs
    endif
    if( .not. nonexc_g ) iaproto(iaabs) = 0
    itypep(iaabs) = itab

    Vsphere = Vsphere_cal(Chargat,Charge_ion,Chargm,Counter_linear,dista(natomp),Flapw,iaproto,icheck(5),Matper,n_atom_proto,natomp)

! Evaluation of the tensor shape of the cartesian tensors
    call Tensor_shape( Atom_with_axe, Nonsph, Axe_atom_clu, Dipmag, E_moment_axis, E1E2_imp, E1E2e, &
            Green, iaabs, icheck(6), igroup, igrpt0, iopsymc, iopsymr, itype, itypep, Ldip, Loct, Lqua, Lseuil, Magnetic, &
            mpirank0, msymdd, msymddi, msymdq, msymdqi, msymdo, msymdoi, msymoo, msymooi, msymqq, msymqqi, Multipole, n_oo, &
            natomp, ngroup, ngroup_m, nlat, nlatm, nspin, ntype, Numat, Octupole, Popats, Pos, Quadrupole, Rot_atom_abs, &
            Rot_atom_spin, Rot_cluster, Spinorbite, State_all, Symmol, Tensor_imp )

    E1E1 = Multipole(1); E1E2 = Multipole(2); E1E3 = Multipole(3)
    E1M1 = Multipole(4); E1M2 = Multipole(5)
    E2E2 = Multipole(6);
    E3E3 = Multipole(7); M1M1 = Multipole(8)
!    E1SP = Multipole(11); SPSP = Multipole(12)
    E2M2 = Multipole(13)

    allocate( Bragg_abs(natomsym,npldafs) )
    Bragg_abs(:,:) = ( 0._db, 0._db )
    allocate( Bragg_rgh_bulk_abs(natomsym,npldafs) )
    allocate( poldafse(3,npldafs,nphim) )
    allocate( poldafss(3,npldafs,nphim) )
    allocate( Vecdafse(3,npldafs,nphim) )
    allocate( Vecdafss(3,npldafs,nphim) )

    ngrm = 0
    do ipr = 1,n_atom_proto
      ngrm = max( ngrm, ngreq(ipr) )
    end do

    allocate( ltypcal(nplrm) )
    allocate( nomabs(ncolm) )
    allocate( pol(3,nplrm) )
    allocate( vec(3,nplrm) )
    allocate( pdp(nplrm,2) )

! Evaluation of xanes polarizations and wave vectors
    if( multi_run == 1 .or. Bulk_step ) then
      ich = icheck(6)
    else
      ich = 0
    endif
    call Polond(axyz,Dipmag,ich,ltypcal,Moyenne,mpirank0,msymdd,msymqq,n_mat_polar,ncolm,ncolr,nomabs,nple,nplr, &
        nplrm,nxanout,Octupole,Orthmatt,Multipole,pdp,Pdpolar,pol,Polar,Polarise,Python,Quadrupole,Veconde,Vec,Xan_atom)

    ncolt = ncolr

    if( .not. Matper ) then
      Volume_maille = 0._db
    elseif( Bulk_step ) then
      Volume_maille = Cal_Volume_maille(axyz_bulk,angxyz_bulk)
    else
      Volume_maille = Cal_Volume_maille(axyz,angxyz)
    endif

    f_avantseuil = f_cal(Bulk_step,Doping,Eseuil,icheck(6),itypepr,n_atom_proto,n_atom_proto_uc,nbseuil, &
                         ngreq,ntype,Numat,numat_abs,Taux_ipr,Volume_maille)

    n_z_SRXRD = 0; n_z_SRXRD_max = 0
    n_z_SRXRD_abs = 0; n_z_SRXRD_abs_max = 0
    allocate( n_zc_SRXRD(n_z_SRXRD) )
    allocate( n_zc_SRXRD_abs(n_z_SRXRD_abs) )
    allocate( igr_z_SRXRD(n_z_SRXRD_max,n_z_SRXRD) )
    allocate( igr_z_SRXRD_abs(n_z_SRXRD_abs_max,n_z_SRXRD_abs) )
    allocate( index_z_SRXRD_abs(n_z_SRXRD_abs_max,n_z_SRXRD_abs) )

    Only_abs = .not. ( ( Bulk_step .and. multi_run == n_multi_run ) .or. ( .not. Bulk_step .and. multi_run == 1 ) )

    Non_resonant_bulk = Film .and. n_atom_per == 0 .and. .not. Abs_in_bulk

    if( Dafs .and. ( Bulk_step .or. ( Film .and. n_atom_per == 0 ) ) ) then
      do i = 1,3
        if( i == 2 ) then
          deallocate( n_zc_SRXRD, n_zc_SRXRD_abs )
          allocate( n_zc_SRXRD(n_z_SRXRD) )
          allocate( n_zc_SRXRD_abs(n_z_SRXRD_abs) )
        endif
        if( i == 3 ) then
          deallocate( igr_z_SRXRD, igr_z_SRXRD_abs, index_z_SRXRD_abs )
          allocate( igr_z_SRXRD(n_z_SRXRD_max,n_z_SRXRD) )
          allocate( igr_z_SRXRD_abs(n_z_SRXRD_abs_max,n_z_SRXRD_abs) )
          allocate( index_z_SRXRD_abs(n_z_SRXRD_abs_max,n_z_SRXRD_abs) )
        endif
        call Cal_z_SRXRD(Bulk_step,i,igr_z_SRXRD,igr_z_SRXRD_abs,igreq,index_z_SRXRD_abs,iprabs_nonexc,itype,n_atom_bulk, &
                        n_atom_proto,n_atom_proto_bulk,n_z_SRXRD,n_z_SRXRD_abs,n_z_SRXRD_max,n_z_SRXRD_abs_max,n_zc_SRXRD, &
                        n_zc_SRXRD_abs,neqm,ngreq,ngroup,ntype,Numat,Only_abs,Posn_bulk)
      end do

    else

    endif

    n_max = max(1,n_z_SRXRD_abs)
    allocate( phdt(npldafs,nphim,n_max) )
    allocate( Sum_Bragg_abs_f0(npldafs,n_z_SRXRD_abs) )
    allocate( Sum_Bragg_nonabs_f(npldafs,n_z_SRXRD) )
    allocate( Pos_z_SRXRD_abs(n_z_SRXRD_abs) )
    allocate( Pos_z_SRXRD(n_z_SRXRD) )
    allocate( Abs_SRXRD_abs(n_z_SRXRD_abs) )
    allocate( Abs_SRXRD(n_z_SRXRD) )

    if( Dafs ) then

! Calculation of non resonant absorption cross section, by layer
      if( n_z_SRXRD > 0 .or. n_z_SRXRD_abs > 0 ) &
        call Abs_NR_layer( Abs_SRXRD, Abs_SRXRD_abs, angxyz_bulk, angxyz_int, angxyz_sur, axyz_bulk, axyz_int, &
               axyz_sur, Bulk_step, Eseuil, icheck(6), igr_z_SRXRD, igr_z_SRXRD_abs, igreq, iprabs_nonexc, itype, multi_run, &
               n_atom_bulk, n_atom_proto, n_atom_proto_bulk, n_atom_sur, n_atom_uc, n_z_SRXRD, n_z_SRXRD_abs, &
               n_z_SRXRD_abs_max, n_z_SRXRD_max, n_zc_SRXRD, n_zc_SRXRD_abs, nbseuil, neqm, ngreq, ngroup, ngroup_taux, &
               ntype, Numat, Numat_abs, Only_abs, Pos_z_SRXRD, Pos_z_SRXRD_abs, Posn, Posn_bulk, Surface_ref, Taux_oc, Z_bulk )

      call Prepdafs(Abs_cap,Abs_in_bulk,Angle_or,Angle_mode,Angpoldafs,Angxyz,Angxyz_bulk,Angxyz_cap,Angxyz_int,Angxyz_sur, &
          Axe_atom_gr,axyz,axyz_bulk,axyz_cap,axyz_int,axyz_sur,Bormann,Bragg_abs,Bragg_rgh_bulk_abs,Bulk,Bulk_roughness, &
          Bulk_step,Cap_B_iso,Cap_layer,Cap_roughness,Cap_thickness,Dafs_bio,Delta_bulk,Delta_cap,Delta_film,Delta_int, &
          Delta_roughness_film,Delta_sur,delta_z_bottom_cap,delta_z_top_bulk,delta_z_top_cap,delta_z_top_film,Eseuil,f_avantseuil, &
          f_no_res,Film,Film_roughness,Film_shift,Film_thickness,hkl_dafs,hkl_film,hkl_ref,ich,igr_z_SRXRD,igr_z_SRXRD_abs, &
          igreq,Interface_shift,iprabs_nonexc,isigpi,itabs,itypepr, &
          Length_abs,lvval,Magnetic,Mat_or,Mat_UB,mpirank0,n_atom_bulk,n_atom_cap, &
          n_atom_int,n_atom_per,n_atom_proto,n_atom_proto_bulk,n_atom_proto_int,n_atom_proto_uc,n_atom_sur,n_atom_uc, &
          n_z_SRXRD,n_z_SRXRD_abs,n_z_SRXRD_abs_max,n_z_SRXRD_max,n_zc_SRXRD,n_zc_SRXRD_abs,n_max,n_temp,natomsym,nbseuil, &
          neqm,ngreq,ngrm,ngroup,ngroup_m,ngroup_taux,nlat,nlatm,Non_resonant_bulk,nphi_dafs,nphim,npl_2d, &
          npldafs,npldafs_2d,npldafs_e,npldafs_f,nrato,nrm,nspin,ntype,Numat,Operation_mode,Operation_mode_used,Orthmatt, &
          phdt,phdt_rgh_Bulk,phi_0,Poldafse,Poldafsem,Poldafss,Poldafssm,popatm,Posn,Posn_bulk,Posn_cap,psival,Ratio_S_ref_bulk, &
          Rato,Sum_Bragg_abs_f0,Sum_Bragg_nonabs_f,Sum_Bragg_NR_Bulk,Sum_Bragg_NR_T,Sum_Bragg_NR_T_rgh_bulk, &
          Surface_shift,Taux,Taux_cap,Taux_oc,Temp,Temp_coef,Vec_orig,Vecdafse,Vecdafsem,Vecdafss,Vecdafssm,Z_bulk,Z_cap)

      call Col_dafs_name(angpoldafs,Bormann,Full_self_abs,hkl_dafs,isigpi,mpirank0,ncolm,ncolr,ncolt, &
                           nomabs,npldafs,Operation_mode_used,Python,Self_abs)
    endif

    n_tens_max = 0
    if( mpirank0 == 0 .and. Spherical_tensor ) then
      if( E1E1 ) n_tens_max = n_tens_max + n_tens_dd
      if( E1E2 ) n_tens_max = n_tens_max + n_tens_dq
      if( E1E2 .and. ( nspin == 2 .or. Spinorbite ) ) n_tens_max = n_tens_max + n_tens_dq
      if( E2E2 ) n_tens_max = n_tens_max + n_tens_qq
      if( E1M1 ) n_tens_max = n_tens_max + n_tens_dm
      if( E1M1 .and. ( nspin == 2 .or. Spinorbite ) ) n_tens_max = n_tens_max + n_tens_dm
    endif
    if( mpirank0 == 0 ) allocate( Int_tens(n_tens_max*ninitr,0:natomsym) )

    Tddft_xanes = Tddft .and. .not. Optic
    Optic_xanes = Optic

! Calculation of useful representations, that is probed by the photoelectron
    if( .not. ( Density .or. Optic .or. NRIXS .or. COOP .or. RIXS_gen ) .and. Test_case(7) ) then
      call Etafin(E1M1,icheck(8),iopsymr,irep_util,jseuil,karact,Ldip,Lmoins1,Loct,Lplus1,Lqua,Lseuil, &
                  M1M1,mpirank0,nb_rep,nbseuil,ngrph,nspino,Spinorbite,State_all,Sym_cubic,Ylm_comp)
      Recop = ( Sym_cubic .or. Sym_4 ) .and. .not. State_all
    else
      if( icheck(27) > 1 ) then
        ich = max( icheck(8), icheck(27) )
      else
        ich = 0
      endif
      call irep_util_all(ich,iopsymr,irep_util,karact,nb_rep,ngrph,nspino,Spinorbite)
      Recop = .false.
    endif
    allocate( Repres_comp(ngrph) )
    call irep_comp(Ylm_comp,Green,iopsymr,irep_util,karact,ngrph,nspino,Repres_comp)

! Loop over the cluster radius - interpoint distances values
    boucle_i_range: do i_range = 1,n_range

      natomeq = natomeq_s(i_radius)
      Rsorte = Rsorte_s(i_radius)
      adimp = adimp_e(i_adimp)

! Calculation of the non-equivalent atoms inside the cluster of calculation
      natome = natome_cal(igrpt_nomag,iopsymr,mpirank0,natomeq,natomp,pos)

! The atoms used to describe the potential can be only the non-equivalent atoms of the unit cell, or the non-equivalent atoms
! inside the cluster
      if( i_range == 1 .and. multi_run_e == 1 .and. .not. self_cons_c ) then
!      if( .not. ( SCF_c .or. Hubbard ) ) then
        Full_atom = ( Full_atom_e  &
                     .or. ( natome <= n_atom_proto -  n_atom_proto_bulk .and. .not. Bulk_step ) &
                     .or. ( natome <= n_atom_proto_bulk .and. Bulk_step ) ) &
                     .and. .not. ( Flapw .or. sum( abs( E_moment_axis(:) ) ) > eps10 )
        Full_atom_gen = Full_atom
      else
        Full_atom = Full_atom_gen
      endif

      if( Full_atom ) then
        n_atom_0 = 1
        n_atom_ind = natome
      else
        if( Nonexc ) then
          n_atom_0 = 1
        else
          n_atom_0 = 0
        endif
        n_atom_ind = n_atom_proto
      endif

      if( mpirank0 == 0 .and. i_range == 1 ) then
        allocate( Int_statedens(lla2_state,nspinp,n_atom_0:n_atom_ind) )
        Int_statedens(:,:,:) = 0._db
      endif

      allocate( Atom_axe(natome) )
      allocate( distai(natome) )
      allocate( ia_eq(nb_sym_op,natome) )
      allocate( ia_eq_inv(natomeq) )
      allocate( ia_rep(nb_sym_op,natome,natome) )
      allocate( iaprotoi(natome) )
      allocate( igroupi(natome) )
      allocate( iopsym_atom(nopsm,natome) )
      allocate( is_eq(nb_sym_op,natome) )
      allocate( itypei(natome) )
      allocate( nb_eq(natome) )
      allocate( nb_rpr(natome,natome) )
      allocate( nb_rep_t(nb_sym_op,natome,natome) )
      allocate( Posi(3,natome) )
      allocate( Rot_atom(3,3,natome) )
      allocate( Rot_atomp(3,3,natomp) )
      allocate( Wigner_one_half(2,2,natome) )

      Rsorte = Rsorte_s(i_radius)

      ich = icheck(7)

      call Atom_selec( Adimp, Atom_axe, Atom_with_axe, Atom_occ_hubb, Axe_atom_clu, dista, distai, E_moment_axis, Full_atom, &
        Green, Hubbard, i_self, ia_eq, ia_eq_inv, ia_rep ,iaabs, iaabsi, iabsorbeur, iaproto, iaprotoi, ich, igreq, igroup, &
        igroupi, igrpt_nomag, igrpt0, iopsym_atom, iopsymr, iord, ipr1, is_eq, isymeq, itequ, itype, itypei, itypep, itypepr, &
        m_hubb ,m_hubb_e, Magnetic, mpirank0, natome, n_atom_0_self, n_atom_ind_self, n_atom_proto, natomeq, natomp, natomsym, &
        nb_eq, nb_rpr, nb_rep_t, nb_sym_op, neqm,ngreq, ngroup, ngroup_hubb, ngroup_m, nlat, nlatm, Nonsph, nspin, nspinp, ntype, &
        Numat, nx, occ_hubb_e, Overad, Popats, Pos, Posi, Proto_calculated, Rmt, Rot_atom, Rot_atom_spin, Rot_atomp, &
        Roverad, Rsort ,Rsorte, Spinorbite ,Symmol, V_hubb, V_hubbard, Ylm_comp )

      if( Spin_axis_free ) call Wigner_one_half_cal(ich,natome,Rot_atom,Wigner_one_half)

      Hubb_abs = Hubb(itabs)
      if( Hubb_abs .and. i_range == 1 .and. .not. extract ) then
        if( Full_atom ) then
          iapr = iaabsi
        elseif( Self_nonexc ) then
          iapr = iprabs_nonexc
        else
          iapr = iprabs
        endif
        V_hubb_abs(:,:,:,:) = V_hubb(:,:,:,:,iapr)
        Hubb_diag_abs = Hubb_diag(iapr)

      elseif( .not. i_range > 1 .and. .not. extract ) then  ! read in the bav file
        Hubb_diag_abs = .true.
      endif

      if( Ylm_comp .and. ( Full_potential .or. ( Hubb_abs .and. .not. Hubb_diag_abs ) ) .and. .not. Spinorbite ) then
        Ylm_comp_loc = .false.
      else
        Ylm_comp_loc = Ylm_comp
      endif

      V_hubb_loc(:,:,:,:) = V_hubb_abs(:,:,:,:)
      if( Ylm_comp .and. .not. Hubb_diag_abs ) &
        call Trans_CompToReal_V_hubb(icheck(7),m_hubb,nspinp,Spinorbite,V_hubb_loc)

      nbtm = 0
      npoint = 0
      npr = 0
      npoint_ns = 0
      nim = 0
      npsom = 0

      if( .not. ( Second_run .or. Extract ) ) then

! Calculation of the table dimensions for the FDM grid of points
        call nbpoint( Adimp, Base_hexa, D_max_pot, Green, iaabsfirst, igrpt_nomag, iopsymr, iord, Mag_axis_free, Moy_loc, &
               mpirank0, natomp, npoint, npso, nvois, nx, pos, Rot_Spinor, Rsort )

        if( Nonsph ) npoint_ns = npoint
        nim = npoint
        npsom = npso

        if( i_range > 1 ) deallocate( clapl, cgrad, ivois, isvois, numia, rvol, xyz )

        allocate( clapl(0:nvois) )
        allocate( cgrad(nvois) )
        allocate( ivois(npsom,nvois) )
        allocate( isvois(npsom,nvois) )
        allocate( numia(npsom) )
        allocate( rvol(nim) )
        allocate( xyz(4,npsom) )
        allocate( indice(3,npsom) )
        allocate( mpres(-nx:nx,-nx:nx,-nx:nx) )

! Elaboration of the FDM grid of point. Even in Green, one defines a grid of point to calculate the average interstitial potential
        call FDM_grid( Adimp, Base_hexa, D_max_pot, Green, iaabsfirst, icheck(9), &
             igrpt_nomag, indice, iopsymr, iord, itypei, Mag_axis_free, Moy_loc, mpirank0, mpres, natome, natomp, nim, &
             npoint, npr, npso, npsom, ntype, numia, nx, Rot_Spinor, pos, Posi, Rmt, rsort, rvol, xyz)

        nbm = 0
        nbtm = 0
        nsort = 0
        nsortf = 0

        allocate( ibord(nbtm,natome) )
        allocate( isbord(nbtm,natome) )
        allocate( isrt(nsort) )
        allocate( nbord(natome) )
        allocate( nbordf(natome) )
        allocate( poidsa(nbm,natome) )
        allocate( poidso(nsortf) )
        nbord(:) = 0
        nbordf(:) = 0

        if( .not. Green ) then
          call laplac(Adimp,Base_hexa,cgrad,clapl,icheck(9),igrpt_nomag,indice,iopsymr,iord,ivois,isvois, &
              mpirank0,mpres,npso,npsom,nvois,nx)

          do i_cycle = 1,2
            call Bordure(Green,i_cycle,icheck(9),ibord,iopsymr,iord,isbord, &
              isrt,ivois,mpirank0,natome,nbm,nbord,nbordf,nbtm,nim,npoint,npso,npsom,nsort, &
              nsortf,numia,nvois,poidsa,poidso,Posi,rvol,xyz)
            if( i_cycle == 2 ) exit
            deallocate( ibord, isbord, isrt, poidsa, poidso )
            allocate( ibord(nbtm,natome) )
            allocate( isbord(nbtm,natome) )
            allocate( isrt(nsort) )
            allocate( poidsa(nbm,natome) )
            allocate( poidso(nsortf) )
         end do

        endif

        deallocate( indice, mpres )

        allocate( Excato(nrm,n_atom_0:n_atom_ind) )
        allocate( rs(npoint) )
        allocate( rhoato(0:nrm,nspin,n_atom_0:n_atom_ind) )
        allocate( rsato(0:nrm,n_atom_0:n_atom_ind) )
        allocate( Vcato(0:nrm,nlm_pot,n_atom_0:n_atom_ind) )
        allocate( Vh(npoint) )
        allocate( Vhns(npoint_ns) )
        allocate( Vxc(npoint,nspin) )
        allocate( Vxcato(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind) )
        Excato(:,:) = 0._db
        rsato(:,:) = 0._db
        rhoato(:,:,:) = 0._db
        Vcato(:,:,:) = 0._db
        Vxcato(:,:,:,:) = 0._db
        if( Bulk_atom_done ) then
          do ipr = n_atom_proto-n_atom_proto_bulk+1, n_atom_proto
            Vcato(:,:,ipr) = Vcato_bulk(:,:,ipr)
            if( .not. Test_case(3) ) rho_self(:,:,:,ipr) = rho_self_bulk(:,:,:,ipr)
          end do
        endif

      endif

      allocate( Ecinetic_a(nspin,n_atom_0:n_atom_ind) )
      allocate( imoy(npoint) );  allocate( imoy_out(npoint) )
      allocate( poidsov(npoint) ); allocate( poidsov_out(npoint) )
      allocate( rho(npoint,nspin) )
      allocate( rhons(npoint_ns) )
      allocate( Vmft(nspin,n_atom_0:n_atom_ind) )
      allocate( Vr(npoint,nspin) )
      allocate( Vrato(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind) )
      allocate( Full_pot(n_atom_0:n_atom_ind) )
      Full_pot(:) = .false.

      if( mpirank0 == 0 ) then
        call CPU_TIME(time)
        Time_loc(2) = real(time,db)
        Time_rout(3) = Time_rout(3) + Time_loc(2) - Time_loc(1)
      endif

      if( i_range == 1 .and. .not. Extract ) then
        allocate( Rato_abs(nrato_abs) )
        Rato_abs(1:nrato_abs) = Rato(1:nrato_abs,itabs)
      endif

      if( .not. ( Second_run .or. Extract ) ) then

! Potential calculation

        if( Flapw ) then

          call Potlapw(axyz,Chargat,Coupelapw,deccent,Exc_abs_i,Flapw_new,Full_atom,iapot, &
            iaproto,iaprotoi,icheck(13),igroup,iprabs_nonexc,ipr1,itabs,its_lapw,itypei,itypep,itypepr,Magnetic,mpinodes0, &
            mpirank0,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(1),Vc_abs_i,Vcato,Vh,Vxc,Vxcato,Wien_file,Wien_matsym, &
            Wien_save,Wien_taulap,xyz)

        else

          call 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_c,Self_nonexc,Spin_axis_free,Sym_2D,Test_case,V_abs_i,V_helm_t,V_intmax,V_surf,Vc_abs_i,Vcato, &
            Vcato_init,Vh,Vhns,Vsphere,Vxc,Vxcato,V0bdcFimp(1),Width_helm,Wigner_one_half,xyz)

        endif

        Other_xanes = SCF .and. One_SCF_surf
        call Potential_comp(Bulk_atom_done,Cal_xanes,distai(natome),dV0bdcF,E_Fermi,Full_atom, &
          Green,i_range,i_self,iaabs,iapot,iaproto,iaprotoi,icheck(13),imoy,imoy_out,iopsymr,ipr1,isrt,itypepr,korigimp,Magnetic, &
          Moy_loc,mpirank0,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_d,Sym_2D,Test_case(2),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)

        if( .not. FDM_comp ) V0bdcF_out(1:nspin) =  V0bdcF(1:nspin)

      endif

      if( Coop_only_abs ) igr_coop(1) = iabsorbeur

      call Atom_coop_selec(COOP,Dist_coop,ia_coop,iaprotoi,icheck(28),igr_coop,igreq,igroupi,iprabs_nonexc,itypei,n_atom_coop, &
                         n_atom_proto,nab_coop,natome,neqm,ngreq,nomfich_s,ntype,Numat,Posi,Rmtg)

      if( i_range == 1 ) then
        nenerg = nenerg_s
        allocate( Energ(nenerg) )
        allocate( Eimag(nenerg) )
        if( Optic ) then
          if( E_cut_man ) then
            Energ(:) = Energ_s(:) + E_cut_imp
          else
            Energ(:) = Energ_s(:)
          endif
        else
          Energ(:) = Energ_s(:)
        endif
        Eimag(:) = Eimag_s(:)
      end if

      if( Full_atom ) then
        if( nonexc ) then
          iaprabs_nonexc = iaabsi
        else
          iaprabs_nonexc = 0
        endif
      else
        iaprabs_nonexc = iprabs_nonexc
      endif

      if( ipr1 == 1 ) Rmtg(0) = Rmtg(iprabs_nonexc)

      if( .not. Extract ) then

! Complementary work on potential
        if( .not. Second_run ) &
          call Check_Ecmax(E_Fermi,Ecineticmax,Ecineticmax_out,Eclie,Eclie_out,Eneg,Energ(nenerg),mpirank,nspin,V0bdcF,V0bdcf_out)

! Non excited absorbing atom potential (used in Energseuil)
        if( Second_run .or. Second_SCF ) then
          if( Flapw ) then
            Exc_abs_i(:) = 0._db
            Vc_abs_i(:) = 0._db
            V_abs_i(:,:) = 0._db
            nr = nrato( itypepr(iaprabs) )
            Vc_abs_i(1:nr) = Vcato(1:nr,1,iaprabs)
            do ispin = 1,nspin
              V_abs_i(1:nr,ispin) = Vc_abs_i(1:nr) +  Vxcato(1:n,1,ispin,iaprabs)
            end do
            if( nspin == 1 ) then
              Exc_abs_i(1:nr) = Vxcato(1:nr,1,1,iaprabs)
            else
              Exc_abs_i(1:nr) = ( Vxcato(1:nr,1,1,iaprabs) + Vxcato(1:nr,1,nspin,iaprabs) ) / nspin
            endif
          else
            allocate( Exc(nrm) )
            allocate( r(nrm) )
            allocate( Vc(nrm) )
            allocate( Vxc_a(nrm,nspin) )
            Vc(1:nrm) = Vcato(1:nrm,1,iaprabs_nonexc)
            Vxc_a(1:nrm,1:nspin) = Vxcato(1:nrm,1,1:nspin,iaprabs_nonexc)
            Exc(1:nrm) = Excato(1:nrm,iaprabs_nonexc)
            r(1:nrm) = rato(1:nrm,itab)
            call mod_V_abs(Exc,Exc_abs_i,icheck(13),nrm,nspin,r,V_abs_i,Vc,Vc_abs_i,Vxc_a)
            deallocate( Exc, r, Vc, Vxc_a )
          endif
        endif

! Calculation of the core level (Kohn-Sham) energy (Epsii)
        if( i_range == 1 ) then
          if( Optic ) then
            Epsii(:) = 0._db; Epsii_moy = 0._db; Delta_Eseuil = 0._db
          else

            call Energseuil(Core_energ_tot,Core_resolved,Delta_Epsii,Delta_Eseuil,E_Fermi,.false.,Epsii,Epsii_moy,Eseuil, &
              Exc_abs_i,icheck(14),is_g,Jseuil,Lseuil,m_g,mpirank0,nbseuil,ninit1,ninit,ninitr,nrato_abs,nrm,nseuil, &
              nspin,numat_abs,psii,Rato_abs,Rmtg(iprabs_nonexc),Rmtsd(iprabs_nonexc),V_abs_i,V_intmax,Vc_abs_i,V0bdcf)
          endif
        endif

      endif

! Determination of Lmax
      if( .not. Green ) then
        call clmax(Ecineticmax_out,Rsort,Lmaxso0,Lmaxso_m,-1,.true.)
        Lmaxso_m = min( Lmaxso_m, Lmaxso_max )
      else
        Lmaxso_m = 0
      endif
      Lmax_max = 0
      if( Full_atom ) then
        iaprabs = iaabsi
      else
        iaprabs = iprabs
      endif

      nlm_p_fp = 1
      if( Full_Potential ) then
        nlm_p_fp = nlm_probe
      elseif( Hubbard ) then
        if( Hubb(itabs) .and. .not. Hubb_diag_abs ) nlm_p_fp = nlm_probe
      endif

      Lmax_abs = 0
      do ipr = 0,n_atom_proto
        Z = Numat( itypepr(ipr) )
        call clmax(Ecineticmax,Rmtg(ipr),Lmaxat0,Lmaxat(ipr),Z,Lmaxfree)
        if( Z == numat_abs ) then
          Lmaxat(ipr) = max( Lmax_probe, Lmaxat(ipr) )
          Lmax_abs = max( Lmaxat(ipr), Lmax_abs )
        endif
        Lmax_max = max(Lmax_max,Lmaxat(ipr))
      end do

      do ipr = 0,n_atom_proto
        Z = Numat( itypepr(ipr) )
        if( Z == numat_abs ) Lmaxat(ipr) = Lmax_abs
      end do

      nlmmax = (Lmax_max + 1 )**2
      if( Tddft .or. Optic .or. RIXS ) then
! nlmamax is used only for Tddft, it is limited to save memory space
        Lmax_abs_t = min( Lmax_abs, Lmax_tddft)
        nlmamax = (Lmax_abs_t + 1 )**2
      else
        Lmax_abs_t = 0
        nlmamax = 0
      endif

      nlmsam = nspinp * nlmmax
      nlmomax = ( Lmaxso_m + 1 )**2
      nso1 = nspino * nlmomax

      if( .not. Green .and. FDM_comp ) then
        Lmax_comp = Lmax_probe
        nlm_comp = ( Lmax_probe + 1 )**2
      else
        nlm_comp = 0
        Lmax_comp = 0
      endif
      allocate( Tau_comp(nlm_comp,nspinp,nlm_comp,nspinp,nenerg) )
      Tau_comp(:,:,:,:,:) = (0._db,0._db)
      allocate( RadialIntegral(nlm_comp,1,nspinp,nlm_comp,1,nspinp,nenerg) )
      RadialIntegral(:,:,:,:,:,:,:) = (0._db,0._db)

! Absorbing atom potential and density storage
      if( i_range == 1 .and. .not. Extract ) then
        if( Full_atom ) then
          iaprabs = iaabsi
        else
          iaprabs = iprabs
        endif
        Rmtg_abs = Rmtg(iprabs)
        Rmtsd_abs = Rmtsd(iprabs)
        allocate( rhoato_abs(nrato_abs,nspin) )
        allocate( rsato_abs(nrato_abs) )
        allocate( Vcato_abs(nrato_abs,nlm_pot) )
        allocate( Vxcato_abs(nrato_abs,nlm_pot,nspin) )
        rhoato_abs(1:nrato_abs,:) = rhoato(1:nrato_abs,:,iaprabs)
        rsato_abs(1:nrato_abs) = rsato(1:nrato_abs,iaprabs)
        Vcato_abs(1:nrato_abs,:) = Vcato(1:nrato_abs,:,iaprabs)
        Vxcato_abs(1:nrato_abs,:,:) = Vxcato(1:nrato_abs,:,:,iaprabs)
        if( icheck(13) > 0 .and. mpirank0 == 0 ) call 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)
      endif

      if( mpirank0 == 0 ) then
        call CPU_TIME(time)
        Time_loc(3) = real(time,db)
        Time_rout(4) = Time_rout(4) + Time_loc(3) - Time_loc(2)
      endif

      allocate( iato(nlmsam,natome,ngrph) )
      allocate( Lato(nlmsam,natome,ngrph) )
      allocate( iso(nso1,ngrph) )
      allocate( Lso(nso1,ngrph) )
      allocate( mato(nlmsam,natome,ngrph) )
      allocate( mso(nso1,ngrph) )
      allocate( nlmso0(ngrph) )
      allocate( nlmsa0(natome,ngrph) )

! Determination of the (l,m) of each representation
      if( .not. ( Second_run .or. Extract ) ) &
        call Lmrep(Green,iaprotoi,iato,icheck(15),iopsym_atom,iopsymr,irep_util,iso,itypei,karact,Lato, &
               Lmaxat,Lmaxso_m,Lso,mato,mpirank0,mso,n_atom_proto,natome,nbordf,ngrph,nlmsa0,nlmsam,nlmso0, &
               nso1,nsortf,nspino,ntype,Numat,Orthmati,Posi,Rot_atom,Spin_axis_free)

! Ylm calculation on the FDM grid points
      if( Green ) then
        nbtm_fdm = 0
      else
        nbtm_fdm = nbtm
      endif
      if( Spin_axis_free ) then
        nbm_c = nbm
      else
        nbm_c = 0
      endif
      allocate( Ylmato(nbtm_fdm,nlmmax,natome) )
      allocate( Ylms(nbm_c,nlmmax,nspinp,nspino,natome) )
      if( .not. ( Second_run .or. Extract .or. Green ) ) then
        allocate( Ylmso(nsort,nlmomax) )
        call Ylmpt(iaprotoi,ibord,icheck(15),iopsymr,isrt,Lmaxat,Lmaxso_m,n_atom_proto,natome, &
             nbord,nbtm,nlmmax,nlmomax,nsort,npsom,Posi,Rot_atom,Spin_axis_free,xyz,Ylmato,Ylmso)
        if( Spin_axis_free ) call Rotate_Ylms(iaprotoi,ibord,icheck(15),Lmaxat,n_atom_proto,natome,nbm_c,nbordf,nbtm,nlmmax, &
                               nspino,nspinp,Rot_atom,Ylmato,Ylms)
      endif

      if( .not. ( Green .or. Second_run .or. Extract ) ) then
        if( Spinorbite .or. Relativiste ) then
          nicm = nim
        else
          nicm = 1
        endif
        allocate( gradvr(nicm,3,nspin))
      endif
      allocate( Lmaxa(natome) )
      allocate( nlmsa(natome) )
      allocate( drho_self(nrm_self,nlm_pot,nspinp,n_atom_0_self:n_atom_ind_self,0:mpinodee-1) )
      allocate( Statedens(lla2_state,nspinp,lla2_state,nspinp,n_atom_0:n_atom_ind,0:mpinodee-1) )
      allocate( Statedens_i(lla2_state,nspinp,lla2_state,nspinp,n_atom_0:n_atom_ind,0:mpinodee-1) )
      allocate( Coverlap(16,16,nspinp,nab_coop,0:mpinodee-1) )
      allocate( index_coop(2,nab_coop) )

      ninitlv = nbseuil
      n_vr_0 = n_atom_0
      n_vr_ind = n_atom_ind

      if( Close_open_bav ) Close(3)

      if( i_range == 1 ) then
        if( Tddft_xanes ) then
          nenerg_tddft = nenerg
        else
          nenerg_tddft = 0
        endif
!  nlmmax = (Lmax_max + 1 )**2   max dimension
        allocate( rof0(nenerg_tddft,nlmamax,nspinp,nspino,nbseuil) )
        allocate( Taull_dft(nlmmax,nspinp,nlmmax,nspinp,0:mpinodee-1) )
        Taull_dft(:,:,:,:,:) = ( 0._db, 0._db )

        if( Tddft_xanes .or. Optic_xanes .or. RIXS ) then
          rof0(:,:,:,:,:) = (0._db,0._db)
          allocate( Tau_abs(nenerg,nlmamax,nspinp,nlmamax,nspinp) )
          Tau_abs(:,:,:,:,:) = (0._db, 0._db)
        endif

        if( RIXS_gen ) then
          nenerg_RIXS = nenerg
          L = Lmax_print( numat_abs )   ! in tab_data.f90
          L = max( L, Lmax_DOSout )
          nlm_rixs = min( nlmmax, ( L + 1 )**2  )
          if( Extract ) then
            nlmomax = extract_nlmomax(multi_run,nom_fich_extract)
            Lmaxso_m = nint( sqrt( real( nlmomax, db ) ) ) - 1
          endif
        else
          nenerg_RIXS = 0
          nlm_rixs = 0
        endif

        allocate( Ampl_dft(nlm_rixs,nspinp,nlmomax,nspinp,0:mpinodee-1) )
        Ampl_dft(:,:,:,:,:) = ( 0._db, 0._db )

        allocate( Ampl_abs(nenerg_RIXS,nlm_probe,nspinp,nlmomax,nspinp) )
        allocate( nlm_fe(nenerg_RIXS) )
        Ampl_abs(:,:,:,:,:) = (0._db, 0._db)

! Green_int for Green integral is true only in tddft calculation
! With Green_int false the tensors "_m" are not used
        Green_int = .false.

        allocate( sec_atom(ninitr) )
        allocate( T_E1E1(3,3,ninitr,0:mpinodee-1) )
        allocate( T_E1E2(3,3,3,ninitr,0:mpinodee-1) )
        allocate( T_E1E3(3,3,3,3,ninitr,0:mpinodee-1) )
        allocate( T_E1M1(3,3,ninitr,0:mpinodee-1) )
        allocate( T_E1M2(3,3,3,ninitr,0:mpinodee-1) )
        allocate( T_E1SP(3,3,ninitr,0:mpinodee-1) )
        allocate( T_E2E2(3,3,3,3,ninitr,0:mpinodee-1) )
        allocate( T_E2M2(3,3,3,3,ninitr,0:mpinodee-1) )
        allocate( T_E3E3(3,n_oo,3,n_oo,ninitr,0:mpinodee-1) )
        allocate( T_M1M1(3,3,ninitr,0:mpinodee-1) )
        allocate( T_SPSP(3,3,ninitr,0:mpinodee-1) )

        allocate( T_E1E1_m(3,3,ninitr,0:mpinodee-1) )
        allocate( T_E1E2_m(3,3,3,ninitr,0:mpinodee-1) )
        allocate( T_E1E3_m(3,3,3,3,ninitr,0:mpinodee-1) )
        allocate( T_E1M1_m(3,3,ninitr,0:mpinodee-1) )
        allocate( T_E1M2_m(3,3,3,ninitr,0:mpinodee-1) )
        allocate( T_E1SP_m(3,3,ninitr,0:mpinodee-1) )
        allocate( T_E2E2_m(3,3,3,3,ninitr,0:mpinodee-1) )
        allocate( T_E2M2_m(3,3,3,3,ninitr,0:mpinodee-1) )
        allocate( T_E3E3_m(3,n_oo,3,n_oo,ninitr,0:mpinodee-1) )
        allocate( T_M1M1_m(3,3,ninitr,0:mpinodee-1) )
        allocate( T_SPSP_m(3,3,ninitr,0:mpinodee-1) )

        allocate( S_nrixs(nq_nrixs,(Lmax_nrixs+1)**2,(Lmax_nrixs+1)**2,ninitr,0:mpinodee-1) )
        allocate( S_nrixs_m(nq_nrixs,(Lmax_nrixs+1)**2,(Lmax_nrixs+1)**2,ninitr,0:mpinodee-1) )

      endif

      Tau_nondiag = .false.
      if( Spinorbite .or. Full_potential ) then
        Tau_nondiag = .true.
      elseif( Hubbard ) then
        do iapr = n_atom_0_self,n_atom_ind_self
          if( Hubb_diag(iapr) ) cycle
          Tau_nondiag = .true.
          exit
        end do
      endif

      if( mpirank0 == 0 ) then
        call CPU_TIME(time)
        Time_loc(4) = real(time,db)
        Time_rout(5) = Time_rout(5) + Time_loc(4) - Time_loc(3)
      endif

      if( i_range == 1 ) then
        ie0 = 1
      else
        ie0 = nenerg0 + 1
      endif
      if( i_range == n_range ) then
        nenerg0 = nenerg
      else
        do ie = ie0,nenerg
          if( Energ(ie) > E_max_range(i_range) + eps10 ) exit
        end do
        nenerg0 = ie - 1
      endif

      if( n_range /= 1 ) then
        if( abs( E_radius(i_radius) - E_max_range(i_range) ) < eps10 ) i_radius = i_radius + 1
        if( abs( E_adimp(i_adimp) - E_max_range(i_range) ) < eps10 ) i_adimp = i_adimp + 1
      endif

! Loop over energy
      nge = ( nenerg0 - ie0 ) / mpinodee + 1

! One makes the storage only when mpinodee > 1, otherwise the writing is a temporary file
      if( One_run_L .and. First_run .and. i_range == 1 ) &
        allocate( Taull_stk(nlm_probe,nspinp,nlm_probe,nspinp,n_multi_run-n_abs_bulk-1,nge) )

      index_e = 0

      First_E = i_range == 1
      boucle_energ_xanes: do je = 1,nge

        if( mpinodee /= mpinodes .and. mpirank0 /= 0 ) cycle

        ie = ie0 + ( je - 1 ) * mpinodee + mpirank

        if( ie <= nenerg0 ) then

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(1) = real(time,db)
          endif

          index_e = index_e + 1
          Enervide = Energ(ie) + E_Fermi

! Calculation of potential in the excited state
          if( Extract ) then
            call E_reading(icheck(19),Eimag(ie),Energ(ie),ie,multi_run_e,nom_fich_extract)
            allocate( Vra(nrato_abs,nlm_pot,nspin) )
            call Potex_abs(alfpot,dV0bdcF,Enervide,icheck(16),nlm_pot,nrato_abs,nspin,Optic,rato_abs,rsato_abs,rsbdc,V_intmax, &
                           V0bdc,Vcato_abs,Vhbdc,Vra,Vxcato_abs,VxcbdcF)

          else
            call Potex(Nonsph,axyz,alfpot,dV0bdcF,Energ(ie),Enervide,Full_atom, &
              iaabsi,iapot,iaprotoi,icheck(16),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)

            if( Trace_k > 3 ) &
              call Trace_cube(Adimp,Base_hexa,iopsymr,itypep,natomeq,natomp,nomfich_s,npoint,npsom,nspin,ntype,Numat,Pos,rho,Vr,xyz)
          endif

          do ispin = 1,nspin

            if( .not. FDM_comp ) V0bdc_out(ispin) =  V0bdc(ispin)

            if( .not. Extract ) then

              if( Muffintin ) call mdfmuf(Nonsph,Axe_Atom_gr,axyz,Full_atom,iaabs,iaproto,iaprotoi,icheck(16), &
                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,V0bdc(ispin),Vr,Vrato,xyz)

              if( Supermuf ) call modmuf(Full_atom,iaprotoi,itypepr,icheck(16), &
                ispin,n_atom_0,n_atom_ind,n_atom_proto,natome,nlm_pot,nrato,nrm,nspin,ntype,Rato,Rmtg,V0bdc(ispin),Vrato)

              if( .not. ( Green .or. Second_run ) .and. ( Spinorbite .or. Relativiste ) ) &
                call gradpot(Base_hexa,cgrad,gradvr,icheck(16),iord,ispin,ivois,nicm,npoint,npsom,nspin,nvois,Vr)

            endif

            Ecinetic_out(ispin) = Enervide - V0bdc_out(ispin)
            Ecinetic(ispin) = Enervide - V0bdc(ispin)
            Ecinetic_a(ispin,:) = Enervide - Vmft(ispin,:)

            if( .not. Eneg ) then
              Ecinetic_out(ispin) = max( Ecinetic_out(ispin), Eclie_out )
              Ecinetic(ispin) = max( Ecinetic(ispin), Eclie )
              Ecinetic_a(ispin,:) = max( Ecinetic_a(ispin,:), Eclie )

              if( Ecinetic(ispin) < eps10 .or. Ecinetic_out(ispin) < eps10 ) then
                call write_error
                do ipr = 6,9,3
                  write(ipr,170) Ecinetic(ispin) * rydb
                  if( nptmoy_out > 0 ) write(ipr,180) Ecinetic_out(ispin) * rydb
                end do
                stop
              endif
            endif

          end do  ! end of loop over spin

          if( Eneg ) then
! Numerical problem around zero
            em = 0.01_db / rydb
            ei0 = 0.01_db / rydb
            E =  min( Ecinetic_out(1), Ecinetic_out(nspin) )
            if( E < 0._db ) then
              Eimag(ie) = max( Eimag(ie), ei0 )
            elseif( E < em ) then
              eii = ei0 * ( 1 - E / em )
              Eimag(ie) = max( Eimag(ie), eii )
            endif
          endif

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(2) = real(time,db)
            Time_rout(6) = Time_rout(6) + Time_loc(2) - Time_loc(1)
          endif

          if( abs( Eimag(ie) ) > eps10 .or. Ecinetic_out(1) < eps10 .or. Ecinetic_out(nspin) < eps10 ) then
            E_comp = .true.
          else
            E_comp = .false.
          endif

          if( No_solsing ) then
            Solsing = .false.
          elseif( E_comp .and. Green ) then
            Solsing = .true.
          else
            Solsing = Solsing_s
          endif

          Ecmax = 0._db
          Ecmax_out = 0._db
          do ispin = 1,nspin
            Ecmax_out = max( Ecmax_out, Ecinetic_out(ispin) )
            Ecmax = max( Ecmax, Ecinetic(ispin) )
          end do

          Lmax_g = 0
          Lmax_abs_a = 0
          do ipr = 0,n_atom_proto
            Z = Numat( itypepr(ipr) )
            call clmax(Ecmax,Rmtg(ipr),Lmaxat0,Lmaxat(ipr),Z,Lmaxfree)
            Lmaxat(ipr) = min(Lmaxat(ipr), Lmax_max)
            if( Z == numat_abs ) then
               Lmaxat(ipr) = max( Lmax_probe, Lmaxat(ipr) )
               Lmax_abs_a = max( Lmax_abs_a, Lmaxat(ipr) )
            end if
            Lmax_g = max( Lmaxat(ipr), Lmax_g)
          end do
          do ipr = 0,n_atom_proto
            Z = Numat( itypepr(ipr) )
            if( Z == numat_abs ) Lmaxat(ipr) = Lmax_abs_a
          end do
          nlmagm = ( Lmax_g + 1 )**2

          allocate( Tau_ato(nlmagm,nspinp,nlmagm,nspinp,n_atom_0:n_atom_ind) )
          if( Green ) then
            nphiato = 0
            nphiato_c = 0
          elseif( abs(Eimag(ie)) > eps10 .or. Spinorbite .or. Ylm_comp ) then
            nphiato = 0
            nphiato_c = nbtm
          else
            nphiato = nbtm
            nphiato_c = 0
            do igrph = 1,ngrph
              if( .not. Repres_comp(igrph) ) cycle
              nphiato = 0
              nphiato_c = nbtm
              exit
            end do
          endif

          allocate( Phiato(nphiato,nlmagm,nspinp,nspino,natome) )
          allocate( Phiato_c(nphiato_c,nlmagm,nspinp,nspino,natome) )
          allocate( Taull(nlmagm,nspinp,nlmagm,nspinp,natome) )
          allocate( Tau_coop(nlmagm,nspinp,nlmagm,nspinp,nab_coop,nspino) )
          Phiato(:,:,:,:,:) = 0._db
          Phiato_c(:,:,:,:,:) = (0._db,0._db)
          Tau_ato(:,:,:,:,:) = (0._db,0._db)
          Taull(:,:,:,:,:) = (0._db,0._db)
          Tau_coop(:,:,:,:,:,:) = (0._db,0._db)

          if( .not. Green ) then
            call clmax(Ecmax_out,Rsort,Lmaxso0,Lmaxso,-1,.true.)
            Lmaxso = min( Lmaxso, Lmaxso_m )
            if( Close_open_bav ) open(3,file=nomfichbav, position='append' )
            if( icheck(18) > 0 ) write(3,'(/a9,i4)') ' Lmaxso =', Lmaxso
            if( Close_open_bav ) close(3)
          endif

          if( icheck(18) > 1 ) write(3,190)

! Loop over non-equivalent atoms
          n1 = n_atom_0

          do iapr = n1,n_atom_ind

            if( Second_run .or. Extract ) exit

            if( Full_atom ) then
              ipr = iaprotoi( iapr )
            else
              ipr = iapr
            endif
            Z = Numat( itypepr(ipr) )
            if( Z == 0 .and. .not. Green ) cycle
            if( Z == Z_nospinorbite ) then
              Spino = .false.
            else
              Spino = Spinorbite
            endif
            it = itypepr(ipr)
            if( Full_atom ) then
              Absorbeur = iapr == iaabsi
            else
              Absorbeur = iapr == iprabs
            endif

            allocate( V_hubb_t(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp))
            if( Hubb(it) .and. iapr <= n_atom_ind_self ) then
              Hubb_a = .true.
              if( Absorbeur ) then
                V_Hubb_t(:,:,:,:) = V_Hubb_abs(:,:,:,:)
                Hubb_d = Hubb_diag_abs
              else
                V_Hubb_t(:,:,:,:) = V_Hubb(:,:,:,:,iapr)
                Hubb_d = Hubb_diag(iapr)
              endif
            else
              Hubb_a = .false.
              Hubb_d = .true.
            end if
            nr = nrato(it)
            allocate( r(nr) )
            allocate( Vrato_e(nr,nlm_pot,nspin) )
            r(1:nr) = Rato(1:nr,it)

            Lmax = Lmaxat(ipr)

            Vrato_e(1:nr,:,:) = Vrato(1:nr,:,:,iapr)

            if( FDM_comp .and. .not. Green ) then
              V0bdc_e(:) = Vmft(:,iapr)
              Ecinetic_e(:) = Ecinetic_a(:,iapr)
            else
              V0bdc_e(:) = V0bdc(:)
              Ecinetic_e(:) = Ecinetic(:)
            endif

            call Sphere( Axe_atom_gr,Ecinetic_e,Eimag(ie),Energ(ie),Enervide,Full_atom, &
              Full_pot(iapr),Green,Hubb_a,Hubb_d,iaabsi,iapr,iaprotoi,ibord,icheck(18),igreq,igroupi,iopsymr,Lmax,Lmax_pot, &
              m_hubb,n_atom_0,n_atom_ind,n_atom_proto,natome,nbord,nbtm,nbtm_fdm,neqm,ngroup_m,nlm_pot,nlmagm,nlmmax, &
              nphiato,nphiato_c,npsom,nr,nspin,nspino,nspinp,Z,Phiato,Phiato_c,Posi,r,Relativiste,Renorm, &
              Rmtg(ipr),Rmtsd(ipr),Spin_axis_free,Spino,Tau_ato,V_hubb_t,V_intmax,V0bdc_e,Vrato_e,xyz,Ylm_comp,Ylmato)

            deallocate( r )
            deallocate( Vrato_e, V_hubb_t )

          end do

          if( Spin_axis_free .and. .not. ( Green .or. Second_run .or. Extract ) ) &
            call Rotate_phiato(iaprotoi,ibord,icheck(18),Lmaxat,n_atom_proto,natome,nbord,nbtm,nlmagm,nlmmax,nphiato_c, &
                               nspino,nspinp,Phiato_c,Rot_atom,Ylmato)

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(3) = real(time,db)
            Time_rout(7) = Time_rout(7) + Time_loc(3) - Time_loc(2)
          endif

! nspinorb = 2 if magnetic without Spin-orbit
! nspinorb = 1 if non-magnetic or Spin-orbit
! nspino = 2 if Spin-orbit

! igrph: loop over representations

          Lmax_g = 0
          do ia = 1,natome
            Lmaxa(ia) = Lmaxat( iaprotoi(ia) )
            Lmax_g = max(Lmax_g,Lmaxa(ia))
          end do
          Time_fill = 0._db; Time_tria = 0._db

          if( .not. ( Second_run .or. Extract ) ) then

            do ispin = 1,nspinorb
              do igrph = 1,ngrph

                nlmsamax = 0
                nlmsa(:) = 0
                do ia = 1,natome
                  Z = Numat(itypei(ia))
                  if( .not. Green .and. Z == 0 ) cycle
                  n = nlmsa0(ia,igrph)
                  allocate( Lval(n) )
                  Lval(1:n) = Lato(1:n,ia,igrph)
                  call cnlmmax(Lmaxa(ia),Lval,n,nlmsa(ia))
                  nlmsamax = max(nlmsamax,nlmsa(ia))
                  deallocate( Lval )
                end do
                if( nlmsamax == 0 .and. igrph /= ngrph ) cycle
                ich = icheck(19)

                if( Green ) then
                  call Mat_MST(Axe_Atom_gr,Cal_xanes,Dist_coop,Ecinetic,Eimag(ie),Full_atom,ia_coop,ia_eq,ia_rep, &
                    iaabsi,iaprotoi,iato,ich,igroupi,igrph,iopsymr,irep_util,is_eq,ispin,karact,Lato,Lmaxa,Lmax_g,mato, &
                    n_atom_0,n_atom_coop,n_atom_ind,n_atom_proto,nab_coop,natome,natomp,nb_eq,nb_rpr,nb_rep_t,nb_sym_op,nb_test, &
                    ngroup_m,ngrph,nlmagm,nlmsa,nlmsam,nlmsamax,Normaltau,nspin,nspino,nspinp,pos,Posi,Recop,Repres_comp(igrph), &
                    Rmtg,Rot_atom,Solsing,Spin_axis_free,Spinorbite,State_all,Sym_cubic,Tau_ato,Tau_nondiag,Tau_coop,Taull, &
                    Test_case,Time_fill,Time_tria,Ylm_comp)

                else

                  n = nlmso0(igrph)
                  allocate( Lval(n) )
                  Lval(1:n) = Lso(1:n,igrph)
                  call cnlmmax(Lmaxso,Lval,n,nlmso)
                  deallocate( Lval )
                  call Mat_FDM(Adimp,Ampl_dft,Atom_axe,Base_hexa,Basereel,Cal_xanes,cgrad, &
                      clapl,Dist_coop,distai,E_comp,Ecinetic_out,Eclie_out,Eimag(ie),Eneg,Enervide, &
                      gradvr,ia_coop,iaabsi,iaprotoi,iato,ibord,ich,ie,igrph,irep_util,isbord, &
                      iso,ispin,isrt,isvois,ivois,karact,Lato,Lmaxa,Lmaxso,Lso,mato,mpinodes,mpirank0,mso, &
                      n_atom_coop,n_atom_proto,nab_coop,natome,nbm,nbm_c,nbord,nbordf,nbtm, &
                      ngrph,nim,nicm,nlm_rixs,nlmagm,nlmmax,nlmomax,nlmsa,nlmsam,nlmso,nphiato,nphiato_c,npoint,npr,npsom, &
                      nsort,nsortf,nso1,nspin,nspino,nspinp,numia,nvois,Phiato,Phiato_c,poidsa,poidso,Posi,R_rydb, &
                      Recop,Relativiste,Repres_comp(igrph),RIXS_gen,Rmtg,Rot_Spinor,Rsort,rvol,Rydberg,Spin_axis_free,Spinorbite, &
                      State_all,Sym_cubic,Tau_coop,Taull,Time_fill,Time_tria,V0bdc_out,Vr,xyz,Ylm_comp, &
                      Ylmato,Ylms,Ylmso)
                endif

              end do  ! end of loop over representations
            end do  ! end of loop over spin

          endif

          if( Spin_axis_free ) then
            if( Close_open_bav ) open(3,file=nomfichbav, position='append' )
            call Rotate_TauLL(ich,Lmaxa,natome,nlmagm,nspinp,Rot_atom,TauLL,.true.)
            if( Close_open_bav ) open(3,file=nomfichbav, position='append' )
          endif

          if( One_run_L .and. .not. Extract ) &
            call Data_one_run(First_run,i_layer,ia_eq,iabsm,icheck(19),igr_layer,igreq,index_e,igroup,igroupi,ipr1,Lmax_probe, &
              Lmaxa,multi_run,n_abs_bulk,n_atom_proto,n_layer_abs,n_multi_run,n_proto_layer,n_proto_layer_max,natome,natomp,nb_eq, &
              nb_sym_op,neqm,nge,ngreq,nlm_probe,nlmagm,nspinp,One_run_s,Rot_atom,Rot_cluster,Spinorbite,Taull,Taull_stk,Ylm_comp)

          if( Extract ) call Tau_reading(icheck(19),ie,iaabsi,Lmaxa(iaabsi),natome,nenerg,nlmagm,nspinp,RIXS_gen,Taull)

          if( Extract .and. RIXS_gen ) call Ampl_reading(Ampl_dft,icheck(19),ie,Lmaxso,mpinodee,mpirank0,nenerg,nlm_probe, &
                                                     nlm_rixs,nlmomax,nspinp)

          nlm = ( Lmaxa(iaabsi) + 1 )**2

          allocate( Taull_loc(nlm,nspinp,nlm,nspinp) )

          TauLL_loc(1:nlm,:,1:nlm,:) = Taull(1:nlm,:,1:nlm,:,iaabsi)

          if( Ylm_comp .and. ( Full_potential .or. ( Hubb_abs .and. .not. Hubb_diag_abs ) ) .and. .not. Spinorbite ) then
            Name = 'TauLL'
            call Trans_CompToReal_TauLL(.true.,icheck(19),Length_n,Lmaxa(iaabsi),Name,nlm,nspinp,Spinorbite,TauLL_loc)
          endif

          do Lm1 = 1,min(nlm,nlmmax)
            do Lm2 = 1,min(nlm,nlmmax)
              Taull_dft(Lm1,:,Lm2,:,mpirank) = TauLL_loc(Lm1,:,Lm2,:)
            end do
          end do

          Lmax_dft(:,mpirank) = Lmaxat(:)

          if( RIXS_gen ) then
            if( nlm_probe > nlm_rixs ) then
              L = nint( sqrt( real( nlm_rixs ) ) ) - 1
              call write_error
              do ipr = 6,9,3
                write(ipr,200) Lmax_probe, L
              end do
              stop
            endif
            nlm_fe(ie) = (Lmaxso+1)**2
            Ampl_abs(ie,1:nlm_probe,:,1:nlm_fe(ie),:) = Ampl_dft(1:nlm_probe,:,1:nlm_fe(ie),:,mpirank0)
          endif

          if( Optic_xanes .or. Tddft_xanes .or. RIXS ) then
! Can be done like this because Eimag = 0 in tddft and optic
            Lm1 = 0
            do l1 = 0,min(Lmaxa(iaabsi),Lmax_tddft)
              do m1 = -l1,l1
                Lm1 = Lm1 + 1
                if( Lm1 > nlm ) exit
                Lm2 = 0
                do l2 = 0,min(Lmaxa(iaabsi),Lmax_tddft)
                  do m2 = -l2,l2
                    Lm2 = Lm2 + 1
                    if( Lm2 > nlm ) exit
                    do isp1 = 1,nspinp
                      do isp2 = 1,nspinp
! In FDM, next line does not change nothing
                        Tau_abs(ie,Lm1,isp1,Lm2,isp2) = 0.5_db * ( TauLL_loc(Lm1,isp1,Lm2,isp2) &
                                                            - conjg( TauLL_loc(Lm2,isp2,Lm1,isp1) ) )
                      end do
                    end do
                  end do
                end do
              end do
            end do
            if( Optic_Xanes ) then
              if( ie == 1 ) write(6,'(/A)') '   Energy   -Tau_i(l,m=0,l,m=0) l = 0,Lmax_probe'
              write(6,'(f10.3,1p,6e13.5)') Energ(ie)*rydb, ( - aimag( Tau_abs(ie,l**2+l+1,1,l**2+l+1,1) ), &
                   L = 0,Lmax_probe )
            endif
          endif

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(4) = real(time,db)
            Time_rout(8) = Time_rout(8) + Time_loc(4) - Time_loc(3)
            Time_rout(9) = Time_rout(9) + Time_fill ! Filling
            Time_rout(10) = Time_rout(10) + Time_tria ! Triang
          endif

          if( Full_atom ) then
            iaprabs = iaabsi
          else
            iaprabs = iprabs
          endif

! Calculation of cartesian tensors
          if( .not. Optic ) then

            ns_dipmag = 1
            ndim2 = 1
            allocate( Taull_abs(nlm_probe,nspinp,nlm_probe,nspinp) )

            do i = 1,2

              if( i == 1 .and. .not. Xan_atom ) cycle

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

              if( i == 2 ) then

                Taull_abs(1:nlm_probe,:,1:nlm_probe,:) = TauLL_loc(1:nlm_probe,:,1:nlm_probe,:)

              elseif( .not. Solsing ) then
          ! For the atomic part, all signal is in the irregular solution

                if( Full_atom ) then
                  iapr = iaabsi
                elseif( Nonexc ) then
                  iapr = iprabs_nonexc
                else
                  iapr = 0
                endif

                do Lm1 = 1,nlm_probe
                  do isp1 = 1,nspinp
                    do Lm2 = 1,nlm_probe
                      do isp2 = 1,nspinp
                        if( .not. Spinorbite .and. isp1 /= isp2 ) cycle
                        Taull_abs(Lm1,isp1,Lm2,isp2) = 0.5_db * &
                                                ( Tau_ato(Lm1,isp1,Lm2,isp2,iapr) -  conjg( Tau_ato(Lm2,isp2,Lm1,isp1,iapr) ) )
                      end do
                    end do
                  end do
                end do

              endif

              if( .not. Extract .and. ( i == 1 .or. .not. Xan_atom ) ) then
                allocate( Vra(nrato_abs,nlm_pot,nspin) )
                if( Full_atom ) then
                  Vra(1:nrato_abs,:,:) = Vrato(1:nrato_abs,:,:,iaabsi)
                else
                  Vra(1:nrato_abs,:,:) = Vrato(1:nrato_abs,:,:,iprabs)
                endif
              endif
              if( Tddft ) then
                ip00 = 0
              else
                ip00 = ip0
              endif
              n_V = 1
              n_Ec = 1
              allocate( Enervide_t(n_Ec) )
              Enervide_t(1) = Enervide

              if( FDM_comp .and. .not. Green ) then
                V0bdc_e(:) = Vmft(:,iaprabs)
                Ecinetic_e(:) = Ecinetic_a(:,iaprabs)
              else
                V0bdc_e(:) = V0bdc(:)
                Ecinetic_e(:) = Ecinetic(:)
              endif

              if( mpirank_in_mumps_group == 0 ) then

                ninit_tddft = 0
                allocate( Chi(nlm_probe*nspino,nlm_probe*nspino,ninit_tddft,ninit_tddft,2,2,ns_dipmag) )

                if( NRIXS ) call S_nrixs_cal( Chi, Coef_g, Core_resolved, Ecinetic_e, &
                  Eimag(ie), Energ(ie), Enervide_t, Eseuil, Final_tddft, Full_pot(iaprabs), Green, Green_int, Hubb_abs, &
                  Hubb_diag_abs, icheck(20), L0_nrixs, Lmax_nrixs, is_g, Lmax_probe, Lmax_pot, Lmoins1, Lplus1, Lseuil, m_g, &
                  m_hubb, mpinodee, mpirank, n_Ec, n_V, nb_test, nbseuil, ns_dipmag, ninit_tddft, &
                  ninit1, ninit, ninitr, ninitlv, nlm_pot, nlm_probe, nlm_p_fp, nq_nrixs, nrato_abs, nrm, nspin, nspino, nspinp, &
                  Numat(itabs), Psii, q_nrixs, rato_abs, Relativiste, Renorm, Rmtg_abs, Rmtsd_abs, &
                  S_nrixs, S_nrixs_m, Solsing, Solsing_only, Spinorbite, Taull_abs, Test_case, &
                  V_hubb_loc, V_intmax, V0bdc_e, Vra, Ylm_comp_loc )

                call Tenseur_car( Chi, Coef_g, Core_resolved, Ecinetic_e, Eimag(ie), Energ(ie), &
                  Enervide_t, Eseuil, Final_tddft, Full_pot(iaprabs), Green, Green_int, Hubb_abs, Hubb_diag_abs, &
                  icheck(20) ,ie, ip_max, ip00, is_g, Lmax_probe, Lmax_pot, Ldip, Lmoins1, Loct, Lplus1, Lqua, Lseuil, m_g, &
                  m_hubb, mpinodee, mpirank, mpirank0, msymdd, msymddi, msymdq, msymdqi, msymdo, msymdoi, msymoo, msymooi, &
                  msymqq, msymqqi, Multipole, n_Ec, n_oo, n_V, nb_test, nbseuil, ns_dipmag, nenerg_tddft, ninit1, &
                  ninit, ninit_tddft, ninitr, ninitlv, nlm_pot, nlm_probe, nlm_p_fp, nlmamax, nrato_abs, nrm, nspin, nspino, &
                  nspinp, Numat(itabs), Psii, Rato_abs, Relativiste, Renorm, Rmtg_abs, Rmtsd_abs, rof0, rot_atom_abs, Rot_cluster, &
                  T_E1E1, T_E1E1_m, T_E1E2, T_E1E2_m, T_E1E3, T_E1E3_m, T_E1M1, T_E1M1_m, T_E1M2, T_E1M2_m, T_E1SP, T_E1SP_m, &
                  T_E2E2, T_E2E2_m, T_E2M2, T_E2M2_m, T_E3E3, T_E3E3_m, T_M1M1, T_M1M1_m, T_SPSP, T_SPSP_m, &
                  Solsing, Solsing_only, Spinorbite, Taull_abs, Tddft, Test_case, V_hubb_loc, V_intmax, V0bdc_e, Vra, Ylm_comp_loc )

                deallocate( Chi )

              endif
              deallocate( Enervide_t )

              if( i == 1 ) then

                sec_atom(:) = 0._db
                do initl = 1,ninitr
                  do j = 1,3
                    sec_atom(initl) = sec_atom(initl) + Real(T_E1E1(j,j,initl,mpirank), db)
                  end do
                end do
                sec_atom(:) = sec_atom(:) / 3

              endif

            end do

            deallocate( Taull_abs )

          endif

          deallocate( Tau_ato )
          deallocate( Phiato, Phiato_c )

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(5) = real(time,db)
            Time_rout(11) = Time_rout(11) + Time_loc(5) - Time_loc(4)
          endif

          ich = icheck(28)
          Solsing_o = Solsing_only

          if( Density .or. FDM_comp ) then
            if( Extract ) then
              if ( Full_atom ) then
                Vrato(1:nrato_abs,:,:,iaabsi) = Vra(1:nrato_abs,:,:)
              else
                Vrato(1:nrato_abs,:,:,iprabs) = Vra(1:nrato_abs,:,:)
              endif
            endif
            if( Density ) &
              call Cal_dens(Cal_xanes,Density_comp,Density_sp,drho_self,Ecinetic,Eimag(ie),Energ(ie),Enervide,Full_atom, &
                Full_pot(iaprabs),Harm_cubic,Hubb,Hubb_diag,Hubb_diag_abs,iaabsi,iaprotoi,ich,itypei,itypepr,lla2_state, &
                Lmax_pot,Lmaxat,m_hubb,mpinodee,mpirank,n_atom_0,n_atom_0_self,n_atom_ind,n_atom_ind_self, &
                n_atom_proto,natome,nb_test,nlmagm,nlm_pot, &
                nrato,nrm,nrm_self,nspin,nspino,nspinp,ntype,Numat,Rato,Relativiste,Renorm,Rmtg,Rmtsd,Solsing,Solsing_o, &
                Spinorbite,State_all_out,Statedens,Statedens_i,Taull,Test_case,V_hubb,V_hubb_abs,V_intmax,V0bdc,Vrato,Ylm_comp)
          endif

          if( COOP ) call Cal_COOP(Coop_z_along_bond,Coverlap,Density_comp,Dist_coop,Ecinetic,Eimag(ie),Energ(ie), &
            Enervide,Full_atom,Full_potential,Harm_cubic,Hubb,Hubb_diag,Hubb_diag_abs,ia_coop,iaabsi,iaprotoi,icheck(28),ie, &
            index_coop,iprabs,itypepr,Lmax_DOSout,Lmax_pot,Lmaxat,m_hubb,mpinodee,mpirank,n_atom_0,n_atom_0_self, &
            n_atom_coop,n_atom_ind,n_atom_ind_self,n_atom_proto,nab_coop,natome,nlm_pot,nlmagm,nrato,nrm, &
            nspin,nspino,nspinp,ntype,Numat,Posi,Rato,Relativiste,Renorm,Rmtg,Rmtg0,Rmtsd,Rot_atom,Spinorbite,Tau_coop,V_hubb, &
            V_hubb_abs,V_intmax,V0bdc,Vrato,Ylm_comp,Z_nospinorbite)

          deallocate( Tau_coop, Taull, TauLL_loc )
          if( Extract .or. ( .not. Optic .and. .not. Extract ) ) deallocate( Vra )

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(6) = real(time,db)
            Time_rout(12) = Time_rout(12) + Time_loc(6) - Time_loc(5)
          endif

        endif ! end of condition on ie <= nenerg

        if( mpinodee > 1 ) then

          call MPI_RECV_Tau(Lmax_dft,mpinodee,mpirank,mpirank0,n_atom_proto,nlmmax,nspinp,Taull_dft)

          if( Density ) &
            call MPI_RECV_statedens(lla2_state,Lmaxat,mpinodes,mpirank,mpirank0,n_atom_0, &
                                      n_atom_ind,n_atom_proto,nspinp,Statedens,Statedens_i)

          if( COOP ) &
            call MPI_RECV_COOP(mpinodes,mpirank,mpirank0,nab_coop,nspinp,Coverlap)

          if( .not. Optic ) &
            call MPI_RECV_all( L0_nrixs, Lmax_nrixs, mpinodee, mpirank, mpirank0, Multipole, n_oo, ninitr, &
                        nq_nrixs, S_nrixs, T_E1E1, T_E1E2, T_E1E3, T_E1M1, T_E1M2, T_E1SP, T_E2E2, T_E2M2, &
                        T_E3E3, T_M1M1, T_SPSP )

          if( Tddft_xanes .or. Optic_xanes .or. RIXS ) &
            call MPI_Bcast_tddft(je,mpinodee,mpirank,nbseuil,nenerg,nenerg_tddft,nlmamax,nspinp,nspino,rof0,Tau_abs)

          if( RIXS_gen ) call MPI_Bcast_RIXS(Ampl_abs,je,mpinodee,mpirank,nenerg_RIXS,nlm_fe,nlm_probe,nlmomax,nspinp)

        endif

        if( Close_open_bav ) open(3,file=nomfichbav, position='append' )

        do ie_computer = 0,mpinodee-1

          ie = ( je - 1 ) * mpinodee + ie_computer + ie0

          if( ie > nenerg0 ) exit

          if( mpinodee > 1 ) call MPI_Bcast(Eimag(ie),1,MPI_REAL8,ie_computer,MPI_COMM_GATHER,mpierr)

          if( mpirank0 == 0 ) then

            call CPU_TIME(time)
            Time_loc(1) = real(time,db)

            if( icheck(19) > 3 .and. .not. FDM_comp ) &
              call Tau_wout(iabsorig(multi_run),Energ(ie),ie,ie_computer,Lmax_dft(iprabs,ie_computer),mpinodee, &
                           n_multi_run,nlmmax,nomfich,nspinp,Taull_dft)

            if( icheck(19) > 0 ) &
              call Tau_writing(Eimag(ie),Energ(ie),iprabs,ie_computer,itypepr,Lmax_dft,Lmax_probe,mpinodee,n_atom_proto, &
                               nlmmax,nspinp,ntype,Numat,Taull_dft)

            if( RIXS_gen .and. icheck(19) > 0 ) &
              call Ampl_writing(Ampl_dft,ie_computer,Lmaxso,mpinodes,nlm_rixs,nlmomax,nspinp)

            if( .not. Optic .and. .not. Only_RIXS ) then

              if( Abs_in_Bulk_roughness .and. DAFS ) then

                call Write_coabs( Abs_cap, Abs_in_Bulk_roughness, Abs_SRXRD, Abs_SRXRD_abs, Abs_U_iso, Allsite, angxyz, axyz, &
                Bragg_rgh_bulk_abs, .false., Cartesian_tensor, &
                Core_resolved, Dafs, Dafs_bio, E_cut, Energ, Energphot, Epsii, Eseuil, Final_tddft, First_E, &
                f_avantseuil, Full_self_abs, Green_int, Header, hkl_dafs, iabsorig(multi_run), icheck(21), ie, ie_computer, &
                index_z_SRXRD_abs, Int_tens, isigpi, isymeq, jseuil, Length_abs, ltypcal, Matper, Moyenne, mpinodee, &
                multi_0, Multipole, n_abs_rgh, n_bulk_sup, n_multi_run, n_z_SRXRD, n_z_SRXRD_abs, &
                n_z_SRXRD_abs_max, n_zc_SRXRD_abs, n_max, n_oo, n_tens_max, natomsym, nbseuil, ncolm, ncolr, ncolt, &
                nenerg, ninit1, ninitr, nomabs, nomfich, nomfich_cal_conv, nomfich_s, Non_resonant_Bulk, nphi_dafs, &
                npldafs, nphim, nplr, nplrm, nseuil, nspinp, numat_abs, nxanout, pdp, phdt_rgh_Bulk, pol, poldafse, poldafss, &
                Pos_z_SRXRD, Pos_z_SRXRD_abs, sec_atom, T_E1E1, T_E1E1_m, T_E1E2, T_E1E2_m, T_E1E3, T_E1E3_m, T_E1M1, T_E1M1_m, &
                T_E1M2, T_E1M2_m, T_E1SP, T_E1SP_m, T_E2E2, T_E2E2_m, T_E2M2, T_E2M2_m, T_E3E3, T_E3E3_m, T_M1M1, T_M1M1_m, &
                T_SPSP, T_SPSP_m, Self_abs, &
                Spherical_signal, Spherical_tensor, Spinorbite, Sum_Bragg_abs_f0, Sum_Bragg_nonabs_f, Sum_Bragg_NR_Bulk, &
                Sum_Bragg_NR_T_rgh_bulk, Surface_ref, Taux_eq, V0muf, Vecdafse, Vecdafss, Vec, Volume_maille, Xan_atom )

                multi_0 = multi_0 + 1
              endif

              call Write_coabs( Abs_cap, Abs_in_Bulk_roughness, Abs_SRXRD, Abs_SRXRD_abs, Abs_U_iso, Allsite, angxyz, axyz, &
                Bragg_abs, Bulk_step, Cartesian_tensor, &
                Core_resolved, Dafs, Dafs_bio, E_cut, Energ, Energphot, Epsii, Eseuil, Final_tddft, First_E, &
                f_avantseuil, Full_self_abs, Green_int, Header, hkl_dafs, iabsorig(multi_run), icheck(21), ie, ie_computer, &
                index_z_SRXRD_abs, Int_tens, isigpi, isymeq, jseuil, Length_abs, ltypcal, Matper, Moyenne, mpinodee, &
                multi_0, Multipole, n_abs_rgh, n_bulk_sup, n_multi_run, n_z_SRXRD, n_z_SRXRD_abs, &
                n_z_SRXRD_abs_max, n_zc_SRXRD_abs, n_max, n_oo, n_tens_max, natomsym, nbseuil, ncolm, ncolr, ncolt,&
                nenerg, ninit1, ninitr, nomabs, nomfich, nomfich_cal_conv, nomfich_s, Non_resonant_bulk, nphi_dafs, &
                npldafs, nphim, nplr, nplrm, nseuil, nspinp, numat_abs, nxanout, pdp, phdt, pol, poldafse, poldafss, &
                Pos_z_SRXRD, Pos_z_SRXRD_abs, sec_atom, T_E1E1, T_E1E1_m, T_E1E2, T_E1E2_m, T_E1E3, T_E1E3_m, T_E1M1, T_E1M1_m, &
                T_E1M2, T_E1M2_m, T_E1SP, T_E1SP_m, T_E2E2, T_E2E2_m, T_E2M2, T_E2M2_m, T_E3E3, T_E3E3_m, T_M1M1, T_M1M1_m, &
                T_SPSP, T_SPSP_m, Self_abs, &
                Spherical_signal, Spherical_tensor, Spinorbite, Sum_Bragg_abs_f0, Sum_Bragg_nonabs_f, Sum_Bragg_NR_Bulk, &
                Sum_Bragg_NR_T, Surface_ref, Taux_eq, V0muf, Vecdafse, Vecdafss, Vec, Volume_maille, Xan_atom )

              if( Abs_in_Bulk_roughness .and. DAFS ) multi_0 = multi_0 - 1

              if( NRIXS ) call Write_RamanX(Abs_U_iso,All_nrixs,Allsite,axyz,Core_resolved,E_cut,Energ,Energphot, &
                Epsii,Eseuil,f_avantseuil,Final_tddft,First_E,Green_int,Header, &
                iabsorig(multi_run),icheck(21),ie,ie_computer,isymeq,jseuil,L0_nrixs,Lmax_nrixs,mpinodee,n_multi_run, &
                natomsym,nbseuil,nenerg,ninit1,ninitr,nomfich,nomfich_cal_conv(multi_run),nq_nrixs,nseuil,nspinp, &
                numat_abs,Orthmatt,q_nrixs,Rot_atom_abs,Rot_cluster,S_nrixs,S_nrixs_m,Spinorbite,Taux_eq,V0muf,Volume_maille)

              First_E = .false.
            endif

            call CPU_TIME(time)
            Time_loc(2) = real(time,db)
            Time_rout(13) = Time_rout(13) + Time_loc(2) - Time_loc(1)

            if( Density .and. i_range == 1 ) &
              call Write_Density(Energ,Density_comp,Full_atom,Harm_cubic,iaabsi,iaprotoi,icheck(28),ie,ie_computer, &
                Int_statedens,itypei,itypepr,lla_state,lla2_state,Lmax_DOSout,Lmaxat,mpinodee,n_atom_0,n_atom_ind,n_atom_proto, &
                natome,nenerg,nomfich_s,nonexc_g,nrato,nrm,nspin,nspinp,ntype,Numat,Rato,Rmtsd,State_all_out,Statedens)

            if( COOP ) then
              if( Spinorbite ) then  ! because coop with real harmonics and spinorbit does not work
                call Write_coop(Coverlap,.true.,Energ(ie),.false.,iaprotoi,ie,ie_computer,index_coop,itypepr, &
                                       Lmax_DOSout,mpinodee,n_atom_proto,nab_coop,natome,nomfich_s,nspin,nspinp,ntype,Numat)
              else
                call Write_coop(Coverlap,Density_comp,Energ(ie),Harm_cubic,iaprotoi,ie,ie_computer,index_coop,itypepr, &
                                       Lmax_DOSout,mpinodee,n_atom_proto,nab_coop,natome,nomfich_s,nspin,nspinp,ntype,Numat)
              endif
            endif

            call CPU_TIME(time)
            Time_loc(3) = real(time,db)
            Time_rout(14) = Time_rout(14) + Time_loc(3) - Time_loc(2)

          endif

        end do

        if( Close_open_bav ) Close(3)

      end do boucle_energ_xanes   ! End of loop over energy

      if( Close_open_bav ) open(3,file=nomfichbav, position='append' )

      if( Bulk_step .and. .not. Full_atom .and. Self_nonexc .and. Self_cons_c ) then
   ! One keeps the bulk atom potentials
        Vcato_bulk(:,:,iprabs_nonexc) = Vcato(:,:,iprabs_nonexc)
        do ipr = n_atom_proto - n_atom_proto_bulk + 1,n_atom_proto
          Vcato_bulk(:,:,ipr) = Vcato(:,:,ipr)
        end do
      endif

      deallocate( Atom_axe, distai, ia_eq, ia_eq_inv, ia_rep, iaprotoi, igroupi, iopsym_atom, is_eq, itypei, nb_eq )
      deallocate( nb_rpr, nb_rep_t, Posi, Rot_atom, Rot_atomp, Wigner_one_half )
      deallocate( RadialIntegral, Tau_comp )

      if( .not. ( Green .or. Second_run .or. Extract ) ) then
        deallocate( gradvr )
        deallocate( Ylmso )
      endif
      deallocate( Ylmato, Ylms )
      if( .not. ( Second_run .or. Extract ) ) &
        deallocate( ibord, isbord, isrt, nbord, nbordf, poidsa, poidso )

      deallocate( Coverlap, drho_self, index_coop, Lmaxa, nlmsa, Statedens, Statedens_i )
      deallocate( iato, Lato, iso, Lso, mato, mso, nlmso0, nlmsa0 )
      deallocate( imoy, imoy_out )
      deallocate( Full_pot, poidsov, poidsov_out, rho, rhons, Vr, Vrato )
      deallocate( Ecinetic_a, Vmft )

      if( One_run_s .and. .not. Bulk_step ) then
        Condition = ( Abs_in_bulk .and. iabsm(multi_run) /= igr_layer(1,i_layer) ) &
                  .or. ( .not. Abs_in_bulk .and. iabsm(multi_run) /= igr_layer(n_proto_layer(i_layer),i_layer) )
      elseif( One_run_L ) then
        Condition = (  Abs_in_bulk .and. multi_run /= 1 ) .or. ( .not. Abs_in_bulk .and. multi_run /= n_multi_run )
      else
        Condition = .false.
      endif

      if( .not. ( ( One_run_L .and. Condition ) .or. Extract ) ) &
        deallocate( Excato, rs, rhoato, rsato, Vcato, Vh, Vhns, Vxc, Vxcato )

    end do boucle_i_range

    if( One_run_s .and. .not. Bulk_step ) then
      Condition = ( Abs_in_bulk .and. iabsm(multi_run) == igr_layer(1,i_layer) ) &
                .or. ( .not. Abs_in_bulk .and. iabsm(multi_run) == igr_layer(n_proto_layer(i_layer),i_layer) )
    elseif( One_run_L ) then
      Condition = (  Abs_in_bulk .and. multi_run == 1 ) .or. ( .not. Abs_in_bulk .and. multi_run == n_multi_run )
    else
      Condition = .false.
    endif

    if( Condition ) deallocate( Taull_stk )

    deallocate( Posi_self, S_nrixs, S_nrixs_m )
    deallocate( T_E1E1, T_E1E2, T_E1E3, T_E1M1, T_E1M2, T_E1SP, T_E2E2, T_E2M2, T_E3E3, T_M1M1, T_SPSP )
    deallocate( T_E1E1_m, T_E1E2_m, T_E1E3_m, T_E1M1_m, T_E1M2_m, T_E1SP_m, T_E2E2_m, T_E2M2_m, T_E3E3_m, T_M1M1_m, T_SPSP_m )
    deallocate( sec_atom )
    deallocate( Energ, Eimag )
    deallocate( Ampl_dft, Taull_dft )

    if( mpirank0 == 0 ) deallocate( Int_statedens )

    deallocate( Repres_comp )

    if( mpirank0 == 0 ) then
      call CPU_TIME(time)
      tp_XANES_2 = real(time,db)
      Time_rout(19) = Time_rout(19) + tp_XANES_2 - tp_XANES_1 ! XANES
    endif

!----------------------------------------------------------------------------------------------------------------------------------------------

    if( RIXS .and. mpirank0 == 0 ) then

      if( multi_run == 1 ) allocate( File_name_rixs(n_multi_run) )

      allocate( Tau_abs_t(nenerg_s,nlm_probe,nspinp,nlm_probe,nspinp) )
      do Lm1 = 1,min(nlm_probe,nlmamax)
        do Lm2 = 1,min(nlm_probe,nlmamax)
          Tau_abs_t(:,Lm1,:,Lm2,:) = Tau_abs(:,Lm1,:,Lm2,:)
        end do
      end do

      call main_RIXS(alfpot,Ampl_abs,Analyzer,Circular,coef_f,Coef_g,Core_resolved,dV0bdcF,Delta_Gauss_Rixs, &
         E_cut,E_cut_imp,E_Emis,E_Fermi,E_cut_man,Ecent,Eclie,Elarg,Eneg,Energ_loss_max,Energ_rixs,Energ_s, &
         Epsif,Epsif_ref,Epsif_ref_man,Epsii,Epsii_ref,Epsii_ref_man,Eseuil, &
         File_name_rixs,Full_potential,Gamma_hole,Gamma_hole_man,HERFD,Hubb_abs,Hubb_diag_abs, &
         iabsorig(multi_run),icheck(29),isymeq,ip0,ip_max,is_f,is_g,J_Emis,jseuil,L_Emis,Lmoins1,Lplus1,Lseuil, &
         m_f,m_g,m_hubb,Moment_conservation,mpirank0,multi_run,Multipole,n_atom_proto,n_atom_uc, &
         n_Emis,n_multi_run,n_q_rixs,n_shift_core,n_theta_rixs,n_trans,natomsym,nb_Emis,nbseuil,nenerg_in_rixs, &
         nenerg_s,neqm,nfinal,nfinal1,nfinalr,ngamh,ninit,ninit1,ninitr,nlm_pot,nlm_probe, &
         nlmomax,nomfich,nrato_abs,nrm,nseuil,nspin,nspino,nspinp,numat_abs,Only_indirect,Orthmati,Powder, &
         Psi_Emis,psii,q_rixs,rato_abs,Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,Rot_atom_abs,Rot_cluster,rsato_abs,rsbdc,Shift_core, &
         Spinorbite,Tau_abs_t,Temp,Theta_rixs,V_intmax,V_hubb,Vcato_abs,Vhbdc,Volume_maille,VxcbdcF,Vxcato_abs,Ylm_comp)

      deallocate( Tau_abs_t )

      if( multi_run == n_multi_run ) deallocate( File_name_rixs )

      if( mpirank0 == 0 ) then
        call CPU_TIME(time)
        Time_loc(2) = real(time,db)
        Time_rout(20) = Time_rout(20) + Time_loc(2) - tp_XANES_2
      endif

      if( .not. ( TDDFT .or. Optic ) ) deallocate( Tau_abs )

    endif

    deallocate( Ampl_abs, nlm_fe )

    if( Tddft .or. Optic ) then

      Atom_nonsph_loc = .false.

      if( Optic ) then

        if( mpirank0 == 0 ) then
          call CPU_TIME(time)
          Time_loc(1) = real(time,db)
        endif

        if( .not. No_DFT ) call main_optic(Abs_U_iso,angxyz,Allsite,axyz,Bragg_abs,Cartesian_tensor, &
          Core_resolved,Dafs,Dafs_bio,dV0bdcF,E_cut,E_cut_imp,E_cut_man,E_Fermi,Eclie,Eneg,Energ_s,Ephot_min, &
          Eseuil,Full_potential,Full_self_abs,Header,hkl_dafs,Hubb_abs,Hubb_diag_abs,icheck, &
          iabsorig(multi_run),ip_max,ip0,isigpi,isymeq, &
          jseuil,Ldip,Length_abs,Lmax_pot,Lmax_probe,Lmax_abs_t,Lmaxat0,Lmaxfree,Lmoins1,Loct,Lplus1,Lqua, &
          ltypcal,m_hubb,Matper,Moyenne,mpinodes,mpirank,mpirank0,msymdd,msymddi,msymdq, &
          msymdqi,msymdo,msymdoi,msymoo,msymooi,msymqq,msymqqi,multi_0,Multipole,n_bulk_sup,n_multi_run, &
          n_oo,n_rout,n_tens_max,natomsym,nbseuil,ncolm,ncolr,ncolt,nenerg_s,ninit1,ninitr,nlm_pot, &
          nlm_probe,nlmamax,nomabs,nomfich,nomfich_cal_conv,nomfich_s,nphi_dafs,nphim,npldafs,nplr,nplrm, &
          nrato_abs,nseuil,nspin,nspino,nspinp,numat_abs,nxanout,pdp,phdt,pol,poldafse,poldafss, &
          rato_abs,Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,rot_atom_abs,Rot_cluster,Self_abs,Spherical_signal, &
          Spherical_tensor,Spinorbite,Sum_Bragg_abs_f0,Sum_Bragg_nonabs_f,Sum_Bragg_NR_T,Tau_abs,Taux_eq, &
          Time_rout,V_intmax,V_hubb_loc,V0muf,Vcato_abs,vec,Vecdafse,Vecdafss,Vhbdc,Volume_maille,VxcbdcF,Vxcato_abs, &
          Ylm_comp_loc)

        if( mpirank0 == 0 ) then
          call CPU_TIME(time)
          Time_loc(2) = real(time,db)
          Time_rout(20) = Time_rout(20) + Time_loc(2) - Time_loc(1)
        endif

        if( Core_resolved ) then
          ninit_out = ninitr
        else
          ninit_out = 1
        endif

        if( Tddft ) call main_tddft_optic( Abs_U_iso, alfpot, angxyz, Allsite, Atomic_scr, axyz, Bragg_abs, &
          Cartesian_tensor, Core_resolved, Dipmag, dV0bdcF, E_cut, E_cut_imp, E_cut_man, E_fermi, Eclie, Eneg, &
          Energ_s, Energphot, Ephot_min, Eseuil, f_avantseuil, Full_potential, Full_self_abs, &
          Gamma_tddft,Header,hkl_dafs,Hubb_abs,Hubb_diag_abs,icheck,iabsorig(multi_run),isigpi,isymeq, &
          jseuil,Kern_fac,Kern_fast,Ldip,Length_abs,Lmax_pot,Lmax_abs_t,Lmoins1,Loct,Lplus1,Lqua, &
          ltypcal,m_hubb,Magnetic,Matper,Moyenne,mpinodes,mpirank,mpirank0,msymdd,msymddi,msymdq, &
          msymdqi,msymdo,msymdoi,msymoo,msymooi,msymqq,msymqqi,multi_0,Multipole, &
          n_bulk_sup,n_multi_run,n_oo,n_rout,n_tens_max, &
          natomsym,nbseuil,ncolm,ncolr,ncolt,nenerg_s,ninit1,ninit,ninit_out,ninitr,nlm_pot,nlmamax, &
          nomabs,nomfich,nomfich_cal_tddft_conv,nomfich_s, &
          nphi_dafs,nphim,npldafs,nplr,nplrm,nrato_abs,nseuil,nspin,nspino,nspinp, &
          numat_abs,nxanout,Octupole,pdp,phdt,pol,poldafse,poldafss, &
          rato_abs,Relativiste,Renorm,rhoato_abs,Rmtg_abs,Rmtsd_abs, &
          rot_atom_abs,Rot_cluster,RPALF,rsato_abs,Self_abs, &
          Spherical_signal,Spherical_tensor,Spinorbite,Sum_Bragg_abs_f0,Sum_Bragg_nonabs_f,Sum_Bragg_NR_T,Tau_abs, &
          Taux_eq,Time_rout,V_intmax,V_hubb_loc,V0muf,Vcato_abs,Vec,Vecdafse,Vecdafss,Vhbdc,Volume_maille,VxcbdcF, &
          Vxcato_abs,Ylm_comp_loc)

        if( mpirank0 == 0 ) then
          call CPU_TIME(time)
          Time_loc(3) = real(time,db)
          Time_rout(21) = Time_rout(21) + Time_loc(3) - Time_loc(2)
        endif

      elseif( Tddft ) then

        if( mpirank0 == 0 ) then
          call CPU_TIME(time)
          Time_loc(2) = real(time,db)
        endif

        ninit_out = 1

        call main_tddft(Abs_cap,Abs_in_Bulk_roughness,Abs_SRXRD,Abs_SRXRD_abs,Abs_U_iso,alfpot,All_nrixs,angxyz,Allsite, &
          Atomic_scr,axyz,Bragg_abs,Bragg_rgh_bulk_abs,Bulk_step,Coef_g,Cartesian_tensor,Core_resolved,Dafs,Dafs_bio, &
          Delta_edge,Delta_Eseuil,Dipmag,dV0bdcF,Dyn_eg,Dyn_g,E_cut,E_cut_imp,E_Fermi,E_cut_man,Ecent,Eclie,Elarg,Eneg, &
          Energ_s,Energphot,Epsii,Epsii_moy,Eseuil,Estart,f_avantseuil,Full_potential,Full_self_abs, &
          Gamma_hole,Gamma_hole_man,Gamma_max,Gamma_tddft,Header,hkl_dafs,Hubb_abs,Hubb_diag_abs,icheck, &
          iabsorig(multi_run),index_z_SRXRD_abs,iopsymc(25),is_g,isigpi,isymeq,jseuil,Kern_fac, &
          L0_nrixs,Ldip,Length_abs,Lmax_pot,Lmax_nrixs,Lmax_abs_t,Lmaxat0,Lmaxfree,Lmoins1,Loct,Lplus1, &
          Lqua,Lseuil,ltypcal,m_g,m_hubb,Magnetic,Matper,Moyenne,mpinodes,mpirank,mpirank0,msymdd,msymddi, &
          msymdq,msymdqi,msymdo,msymdoi,msymoo,msymooi,msymqq,msymqqi,multi_0,multi_run,Multipole, &
          n_abs_rgh,n_bulk_sup,n_z_SRXRD,n_z_SRXRD_abs,n_z_SRXRD_abs_max,n_zc_SRXRD_abs,n_max,n_multi_run, &
          n_oo,n_rout,n_tens_max,natomsym,nb_test, &
          nbseuil,ncolm,ncolr,ncolt,nenerg_s,nenerg_tddft,ngamh,ninit1,ninit,ninit_out,ninitr,nlm_pot,nlmamax, &
          nomabs,nomfich,nomfich_cal_tddft_conv,nomfich_s,Non_resonant_bulk, &
          nphi_dafs,nphim,npldafs,nplr,nplrm,nq_nrixs,nrato_abs,NRIXS,nrm,nseuil,nspin,nspino,nspinp, &
          numat_abs,nxanout,Octupole,Orthmatt,pdp,phdt,phdt_rgh_Bulk,pol,poldafse,poldafss,Pos_z_SRXRD,Pos_z_SRXRD_abs, &
          psii,q_nrixs,Quadrupole,rato_abs,Relativiste,Renorm,rhoato_abs,Rmtg_abs,Rmtsd_abs, &
          rof0,Rot_atom_abs,Rot_cluster,RPALF,rsato_abs,rsbdc,Self_abs,Solsing_only,Spherical_signal,Spherical_tensor, &
          Spinorbite,Sum_Bragg_abs_f0,Sum_Bragg_nonabs_f,Sum_Bragg_NR_Bulk,Sum_Bragg_NR_T,Sum_Bragg_NR_T_rgh_bulk,Surface_ref, &
          Tau_abs,Taux_eq,Test_case, &
          Time_rout,V_intmax,V_hubb_loc,V0muf,Vcato_abs,Vec,Vecdafse,Vecdafss,Vhbdc,Volume_maille,VxcbdcF,Vxcato_abs, &
          Ylm_comp_loc)

        if( mpirank0 == 0 ) then
          call CPU_TIME(time)
          Time_loc(3) = real(time,db)
          Time_rout(21) = Time_rout(21) + Time_loc(3) - Time_loc(2)
        endif

      endif

      deallocate( Tau_abs )

    endif

    deallocate( rof0 )

    if( .not. Extract ) then
      if( Bulk_step .and. .not. Full_atom .and. Self_nonexc .and. self_cons_c .and. Bulk_atom_used ) then
        Bulk_atom_done = .true.
   ! One keeps the bulk atom potentials
        chargat_init_bulk(iprabs_nonexc,:) = Chargat_init(iprabs_nonexc,:)
        chargat_self_bulk(iprabs_nonexc,:) = Chargat_self(iprabs_nonexc,:)
        rho_self_bulk(:,:,:,iprabs_nonexc) = rho_self(:,:,:,iprabs_nonexc)
        rhoato_init_bulk(:,:,iprabs_nonexc) = rhoato_init(:,:,iprabs_nonexc)
        rhoato_out_bulk(:,:,iprabs_nonexc) = rhoato_out(:,:,iprabs_nonexc)
        Vcato_init_bulk(:,iprabs_nonexc) = Vcato_init(:,1,iprabs_nonexc)
        do ipr = n_atom_proto - n_atom_proto_bulk + 1,n_atom_proto
          if( Numat( itypepr(ipr) ) == numat_abs ) cycle
          chargat_init_bulk(ipr,:) = Chargat_init(ipr,:)
          chargat_self_bulk(ipr,:) = Chargat_self(ipr,:)
          rho_self_bulk(:,:,:,ipr) = rho_self(:,:,:,ipr)
          rhoato_init_bulk(:,:,ipr) = rhoato_init(:,:,ipr)
          rhoato_out_bulk(:,:,ipr) = rhoato_out(:,:,ipr)
          Vcato_init_bulk(:,ipr) = Vcato_init(:,1,ipr)
        end do
      endif

      if( .not. ( ( One_SCF .or. One_SCF_surf ) .and. multi_run_e /= n_multi_run ) ) then
        deallocate( Chargat_init )
        deallocate( Chargat_self )
        deallocate( rhoato_out, rho_self )
        deallocate( rhoato_init, Vcato_init )
        deallocate( dExc_ex_nex, drho_ex_nex, dvc_ex_nex, dv_ex_nex )
      endif
      deallocate( Exc_abs_i, Vc_abs_i, V_abs_i )
      if( multi_run_e == n_multi_run .and. Self_cons_c ) &
        deallocate( chargat_init_bulk, chargat_self_bulk, pop_orb_val_bulk, rho_self_bulk, rhoato_init_bulk, rhoato_out_bulk, &
                    Vcato_bulk, Vcato_init_bulk )

    endif

    deallocate( ia_eq_inv_self )
    deallocate( Hubb_diag, V_hubb_abs, V_hubb_loc )
    deallocate( V_hubb )

    if( One_run_s .and. .not. Bulk_step ) then
      Condition = iabsm(multi_run) == igr_layer(1,i_layer)
    elseif( One_run_L ) then
      Condition = multi_run_e == n_multi_run
    else
      Condition = .true.
    endif

    if( Condition .and. .not. Extract ) then
      deallocate( xyz )
      deallocate( cgrad, clapl, ivois, isvois )
      deallocate( numia, rvol )
    endif

    deallocate( Bragg_abs, Bragg_rgh_bulk_abs, karact, Axe_atom_clu, dista )
    deallocate( Epsif, Epsii )
    deallocate( iaproto, igroup, igroup_ato, igroup_dip, igroup_ion, isymeq, itypep )
    deallocate( Pos, Pos_ato, Pos_dip, Pos_ion, Rot_atom_spin, Taux_eq )
    deallocate( poldafse, poldafss, phdt, Sum_Bragg_abs_f0, Sum_Bragg_nonabs_f )
    deallocate( Vecdafse, Vecdafss, ltypcal, nomabs, pdp, pol, vec )
    deallocate( Abs_SRXRD, Abs_SRXRD_abs, igr_z_SRXRD, igr_z_SRXRD_abs, index_z_SRXRD_abs, n_zc_SRXRD, n_zc_SRXRD_abs, &
                Pos_z_SRXRD_abs, Pos_z_SRXRD )

    if( mpirank0 == 0 ) deallocate( Int_tens )

    deallocate( rato_abs, rhoato_abs, rsato_abs, Vcato_abs, Vxcato_abs )

    multi_0 = multi_0 + max( 1, n_z_SRXRD_abs )
    if( Bulk_roughness > 0 .and. Bulk_step ) multi_0 = multi_0 + 1

  end do boucle_multi ! End of loop over non-equivalent atoms

  if( One_SCF ) deallocate( ia_eq_inv_self )
  deallocate( Coef_g, is_g, m_g )
  deallocate( coef_f, is_f, m_f )
  if( .not. Extract ) deallocate( Eimag_s, Energ_s )
  deallocate( msymoo, msymooi )

  deallocate( E_Emis, Psi_Emis )

  return

  110 format(/' ----------',110('-'),//' Absorbing atom',i4,' begining')
  140 format(/1x,120('-')//,' Last cycle, XANES calculation')
  150 format(/1x,120('-')//,' Begining of cycle',i3)
  155 format(/1x,120('-')//,' Begining of cycle, calculation of excited absorbing atom Fermi energy')
  160 format(/' E_cut =',f11.5,' eV, E_Fermi =',f11.5,' eV')
  170 format(///' E_kinetic =',f7.3,' eV < 0.',/ ' Start the calculation at higher energy !'///)
  180 format(///' or E_kinetic_ext =',f7.3,' eV < 0.',/ ' Start the calculation at higher energy !'///)
  190 format(/' ---- Sphere -------',100('-'))
  200 format(//' Lmax for the probed states =',i2,' >',i2,' used for RIXS.',/ &
              ' Increase this last value with keyword Lmax_DOSout')
end

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

! Calculation of Fermi level and self-consistent electronic structure
! natome_self and natomeq_self are changed in natome and natomeq during the transfer
! n_atom_ind_self, natome_self and natomeq_self are changed in n_atom_ind, natome and natomeq during the transfer

subroutine SCF_step( Adimp, alfpot, Atom_occ_hubb, Atom_with_axe, Axe_atom_clu, Axe_atom_gr, &
        axyz, Base_hexa, Basereel, Bulk_atom_done, Bulk_step_alone, Charge_ion, Chargm_SCF, Chargat, Chargat_init, &
        Chargat_self, Counter_ato, Counter_dip, Counter_ion, Counter_linear, D_max_pot, Delta_En_conv, Delta_helm, Delta_z_lin, &
        Density, Density_comp, Density_sp, dExc_ex_nex, Dist_coop, Doping, drho_ex_nex, dv_ex_nex, dvc_ex_nex, dista, dV0bdcF, &
        E_cut, E_moment, E_moment_axis, E_Fermi, Eclie, Eclie_out, Exc_abs_i, FDM_comp, Flapw, Full_atom, Full_potential, &
        Green_self, Helm_cos, Helm_lin, Helm_mix, Hubb, Hubb_diag, Hubbard, Hybrid, i_self, ia_eq_inv_self, iaabs, &
        iaabsfirst, iabsorbeur, iapot, iaproto, icheck, igreq, igroup, igroup_ato, igroup_dip, igroup_ion, igrpt_nomag, igrpt0, &
        Image_charge, iopsymr, iord, ipr_dop, iprabs, iprabs_nonexc, isymeq, itabs, itabs_nonexc, itequ, itype, itypep, itypepr, &
        Jseuil, karact, korigimp, Lcoeur, LLa_state, LLa2_state, Lmax_pot, Lmaxat0, Lmax_DOSout, Lmaxfree, &
        Lmaxso_max, Lmaxso0, Lseuil, Lvval, m_hubb, m_hubb_e, Mag_axis_free, Magnetic, Matper, Moy_cluster, mpirank, mpirank0, &
        mpinodes, mpinodes0, Muffintin, n_atom_0, n_atom_0_self, n_atom_ind, n_atom_proto, n_atom_proto_bulk, n_atom_proto_uc, &
        n_counter_ato, n_counter_dip, n_counter_ion, n_devide, n_rout, natome, natomeq, &
        natomp, natomp_ato, natomp_dip, natomp_ion, natomsym, nb_test, nb_rep, nb_sym_op, ncoeur, neqm, ngreq, ngroup, &
        ngroup_hubb, ngroup_m, ngroup_nonsph, nlat, nlatm, nlm_pot, Nomfich_s, Nonexc, norbv, Normaltau, Normrmt, nrato, nrm, &
        nrm_self, nself, nself_bulk, nseuil, nspin, nspino, nspinp, ntype, Numat, numat_abs, nhybm, Occ_hubb_e, One_SCF_Surf, &
        Optic, Orthmati, &
        Overad, Overlap, p_self, p_self_max, p_self0, p_self0_bulk, Pas_SCF, Pop_nonsph, Pop_open_val, Pop_orb_val_bulk, &
        Popatm, Popats, Popatv, Pos, Pos_ato, Pos_dip, Pos_ion, Posi_self, Proto_calculated, psi_coeur, psi_open_val, Psival, &
        R_rydb, Rato, Rchimp, Relativiste, rho_coeur, rho_self, rho_self_bulk, rhoato_init, rhoato_out, rhoit, Rionic_imp, Rmt, &
        Rmtimp, Rmtsd, Rot_Atom_gr, Rot_Atom_nsph, Rot_atom_spin, Rot_cluster, Rot_Spinor, Roverad, rsbdc, rsbdc_out, Rsorte, &
        Rydberg, SCF_c, SCF_elecAbs, &
        SCF_mag_free, SCF_smooth, Self_nonexc, Solsing_s, Spin_axis_free, Spinorbite, State_all, State_all_out, Supermuf, Sym_2D, &
        Sym_cubic, Symmol, Tddft, Test_case, Time_rout, Trace_k, Trace_p, V_abs_i, V_helm_t, V_hubb, V_hubbard, V_intmax, &
        V0bdcFimp, V0muf, Vc_abs_i, Vcato_bulk, Vcato_init, Vhbdc_init, Vhbdc_p, Width_helm, Ylm_comp, Z_nospinorbite)

  use declarations
  implicit none

  include 'mpif.h'

  integer, parameter:: n_atom_coop = 0

  integer:: i_attempt, i_cycle, i_range, i_self, ia, iaabs, iaabsi, iaabsfirst, iabsorbeur, iapr, iaprabs_nonexc, ich, icheck_13, &
    icheck_27, ie, ie_computer, ie0, igrph, igrpt_nomag, igrpt0, &
    index_e, iord, ipr, ipr_dop, ipr1, iprabs, iprabs_nonexc, ir, isp, ispin, it, itab, itabs, itabs_nonexc, &
    je, Jseuil, L, L_hubbard, LLa_state, LLa2_state, Lmax, Lmax_abs, Lmax_abs_a, Lmax_g, Lmax_max, Lmax_pot, Lmaxat0, Lmax_DOSout, &
    Lmaxso, Lmaxso_m, Lmaxso_max, Lmaxso0, Lseuil, m, m_hubb, m2, m_hubb_e, mpierr, mpinodes, mpinodes0, mpirank, mpirank0, n, &
    n_atom_0, n_atom_0_self, n_atom_ind, n_atom_ind_self, n_atom_proto, n_atom_proto_bulk, n_atom_proto_uc, &
    n_counter_ato, n_counter_dip, n_counter_ion, n_devide, n_rout, n_vr_0, n_vr_ind, n1, nab_coop, natome, natome_self, &
    natomeq, natomeq_self, natomp, natomp_ato, natomp_dip, natomp_ion, natomsym, nb_test, nb_rep, &
    nb_sym_op, nbm, nbm_c, nbtm, nbtm_fdm, nenerg, nenerg_coh, nenerg0, neqm, nge, ngroup, ngroup_hubb, ngroup_m, &
    ngroup_nonsph, ngrph, nicm, nim, nlatm, nlm_pot, nlm_RIXS, nlmagm, nlmmax, nlmomax, nlmsam, nlmsamax, nlmso, Normrmt, nphiato, &
    nphiato_c, npoint, npoint_ns, npr, npso, npsom, nptmoy, nptmoy_out, nr, nrm, nrm_self, nself, nself_bulk, nself_c, nseuil, &
    nso1, nsort, nsortf, nspin, nspino, nspinorb, nspinp, ntype, numat_abs, nvois, nx, nhybm, Trace_l, Trace_k, Z, &
    Z_nospinorbite

  integer, dimension(30):: icheck
  integer, dimension(nopsm):: iopsymr
  integer, dimension(natome):: iaprotoi, igroupi, itypei, nb_eq
  integer, dimension(natomp):: iaproto, igroup, itypep
  integer, dimension(natomp_ato):: igroup_ato
  integer, dimension(natomp_dip):: igroup_dip
  integer, dimension(natomp_ion):: igroup_ion
  integer, dimension(natomeq):: ia_eq_inv, ia_eq_inv_self   ! here natomeq = natomeq_self
  integer, dimension(natomsym):: isymeq
  integer, dimension(ngroup):: itype
  integer, dimension(n_atom_coop):: ia_coop
  integer, dimension(0:ntype):: itequ, nlat, nrato, Numat
  integer, dimension(0:n_atom_proto):: iapot, itypepr, Lmaxat, nb_eq_2D, ngreq
  integer, dimension(2,0:ntype):: Lcoeur, ncoeur
  integer, dimension(nrepm,2):: irep_util
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(natome,natome):: nb_rpr
  integer, dimension(nopsm,natome):: iopsym_atom
  integer, dimension(nb_sym_op,natome):: ia_eq, is_eq
  integer, dimension(0:ntype,nlatm):: Lvval
  integer, dimension(0:ngroup_nonsph):: norbv
  integer, dimension(nb_sym_op,natome,natome):: ia_rep, nb_rep_t

  integer, dimension(:), allocatable:: imoy, imoy_out, ispin_maj, isrt, Lmaxa, Lval, nbord, nbordf, nlmsa, nlmso0, numia
  integer, dimension(:,:), allocatable:: ibord, indice, iso, ivois, isbord, isvois, Lso, mso, nlmsa0
  integer, dimension(:,:,:), allocatable:: iato, Lato, mato, mpres

  character(len=3):: Atom_kind
  character(len=Length_name):: nomfich_s

  complex(kind=db), dimension(nopsm,nrepm):: karact
  complex(kind=db), dimension(2,2,natome):: Wigner_one_half
  complex(kind=db), dimension(nhybm,16,ngroup_nonsph):: Hybrid
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb_abs
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp,n_atom_0_self:n_atom_ind):: Occ_hubb, V_hubb, V_hubb_s
  complex(kind=db), dimension(:,:,:,:), allocatable:: V_hubb_t
  complex(kind=db), dimension(:,:,:,:,:), allocatable:: Ampl_dft, Phiato_c, Tau_ato, Taull, Ylms
  complex(kind=db), dimension(:,:,:,:,:,:), allocatable:: Tau_coop

  logical:: Absorbeur, Atom_occ_hubb, Base_hexa, Basereel, Bulk_atom_done, Bulk_step_alone, Cal_xanes, Care_shift, &
    Close_open_bav, Convergence, Counter_linear, Density, Density_comp, Density_sp, &
    Devide_Ei, Doping, E_comp, Eneg, FDM_comp, Fermi, Fermi_first, Flapw, Full_atom, Full_potential, Green, &
    Green_self, Hubb_a, Hubb_d, Hubb_diag_abs, Hubbard, Helm_cos, Helm_lin, Helm_mix, Image_charge, korigimp, Level_val_abs, &
    Level_val_exc, Lmaxfree, Mag_axis_free, Magnetic, Matper, Moy_cluster, Moy_loc, Muffintin, No_solsing, Nonexc, Nonexc_g, &
    Nonsph, Normaltau, One_SCF_Surf, Optic, Other_xanes, Overad, Recop, Relativiste, Renorm, RIXS_gen, Rydberg, SCF_c, &
    SCF_elecAbs, SCF_mag_fix, SCF_mag_free, SCF_smooth, Second_try, Self_nonexc, Solsing_o, Solsing_s, Solsing, Spin_axis_free, &
    Spino, Spinorbite, State_all, State_all_out, Supermuf, Sym_2D, Sym_cubic, Symmol, Tau_nondiag, Tddft, Ylm_comp

  logical, dimension(natome):: Atom_axe
  logical, dimension(nb_test):: Test_case
  logical, dimension(0:ngroup_m):: Atom_with_axe
  logical, dimension(0:ntype):: Hubb
  logical, dimension(0:n_atom_proto):: Proto_calculated
  logical, dimension(n_atom_0_self:n_atom_ind):: Hubb_diag

  logical, dimension(:), allocatable:: Full_pot, Repres_comp

  real(kind=db):: Adimp, alfpot, Charge_ion, Chargm_SCF, D_max_pot, Delta_E_conv, Delta_En_conv, Delta_energ, Delta_energ_s, &
    Delta_helm, Delta_z_lin, E_cluster, E_cluster_s, E_cut, E_Fermi, E_moment, &
    E_Open_val, E_Open_val_exc, E_start, Ecineticmax, Ecineticmax_out, Eclie, Eclie_out, &
    Ecmax, Ecmax_out, Ei0, Eii, Em, Enervide, Overlap, p_self, p_self_max, p_self0, p_self0_c, p_self0_bulk, Pas_SCF, R_rydb, &
    Roverad, rsbdc, rsbdc_out, Rsort, Rsorte, Time_fill, Time_tria, V_helm_t, V_intmax, V0muf, Vhbdc, Vhbdc_p, Vhbdc_init, &
    Vhbdc_out, Vsphere, Vsphere_cal, Width_helm

  real(kind=db), dimension(2):: chg_open_val, Dist_coop, Pop_open_val
  real(kind=db), dimension(3):: axyz, Charge_f, E_moment_axis, V_surf
  real(kind=db), dimension(6):: Trace_p
  real(kind=db), dimension(7):: Time_loc
  real(kind=db), dimension(n_rout):: Time_rout
  real(kind=db), dimension(nspin):: Chg_reference, dV0bdcF, Ecinetic, Ecinetic_e, Ecinetic_out, V0bdc, V0bdc_e, V0bdc_out, &
                                    V0bdcF, V0bdcF_out, VxcbdcF, VxcbdcF_out, V0bdcFimp
  real(kind=db), dimension(natome):: distai
  real(kind=db), dimension(natomp):: dista
  real(kind=db), dimension(nrm):: dExc_ex_nex, dvc_ex_nex, Exc_abs_i, Vc_abs_i
  real(kind=db), dimension(nrm,nspin):: drho_ex_nex, dv_ex_nex, V_abs_i
  real(kind=db), dimension(0:ntype):: Rchimp, Rionic_imp, Rmt, Rmtimp, V_hubbard
  real(kind=db), dimension(0:n_atom_proto):: Chargat, Rmtg, Rmtg0, Rmtsd
  real(kind=db), dimension(3,3):: Orthmati, Rot_cluster, Rot_Spinor
  real(kind=db), dimension(nrm,2):: psi_open_val
  real(kind=db), dimension(3,natome):: Posi, Posi_self
  real(kind=db), dimension(3,natomp):: Axe_atom_clu, 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(nhybm,ngroup_nonsph):: Pop_nonsph
  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_m):: Rot_Atom_gr
  real(kind=db), dimension(3,3,ngroup_nonsph):: Rot_Atom_nsph
  real(kind=db), dimension(3,3,natomp):: Rot_atom_spin
  real(kind=db), dimension(0:nrm,2,0:ntype):: psi_coeur
  real(kind=db), dimension(ngroup,nlatm,nspin):: Popats
  real(kind=db), dimension(0:n_atom_proto,nlatm,nspin):: Popatm
  real(kind=db), dimension(0:ntype,nlatm):: Popatv
  real(kind=db), dimension(0:nrm,0:ntype):: Rato, rho_coeur, rhoit
  real(kind=db), dimension(0:nrm,nlatm,0:ntype):: Psival
  real(kind=db), dimension(n_atom_proto-n_atom_proto_bulk+1:n_atom_proto,nspin):: pop_orb_val_bulk
  real(kind=db), dimension(n_atom_0_self:n_atom_ind):: E_KS_core, Energ_self, Energ_self_s
  real(kind=db), dimension(n_atom_0_self:n_atom_ind,nspin):: Chargat_init, Chargat_self, Chargat_self_s, pop_orb_val
  real(kind=db), dimension(-m_hubb_e:m_hubb_e,-m_hubb_e:m_hubb_e,nspin,ngroup_hubb):: Occ_hubb_e
  real(kind=db), dimension(0:nrm_self,nlm_pot,n_atom_proto-n_atom_proto_bulk+1:n_atom_proto):: Vcato_bulk
  real(kind=db), dimension(0:nrm_self,nlm_pot,nspin,n_atom_proto-n_atom_proto_bulk+1:n_atom_proto):: rho_self_bulk
  real(kind=db), dimension(0:nrm_self,nspin,n_atom_0_self:n_atom_ind):: rhoato_init, rhoato_out
  real(kind=db), dimension(0:nrm_self,nlm_pot,nspin,n_atom_0_self:n_atom_ind):: rho_self
  real(kind=db), dimension(0:nrm_self,nlm_pot,n_atom_0_self:n_atom_ind):: Vcato_init

  real(kind=db), dimension(:), allocatable:: Chg_coeur, clapl, cgrad, E_starta, Energ, Energ_coh, Eimag, Eimag_coh, poidso, &
                                             poidsov, poidsov_out, r, rhons, rs, rvol, Vh, Vhns
  real(kind=db), dimension(:,:), allocatable:: Ecinetic_a, Excato, poidsa, rho, rsato, Vmft, Vr, Vxc, xyz, Ylmso
  real(kind=db), dimension(:,:,:), allocatable:: Gradvr, Int_statedens, rho_self_t, rhoato, Vcato, Vrato_e, Ylmato
  real(kind=db), dimension(:,:,:,:), allocatable:: rho_self_s, Vrato, Vxcato
  real(kind=db), dimension(:,:,:,:,:), allocatable:: drho_self, Phiato
  real(kind=db), dimension(:,:,:,:,:,:), allocatable:: Statedens, Statedens_i

  real(kind=sg) time

  Close_open_bav = .false.
  icheck_27 = icheck(27)
  n_atom_ind_self = n_atom_ind
  natome_self = natome
  natomeq_self = natomeq
  No_solsing = .false.
  Renorm = .true.
  RIXS_gen = .false.

  i_range = 1

  if( Bulk_step_alone ) then
    p_self0_c = p_self0_bulk
    nself_c = nself_bulk
  else
    p_self0_c = p_self0
    nself_c = nself
  endif

  if( nspin == 1 .or. Spinorbite ) then
    nspinorb = 1
  else
    nspinorb = 2
  endif

! Preambule coherence:
  Convergence = .false.

  E_KS_core(:) = 0._db

  allocate( rho_self_s(0:nrm_self,nlm_pot,nspin,n_atom_0_self:n_atom_ind) )
  allocate( rho_self_t(0:nrm_self,nlm_pot,n_atom_0_self:n_atom_ind) )

  Energ_self_s(:) = 0._db
  V_hubb_s(:,:,:,:,:) = (0._db, 0._db)

  if( .not. ( Bulk_step_alone .or. Full_atom .or. One_SCF_Surf ) ) then
    do ipr = n_atom_proto-n_atom_proto_bulk+1, n_atom_proto
      pop_orb_val(ipr,:) = pop_orb_val_bulk(ipr,:)
    end do
  endif

  if( Optic .or. Tddft ) then
    Fermi_first = .true.
    Devide_Ei = .true.
  else
    Fermi_first = .false.
    Devide_Ei = .false.
  endif

  Cal_xanes = .false.
  Nonsph = .false.
  Green = Green_self
  Eneg = .true.
  Moy_loc = Green .and. .not. Moy_cluster
  Nonexc_g = Self_nonexc
  Recop = .false.

  if( Nonexc_g ) then
    ipr1 = 1
    itab = itabs_nonexc
  else
    ipr1 = 0
    itab = itabs
  endif

  if( .not. Nonexc_g ) iaproto(iaabs) = 0
  itypep(iaabs) = itab
  Vsphere = Vsphere_cal(Chargat,Charge_ion,Chargm_SCF,Counter_linear,dista(natomp),Flapw,iaproto,icheck(5),Matper,n_atom_proto, &
                        natomp)

! For the SCF calculation, all representations must be calculated
  if( icheck_27 > 1 ) then
    ich = max( icheck(8), icheck_27 )
  else
    ich = 0
  endif
  call irep_util_all(ich,iopsymr,irep_util,karact,nb_rep,ngrph,nspino,Spinorbite)
  allocate( Repres_comp(ngrph) )
  call irep_comp(Ylm_comp,Green,iopsymr,irep_util,karact,ngrph,nspino,Repres_comp)

  nb_eq_2D(:) = 0

  if( icheck_27 > 1 ) then
    ich = max( icheck(7), icheck_27 )
  else
    ich = 0
  endif

  i_self = 1

  call Atom_selec( Adimp, Atom_axe, Atom_with_axe, Atom_occ_hubb, Axe_atom_clu, dista, distai, E_moment_axis, Full_atom, &
        Green, Hubbard, i_self, ia_eq, ia_eq_inv, ia_rep, iaabs, iaabsi, iabsorbeur, iaproto, iaprotoi, ich, igreq, igroup, &
        igroupi, igrpt_nomag, igrpt0, iopsym_atom, iopsymr, iord, ipr1, is_eq, isymeq, itequ, itype, itypei, itypep, itypepr, &
        m_hubb, m_hubb_e, Magnetic, mpirank0, natome, n_atom_0_self, n_atom_ind_self, n_atom_proto, natomeq, natomp, natomsym, &
        nb_eq, nb_rpr, nb_rep_t, nb_sym_op, neqm, ngreq, ngroup, ngroup_hubb, ngroup_m, nlat, nlatm, Nonsph, nspin, nspinp, ntype, &
        Numat, nx, Occ_hubb_e, Overad, Popats, Pos, Posi, Proto_calculated, Rmt, Rot_atom, Rot_atom_spin, Rot_atomp, &
        Roverad ,Rsort, Rsorte, Spinorbite, Symmol, V_hubb, V_hubbard, Ylm_comp )

  if( Spin_axis_free ) call Wigner_one_half_cal(ich,natome,Rot_atom,Wigner_one_half)

  if( Sym_2D ) call Cal_nb_eq_2D(iaproto,iaprotoi,igrpt_nomag,iopsymr,mpirank0,n_atom_proto,n_atom_proto_bulk,natome,natomeq, &
                                 natomp,nb_eq_2D,Pos,Posi,Proto_calculated)

  ia_eq_inv_self(:) = ia_eq_inv(:)
  posi_self(:,:) = Posi(:,:)

! in the SCF part even if SCFexc, one calls it iaprabs_nonexc anyway
  if( Full_atom ) then
    iaprabs_nonexc = iaabsi
  else
    iaprabs_nonexc = iprabs_nonexc
  endif

  npoint = 0;  npr = 0

! Calculation of the dimensions for the FDM grid of points
  call nbpoint( Adimp, Base_hexa, D_max_pot, Green, iaabsfirst, igrpt_nomag, iopsymr, iord, Mag_axis_free, Moy_loc, &
               mpirank0, natomp, npoint, npso, nvois, nx, pos, Rot_Spinor, Rsort )

  if( Nonsph ) then
    npoint_ns = npoint
  else
    npoint_ns = 0
  endif
  nim = npoint
  npsom = npso

  allocate( clapl(0:nvois) )
  allocate( cgrad(nvois) )
  allocate( ivois(npsom,nvois) )
  allocate( isvois(npsom,nvois) )
  allocate( numia(npsom) )
  allocate( rvol(nim) )
  allocate( xyz(4,npsom) )

  allocate( indice(3,npsom) )
  allocate( mpres(-nx:nx,-nx:nx,-nx:nx) )

! Making of the FDM grid of points. Even with Green, it is used for the calculation of the interstitial potential
  call FDM_grid( Adimp, Base_hexa, D_max_pot, Green, iaabsfirst, icheck(9), &
               igrpt_nomag, indice, iopsymr, iord, itypei, Mag_axis_free, Moy_loc, mpirank0, mpres, natome, natomp, nim, &
               npoint, npr, npso, npsom, ntype, numia, nx, Rot_Spinor, Pos, Posi, Rmt, Rsort, rvol, xyz )

  nbm = 0
  nbtm = 0
  nsort = 0
  nsortf = 0

  allocate( ibord(nbtm,natome) )
  allocate( isbord(nbtm,natome) )
  allocate( isrt(nsort) )
  allocate( nbord(natome) )
  allocate( nbordf(natome) )
  allocate( poidsa(nbm,natome) )
  allocate( poidso(nsortf) )
  nbord(:) = 0
  nbordf(:) = 0

  if( .not. Green ) then
    call laplac(Adimp,Base_hexa,cgrad,clapl,icheck(9),igrpt_nomag,indice,iopsymr,iord,ivois,isvois, &
          mpirank0,mpres,npso,npsom,nvois,nx)

    do i_cycle = 1,2
      call Bordure(Green,i_cycle,icheck(9),ibord,iopsymr,iord,isbord, &
          isrt,ivois,mpirank0,natome,nbm,nbord,nbordf,nbtm,nim,npoint,npso,npsom,nsort, &
          nsortf,numia,nvois,poidsa,poidso,Posi,rvol,xyz)
      if( i_cycle == 2 ) exit
      deallocate( ibord, isbord, isrt, poidsa, poidso )
      allocate( ibord(nbtm,natome) )
      allocate( isbord(nbtm,natome) )
      allocate( isrt(nsort) )
      allocate( poidsa(nbm,natome) )
      allocate( poidso(nsortf) )
    end do

  endif

  deallocate( indice, mpres )

  allocate( Chg_coeur(n_atom_0_self:n_atom_ind) )
  allocate( E_starta(n_atom_0_self:n_atom_ind) )
  allocate( Ecinetic_a(nspin,n_atom_0:n_atom_ind) )
  allocate( Excato(nrm,n_atom_0:n_atom_ind) )
  allocate( Full_pot(n_atom_0:n_atom_ind) )
  allocate( imoy(npoint) );  allocate( imoy_out(npoint) )
  allocate( Int_statedens(lla2_state,nspinp,n_atom_0:n_atom_ind) )
  allocate( ispin_maj(n_atom_0_self:n_atom_ind) )
  allocate( poidsov(npoint) ); allocate( poidsov_out(npoint) )
  allocate( rho(npoint,nspin) )
  allocate( rhoato(0:nrm,nspin,n_atom_0:n_atom_ind) )
  allocate( rhons(npoint_ns) )
  allocate( rs(npoint) )
  allocate( rsato(0:nrm,n_atom_0:n_atom_ind) )
  allocate( Vcato(0:nrm,nlm_pot,n_atom_0:n_atom_ind) )
  allocate( Vh(npoint) )
  allocate( Vhns(npoint_ns) )
  allocate( Vmft(nspin,n_atom_0:n_atom_ind) )
  allocate( Vr(npoint,nspin) )
  allocate( Vrato(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind) )
  allocate( Vxc(npoint,nspin) )
  allocate( Vxcato(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind) )

  Full_pot(:) = .false.
  Delta_energ_s = 0._db

! Loop on self-consistency iterations
  boucle_coh: do i_self = 1,nself_c

    if( mpirank0 == 0 ) then
      call CPU_TIME(time)
      Time_loc(1) = real(time,db)
    endif

    if( icheck(4) > 1 ) write(3,150) i_self

    Loop_attempt: do i_attempt = 1,2

      Second_try = i_attempt == 2

      E_Fermi = -5._db / Rydb
      E_cut = E_Fermi
      E_Open_val = E_Fermi
      E_Open_val_exc = E_Fermi
      Fermi = .false.
      Level_val_abs = .false.
      Level_val_exc = .false.

      Int_statedens(:,:,:) = 0._db
      rhoato(:,:,:) = 0._db
      rsato(:,:) = 0._db
      Vcato(:,:,:) = 0._db
      Vxcato(:,:,:,:) = 0._db

      if( Bulk_atom_done ) then
        do ipr = n_atom_proto-n_atom_proto_bulk+1, n_atom_proto
          Vcato(:,:,ipr) = Vcato_bulk(:,:,ipr)
          if( .not. Test_case(3) ) rho_self(:,:,:,ipr) = rho_self_bulk(:,:,:,ipr)
        end do
      endif

      if( mpirank0 == 0 ) then
        call CPU_TIME(time)
        Time_loc(2) = real(time,db)
        Time_rout(3) = Time_rout(3) + Time_loc(2) - Time_loc(1)
      endif

      if( i_attempt == 2 ) then
        icheck_13 = icheck(13)
        icheck(13) = 0
      endif

      call 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_c,Self_nonexc,Spin_axis_free,Sym_2D,Test_case,V_abs_i,V_helm_t,V_intmax,V_surf,Vc_abs_i,Vcato, &
            Vcato_init,Vh,Vhns,Vsphere,Vxc,Vxcato,V0bdcFimp(1),Width_helm,Wigner_one_half,xyz)

      if( i_attempt == 2 ) icheck(13) = icheck_13

      if( i_attempt == 1 ) then
        ich = icheck(13)
      else
        ich = 0
      endif
! Complementary operations on potential
      Other_xanes = .false.
      call Potential_comp(Bulk_atom_done,Cal_xanes,distai(natome),dV0bdcF,E_Fermi,Full_atom, &
      Green,i_range,i_self,iaabs,iapot,iaproto,iaprotoi,ich,imoy,imoy_out,iopsymr,ipr1,isrt,itypepr,korigimp,Magnetic, &
      Moy_loc,mpirank0,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_c,Sym_2D,Test_case(2),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)

      V0bdcF_out(:) = V0bdcF(:)

      if( i_self == 1 ) then

        if( ipr1 == 1 ) Rmtg(0) = Rmtg(iprabs_nonexc)

! Initialisation of rho_self, when new potential in Potsup is calculated
! Beyond Rmtsd initialisation is at zero.
        rho_self_s(:,1,:,:) = rhoato_init(:,:,:)
        if( nlm_pot > 1 ) rho_self_s(:,2:nlm_pot,:,:) = 0._db

        if( i_attempt == 1 ) then
          ich = icheck_27
        else
          ich = 0
        endif
! Calculation of the reference charge for self-consistency
        call Chg_agr(Bulk_step_alone,Chargat,Chargat_init,Chg_coeur,Chg_reference,chg_open_val,Doping,Full_atom, &
          iaprotoi,ipr_dop,iprabs_nonexc,ispin_maj,itabs,ich,itypepr,mpirank0, &
          n_atom_0_self,n_atom_ind_self,n_atom_proto,n_atom_proto_bulk,natome, &
          nb_eq,nb_eq_2D,ngreq,nrato,nrm,nrm_self,nspin,ntype,Numat,pop_open_val, &
          Proto_calculated,psi_open_val,Rato,rho_coeur,rhoato_init,rhoato_out,Rmtsd,SCF_mag_fix,SCF_mag_free,Sym_2D)

        chargat_self_s(:,:) = Chargat_init(:,:)

    endif

     Care_shift = .true.
! Calculation of the starting energy for the SCF
! It is calculated only at the first cycle eventhough states can be shifted along the cycles
      if( i_self == 1 .or. Care_shift ) then
        call Starting_energ(Bulk_step_alone,E_start,E_starta,Full_atom,i_self,iaprotoi,icheck_27,itypepr,Lcoeur,n_atom_0, &
            n_atom_0_self,n_atom_ind,n_atom_ind_self,n_atom_proto,n_atom_proto_uc,natome,ncoeur,nenerg_coh,nlm_pot, &
            nrato,nrm,Numat,nspin,ntype,Pas_SCF,Proto_calculated,psi_coeur,Rato,Second_try,Vcato,Vxcato)
! Establishment of the energy grid for self-consistency
        allocate( Energ_coh(nenerg_coh) )
        allocate( Eimag_coh(nenerg_coh) )
        call grille_coh(Eimag_coh,Energ_coh,E_start,Green,icheck_27,nenerg_coh,Pas_SCF)
      endif

      if( Fermi_first .or. .not. Devide_Ei ) then
        nenerg = nenerg_coh
        allocate( Energ(nenerg) )
        allocate( Eimag(nenerg) )
        Energ(:) = Energ_coh(:)
        Eimag(:) = Eimag_coh(:)
      else
        nenerg = n_devide * nenerg_coh
        allocate( Energ(nenerg) )
        allocate( Eimag(nenerg) )
        Energ(1) = energ_coh(1)
        do ie = 2,nenerg
          Energ(ie) = Energ(ie-1) + Pas_SCF / n_devide
        end do
        Eimag(:) = Eimag_coh(1) / n_devide
      endif

      if( i_self == 1 .or. Care_shift ) deallocate( Eimag_coh, Energ_coh )

      call Check_Ecmax(E_Fermi,Ecineticmax,Ecineticmax_out,Eclie,Eclie_out,Eneg,Energ(nenerg),mpirank0,nspin,V0bdcF,V0bdcF_out)

      do iapr = n_atom_0_self,n_atom_ind_self
        if( Full_atom ) then
          ipr = iaprotoi(iapr)
        else
          ipr = iapr
          if( Bulk_atom_done .and. ipr > n_atom_proto - n_atom_proto_bulk ) cycle
        endif
        it = itypepr(ipr)
        nr = nrato(it)
        do n = 1,nr
          if( Rato(n,it) > Rmtsd(ipr) ) exit
        end do
        do isp = 1,nspin
          do ir = 0,n
            rho_self(ir,1,isp,iapr) = rhoato_out(ir,isp,iapr) + ( rho_coeur(ir,it) / nspin )
          end do
          rho_self(n+1:nr,1,:,iapr) = rhoato_init(n+1:nr,:,iapr)
        end do
      end do

      if( mpirank0 == 0 ) then
        call CPU_TIME(time)
        Time_loc(3) = real(time,db)
        Time_rout(4) = Time_rout(4) + Time_loc(3) - Time_loc(2)
      endif

      if( i_self == 1 .and. i_attempt == 1 ) then

! Lmax calculation
        if( .not. Green ) then
          call clmax(Ecineticmax_out,Rsort,Lmaxso0,Lmaxso_m,-1,.true.)
          Lmaxso_m = min( Lmaxso_m, Lmaxso_max )
        else
          Lmaxso_m = 0
        endif

        Lmax_max = 0
        Lmax_abs = 0
        do ipr = 0,n_atom_proto
          Z = Numat( itypepr(ipr) )
          call clmax(Ecineticmax,Rmtg(ipr),Lmaxat0,Lmaxat(ipr),Z,Lmaxfree)
          if( Z == numat_abs ) Lmax_abs = max( Lmaxat(ipr), Lmax_abs )
          Lmax_max = max(Lmax_max,Lmaxat(ipr))
        end do
        do ipr = 0,n_atom_proto
          Z = Numat( itypepr(ipr) )
          if( Z == numat_abs ) Lmaxat(ipr) = Lmax_abs
        end do

        nlmmax = (Lmax_max + 1 )**2
        nlmsam = nspinp * nlmmax
        nlmomax = ( Lmaxso_m + 1 )**2
        nso1 = nspino * nlmomax

        allocate( iato(nlmsam,natome,ngrph) )
        allocate( Lato(nlmsam,natome,ngrph) )
        allocate( iso(nso1,ngrph) )
        allocate( Lso(nso1,ngrph) )
        allocate( mato(nlmsam,natome,ngrph) )
        allocate( mso(nso1,ngrph) )
        allocate( nlmso0(ngrph) )
        allocate( nlmsa0(natome,ngrph) )

! Determination of the (l,m) of all the representation
        call Lmrep(Green,iaprotoi,iato,icheck(15),iopsym_atom,iopsymr,irep_util,iso,itypei,karact,Lato, &
           Lmaxat,Lmaxso_m,Lso,mato,mpirank0,mso,n_atom_proto,natome,nbordf,ngrph,nlmsa0,nlmsam,nlmso0, &
           nso1,nsortf,nspino,ntype,Numat,Orthmati,Posi,Rot_atom,Spin_axis_free)

! Calculation of the Ylm on the FDM grid points
        if( Green ) then
          nbtm_fdm = 0
        else
          nbtm_fdm = nbtm
        endif
        if( .not. Green .and. Spin_axis_free ) then
          nbm_c = nbm
        else
          nbm_c = 0
        endif
        allocate( Ylmato(nbtm_fdm,nlmmax,natome) )
        allocate( Ylms(nbm_c,nlmmax,nspinp,nspino,natome) )
        if( .not. Green )  then
          allocate( Ylmso(nsort,nlmomax) )
          call Ylmpt(iaprotoi,ibord,icheck(15),iopsymr,isrt,Lmaxat,Lmaxso_m,n_atom_proto,natome, &
             nbord,nbtm,nlmmax,nlmomax,nsort,npsom,Posi,Rot_atom,Spin_axis_free,xyz,Ylmato,Ylmso)
             if( Spin_axis_free .and. .not. Green ) &
               call Rotate_Ylms(iaprotoi,ibord,icheck(15),Lmaxat,n_atom_proto,natome,nbm_c,nbordf,nbtm,nlmmax, &
                               nspino,nspinp,Rot_atom,Ylmato,Ylms)
        endif

        if( .not. Green ) then
          if( Spinorbite .or. Relativiste ) then
            nicm = nim
          else
            nicm = 1
          endif
          allocate( gradvr(nicm,3,nspin))
        endif
        allocate( Lmaxa(natome) )
        allocate( nlmsa(natome) )
        allocate( drho_self(nrm_self,nlm_pot,nspinp,n_atom_0_self:n_atom_ind_self,0:mpinodes-1) )
        allocate( Statedens(lla2_state,nspinp,lla2_state,nspinp,n_atom_0:n_atom_ind,0:mpinodes-1) )
        allocate( Statedens_i(lla2_state,nspinp,lla2_state,nspinp,n_atom_0:n_atom_ind,0:mpinodes-1) )

        nlm_RIXS = 0
        allocate( Ampl_dft(nlm_RIXS,nspinp,nlmomax,nspinp,0:mpinodes-1) )

      endif

! Initialization of cluster energy
      Energ_self(:) = 0._db

      n_vr_0 = n_atom_0
      n_vr_ind = n_atom_ind

      Tau_nondiag = .false.
      if( Spinorbite .or. Full_potential ) then
        Tau_nondiag = .true.
      elseif( Hubbard ) then
        do iapr = n_atom_0_self,n_atom_ind_self
          if( Hubb_diag(iapr) ) cycle
          Tau_nondiag = .true.
          exit
        end do
      endif

      if( mpirank0 == 0 ) then
        call CPU_TIME(time)
        Time_loc(4) = real(time,db)
        Time_rout(5) = Time_rout(5) + Time_loc(4) - Time_loc(3)
      endif

      ie0 = 1
      nenerg0 = nenerg

! Loop over energy
      nge = ( nenerg0 - ie0 ) / mpinodes + 1

      index_e = 0

      boucle_energ: do je = 1,nge

        ie = ie0 + ( je - 1 ) * mpinodes + mpirank

        if( ie <= nenerg0 ) then

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(1) = real(time,db)
          endif

          index_e = index_e + 1
          Enervide = Energ(ie)

          ich = min( icheck(16), icheck_27 )
          if( ich < 2 ) then
            Trace_l = 0
          else
            Trace_l = Trace_k
          endif

! Potentiel calculation in the excited state
          call Potex(Nonsph,axyz,alfpot,dV0bdcF,Energ(ie),Enervide,Full_atom, &
            iaabsi,iapot,iaprotoi,ich,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_l,Trace_p, &
            V_intmax,Vcato,Vh,Vhbdc,Vhbdc_out,Vhns,Vmft,Vr,Vxc,VxcbdcF,VxcbdcF_out,Vrato,Vxcato,V0bdc,V0bdc_out,xyz)

          do ispin = 1,nspin

            V0bdc_out(ispin) = V0bdc(ispin)

            if( Muffintin ) call mdfmuf(Nonsph,Axe_Atom_gr,axyz,Full_atom,iaabs,iaproto,iaprotoi,ich, &
              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_l,Trace_p,Vhns,V0bdc(ispin),Vr,Vrato,xyz)

            if( Supermuf ) call modmuf(Full_atom,iaprotoi,itypepr,ich, &
              ispin,n_atom_0,n_atom_ind,n_atom_proto,natome,nlm_pot,nrato,nrm,nspin,ntype,Rato,Rmtg,V0bdc(ispin),Vrato)

            if( .not. Green .and. ( Spinorbite .or. Relativiste ) ) &
              call gradpot(Base_hexa,cgrad,Gradvr,ich,iord,ispin,ivois,nicm,npoint,npsom,nspin,nvois,Vr)

            Ecinetic_out(ispin) = Enervide - V0bdc_out(ispin)
            Ecinetic(ispin) = Enervide - V0bdc(ispin)
            Ecinetic_a(ispin,:) = Enervide - Vmft(ispin,:)

            if( Eneg ) then
! Numerical problem around 0.
              Em = 0.01_db / rydb
              Ei0 = 0.01_db / rydb
              if( Ecinetic_out(ispin) < 0._db ) then
                Eimag(ie) = max( Eimag(ie), ei0 )
              elseif( Ecinetic_out(ispin) < Em ) then
                Eii = ei0 * ( 1 - Ecinetic_out(ispin) / em )
                Eimag(ie) = max( Eimag(ie), Eii )
              endif
            else
              Ecinetic_out(ispin) = max( Ecinetic_out(ispin), Eclie_out)
              Ecinetic(ispin) = max( Ecinetic(ispin), Eclie )
              Ecinetic_a(ispin,:) = max( Ecinetic_a(ispin,:), Eclie )
            endif

            if( ( Ecinetic(ispin) < eps10 .or. Ecinetic_out(ispin) < eps10 ) .and. .not. Eneg ) then
              call write_error
              do ipr = 6,9,3
                write(ipr,170) Ecinetic(ispin) * rydb
                if( nptmoy_out > 0 ) write(ipr,180) Ecinetic_out(ispin) * rydb
              end do
              stop
            endif

        end do  ! End of loop over spin

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(2) = real(time,db)
            Time_rout(6) = Time_rout(6) + Time_loc(2) - Time_loc(1)
          endif

          if( abs( Eimag(ie) ) > eps10 .or. Ecinetic_out(1) < eps10 .or. Ecinetic_out(nspin) < eps10 ) then
            E_comp = .true.
          else
            E_comp = .false.
          endif

          if( No_solsing ) then
            Solsing = .false.
          elseif( E_comp .and. Green ) then
            Solsing = .true.
          else
            Solsing = Solsing_s
          endif

          Ecmax = 0._db
          Ecmax_out = 0._db
          do ispin = 1,nspin
            Ecmax_out = max( Ecmax_out, Ecinetic_out(ispin) )
            Ecmax = max( Ecmax, Ecinetic(ispin) )
          end do

          Lmax_g = 0
          Lmax_abs_a = 0
          do ipr = 0,n_atom_proto
            Z = Numat( itypepr(ipr) )
            call clmax(Ecmax,Rmtg(ipr),Lmaxat0,Lmaxat(ipr),Z,Lmaxfree)
            Lmaxat(ipr) = min(Lmaxat(ipr), Lmax_max)
  ! For SCF, limited to 1 for H and He
            if( Z < 3 ) Lmaxat(ipr) = min( Lmaxat(ipr), 1 )
            if( Z == numat_abs ) Lmax_abs_a = max( Lmax_abs_a, Lmaxat(ipr) )
            Lmax_g = max( Lmaxat(ipr), Lmax_g)
          end do
          do ipr = 0,n_atom_proto
            Z = Numat( itypepr(ipr) )
            if( Z == numat_abs ) Lmaxat(ipr) = Lmax_abs_a
          end do
          nlmagm = ( Lmax_g + 1 )**2

          allocate( Tau_ato(nlmagm,nspinp,nlmagm,nspinp,n_atom_0:n_atom_ind) )
          if( Green ) then
            nphiato = 0
            nphiato_c = 0
          elseif( abs(Eimag(ie)) > eps10 .or. Spinorbite .or. Ylm_comp ) then
            nphiato = 0
            nphiato_c = nbtm
          else
            nphiato = nbtm
            nphiato_c = 0
            do igrph = 1,ngrph
              if( .not. Repres_comp(igrph) ) cycle
              nphiato = 0
              nphiato_c = nbtm
              exit
            end do
          endif
          nab_coop = 0
          allocate( Phiato(nphiato,nlmagm,nspinp,nspino,natome) )
          allocate( Phiato_c(nphiato_c,nlmagm,nspinp,nspino,natome) )
          allocate( Taull(nlmagm,nspinp,nlmagm,nspinp,natome) )
          allocate( Tau_coop(nlmagm,nspinp,nlmagm,nspinp,nab_coop,nspino) )
          Phiato(:,:,:,:,:) = 0._db
          Phiato_c(:,:,:,:,:) = (0._db,0._db)
          Tau_ato(:,:,:,:,:) = (0._db,0._db)
          Taull(:,:,:,:,:) = (0._db,0._db)
          Tau_coop(:,:,:,:,:,:) = (0._db,0._db)

          if( .not. Green ) then
            call clmax(Ecmax_out,Rsort,Lmaxso0,Lmaxso,-1,.true.)
            Lmaxso = min( Lmaxso, Lmaxso_max )
          endif

          ich = min( icheck(18), icheck_27 )
          if( ich > 1 ) write(3,190)

! Loop over non equivalent atoms
          n1 = n_atom_0_self

          do iapr = n1,n_atom_ind

            if( Full_atom ) then
              ipr = iaprotoi( iapr )
            else
              ipr = iapr
            endif
            Z = Numat( itypepr(ipr) )
            if( Z == 0 .and. .not. Green ) cycle
            if( Z == Z_nospinorbite ) then
              Spino = .false.
            else
              Spino = Spinorbite
            endif
            it = itypepr(ipr)
            Absorbeur = .false.

            allocate( V_hubb_t(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp))
            if( Hubb(it) .and. iapr <= n_atom_ind_self ) then
              Hubb_a = .true.
              V_Hubb_t(:,:,:,:) = V_Hubb(:,:,:,:,iapr)
              Hubb_d = Hubb_diag(iapr)
            else
              Hubb_a = .false.
              Hubb_d = .true.
            end if

            nr = nrato(it)
            allocate( r(nr) )
            allocate( Vrato_e(nr,nlm_pot,nspin) )
            r(1:nr) = Rato(1:nr,it)

            Lmax = Lmaxat(ipr)

            Vrato_e(1:nr,:,:) = Vrato(1:nr,:,:,iapr)

            if( FDM_comp .and. .not. Green ) then
              V0bdc_e(:) = Vmft(:,iapr)
              Ecinetic_e(:) = Ecinetic_a(:,iapr)
            else
              V0bdc_e(:) = V0bdc(:)
              Ecinetic_e(:) = Ecinetic(:)
            endif

            call Sphere(Axe_atom_gr,Ecinetic_e,Eimag(ie),Energ(ie),Enervide,Full_atom, &
            Full_pot(iapr),Green,Hubb_a,Hubb_d,iaabsi,iapr,iaprotoi,ibord,ich,igreq,igroupi,iopsymr,Lmax,Lmax_pot, &
            m_hubb,n_atom_0,n_atom_ind,n_atom_proto,natome,nbord,nbtm,nbtm_fdm,neqm,ngroup_m,nlm_pot,nlmagm,nlmmax, &
            nphiato,nphiato_c,npsom,nr,nspin,nspino,nspinp,Z,Phiato,Phiato_c,Posi,r,Relativiste,Renorm, &
            Rmtg(ipr),Rmtsd(ipr),Spin_axis_free,Spino,Tau_ato,V_hubb_t,V_intmax,V0bdc_e,Vrato_e,xyz,Ylm_comp,Ylmato)

            deallocate( r )
            deallocate( Vrato_e, V_hubb_t )

          end do

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(3) = real(time,db)
            Time_rout(7) = Time_rout(7) + Time_loc(3) - Time_loc(2)
          endif

          Lmax_g = 0
          do ia = 1,natome
            Lmaxa(ia) = Lmaxat( iaprotoi(ia) )
            Lmax_g = max(Lmax_g,Lmaxa(ia))
          end do

          Time_fill = 0._db; Time_tria = 0._db

! Second_ run and Second_SCF are necessarily false here

          do ispin = 1,nspinorb
! igrph: index of representations
            do igrph = 1,ngrph

              nlmsamax = 0
              nlmsa(:) = 0
              do ia = 1,natome
                Z = Numat(itypei(ia))
                if( .not. Green .and. Z == 0 ) cycle
                n = nlmsa0(ia,igrph)
                allocate( Lval(n) )
                Lval(1:n) = Lato(1:n,ia,igrph)
                call cnlmmax(Lmaxa(ia),Lval,n,nlmsa(ia))
                nlmsamax = max(nlmsamax,nlmsa(ia))
                deallocate( Lval )
              end do
              if( nlmsamax == 0 .and. igrph /= ngrph ) cycle
              ich = min( icheck(19), icheck_27 )

              if( Green ) then
                call Mat_MST(Axe_Atom_gr,Cal_xanes,Dist_coop,Ecinetic,Eimag(ie),Full_atom,ia_coop,ia_eq,ia_rep, &
                  iaabsi,iaprotoi,iato,ich,igroupi,igrph,iopsymr,irep_util,is_eq,ispin,karact,Lato,Lmaxa,Lmax_g,mato, &
                  n_atom_0,n_atom_coop,n_atom_ind,n_atom_proto,nab_coop,natome,natomp,nb_eq,nb_rpr,nb_rep_t,nb_sym_op,nb_test, &
                  ngroup_m,ngrph,nlmagm,nlmsa,nlmsam,nlmsamax,Normaltau,nspin,nspino,nspinp,pos,Posi,Recop,Repres_comp(igrph), &
                  Rmtg,Rot_atom,Solsing,Spin_axis_free,Spinorbite,State_all,Sym_cubic,Tau_ato,Tau_nondiag,Tau_coop,Taull, &
                  Test_case,Time_fill,Time_tria,Ylm_comp)
              else
                n = nlmso0(igrph)
                allocate( Lval(n) )
                Lval(1:n) = Lso(1:n,igrph)
                call cnlmmax(Lmaxso,Lval,n,nlmso)
                deallocate( Lval )
                call Mat_FDM(Adimp,Ampl_dft,Atom_axe,Base_hexa,Basereel,Cal_xanes,cgrad, &
                      clapl,Dist_coop,distai,E_comp,Ecinetic_out,Eclie_out,Eimag(ie),Eneg,Enervide, &
                      gradvr,ia_coop,iaabsi,iaprotoi,iato,ibord,ich,ie,igrph,irep_util,isbord, &
                      iso,ispin,isrt,isvois,ivois,karact,Lato,Lmaxa,Lmaxso,Lso,mato,mpinodes,mpirank0,mso, &
                      n_atom_coop,n_atom_proto,nab_coop,natome,nbm,nbm_c,nbord,nbordf,nbtm, &
                      ngrph,nim,nicm,nlm_rixs,nlmagm,nlmmax,nlmomax,nlmsa,nlmsam,nlmso,nphiato,nphiato_c,npoint,npr,npsom, &
                      nsort,nsortf,nso1,nspin,nspino,nspinp,numia,nvois,Phiato,Phiato_c,poidsa,poidso,Posi,R_rydb, &
                      Recop,Relativiste,Repres_comp(igrph),RIXS_gen,Rmtg,Rot_Spinor,Rsort,rvol,Rydberg,Spin_axis_free,Spinorbite, &
                      State_all,Sym_cubic,Tau_coop,Taull,Time_fill,Time_tria,V0bdc_out,Vr,xyz,Ylm_comp, &
                      Ylmato,Ylms,Ylmso)
              endif

            end do  ! end of loop over representations
          end do  ! end of loop over spin

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(4) = real(time,db)
            Time_rout(8) = Time_rout(8) + Time_loc(4) - Time_loc(3)
            Time_rout(9) = Time_rout(9) + Time_fill ! Filling
            Time_rout(10) = Time_rout(10) + Time_tria ! Triang
          endif

          deallocate( Tau_ato )
          deallocate( Phiato, Phiato_c )

          ich = min( icheck_27, icheck(28) )
          Solsing_o = .false.

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(5) = real(time,db)
            Time_rout(11) = Time_rout(11) + Time_loc(5) - Time_loc(4)
          endif

          if( Full_atom ) then
            iapr = iaabsi
          elseif( Self_nonexc ) then
            iapr = iprabs_nonexc
          else
            iapr = iprabs
          endif
          V_hubb_abs(:,:,:,:) = V_hubb(:,:,:,:,iapr)
          Hubb_diag_abs = Hubb_diag(iapr)

! It is Harm_cubic which is taken as .false. in the SCF_step
          call Cal_dens(Cal_xanes,Density_comp,Density_sp,drho_self,Ecinetic,Eimag(ie),Energ(ie),Enervide,Full_atom, &
            Full_pot(iapr),.false.,Hubb,Hubb_diag,Hubb_diag_abs,iaabsi,iaprotoi,ich,itypei,itypepr,lla2_state, &
            Lmax_pot,Lmaxat,m_hubb,mpinodes,mpirank,n_atom_0,n_atom_0_self,n_atom_ind,n_atom_ind_self, &
            n_atom_proto,natome,nb_test,nlmagm,nlm_pot, &
            nrato,nrm,nrm_self,nspin,nspino,nspinp,ntype,Numat,Rato,Relativiste,Renorm,Rmtg,Rmtsd,Solsing,Solsing_o, &
            Spinorbite,State_all_out,Statedens,Statedens_i,Taull,Test_case,V_hubb,V_hubb_abs,V_intmax,V0bdc,Vrato,Ylm_comp)

          deallocate( Taull, Tau_coop )

          if( mpirank0 == 0 ) then
            call CPU_TIME(time)
            Time_loc(6) = real(time,db)
            Time_rout(12) = Time_rout(12) + Time_loc(6) - Time_loc(5)
          endif

        endif ! end of condition on ie <= nenerg, for parallel processing

        if( mpinodes > 1 ) then

          call MPI_RECV_statedens(LLa2_state,Lmaxat,mpinodes,mpirank,mpirank0,n_atom_0, &
                                    n_atom_ind,n_atom_proto,nspinp,Statedens,Statedens_i)

          call MPI_RECV_self(drho_self,nlm_pot,mpinodes,mpirank,mpirank0,n_atom_0_self, &
                               n_atom_ind_self,nrm_self,nspinp)
        endif

        do ie_computer = 0,mpinodes-1

          ie = ( je - 1 ) * mpinodes + ie_computer + ie0

          if( ie > nenerg0 ) exit

          if( mpirank0 == 0 ) then

            call CPU_TIME(time)
            Time_loc(1) = real(time,db)

            call CPU_TIME(time)
            Time_loc(2) = real(time,db)
            Time_rout(13) = Time_rout(13) + Time_loc(2) - Time_loc(1)

            call Search_Fermi(Bulk_atom_done,Bulk_step_alone,Charge_f,Chg_reference,chg_open_val,Chargat_self,Density,Doping, &
              drho_self, &
              E_cut,E_Open_val,E_Open_val_exc,E_starta,Energ,E_Fermi,Energ_self,Fermi,Full_atom,Hubb,Hubb_diag,iaabsi,iaprotoi, &
              i_self,icheck_27,ie,ie_computer,Int_statedens,ipr_dop,ispin_maj,itypei,itypepr, &
              Level_val_abs,Level_val_exc,LLa_state,LLa2_state,Lmax_DOSout,Lmaxat,m_hubb,mpinodes,n_atom_0,n_atom_0_self, &
              n_atom_ind,n_atom_ind_self,n_atom_proto,n_atom_proto_bulk,n_atom_proto_uc,natome,nb_eq,nb_eq_2D,nenerg,ngreq, &
              nlm_pot,nomfich_s,nrato, &
              nrm,nrm_self,nspin,nspinp,ntype,Numat,Occ_hubb,pop_orb_val,Proto_calculated,Rato,rho_self,rho_self_t, &
              Rmtsd,SCF_elecAbs,SCF_mag_fix,Self_nonexc,Statedens,Statedens_i,Sym_2D,V_hubb,V_hubbard,Ylm_comp)

            call CPU_TIME(time)
            Time_loc(3) = real(time,db)
            Time_rout(14) = Time_rout(14) + Time_loc(3) - Time_loc(2)

          endif

          call MPI_Bcast(Fermi,1,MPI_LOGICAL,0,MPI_COMM_WORLD, mpierr)
          call MPI_Bcast(E_cut,1,MPI_REAL8,0,MPI_COMM_WORLD, mpierr)
          call MPI_Bcast(E_Fermi,1,MPI_REAL8,0,MPI_COMM_WORLD, mpierr)

! When reaching Fermi one exits the loop
          if( Fermi ) exit boucle_energ

        end do

      end do boucle_energ   ! End of loop over energy

      deallocate( Energ, Eimag )

      if( Fermi ) then

        exit Loop_attempt

      else

        if( mpirank == 0 ) then
          if( Second_try ) call write_error
          do ipr = 3,9,3
            if( .not. Second_try .and. ipr == 9 ) exit
            write(ipr,'(/A)') ' The Fermi level was not reached !'
            write(ipr,'(a14,f10.3,a14,f10.3)')   '      Charge =', Charge_f(1), ', Charge_ref =', sum( Chg_reference(:) )
            if( nspin == 2 ) then
              write(ipr,'(a14,f10.3,a14,f10.3)') '   Charge_up =', Charge_f(2), ', Charge_ref =', Chg_reference(1)
              write(ipr,'(a14,f10.3,a14,f10.3)') '   Charge_dn =', Charge_f(3), ', Charge_ref =', Chg_reference(2)
            endif
         end do
        endif
        if( Second_try ) stop

      endif

    end do Loop_attempt ! loop on attempt

    if( Hubbard .and. mpinodes0 > 1 ) call MPI_Bcast_Hubb(Hubb_diag,m_hubb,mpirank0,n_atom_0_self,n_atom_ind_self,nspinp,V_hubb)

! Cluster energy calculation

    if( mpirank0 == 0 ) then
      call Energ_KS_core(Bulk_step_alone,E_KS_core,Full_atom,iaprotoi,icheck_27,itypepr,Jseuil,lcoeur,Lseuil,n_atom_0, &
          n_atom_0_self,n_atom_ind,n_atom_ind_self,n_atom_proto,n_atom_proto_uc,natome,ncoeur,nlm_pot,nrato, &
          nrm,nspin,nseuil,ntype,Numat,Proto_calculated,psi_coeur,Rato,Vcato,Vxcato)

      call Energ_DFT(Bulk_step_alone,Doping,E_cluster,Energ_self,E_KS_core,Excato,Full_atom,Hubb,iaprotoi, &
        icheck_27,ipr_dop,itypepr,m_hubb,n_atom_0,n_atom_0_self,n_atom_ind,n_atom_ind_self,n_atom_proto,n_atom_proto_uc, &
        natome,nb_eq,nb_eq_2D,ngreq,nlm_pot,nrm,nrm_self,nrato,nspin,nspinp,ntype,Numat,Occ_hubb, &
        Proto_calculated,Rato,rho_self,rmtsd,Sym_2D,V_hubb,Vcato,Vxcato)

    end if

! Exchange of tables for SCF
    if( mpinodes0 > 1 ) then
      m = n_atom_ind_self - n_atom_0_self + 1
      m2 = nspin * m
      n = ( 1 + nrm_self ) * nspin * m * nlm_pot

        call MPI_Bcast(rho_self,n,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
        call MPI_Bcast(rho_self_s,n,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
        call MPI_Bcast(Chargat_self,m2,MPI_REAL8,0, MPI_COMM_WORLD,mpierr)
        call MPI_Bcast(Chargat_self_s,m2,MPI_REAL8,0, MPI_COMM_WORLD,mpierr)
        call MPI_Bcast(pop_orb_val,m2,MPI_REAL8,0, MPI_COMM_WORLD,mpierr)
        call MPI_Bcast(Energ_self,m,MPI_REAL8,0, MPI_COMM_WORLD,mpierr)
        call MPI_Bcast(E_cluster,1,MPI_REAL8,0,MPI_COMM_WORLD, mpierr)
    endif

! Preparation of next iteration for self-consistence
    if( Fermi_first .and. (TDDFT .or. Optic) ) then
      Delta_E_conv = 2 * Delta_En_conv
    else
      Delta_E_conv = Delta_En_conv
    endif

    call Prep_next_iter(Bulk_step_alone,Chargat_init,Chargat_self,chargat_self_s,Convergence,Delta_E_conv,Delta_energ, &
         Delta_energ_s,Doping,E_cluster,E_cluster_s,Energ_self,Energ_self_s,Fermi_first,Full_atom,Hubb, &
         Hubbard,i_self,iaprotoi,icheck_27,ipr_dop,itypepr,Lmaxat,m_hubb,mpirank0,n_atom_0_self,n_atom_ind_self, &
         n_atom_proto,n_atom_proto_uc,n_devide,natome,nb_eq,nb_eq_2D,ngreq,nlm_pot,nrm_self,nself_c,nspin,nspinp, &
         ntype,Numat,Occ_hubb,p_self,p_self_max,p_self0_c,pop_orb_val,Proto_calculated,rho_self,rho_self_s, &
         Rmtsd,SCF_smooth,Sym_2D,V_hubb,V_hubb_s,V_hubbard)

    if( Convergence ) exit

  end do boucle_coh  ! End of loop over iteration to converge in SCF

  if( icheck_27 == 1 ) then
    if( Full_atom ) then
      Atom_kind = ' ia'
    else
      Atom_kind = 'ipr'
    endif

    do iapr = n_atom_0_self,n_atom_ind_self
      if( Full_atom) then
        it = itypei(iapr)
        Z = Numat( it )
      else
        it = itypepr(iapr)
        Z = Numat( it )
      endif
      if( .not. Hubb(it) ) cycle
      L = L_hubbard( Z )
      call Write_occ_hubb(Atom_kind,iapr,L,m_hubb,n_atom_0_self,n_atom_ind_self,nspinp,Occ_hubb,Z)
      call Write_V_hubb(Atom_kind,iapr,it,L,m_hubb,n_atom_0_self,n_atom_ind_self,nspinp,ntype,V_hubb,V_hubbard,Z)
    end do
  endif

  if( Bulk_step_alone .and. .not. Full_atom .and. Self_nonexc ) then
! One keeps the bulk atom occupancies
    pop_orb_val_bulk(iprabs_nonexc,:) = pop_orb_val(iprabs_nonexc,:)
    do ipr = n_atom_proto - n_atom_proto_bulk + 1,n_atom_proto
      if( Numat( itypepr(ipr) ) == numat_abs ) cycle
      pop_orb_val_bulk(ipr,:) = pop_orb_val(ipr,:)
    end do
  endif

  deallocate( Ampl_dft, Chg_coeur, clapl, cgrad, drho_self )
  deallocate( iato, ibord, imoy, imoy_out, isbord, ispin_maj, isrt, Int_statedens, iso, ivois, isvois )
  deallocate( Lato, Lmaxa, Lso )
  deallocate( E_starta, Excato )
  deallocate( mato, mso )
  deallocate( nbord, nbordf, nlmsa, nlmsa0, nlmso0, numia )
  deallocate( poidsa, poidso, poidsov, poidsov_out )
  deallocate( Repres_comp, rho, rhoato, rhons, rho_self_s, rho_self_t, rs, rsato, rvol )
  deallocate( Full_pot, Statedens, Statedens_i, Vcato, Vh, Vhns, Vr, Vrato, Vxc, Vxcato, xyz, Ylms, Ylmato )
  deallocate( Ecinetic_a, Vmft )

  if( .not. Green ) deallocate( gradvr, Ylmso )

  return
  150 format(/1x,120('-')//,' Begining of cycle',i3)
  170 format(///' E_kinetic =',f7.3,' eV < 0.',/ ' Start the calculation at higher energy !'///)
  180 format(///' or E_kinetic_ext =',f7.3,' eV < 0.',/ ' Start the calculation at higher energy !'///)
  190 format(/' ---- Sphere -------',100('-'))
end

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

subroutine MPI_RECV_Tau(Lmax_dft,mpinodes,mpirank,mpirank0,n_atom_proto,nlmmax,nspinp,Taull_dft)

  use declarations
  implicit real(kind=db) (a-h,o-z)
  include 'mpif.h'

  integer:: idim, ie, mpinodes, mpirank, mpirank0, n_atom_proto, nlmmax, nspinp, mpierr, mpirank_in_mumps_group

  integer, dimension(0:n_atom_proto,0:mpinodes-1):: Lmax_dft

  complex(kind=db), dimension(nlmmax,nspinp,nlmmax,nspinp,0:mpinodes-1):: Taull_dft

  real(kind=db), dimension(nlmmax,nspinp,nlmmax,nspinp,0:mpinodes-1):: Taull_dft_i, Taull_dft_r

  call MPI_Comm_Rank(MPI_COMM_MUMPS,mpirank_in_mumps_group,mpierr)
  idim = n_atom_proto + 1
  if( mpirank0 == 0 ) then
   call MPI_GATHER(MPI_IN_PLACE,idim,MPI_INTEGER,Lmax_dft,idim,MPI_INTEGER,0,MPI_COMM_GATHER,mpierr)
  elseif( mpirank_in_mumps_group == 0 ) then
	  call MPI_GATHER(lmax_dft(0,mpirank),idim,MPI_INTEGER,Lmax_dft,idim,MPI_INTEGER,0,MPI_COMM_GATHER,mpierr)
  endif

  Taull_dft_r(:,:,:,:,mpirank) = real( Taull_dft(:,:,:,:,mpirank),db )
  Taull_dft_i(:,:,:,:,mpirank) = aimag( Taull_dft(:,:,:,:,mpirank) )

  idim = ( nlmmax * nspinp )**2

  if( mpirank0 == 0 ) then
   call MPI_GATHER(MPI_IN_PLACE,idim,MPI_REAL8,Taull_dft_r,idim,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
   call MPI_GATHER(MPI_IN_PLACE,idim,MPI_REAL8,Taull_dft_i,idim,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
  elseif( mpirank_in_mumps_group == 0 ) then
	  call MPI_GATHER(Taull_dft_r(1,1,1,1,mpirank),idim,MPI_REAL8,Taull_dft_r,idim,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  call MPI_GATHER(Taull_dft_i(1,1,1,1,mpirank),idim,MPI_REAL8,Taull_dft_i,idim,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
  endif

  if( mpirank0 == 0 ) then
    do ie = 1,mpinodes-1
      Taull_dft(:,:,:,:,ie) = cmplx( Taull_dft_r(:,:,:,:,ie), Taull_dft_i(:,:,:,:,ie),db )
    end do
  end if

  return
end

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

subroutine MPI_RECV_all( L0_nrixs, Lmax_nrixs, mpinodes, mpirank, mpirank0, Multipole, n_oo, ninitr, &
                        nq_nrixs, S_nrixs, T_E1E1, T_E1E2, T_E1E3, T_E1M1, T_E1M2, T_E1SP, T_E2E2, T_E2M2, &
                        T_E3E3, T_M1M1, T_SPSP )

  use declarations
  implicit real(kind=db) (a-h,o-z)
  include 'mpif.h'

  integer:: idim1, idim2, idim3, idim4, idim5, L0_nrixs, Lmax_nrixs, mpirank_in_mumps_group, mpierr, mpinodes, mpirank, &
    mpirank0, n_oo, ninitr, nq_nrixs, rang

  complex(kind=db), dimension(3,3,ninitr,0:mpinodes-1):: T_E1E1, T_E1SP, T_E1M1, T_M1M1, T_SPSP
  complex(kind=db), dimension(3,3,3,ninitr,0:mpinodes-1):: T_E1E2, T_E1M2
  complex(kind=db), dimension(3,3,3,3,ninitr,0:mpinodes-1):: T_E1E3, T_E2E2, T_E2M2
  complex(kind=db), dimension(3,n_oo,3,n_oo,ninitr,0:mpinodes-1):: T_E3E3
  complex(kind=db), dimension(nq_nrixs,(Lmax_nrixs+1)**2,(Lmax_nrixs+1)**2,ninitr,0:mpinodes-1):: S_nrixs

  logical:: E1E1, E1E2, E1E3, E1M1, E1M2, E1SP, E2E2, E2M2, E3E3, M1M1, SPSP

  logical, dimension(n_Multipole_max):: Multipole

  real(kind=db), dimension(nq_nrixs,(Lmax_nrixs+1)**2,(Lmax_nrixs+1)**2,ninitr,0:mpinodes-1):: S_nrixs_ei, S_nrixs_er
  real(kind=db), dimension(3,3,ninitr,0:mpinodes-1):: T_E1E1_er, T_E1E1_ei, T_E1SP_er, T_E1SP_ei, T_E1M1_er, T_E1M1_ei, &
                                                      T_M1M1_er, T_M1M1_ei, T_SPSP_er, T_SPSP_ei
  real(kind=db), dimension(3,3,3,ninitr,0:mpinodes-1):: T_E1E2_er, T_E1E2_ei, T_E1M2_er, T_E1M2_ei
  real(kind=db), dimension(3,3,3,3,ninitr,0:mpinodes-1):: T_E1E3_ei, T_E1E3_er, T_E2E2_ei, T_E2E2_er, T_E2M2_ei, T_E2M2_er
  real(kind=db), dimension(3,n_oo,3,n_oo,ninitr,0:mpinodes-1):: T_E3E3_ei, T_E3E3_er

  call MPI_Comm_Rank(MPI_COMM_MUMPS,mpirank_in_mumps_group,mpierr)

  E1E1 = Multipole(1); E1E2 = Multipole(2); E1E3 = Multipole(3)
  E1M1 = Multipole(4); E1M2 = Multipole(5)
  E2E2 = Multipole(6);
  E3E3 = Multipole(7); M1M1 = Multipole(8)
  E1SP = Multipole(11); SPSP = Multipole(12)
  E2M2 = Multipole(13)

  idim1 = 9 * ninitr
  idim2 = 3 * idim1
  idim3 = 3 * idim2
  idim4 = ( n_oo**2 ) * idim2
  idim5 = nq_nrixs * ninitr * (Lmax_nrixs+1)**4

! Copies to store the real and imaginary part
! The processor index is the last index

  if( E1E1 )  then
    T_E1E1_er(:,:,:,mpirank) = real( T_E1E1(:,:,:,mpirank),db )
    T_E1E1_ei(:,:,:,mpirank) = aimag( T_E1E1(:,:,:,mpirank) )
  endif

  if( E1SP )  then
    T_E1SP_er(:,:,:,mpirank) = real( T_E1SP(:,:,:,mpirank),db )
    T_E1SP_ei(:,:,:,mpirank) = aimag( T_E1SP(:,:,:,mpirank) )
  endif

  if( SPSP )  then
    T_SPSP_er(:,:,:,mpirank) = real( T_SPSP(:,:,:,mpirank),db )
    T_SPSP_ei(:,:,:,mpirank) = aimag( T_SPSP(:,:,:,mpirank) )
  endif

  if( E1M1 )  then
    T_E1M1_er(:,:,:,mpirank) = real( T_E1M1(:,:,:,mpirank),db )
    T_E1M1_ei(:,:,:,mpirank) = aimag( T_E1M1(:,:,:,mpirank) )
  endif

  if( M1M1 )  then
    T_M1M1_er(:,:,:,mpirank) = real( T_M1M1(:,:,:,mpirank),db )
    T_M1M1_ei(:,:,:,mpirank) = aimag( T_M1M1(:,:,:,mpirank) )
  endif

  if( E1E2 )  then
    T_E1E2_er(:,:,:,:,mpirank) = real( T_E1E2(:,:,:,:,mpirank),db)
    T_E1E2_ei(:,:,:,:,mpirank) = aimag( T_E1E2(:,:,:,:,mpirank) )
  endif

  if( E1M2 )  then
    T_E1M2_er(:,:,:,:,mpirank) = real( T_E1M2(:,:,:,:,mpirank),db)
    T_E1M2_ei(:,:,:,:,mpirank) = aimag( T_E1M2(:,:,:,:,mpirank) )
  endif

  if( E1E3 )  then
    T_E1E3_er(:,:,:,:,:,mpirank) = real( T_E1E3(:,:,:,:,:,mpirank),db )
    T_E1E3_ei(:,:,:,:,:,mpirank) = aimag( T_E1E3(:,:,:,:,:,mpirank) )
  endif

  if( E3E3 )  then
    T_E3E3_er(:,:,:,:,:,mpirank) = real( T_E3E3(:,:,:,:,:,mpirank),db )
    T_E3E3_ei(:,:,:,:,:,mpirank) = aimag( T_E3E3(:,:,:,:,:,mpirank) )
  endif

  if( E2E2 )  then
    T_E2E2_er(:,:,:,:,:,mpirank) = real( T_E2E2(:,:,:,:,:,mpirank),db )
    T_E2E2_ei(:,:,:,:,:,mpirank) = aimag( T_E2E2(:,:,:,:,:,mpirank) )
  endif

  if( E2M2 )  then
    T_E2M2_er(:,:,:,:,:,mpirank) = real( T_E2M2(:,:,:,:,:,mpirank),db )
    T_E2M2_ei(:,:,:,:,:,mpirank) = aimag( T_E2M2(:,:,:,:,:,mpirank) )
  endif

  S_nrixs_er(:,:,:,:,mpirank) = real( S_nrixs(:,:,:,:,mpirank),db)
  S_nrixs_ei(:,:,:,:,mpirank) = aimag( S_nrixs(:,:,:,:,mpirank) )

  if( mpirank0 == 0 ) then
    if( E1E1 )  then
      call MPI_GATHER(MPI_IN_PLACE,idim1,MPI_REAL8,T_E1E1_er,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim1,MPI_REAL8,T_E1E1_ei,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    endif
    if( E1SP )  then
      call MPI_GATHER(MPI_IN_PLACE,idim1,MPI_REAL8,T_E1SP_er,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim1,MPI_REAL8,T_E1SP_ei,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    endif
    if( SPSP )  then
      call MPI_GATHER(MPI_IN_PLACE,idim1,MPI_REAL8,T_SPSP_er,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim1,MPI_REAL8,T_SPSP_ei,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    endif
    if( E1M1 )  then
      call MPI_GATHER(MPI_IN_PLACE,idim1,MPI_REAL8,T_E1M1_er,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim1,MPI_REAL8,T_E1M1_ei,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    end if
    if( M1M1 )  then
      call MPI_GATHER(MPI_IN_PLACE,idim1,MPI_REAL8,T_M1M1_er,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim1,MPI_REAL8,T_M1M1_ei,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    end if
    if( E1E2 )  then
      call MPI_GATHER(MPI_IN_PLACE,idim2,MPI_REAL8,T_E1E2_er,idim2,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim2,MPI_REAL8,T_E1E2_ei,idim2,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    end if
    if( E1M2 )  then
      call MPI_GATHER(MPI_IN_PLACE,idim2,MPI_REAL8,T_E1M2_er,idim2,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim2,MPI_REAL8,T_E1M2_ei,idim2,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    end if
    if( E2E2 )  then
      call MPI_GATHER(MPI_IN_PLACE,idim3,MPI_REAL8,T_E2E2_er,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim3,MPI_REAL8,T_E2E2_ei,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    end if
    if( E2M2 )  then
      call MPI_GATHER(MPI_IN_PLACE,idim3,MPI_REAL8,T_E2M2_er,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim3,MPI_REAL8,T_E2M2_ei,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    end if
    if( E1E3 )  then
      call MPI_GATHER(MPI_IN_PLACE,idim3,MPI_REAL8,T_E1E3_er,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim3,MPI_REAL8,T_E1E3_ei,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    end if
    if( E3E3 )  then
      call MPI_GATHER(MPI_IN_PLACE,idim4,MPI_REAL8,T_E3E3_er,idim4,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim4,MPI_REAL8,T_E3E3_ei,idim4,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    end if

    if( idim5 > 0 ) then
      call MPI_GATHER(MPI_IN_PLACE,idim5,MPI_REAL8,S_nrixs_er,idim5,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      call MPI_GATHER(MPI_IN_PLACE,idim5,MPI_REAL8,S_nrixs_ei,idim5,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
    endif

  elseif( mpirank_in_mumps_group == 0 ) then

	  if( E1E1 ) then
	    call MPI_GATHER(T_E1E1_er(1,1,1,mpirank),idim1,MPI_REAL8,T_E1E1_er,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(T_E1E1_ei(1,1,1,mpirank),idim1,MPI_REAL8,T_E1E1_ei,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  endif
	  if( E1SP ) then
	    call MPI_GATHER(T_E1SP_er(1,1,1,mpirank),idim1,MPI_REAL8,T_E1SP_er,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(T_E1SP_ei(1,1,1,mpirank),idim1,MPI_REAL8,T_E1SP_ei,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  endif
	  if( SPSP ) then
	    call MPI_GATHER(T_SPSP_er(1,1,1,mpirank),idim1,MPI_REAL8,T_SPSP_er,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(T_SPSP_ei(1,1,1,mpirank),idim1,MPI_REAL8,T_SPSP_ei,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  endif
	  if( E1M1 ) then
	    call MPI_GATHER(T_E1M1_er(1,1,1,mpirank),idim1,MPI_REAL8,T_E1M1_er,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(T_E1M1_ei(1,1,1,mpirank),idim1,MPI_REAL8,T_E1M1_ei,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  end if

	  if( M1M1 ) then
	    call MPI_GATHER(T_M1M1_er(1,1,1,mpirank),idim1,MPI_REAL8,T_M1M1_er,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(T_M1M1_ei(1,1,1,mpirank),idim1,MPI_REAL8,T_M1M1_ei,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  end if

	  if( E1E2 ) then
	    call MPI_GATHER(T_E1E2_er(1,1,1,1,mpirank),idim2, MPI_REAL8,T_E1E2_er,idim2,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(T_E1E2_ei(1,1,1,1,mpirank),idim2, MPI_REAL8,T_E1E2_ei,idim2,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  end if

	  if( E1M2 ) then
	    call MPI_GATHER(T_E1M2_er(1,1,1,1,mpirank),idim2, MPI_REAL8,T_E1M2_er,idim2,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(T_E1M2_ei(1,1,1,1,mpirank),idim2, MPI_REAL8,T_E1M2_ei,idim2,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  end if

	  if( E2E2 ) then
	    call MPI_GATHER(T_E2E2_er(1,1,1,1,1,mpirank),idim3, MPI_REAL8,T_E2E2_er,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(T_E2E2_ei(1,1,1,1,1,mpirank),idim3, MPI_REAL8,T_E2E2_ei,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  end if

	  if( E2M2 ) then
	    call MPI_GATHER(T_E2M2_er(1,1,1,1,1,mpirank),idim3, MPI_REAL8,T_E2M2_er,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(T_E2M2_ei(1,1,1,1,1,mpirank),idim3, MPI_REAL8,T_E2M2_ei,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  end if

	  if( E1E3 ) then
	    call MPI_GATHER(T_E1E3_er(1,1,1,1,1,mpirank),idim3, MPI_REAL8,T_E1E3_er,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(T_E1E3_ei(1,1,1,1,1,mpirank),idim3, MPI_REAL8,T_E1E3_ei,idim3,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  end if

	  if( E3E3 ) then
	    call MPI_GATHER(T_E3E3_er(1,1,1,1,1,mpirank),idim4, MPI_REAL8,T_E3E3_er,idim4,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(T_E3E3_ei(1,1,1,1,1,mpirank),idim4, MPI_REAL8,T_E3E3_ei,idim4,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	  end if

      if( idim5 > 0 ) then
	    call MPI_GATHER(S_nrixs_er(1,1,1,1,mpirank),idim5,MPI_REAL8,S_nrixs_er,idim5,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
	    call MPI_GATHER(S_nrixs_ei(1,1,1,1,mpirank),idim5,MPI_REAL8,S_nrixs_ei,idim5,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      endif

  end if

! One rebuilds the Tensors. Now the central processor has the results from all the others
  if( mpirank0 == 0 ) then
    do rang = 1,mpinodes-1
      if( E1E1 ) T_E1E1(:,:,:,rang) = cmplx( T_E1E1_er(:,:,:,rang), T_E1E1_ei(:,:,:,rang),db )
      if( E1SP ) T_E1SP(:,:,:,rang) = cmplx( T_E1SP_er(:,:,:,rang), T_E1SP_ei(:,:,:,rang),db )
      if( SPSP ) T_SPSP(:,:,:,rang) = cmplx( T_SPSP_er(:,:,:,rang), T_SPSP_ei(:,:,:,rang),db )
      if( E1M1 ) T_E1M1(:,:,:,rang) = cmplx( T_E1M1_er(:,:,:,rang), T_E1M1_ei(:,:,:,rang),db )
      if( M1M1 ) T_M1M1(:,:,:,rang) = cmplx( T_M1M1_er(:,:,:,rang), T_M1M1_ei(:,:,:,rang),db )
      if( E1E2 ) T_E1E2(:,:,:,:,rang) = cmplx( T_E1E2_er(:,:,:,:,rang), T_E1E2_ei(:,:,:,:,rang),db )
      if( E1M2 ) T_E1M2(:,:,:,:,rang) = cmplx( T_E1M2_er(:,:,:,:,rang), T_E1M2_ei(:,:,:,:,rang),db )
      if( E2E2 ) T_E2E2(:,:,:,:,:,rang) = cmplx( T_E2E2_er(:,:,:,:,:,rang), T_E2E2_ei(:,:,:,:,:,rang),db )
      if( E2M2 ) T_E2M2(:,:,:,:,:,rang) = cmplx( T_E2M2_er(:,:,:,:,:,rang), T_E2M2_ei(:,:,:,:,:,rang),db )
      if( E1E3 ) T_E1E3(:,:,:,:,:,rang) = cmplx( T_E1E3_er(:,:,:,:,:,rang), T_E1E3_ei(:,:,:,:,:,rang),db )
      if( E3E3 ) T_E3E3(:,:,:,:,:,rang) = cmplx( T_E3E3_er(:,:,:,:,:,rang), T_E3E3_ei(:,:,:,:,:,rang),db )
      S_nrixs(:,:,:,:,rang) = cmplx( S_nrixs_er(:,:,:,:,rang), S_nrixs_ei(:,:,:,:,rang),db )
    end do
  end if

  return
end

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

subroutine MPI_RECV_statedens(lla2_state,Lmaxat,mpinodes,mpirank,mpirank0,n_atom_0, &
                              n_atom_ind,n_atom_proto,nspinp,Statedens,Statedens_i)

  use declarations
  implicit real(kind=db) (a-h,o-z)
  include 'mpif.h'

  integer:: idim, lla2_state, mpierr, mpinodes, mpirank, mpirank0, n_atom_0, n_atom_ind, n_atom_proto, nspinp, &
    mpirank_in_mumps_group

  integer, dimension(0:n_atom_proto):: Lmaxat
  integer, dimension(0:n_atom_proto,0:mpinodes-1):: lmaxat_e

  real(kind=db), dimension(lla2_state,nspinp,lla2_state,nspinp,n_atom_0:n_atom_ind,0:mpinodes-1):: Statedens, Statedens_i

  call MPI_Comm_Rank(MPI_COMM_MUMPS,mpirank_in_mumps_group,mpierr)
  lmaxat_e(:,mpirank) = Lmaxat(:)
  idim = n_atom_proto + 1

! MPI_GATHER: le choix lorsque tous les ordinateurs envoyent le meme nombre d'elements a l'ordinateur central

  if( mpirank0 == 0 ) then
    call MPI_GATHER(MPI_IN_PLACE,idim,MPI_INTEGER,lmaxat_e,idim,MPI_INTEGER,0,MPI_COMM_GATHER,mpierr)
  elseif ( mpirank_in_mumps_group == 0 ) then
    call MPI_GATHER(lmaxat_e(0,mpirank),idim,MPI_INTEGER,lmaxat_e,idim,MPI_INTEGER,0,MPI_COMM_GATHER,mpierr)
  end if

! It is the Lmax corresponding to the highest energy, which are the biggest

  if( mpirank0 == 0 ) Lmaxat(:) = lmaxat_e(:,mpinodes-1)

  idim = ( n_atom_ind - n_atom_0 + 1 ) * (lla2_state * nspinp)**2

  if( mpirank0 == 0 ) then
    call MPI_GATHER(MPI_IN_PLACE,idim,MPI_REAL8,Statedens,idim,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
  elseif( mpirank_in_mumps_group == 0 ) then
    call MPI_GATHER(Statedens(1,1,1,1,n_atom_0,mpirank),idim,MPI_REAL8,Statedens,idim,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
  end if

  if( mpirank0 == 0 ) then
    call MPI_GATHER(MPI_IN_PLACE,idim,MPI_REAL8,Statedens_i,idim,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
  elseif( mpirank_in_mumps_group == 0 ) then
    call MPI_GATHER(Statedens_i(1,1,1,1,n_atom_0,mpirank),idim, MPI_REAL8,Statedens_i,idim,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
  end if

  return
end

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

subroutine MPI_RECV_COOP(mpinodes,mpirank,mpirank0,nab_coop,nspinp,Coverlap)

  use declarations
  implicit real(kind=db) (a-h,o-z)
  include 'mpif.h'

  integer:: idim, mpierr, mpinodes, mpirank, mpirank_in_mumps_group, mpirank0, nab_coop, nspinp

  real(kind=db), dimension(16,16,nspinp,nab_coop,0:mpinodes-1):: Coverlap

  call MPI_Comm_Rank(MPI_COMM_MUMPS,mpirank_in_mumps_group,mpierr)

! MPI_GATHER: le choix lorsque tous les ordinateurs envoyent le meme nombre d'elements a l'ordinateur central

  idim = nab_coop * nspinp * (16)**2

  if( mpirank0 == 0 ) then
    call MPI_GATHER(MPI_IN_PLACE,idim,MPI_REAL8,Coverlap,idim,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
  elseif( mpirank_in_mumps_group == 0 ) then
    call MPI_GATHER(Coverlap(1,1,1,1,mpirank),idim,MPI_REAL8,Coverlap,idim,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
  end if

  return
end

!***********************************************************************
! IMPORTANT: depending on the operating system, the executable may run out
!     of virtual memory as the dummy arrays (such as drho_self) and the temporary ones are created in
!     the stack (i.e. static memory), which is subject to a limited available space.
!     Whereas a sequential application would normally return an error message,
!     a parallel MPI one would crash without any indication.
!     In order to avoid such problems it is advisable to force your compiler use
!     dynamic allocation even for temporary arrays, at least for those whose size
!     exceeds a certain limit that you may indicate at compilation time.
!     Should you use this trick, make sure that you compile and run the program
!     on the very same machine. This operation might have a price to pay in terms of performance.

!     Linux Intel compiler for Itanium based applications: -heap-array[:size]

subroutine MPI_RECV_self(drho_self,nlm_pot,mpinodes,mpirank,mpirank0,n_atom_0_self,n_atom_ind_self, &
                         nrm_self,nspinp)

  use declarations
  implicit real(kind=db) (a-h,o-z)
  include 'mpif.h'

  integer:: ia, idim1, lm, mpierr, mpirank_in_mumps_group, mpinodes, mpirank, mpirank0, n_atom_0_self, n_atom_ind_self, nlm_pot, &
            nrm_self, nspinp, rang

  real(kind=db), dimension(nrm_self,nlm_pot,nspinp,n_atom_0_self:n_atom_ind_self,0:mpinodes-1):: drho_self
  real(kind=db), dimension(nrm_self,nspinp,0:mpinodes-1):: drho_self_e

  call MPI_Comm_Rank(MPI_COMM_MUMPS,mpirank_in_mumps_group,mpierr)
  idim1 = nrm_self * nspinp

  do lm = 1,nlm_pot
    do ia = n_atom_0_self,n_atom_ind_self

      drho_self_e(:,:,mpirank) = drho_self(:,lm,:,ia,mpirank)

! Barrier is here very important: without it, it can be that we use the same
!    buffer rhov_self_eX by 2 different process with different iapr

      if( mpirank0 == 0 ) then
        call MPI_GATHER(MPI_IN_PLACE,idim1,MPI_REAL8,drho_self_e,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      elseif( mpirank_in_mumps_group == 0 ) then
        call MPI_GATHER(drho_self_e(1,1,mpirank),idim1,MPI_REAL8,drho_self_e,idim1,MPI_REAL8,0,MPI_COMM_GATHER,mpierr)
      end if

      if( mpirank0 == 0 ) then
        do rang = 1,mpinodes-1
          drho_self(:,lm,:,ia,rang) = drho_self_e(:,:,rang)
        end do
      end if

! This barrier is important, because drho_self_e eis used as
! buffer and must not be filled by 2 different atom ia

    end do
  end do

  return
end

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

subroutine MPI_Bcast_Hubb(Hubb_diag,m_hubb,mpirank,n_atom_0_self,n_atom_ind_self,nspinp,V_hubb)

  use declarations
  implicit real(kind=db) (a-h,o-z)
  include 'mpif.h'

  integer:: m_hubb, mpierr, mpirank, n_atom_0_self, n_atom_ind_self, ndim, nspinp

  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp,n_atom_0_self:n_atom_ind_self):: V_hubb

  logical, dimension(n_atom_0_self:n_atom_ind_self):: Hubb_diag

  real(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp,n_atom_0_self:n_atom_ind_self):: V_hubb_i, V_hubb_r

  ndim = ( n_atom_ind_self - n_atom_0_self + 1 ) * nspinp**2 * ( 2 * m_hubb + 1 )**2

  if( mpirank == 0 ) then
    V_hubb_r(:,:,:,:,:) = real( V_hubb(:,:,:,:,:), db )
    V_hubb_i(:,:,:,:,:) = aimag( V_hubb(:,:,:,:,:) )
  endif

  call MPI_Bcast(V_hubb_r,ndim,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
  call MPI_Bcast(V_hubb_i,ndim,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)

  if( mpirank /= 0 ) V_hubb(:,:,:,:,:) = cmplx( V_hubb_r(:,:,:,:,:), V_hubb_i(:,:,:,:,:), db )

  ndim = n_atom_ind_self - n_atom_0_self + 1

  call MPI_Bcast(Hubb_diag,ndim,MPI_LOGICAL,0,MPI_COMM_WORLD,mpierr)

  return
end

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

subroutine MPI_Bcast_tddft(je,mpinodes,mpirank,nbseuil,nenerg,nenerg_tddft,nlmamax,nspinp,nspino,rof0,Tau_abs)

  use declarations
  implicit real(kind=db) (a-h,o-z)
  include 'mpif.h'

  integer:: ie, ie_computer, je, mpierr, mpinodes, mpirank, ndim, nbseuil, nenerg, nenerg_tddft, nlmamax, nspinp, nspino

  complex(kind=db), dimension(nenerg_tddft,nlmamax,nspinp,nspino,nbseuil):: rof0
  complex(kind=db), dimension(nenerg,nlmamax,nspinp,nlmamax,nspinp):: Tau_abs

  real(kind=db), dimension(nlmamax,nspinp,nlmamax,nspinp):: Taull_tdd_i, Taull_tdd_r
  real(kind=db), dimension(nlmamax,nspinp,nspino,nbseuil):: rof0_i, rof0_r

  ndim = ( nlmamax * nspinp )**2

  do ie_computer = 0,mpinodes-1

    ie = ( je - 1 ) * mpinodes + ie_computer + 1
    if( ie > nenerg ) exit

    if( ie_computer == mpirank ) then
      Taull_tdd_r(:,:,:,:) = real( Tau_abs(ie,:,:,:,:), db )
      Taull_tdd_i(:,:,:,:) = aimag( Tau_abs(ie,:,:,:,:) )
    endif

    call MPI_Bcast(Taull_tdd_r,ndim,MPI_REAL8,ie_computer,MPI_COMM_GATHER,mpierr)
    call MPI_Bcast(Taull_tdd_i,ndim,MPI_REAL8,ie_computer,MPI_COMM_GATHER,mpierr)



    if( ie_computer /= mpirank ) Tau_abs(ie,:,:,:,:) = cmplx( Taull_tdd_r(:,:,:,:), Taull_tdd_i(:,:,:,:), db )

  end do

  ndim = nlmamax * nspinp * nspino * nbseuil

  if( nenerg_tddft > 0 ) then

    do ie_computer = 0,mpinodes-1

      ie = ( je - 1 ) * mpinodes + ie_computer + 1
      if( ie > nenerg_tddft ) exit

      if( ie_computer == mpirank ) then
        rof0_r(:,:,:,:) = real( rof0(ie,:,:,:,:),db )
        rof0_i(:,:,:,:) = aimag( rof0(ie,:,:,:,:) )
      endif

      call MPI_Bcast(rof0_r,ndim,MPI_REAL8,ie_computer,MPI_COMM_GATHER,mpierr)

      call MPI_Bcast(rof0_i,ndim,MPI_REAL8,ie_computer,MPI_COMM_GATHER,mpierr)



      if( ie_computer /= mpirank ) rof0(ie,:,:,:,:) = cmplx( rof0_r(:,:,:,:), rof0_i(:,:,:,:), db )

    end do

  endif

  return
end

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

subroutine MPI_Bcast_RIXS(Ampl_Abs,je,mpinodes,mpirank,nenerg_RIXS,nlm_fe,nlm_probe,nlmomax,nspinp)

  use declarations
  implicit real(kind=db) (a-h,o-z)
  include 'mpif.h'

  integer:: ie, ie_computer, je, mpierr, mpinodes, mpirank, ndim, nenerg_RIXS, nlm, nlm_probe, nlmomax, nspinp

  integer, dimension(nenerg_RIXS):: nlm_fe

  complex(kind=db), dimension(nenerg_RIXS,nlm_probe,nspinp,nlmomax,nspinp):: Ampl_abs

  real(kind=db), dimension(nlm_probe,nspinp,nlmomax,nspinp):: Ampl_abs_i, Ampl_abs_r

  ndim = nlm_probe * nspinp**2 * nlmomax

  do ie_computer = 0,mpinodes-1

    ie = ( je - 1 ) * mpinodes + ie_computer + 1
    if( ie > nenerg_RIXS ) exit

    if( ie_computer == mpirank ) then
      Ampl_abs_r(:,:,:,:) = real( Ampl_abs(ie,:,:,:,:), db )
      Ampl_abs_i(:,:,:,:) = aimag( Ampl_abs(ie,:,:,:,:) )
      nlm = nlm_fe(ie)
    endif

    call MPI_Bcast(Ampl_abs_r,ndim,MPI_REAL8,ie_computer,MPI_COMM_GATHER,mpierr)
    call MPI_Bcast(Ampl_abs_i,ndim,MPI_REAL8,ie_computer,MPI_COMM_GATHER,mpierr)
    call MPI_Bcast(nlm,1,MPI_INTEGER,ie_computer,MPI_COMM_GATHER,mpierr)

    if( ie_computer /= mpirank ) then
      Ampl_abs(ie,:,:,:,:) = cmplx( Ampl_abs_r(:,:,:,:), Ampl_abs_i(:,:,:,:), db )
      nlm_fe(ie) = nlm
    endif

  end do

  return
end

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

! When extract is used, reading of the potential and other data in the bav file

subroutine Potential_reading(Delta_Eseuil,dV0bdcf,E_cut,E_Fermi,Ecineticmax,Epsii,Epsii_moy,Hubb_abs,Hubb_diag_abs, &
                             m_hubb,mpinodes,mpirank0,multi_run,ninitr,nlm_pot,nom_fich_extract,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
  include 'mpif.h'

  integer:: i, ir, isp, jsp, Lmax_abs, m, m_hubb, mp, mpierr, mpinodes, mpirank0, multi_run, n, ndim, ninitr, nlm_pot, nnombre, &
            nrato_abs, nspin, nspinp

  character(len=15):: mot
  character(len=Length_name):: nom_fich_extract

  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, Rmtg_abs, Epsii_moy, 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
  real(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb_abs_i, V_hubb_abs_r

  if( mpirank0 == 0 ) then

    Open(1,file = nom_fich_extract )

    i = 0
    do
      read(1,'(A)' ) mot
      if( mot /= ' ---- Potential' ) cycle
      i = i + 1
      if( i == multi_run ) exit
    end do

    read(1,*); read(1,*)
    read(1,*) nspin, nspinp, nrato_abs, nlm_pot, m_hubb, Lmax_abs
    read(1,*); read(1,*)
    read(1,*) E_cut, E_Fermi, V0muf, Vhbdc, VxcbdcF(:), dV0bdcF(:), rsbdc, Ecineticmax
    read(1,*); read(1,*)
    read(1,*) Hubb_abs, Hubb_diag_abs
    if( Hubb_abs ) then
      read(1,*); read(1,*)
      do isp = 1,nspinp
        do jsp = 1,nspinp
          do m = -m_hubb,m_hubb  ! it is the transpose but also in the writing
            read(1,*) ( V_hubb_abs_r(mp,isp,m,jsp), V_hubb_abs_i(mp,isp,m,jsp), mp = -m_hubb,m_hubb )
          end do
        end do
      end do
      V_hubb_abs(:,:,:,:) = cmplx( V_hubb_abs_r(:,:,:,:), V_hubb_abs_i(:,:,:,:), db )
    endif

    read(1,*); read(1,*)
    read(1,*) Rmtg_abs, Rmtsd_abs

    read(1,*); read(1,*)
    n = nnombre(1,300) - 2
    read(1,*) Epsii_moy, Delta_Eseuil, Epsii(1:n)
    if( n < ninitr ) then  ! when core_resolved is used in the extract and not in bav
      if( n == 1 ) then
        Epsii(2:ninitr) = Epsii(1)
      elseif( ninitr == 6 ) then ! L23, M23...
        Epsii(3:ninitr) = Epsii(2)
        Epsii(2) = Epsii(1)
      elseif( ninitr == 10 ) then ! M45
        Epsii(5:ninitr) = Epsii(2)
        Epsii(2:4) = Epsii(1)
      endif
    endif

    read(1,*); read(1,*)

    do ir = 1,nrato_abs
     read(1,*) rato_abs(ir), Vcato_abs(ir,:),  Vxcato_abs(ir,:,:), rhoato_abs(ir,:), rsato_abs(ir)
    end do

    Delta_Eseuil = Delta_Eseuil / Rydb
    E_cut = E_cut / Rydb
    E_Fermi = E_Fermi / Rydb
    Ecineticmax = Ecineticmax / Rydb
    Epsii(:) = Epsii(:) / Rydb
    Epsii_moy = Epsii_moy / Rydb
    V0muf = V0muf / Rydb
    Vhbdc = Vhbdc / Rydb
    VxcbdcF(:) = VxcbdcF(:) / Rydb
    dV0bdcF(:) = dV0bdcF(:) / Rydb

    if( Hubb_abs ) V_hubb_abs(:,:,:,:) = V_hubb_abs(:,:,:,:) / Rydb

    Rmtg_abs = Rmtg_abs / bohr
    Rmtsd_abs =  Rmtsd_abs / bohr
    rato_abs(:) = rato_abs(:) / bohr
    Vcato_abs(:,:) = Vcato_abs(:,:) / Rydb
    Vxcato_abs(:,:,:) = Vxcato_abs(:,:,:) / Rydb

  endif

  if( mpinodes > 1 ) then
      call MPI_Bcast(Delta_Eseuil,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(dV0bdcf,nspin,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(E_cut,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(E_Fermi,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(Ecineticmax,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(Epsii,ninitr,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(Epsii_moy,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(Hubb_abs,1,MPI_LOGICAL,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(Hubb_diag_abs,1,MPI_LOGICAL,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(rato_abs,nrato_abs,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(rsato_abs,nrato_abs,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(rhoato_abs,nrato_abs*nspin,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(Vcato_abs,nrato_abs*nlm_pot,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(Vxcato_abs,nrato_abs*nlm_pot*nspin,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(Rmtg_abs,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(Rmtsd_abs,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(rsbdc,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(V0muf,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(Vhbdc,1,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(VxcbdcF,nspin,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)

    ndim = ( ( 2 * m_hubb + 1 ) * nspinp )**2

    if( mpirank0 == 0 ) then
      V_hubb_abs_r(:,:,:,:) = real( V_hubb_abs(:,:,:,:), db )
      V_hubb_abs_i(:,:,:,:) = aimag( V_hubb_abs(:,:,:,:) )
    endif

      call MPI_Bcast(V_hubb_abs_i,ndim,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(V_hubb_abs_r,ndim,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)

    if( mpirank0 /= 0 ) V_hubb_abs(:,:,:,:) = cmplx( V_hubb_abs_r(:,:,:,:), V_hubb_abs_i(:,:,:,:), db )

  endif

  Close(1)

  return
end

