! FDMNES subroutine

! Set of subroutines for RIXS

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

! nlm_f = nlmomax: number max of harmonics in the outer sphere (= number of states at the maximum energy)
! nb_Emis = nbr of emission line ( 1 or 2, 2 for L23 for example)
! n_Emis first quantum number of the Emission line

subroutine 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,icheck,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, &
         nlm_f,nomfich,nr,nrm,nseuil,nspin,nspino,nspinp,numat_abs,Only_indirect,Orthmati,Powder, &
         Psi_Emis,psii,q_rixs,r,Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,Rot_atom_abs,Rot_cluster,rsato_abs,rsbdc,Shift_core, &
         Spinorbite,Tau_abs,Temp,Theta_rixs,V_intmax,V_hubb,Vcato,Vhbdc,Volume_maille,VxcbdcF,Vxcato,Ylm_comp)

  use declarations
  implicit none

  integer, parameter:: ndim2 = 1
  integer, parameter:: nenerg_tddft = 0

  integer:: i_q, i_theta, iabsorig, ich, icheck, ie, ie_min, ip0, ip_max, isp, J_emis, Jseuil, L_emis, Lm1_mult, Lmax, &
     Lmax_mult, Lmax_pot, Lmin_mult, Lseuil, m_hubb, mpirank0, multi_run, n_atom_proto, n_atom_uc, n_Emis, n_multi_run, &
     n_process, n_q_dim, n_q_rixs, n_shift_core, n_theta_rixs, n_trans, natomsym, nb_Emis, nbseuil, &
     nenerg_emis, nenerg_in, nenerg_in_rixs, nenerg_loss, nenerg_oc, nenerg_s, &
     neqm, nfinal, nfinal1, nfinalr, ngamh, ninit, ninit1, ninitr, nlm_f, nlm_mult, nlm_p_fp, nlm_pot, nlm_probe, &
     nlms_f, npl, npl_abs, nr, nrm, nseuil, nspin, nspino, nspinp, numat_abs

  integer, dimension(natomsym):: isymeq
  integer, dimension(ninit,2):: m_g
  integer, dimension(ninit):: is_g
  integer, dimension(nfinal,2):: m_f
  integer, dimension(nfinal):: is_f
  integer, dimension(0:n_atom_proto,neqm):: igreq

  character(len=Length_name):: File_name, nomfich
  character(len=Length_name), dimension(n_multi_run):: File_name_rixs

  complex(kind=db), dimension(nenerg_s,nlm_probe,nspinp,nlm_f,nspinp):: Ampl_abs
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb
  complex(kind=db), dimension(nenerg_s,nlm_probe,nspinp,nlm_probe,nspinp):: Tau_abs

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

  logical:: Analyzer, Circular, Core_resolved, Diag_harm_basis, E_cut_man, E1E1, E1E2, E1E3, E1M1, &
    E1SP, E2E2, E3E3, Epsif_ref_man, Epsii_ref_man, Extract_ten, Eneg, Full_potential, Gamma_hole_man, Gamma_max_man_L, &
    HERFD, Hubb_abs, Hubb_diag_abs, Lmoins1, Lplus1, M1M1, Magn_sens, Moment_conservation, Monocrystal, &
    Only_indirect, Powder, Relativiste, Renorm, Spinorbite, SPSP, Ylm_comp 

  Logical, save:: Epsii_ref_RIXS_man, Epsif_ref_RIXS_man

  logical, dimension(13):: Multipole, Multipole_R

  real(kind=db), save:: Epsii_moy_min, Epsif_moy_min

  real(kind=db):: alfpot, Delta_E, Delta_E_emis, Delta_Epsif, Delta_Gauss_Rixs, E_cut, E_cut_imp, E_cut_o, E_cut_rixs, E_Fermi, &
    E_loss_max, Ecent, Eclie, Eimag, Elarg, Energ_in_max, Energ_loss_max, Epsif_moy, Epsif_ref, Epsii_moy, Epsii_ref, &
    Gamma_max_L, Rmtg_abs, Rmtsd_abs, Rot_sample, rsbdc, Shift_vs_XANES, Temp, Theta, Two_theta, V_intmax, Vhbdc, Volume_maille

  real(kind=db), dimension(3):: Pol_i_s, Pol_i_p, Pol_s_s, Pol_s_p, Q_vec, Vec_i, Vec_s
  real(kind=db), dimension(10):: Gamma_hole
  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(nbseuil):: Eseuil
  real(kind=db), dimension(nb_Emis):: E_Emis
  real(kind=db), dimension(ninitr):: Epsii
  real(kind=db), dimension(nfinalr):: Epsif
  real(kind=db), dimension(ninit,2):: coef_g
  real(kind=db), dimension(nfinal,2):: coef_f
  real(kind=db), dimension(nspin):: dV0bdcF, V0bdcF, VxcbdcF
  real(kind=db), dimension(nr):: r, rsato_abs
  real(kind=db), dimension(n_theta_rixs,2):: Theta_rixs
  real(kind=db), dimension(nenerg_in_rixs):: Energ_rixs
  real(kind=db), dimension(n_shift_core):: Shift_core
  real(kind=db), dimension(3,3):: Mat_orth, Orthmat, Orthmati, Rot_atom, Rot_atom_abs, Rot_cluster, &
                                  Trans_Lab_Dir_Q, Trans_rec_dir, Trans_rec_lab
  real(kind=db), dimension(nb_Emis,nbseuil):: RadMat_Emis
  real(kind=db), dimension(3,n_atom_uc):: posn
  real(kind=db), dimension(4,n_q_rixs):: q_rixs
  real(kind=db), dimension(nrm,nbseuil):: psii
  real(kind=db), dimension(nrm,nb_Emis):: Psi_Emis
  real(kind=db), dimension(nr,nlm_pot):: Vcato
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vxcato

  real(kind=db), dimension(:), allocatable:: Betalor, Energ_emis, Energ_in, Energ_loss, Exc_abs_i, &
                                             Gamma, Pseudo_shift_emis, Shift, Shift_emis, Vc_abs_i
  real(kind=db), dimension(:,:), allocatable:: V_abs_i
  real(kind=db), dimension(:,:,:), allocatable:: Pol_i_s_g, Pol_i_p_g, Pol_s_s_g, Pol_s_p_g, Vec_i_g, Vec_s_g

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

! When no momentum transfer direction given, calculation is done for powder 
  Monocrystal = .not. Powder

  Eimag = 0._db
  Extract_ten = .false.
  
  if( multi_run == 1 ) then
    Epsii_ref_RIXS_man = Epsii_ref_man
    Epsif_ref_RIXS_man = Epsif_ref_man
  endif

! in order the real part is the modulus square of the atomic amplitude  
  Tau_abs(:,:,:,:,:) = img * Tau_abs(:,:,:,:,:)

  ich = max(icheck-1,1)
  Magn_sens = nspin == 2 .or. Spinorbite

! Number of in polarization to calculate  
  if( Circular ) then
    npl = 8
  elseif( Powder ) then
    npl = 6
  else
    npl = 4
  endif

! number of polarization for XANES
  npl_abs = 4

  if( Hubb_abs .or. Full_potential ) then
    nlm_p_fp = nlm_probe
  else
    nlm_p_fp = 1
  endif

  Diag_harm_basis = nlm_p_fp == 1 

  Multipole_R(:) = Multipole(:)
!  if( Multipole(6) ) Multipole_R(2) = .true.
!  if( Multipole(8) ) Multipole_R(4) = .true.
!  if( HERFD ) then
!    Multipole_R(6) = .false.
!    Multipole_R(8) = .false.
!  endif
  
  E1E1 = Multipole_R(1); E1E2 = Multipole_R(2); E1E3 = Multipole_R(3);
  E1M1 = Multipole_R(4); E2E2 = Multipole_R(6);
  E3E3 = Multipole_R(7); M1M1 = Multipole_R(8)
  E1SP = Multipole_R(11); SPSP = Multipole_R(12)

  if( E1E3 .or. E3E3 ) then
    Lmax_mult = 3
  elseif( E1E2 .or. E2E2 ) then
    Lmax_mult = 2
  elseif( E1E1 ) then
    Lmax_mult = 1
  endif
  if( E1M1 .or. M1M1 .or. E1E2 .or. E2E2 .or. E1E3 .or. E3E3 ) then
    Lmin_mult = 0
    Lm1_mult = 1
  else
    Lmin_mult = 1
    Lm1_mult = 2
  endif
  
  nlm_mult = ( Lmax_mult + 1 )**2
  
  V0bdcF(:) = Vhbdc + VxcbdcF(:)  

  if( HERFD ) then
    allocate( Vc_abs_i(nr) ) 
    allocate( Exc_abs_i(nr) ) 
    allocate( V_abs_i(nr,nspin) )
     
    Vc_abs_i(:) = Vcato(:,1)
    do isp = 1,nspin
      V_abs_i(:,isp) = Vc_abs_i(:) +  Vxcato(:,1,isp)
    end do
    if( nspin == 1 ) then
      Exc_abs_i(:) = Vxcato(:,1,1)
    else
      Exc_abs_i(:) = 0.5_db * ( Vxcato(:,1,1) + Vxcato(:,1,2) )
    endif

    if( nb_Emis == 2 ) then
      Delta_Epsif = E_Emis(1) - E_Emis(2)
    else
      Delta_Epsif = 1000000._db
    endif
    call Energseuil(.true.,Core_resolved,Delta_Epsif,Delta_E_Emis,E_Fermi,.true.,Epsif,Epsif_moy,E_Emis, &
               Exc_abs_i,ich,is_f,J_emis,L_Emis,m_f,mpirank0,nb_Emis,nfinal1,nfinal,nfinalr,nr, nr,n_Emis, &
               nspin,numat_abs,Psi_Emis,R,Rmtg_abs,Rmtsd_abs,V_abs_i,V_intmax,Vc_abs_i,V0bdcF)

    deallocate( Vc_abs_i, Exc_abs_i, V_abs_i )
  endif
  
  Lmax = nint( sqrt( real( nlm_probe ) ) ) - 1
  Lmax_pot = nint( sqrt( real( nlm_pot ) ) ) - 1

  if( E_cut_man ) then
    E_cut_rixs = E_cut_imp
    E_cut_o = E_cut_imp / rydb
  else
    E_cut_rixs = E_cut
    E_cut_o = - 1001._db
  endif

! Energy grids --------------------------
  
  do ie = 1,nenerg_s
    if( Energ_s(ie) > E_cut_RIXS + eps10 ) exit
  end do
  
  if( nenerg_in_rixs > 0 ) then
    nenerg_in = nenerg_in_rixs
  else
    do ie = nenerg_s,1,-1
      if( Energ_s(ie) < - eps10 ) exit
    end do 
    nenerg_in = nenerg_s - ie
  endif

  allocate( Energ_in(nenerg_in) )

  if( nenerg_in_rixs > 0 ) then
    Energ_in(:) = Energ_rixs(:)
  else
    do ie = nenerg_in,1,-1
      Energ_in(ie) = Energ_s(ie + nenerg_s - nenerg_in)
    end do
  endif

  write(6,'(/A)') ' -- RIXS --- '
  write(6,'(a30,i5)') ' Number of incoming energies =', nenerg_in
 
! E_cut rixs is not let equal to a grid point energy. 
  do ie = 1,nenerg_s
    if( Energ_s(ie) > E_cut_RIXS + eps10 ) exit
  end do
  nenerg_oc = ie - 1
  if( ie > 1 ) then
    if( abs( Energ_s(ie-1) - E_cut_RIXS ) < eps10 ) E_cut_RIXS = ( Energ_s(ie-1) + Energ_s(ie) ) / 2 
  endif

! ie_min = 1 is used for Fermi Dirac distribution
  if( Temp > eps10 ) then
    ie_min = 1
  else
    ie_min = nenerg_oc + 1
  endif

! Shift and broadening ------------------------------------
  
! Shifts of the core-hole levels
  allocate( Shift(ninitr) )
  call Cal_shift(.false.,Epsii,Epsii_moy,Epsii_moy_min,Epsii_ref,Epsii_ref_RIXS_man,icheck,multi_run,n_shift_core,ninit, &
                 ninit1,ninitr,Shift,Shift_core)

! Shift_vs_XANES is used in the final writing to shift all the spectra when the Epsii_moy minimum is not the first one 
  if( Epsii_ref_man .or. multi_run == 1 ) then
    Shift_vs_XANES = 0._db
  else
    Shift_vs_XANES = Epsii_ref - Epsii_moy_min  
  endif
  
! Broadening parameters
  allocate( Gamma(ninitr) )
  allocate( Betalor(nenerg_in) )

! Width of the core hole
  call Cal_width(Core_resolved,Eseuil,Gamma,Gamma_hole,Gamma_hole_man,Jseuil,nbseuil,ngamh,ninit1,ninitr,nseuil,numat_abs)

  ! It seems, the broadening of the photoelectron states must not be taken into account in RIXS   
  Gamma_max_L = 0._db
  Gamma_max_man_L = .false.

  call GammArc(Ecent,Elarg,Gamma_max_L,E_cut_RIXS,nenerg_in,Energ_in,Betalor)
  Betalor(:) = 0.5_db * Betalor(:) 

! Output file name
  call Output_Rixs_Filename(Delta_Gauss_Rixs,E_cut_imp,E_cut_man,Epsii_ref,Epsii_ref_man,File_name,File_name_rixs,Gamma_hole(1), &
                                Gamma_hole_man,Gamma_max_L,Gamma_max_man_L,iabsorig,multi_run,n_multi_run,nomfich)

! Polarization and crystal 
  n_q_dim = max( n_q_rixs, 1 )
  
  allocate( Pol_i_s_g(3,n_theta_rixs,n_q_dim) ) 
  allocate( Pol_i_p_g(3,n_theta_rixs,n_q_dim) ) 
  allocate( Pol_s_s_g(3,n_theta_rixs,n_q_dim) ) 
  allocate( Pol_s_p_g(3,n_theta_rixs,n_q_dim) ) 
  allocate( Vec_i_g(3,n_theta_rixs,n_q_dim) ) 
  allocate( Vec_s_g(3,n_theta_rixs,n_q_dim) ) 

! Rotation to go from the local atom basis to the tensors R1 basis
  Rot_atom = matmul( Rot_cluster, Rot_atom_abs )

! Transformation to go from crystal basis to orthonormal basis
  call invermat(Orthmati,Orthmat)
  Mat_orth = matmul( Rot_cluster, Orthmat )

  call Reciprocal_Vector(icheck,Mat_orth,Trans_rec_dir,Trans_rec_lab)

  do i_q = 1,n_q_dim

    if( n_q_rixs > 0 ) then
      Q_vec(:) = Q_rixs(1:3,i_q)
      Rot_sample = Q_rixs(4,i_q)
      Q_vec = matmul( Trans_rec_dir, Q_vec )
      Q_vec(:) = Q_vec(:) / sqrt( sum( Q_vec(:)**2 ) ) 
    else   ! default 
      Q_vec(1:2) = 0._db; Q_vec(3) = 1._db
      Rot_sample = 0._db
    endif

    call Cal_Mat_rot(icheck,Mat_orth,Q_vec,Rot_sample,Trans_Lab_Dir_Q,Trans_rec_dir,Trans_rec_lab)      

    do i_theta = 1,n_theta_rixs

      Theta = Theta_rixs(i_theta,1)      
      Two_theta = Theta_rixs(i_theta,2)   
      
      call Cal_Pol(icheck,Pol_i_s,Pol_i_p,Pol_s_s,Pol_s_p,Theta,Trans_Lab_Dir_Q,Two_theta,Vec_i,Vec_s)

      Pol_i_s_g(:,i_theta,i_q) = Pol_i_s(:)     
      Pol_i_p_g(:,i_theta,i_q) = Pol_i_p(:)     
      Pol_s_s_g(:,i_theta,i_q) = Pol_s_s(:)     
      Pol_s_p_g(:,i_theta,i_q) = Pol_s_p(:)     
      Pol_i_s_g(:,i_theta,i_q) = Pol_i_s(:)     
      Vec_i_g(:,i_theta,i_q) = Vec_i(:)     
      Vec_s_g(:,i_theta,i_q) = Vec_s(:)
           
    end do
  end do

  nlms_f = nlm_f * nspinp

! Calculation of the radial integral for the <g|o|n> core-continuum state transition  
  allocate( Rad_gon(nenerg_s,nlm_probe,nlm_p_fp,nspinp,nspino,ip0:ip_max,nbseuil) ) 

  call Cal_Rad_gon(alfpot,Diag_harm_basis,dV0bdcF,E_Fermi,Eclie,Eneg,Energ_s,Eseuil,Full_potential,Hubb_abs,Hubb_diag_abs, &
           icheck,ip0,ip_max,Lmax,Lmax_pot,m_hubb,nbseuil,nenerg_s,nlm_pot,nlm_p_fp,nlm_probe,nr,nrm,nspin,nspino,nspinp, &
           numat_abs,psii,r,Rad_gon,Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,rsato_abs,rsbdc,Spinorbite,V_hubb,V_intmax, &
           Vcato,Vhbdc,VxcbdcF,Vxcato,Ylm_comp)

  if( HERFD ) then
    n_process = 1
  else
    n_process = 2
  endif

  if( HERFD ) then
  
  ! We neglect the magnetic splitting for the core level which must be smaller than for the emission level
  ! Epsif are difined as negative and Epsii as positive what explain the same sign in the formula below
    nenerg_emis = nfinalr

    write(6,'(a30,i5)') ' Number of emission energies =', nenerg_emis
  
    allocate( Energ_emis(nenerg_emis) )

    allocate( Shift_emis(nfinalr) )
    allocate( Pseudo_shift_emis(0) )
    call Cal_shift(.true.,Epsif,Epsif_moy,Epsif_moy_min,Epsif_ref,Epsif_ref_RIXS_man,icheck,multi_run,0,nfinal, &
                   nfinal1,nfinalr,Shift_emis,Pseudo_shift_emis)
    deallocate( Pseudo_shift_emis )

    Energ_emis(:) = E_emis(nb_emis) - Shift_emis(:) - ( Epsii_moy - Epsii_ref ) 

    deallocate( Shift_emis )  

! Rad_matrix_Emis is in sphere.f90
    call Rad_matrix_Emis(nb_Emis,nbseuil,nr,nrm,Psi_Emis,Psii,RadMat_Emis,r)

    nenerg_loss = 0
    allocate( Energ_loss(nenerg_loss) )
    
  else  

    E_loss_max = min( Energ_loss_max, Energ_s(nenerg_s) - Energ_s(1) )
    Energ_in_max = maxval( Energ_in )
    E_loss_max = min( E_loss_max, Energ_in_max - Energ_s(1) )
    Delta_E = Energ_s(2) - Energ_s(1)
    nenerg_loss = int( E_loss_max / Delta_E ) + 1

    allocate( Energ_loss(nenerg_loss) )
    do ie = 1,nenerg_loss
      Energ_loss(ie) = ( ie - 1 ) * Delta_E
    end do      

    write(6,'(a30,i5)') ' Number of loss energies     =', nenerg_loss

    nenerg_emis = 0
    allocate( Energ_emis(nenerg_emis) )
    
  endif

  if( HERFD .or. .not. Only_indirect ) then

    if( icheck > 0 ) write(3,'(/A)') ' ----- Direct process ------- '
    write(6,'(/A)') ' Direct process '

    call Direct_process(Analyzer,Betalor,Coef_f,Coef_g,Core_resolved,Delta_Gauss_Rixs,Diag_harm_basis,E_cut_Rixs,E_Fermi, &
        Eclie,Eneg,Energ_in,Energ_emis,Energ_loss,Energ_s,Eseuil,File_name_rixs,Gamma,HERFD, &
        icheck,ie_min,ip0,ip_max,isymeq,L_emis,Lm1_mult,Lmax,Lmax_mult,Lmin_mult,Lmoins1,Lplus1,Lseuil,m_f,m_g,M1M1, &
        Moment_conservation,Monocrystal,Multipole_R,multi_run,n_multi_run,n_q_dim,n_theta_rixs,natomsym, &
        nb_Emis,nbseuil,nenerg_emis,nenerg_in,nenerg_loss,nenerg_oc,nenerg_s,nfinal,nfinal1,nfinalr,ninit,ninit1,ninitr, &
        nlm_mult,nlm_p_fp,nlm_probe,npl,npl_abs,nspin,nspino,nspinp,Pol_i_s_g,Pol_i_p_g,Pol_s_s_g,Pol_s_p_g,Powder, &
        Rad_gon,RadMat_Emis,Rot_atom,Shift,Spinorbite,Tau_abs,Temp,Theta_rixs,V0bdcF,Vec_i_g,Vec_s_g,Volume_maille,Ylm_comp)
   
  endif

  if( .not. HERFD ) then
     
    if( icheck > 0 ) write(3,'(/A)') ' ----- Indirect process ------- '
    write(6,'(/A)') ' Indirect process'

    call Indirect_process(alfpot,Analyzer,Betalor,Coef_g,Core_resolved,Delta_Gauss_Rixs,Diag_harm_basis,dV0bdcF,E_cut_Rixs, &
      E_Fermi,Eclie,Eneg,Energ_in,Energ_loss,Energ_s,Eseuil,File_name_rixs,Full_potential, &
      Gamma,Hubb_abs,Hubb_diag_abs,icheck,ie_min,ip0,ip_max,isymeq,Lm1_mult,Lmax,Lmax_mult,Lmax_pot,Lmin_mult,Lmoins1,Lplus1, &
      Lseuil,m_g,m_hubb,M1M1,Moment_conservation,Monocrystal,Multipole_R,multi_run,n_multi_run,n_q_dim, &
      n_theta_rixs,n_trans,natomsym,nbseuil,nenerg_in,nenerg_loss,nenerg_oc,nenerg_s,ninit,ninit1, &
      ninitr,nlm_f,nlm_mult,nlm_p_fp,nlm_pot,nlm_probe,nlms_f,npl,npl_abs,nr,nspin, &
      nspino,nspinp,numat_abs,Pol_i_s_g,Pol_i_p_g,Pol_s_s_g,Pol_s_p_g,Powder,r,Rad_gon,Relativiste, &
      Renorm,Rmtg_abs,Rmtsd_abs,Rot_atom,rsato_abs,rsbdc,Shift,Spinorbite,Tau_abs,Temp,Theta_rixs,V_hubb,V_intmax, &
      V0bdcF,Vcato,Vec_i_g,Vec_s_g,Vhbdc,Volume_maille,VxcbdcF,Vxcato,Ylm_comp)

    if( .not. Only_indirect ) &
      call Write_out_RIXS_tot(File_name_rixs,multi_run,n_multi_run,nenerg_loss)

  endif
    
  if( n_multi_run > 1 .and. multi_run == n_multi_run ) then
    if( HERFD ) then
      call Write_out_RIXS_sum(Analyzer,Energ_emis,Energ_in,File_name_rixs,HERFD,multi_run,n_multi_run,n_theta_rixs, &
                         n_trans,nenerg_emis,nenerg_in,npl,Only_indirect,Powder,Shift_vs_XANES)
    else
      call Write_out_RIXS_sum(Analyzer,Energ_loss,Energ_in,File_name_rixs,HERFD,multi_run,n_multi_run,n_theta_rixs, &
                         n_trans,nenerg_loss,nenerg_in,npl,Only_indirect,Powder,Shift_vs_XANES)
    endif
  endif

  deallocate( Betalor, Energ_emis, Energ_in, Energ_loss, Gamma, Rad_gon, Shift )
  deallocate( Pol_i_s_g, Pol_i_p_g, Pol_s_s_g, Pol_s_p_g, Vec_i_g, Vec_s_g )
  
  return
  110 format(/150('-'),//' RIXS step')
end

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

subroutine Output_Rixs_Filename(Delta_Gauss_Rixs,E_cut_imp,E_cut_man,Epsii_ref,Epsii_ref_man,File_name,File_name_rixs,Gamma_hole, &
                                Gamma_hole_man,Gamma_max,Gamma_max_man,iabsorig,multi_run,n_multi_run,nomfich)

  use declarations
  implicit none

  integer:: i, iabsorig, k, L, Length, multi_run, n_multi_run
  
  character(len=10):: mot10
  character(len=Length_name):: File_name, nomfich
  character(len=Length_name), dimension(n_multi_run):: File_name_rixs
  
  logical:: E_cut_man, Epsii_ref_man, Gamma_hole_man, Gamma_max_man

  real(kind=db):: Delta_Gauss_Rixs, E_cut_imp, Epsii_ref, Gamma_hole, Gamma_max, x, y

  File_name = nomfich
  Length = len_trim( File_name )
  do k = 1,5
  
    select case(k)
      case(1)
       if( .not. E_cut_man ) cycle
       y = E_cut_imp * Rydb
      case(2)
       if( .not. Gamma_max_man ) cycle
       y = Gamma_max * Rydb
      case(3)
       if( .not. Gamma_hole_man ) cycle
       y = Gamma_hole * Rydb
      case(4)
       if( .not. Epsii_ref_man ) cycle
       y = Epsii_ref * Rydb          
      case(5)
       if( Delta_Gauss_Rixs < eps10 ) cycle
       y = Delta_Gauss_Rixs * Rydb          
    end select
    
    x = y / 10
    do i = 0,4
      x = 10 * x
      if( abs( x - nint(x) ) < eps10 ) exit
    end do
    
    select case(i)
      case(0)
        write(mot10,'(i10)') nint( y )
      case(1)
        write(mot10,'(f10.1)') y
      case(2)
        write(mot10,'(f10.2)') y
      case(3)
        write(mot10,'(f10.3)') y
      case default
        write(mot10,'(f10.4)') y
    end select
    
    mot10 = adjustl( mot10 )   
    L = len_trim( mot10 )
    if( i > 0 ) mot10(L-i:L-i) = 'p'
  
    Length = len_trim( File_name ) + 1

    select case(k)
      case(1)          
        File_name(Length:Length+2) = '_EF'
      case(2)
        File_name(Length:Length+2) = '_Gm'
      case(3)
        File_name(Length:Length+2) = '_GH'
      case(4)
        File_name(Length:Length+2) = '_Ep'
      case(5)
        File_name(Length:Length+2) = '_Ga'
      case(6)
        File_name(Length:Length+2) = '_Ui'
    end select
    Length = Length + 2
    
    File_name(Length+1:Length+L) = mot10(1:L)
    
  end do
  
  Length = len_trim( File_name )

  File_name(Length+1:Length+5) = '_rixs'

  if( n_multi_run > 1 ) then
    Length = Length + 6
    File_name(Length:Length) = '_'
    call ad_number(iabsorig,File_name,Length_name)
  endif
  Length = len_trim(File_name)
  File_name(Length+1:Length+4) = '.txt'
  File_name_rixs(multi_run) = File_name

  return
end

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

! Calculation of the shifts

subroutine Cal_shift(Emission,Epsii,Epsii_moy,Epsii_moy_min,Epsii_ref,Epsii_ref_RIXS_man,icheck,multi_run,n_shift_core,ninit, &
                     ninit1,ninitr,Shift,Shift_core)

  use declarations
  implicit none

  integer:: icheck, multi_run, n_shift_core, ninit, ninit1, ninitr
  
  logical:: Emission, Epsii_ref_RIXS_man
  
  real(kind=db):: Epsii_moy, Epsii_moy_min, Epsii_ref
  real(kind=db), dimension(ninitr):: Epsii, Shift
  real(kind=db), dimension(n_shift_core):: Shift_core
   
  select case(ninitr)
    case(1)
      Epsii_moy = Epsii(1)
    case(2)
      if( ninit1 /= ninit ) then
        Epsii_moy = Epsii(2)
      else
        Epsii_moy = sum( Epsii(1:ninitr) ) / ninitr
      endif
    case(4,6,10)
 ! in these case ninit = ninitr
      if( ninit1 /= ninit ) then
        Epsii_moy = sum( Epsii(ninit1+1:ninitr) ) / ( ninitr - ninit1 )
      else
        Epsii_moy = sum( Epsii(1:ninitr) ) / ninitr
      endif
  end select

  if( .not. Epsii_ref_RIXS_man ) then
! First calculation site becomes the reference
    Epsii_ref = Epsii_moy
    Epsii_moy_min = Epsii_moy
    Epsii_ref_RIXS_man = .true.
  endif
  Epsii_moy_min = min( Epsii_moy, Epsii_moy_min ) 

  Shift(:) = Epsii(:) - Epsii_ref 

 ! Shift_core is in option, not in the manual, to impose shifts at specific sites
  if( multi_run <= n_shift_core ) Shift(:) = Shift(:) + Shift_core(multi_run) 

  if( icheck > 0 ) then
    if( Emission ) then
      write(3,'(/A)') ' Shift_emission(i = 1,nfinalr)'
    else
      write(3,110) 
      write(3,'(/A)') ' Shift(i = 1,ninitr)'
    endif
    write(3,'(10f9.5)') Shift(:) * rydb
  endif  
    
  return
110 format(/'---------- RIXS shift ',80('-'))
end

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

! calculation of core state width

subroutine Cal_width(Core_resolved,Eseuil,Gamma,Gamma_hole,Gamma_hole_man,Jseuil,nbseuil,ngamh,ninit1,ninitr,nseuil,numat_abs)

  use declarations
  implicit none

  integer:: initr, iseuil, Js, Jseuil, nbseuil, ngamh, ninit1, ninitr, nseuil, numat_abs
  
  logical:: Core_resolved, Gamma_hole_man
 
  real(kind=db):: Tab_width 
  real(kind=db), dimension(10):: Gamma_hole
  real(kind=db), dimension(ninitr):: Gamma
  real(kind=db), dimension(nbseuil):: Eseuil

  do initr = 1,ninitr       ! ----------> Loop over edges or core states

    if( Core_resolved ) then
      if( initr <= ninit1 ) then
        iseuil = 1
      else
        iseuil = min(2, nbseuil)
      endif
    else
      iseuil = min(initr, nbseuil)
    endif

    if( Gamma_hole_man ) then
      if( ngamh == 1 ) then
        Gamma(initr) = Gamma_hole(1)
      elseif( ngamh == ninitr ) then
        Gamma(initr) = Gamma_hole(initr)
      elseif( initr <= ninit1 ) then
        Gamma(initr) = Gamma_hole(1)
      else
        Gamma(initr) = Gamma_hole(2)
      endif
    else
      Js = Jseuil + iseuil - 1 
 
      Gamma_hole(1) = Tab_width(Eseuil(iseuil),Js,nseuil,numat_abs)
      Gamma(initr) = Gamma_hole(1)
    endif
    Gamma(initr) = 0.5_db * Gamma(initr)  ! It is in fact Gamma / 2 in the formula  

  end do
  
  return
end

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

! Calculation of the reciprocal vector in the lab frame

subroutine Reciprocal_Vector(icheck,Mat_orth,Trans_rec_dir,Trans_rec_lab)

  use declarations
  implicit none

  integer:: i, icheck
  
  real(kind=db):: Cos_a, Cos_b, Cos_t, Phi, Sin_t, Theta, Vol, Wx_mod, Wy_mod, Wz_mod 
  real(kind=db), dimension(3):: Vec, Vx, Vy, Vz, Wx, Wy, Wx_lab, Wy_lab, Wz, Wz_lab
  real(kind=db), dimension(3,3):: Mat_orth, Trans_rec_dir, Trans_rec_lab 
  
! Diffraction vector in the internal orthogonal basis
  Vx(:) = Mat_orth(:,1)
  Vy(:) = Mat_orth(:,2)
  Vz(:) = Mat_orth(:,3)

! Wx, Wy, Wz : reciprocal cell basis
  call prodvec(Wx,vy,vz)

  vol = sum( Wx(:) * vx(:) )
  Wx(:) = Wx(:) / vol
  call prodvec(Wy,vz,vx)
  Wy(:) = Wy(:) / vol
  call prodvec(Wz,vx,vy)
  Wz(:) = Wz(:) / vol
  Trans_rec_dir(1,:) = Wx(:)
  Trans_rec_dir(2,:) = Wy(:)
  Trans_rec_dir(3,:) = Wz(:)

! Calculation of the matrix to transform the diffraction vector in the Lab basis, at origin, that is before any rotation:
! x: vertical
! y: horizontal, along the incoming beam
! z: horizontal, perpendicular to the incoming beam

  Wx_mod = sqrt( dot_product( Wx, Wx ) )
  Wy_mod = sqrt( dot_product( Wy, Wy ) )
  Wz_mod = sqrt( dot_product( Wz, Wz ) )

  call prodvec(Vec,Wx,Wy)
  Vec(:) = Vec(:) / sqrt( dot_product( Vec, Vec ) )
        
! Basis Vx vertical, Wy in the (incoming, Vx) plane
  Wx_lab(1) = Wx_mod; Wx_lab(2) = 0._db; Wx_lab(3) = 0._db;
  Cos_t = dot_product( Wx, Wy ) / ( Wx_mod * Wy_mod ) 
  Theta = acos( Cos_t )
  Sin_t = sin( Theta )
  Wy_lab(1) = Cos_t * Wy_mod; Wy_lab(2) = sin_t * Wy_mod; Wy_lab(3) = 0._db;

  call prodvec(Vz,Wx,Wy)
  Vz(:) = Vz(:) / sqrt( dot_product( Vz, Vz ) )
  call prodvec(Vy,Vz,Wx)
  Vy(:) = Vy(:) / sqrt( dot_product( Vy, Vy ) )
  Cos_t = dot_product( Wz, Vz ) / Wz_mod
  Theta = acos( Cos_t )
  Sin_t = sin( Theta ) 

  if( abs( Cos_t - 1._db ) < eps10 ) then
    Wz_lab(1) = 0._db; Wz_lab(2) = 0._db; Wz_lab(3) = Wz_mod
  elseif(  abs( Cos_t + 1._db ) < eps10 ) then
    Wz_lab(1) = 0._db; Wz_lab(2) = 0._db; Wz_lab(3) = -Wz_mod
  else
    Cos_a = dot_product( Wz, Vx ) / Wz_mod 
    Cos_b = dot_product( Wz, Vy ) / Wz_mod
    if( abs( Cos_a ) < eps10 ) then
      Wz_lab(1) = 0._db; Wz_lab(2) = Sin_t * Wz_mod; Wz_lab(3) = Cos_t * Wz_mod
    else
      Phi = atan( Cos_b / Cos_a )
      if( Cos_a < 0._db ) Phi = Phi + pi  
      Wz_lab(1) = Sin_t * cos( Phi ) * Wz_mod ; Wz_lab(2) = Sin_t * sin( Phi ) * Wz_mod; Wz_lab(3) = Cos_t * Wz_mod
    endif
  endif

  Trans_rec_lab(:,1) = Wx_lab(:)
  Trans_rec_lab(:,2) = Wy_lab(:)
  Trans_rec_lab(:,3) = Wz_lab(:)
  
  if( icheck > 0 ) then
    write(3,110)
    write(3,'(/A)') ' Reciprocal vector in lab frame:'
    write(3,'(A)') '      A         B        C'
    do i = 1,3
      write(3,'(3f10.5)') Trans_rec_lab(i,:)
    end do
  endif 

  return
110 format(/'---------- Basis in RIXS ',80('-'))
end

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

! Calculation of transormation matrix to have polarizations and wave vectors in crystal basis

subroutine Cal_Mat_rot(icheck,Mat_orth,Q_vec,Rot_sample,Trans_Lab_Dir_Q,Trans_rec_dir,Trans_rec_lab)

  use declarations
  implicit none

  integer:: i, icheck
  
  real(kind=db):: Cos_p, Cos_t, Phi, Q_mod, Rot_sample, Sin_p, Sin_t, Theta 
  real(kind=db), dimension(3):: Q_lab, Q_dir, Q_vec, Vec
  real(kind=db), dimension(3,3):: Mat, Mat_orth, Rot, Rot_1, Rot_2, Trans_Lab_Dir_Q, Trans_rec_dir, Trans_rec_lab
  
  Q_lab(:) = Matmul( Trans_rec_lab, Q_vec )
  Q_mod = sqrt( sum( Q_lab(:)**2 ) )
  if( abs(Q_mod) > eps10 ) Q_lab(:) = Q_lab(:) / Q_mod
    
! Crystal rotation to be with Q along z lab
  if( abs( Q_lab(2) ) > eps10 ) then
    if( abs( Q_lab(3) ) < eps10 .and. Q_lab(2) > eps10 ) then
      Phi = pi / 2
    elseif( abs( Q_lab(3) ) < eps10 .and. Q_lab(2) < - eps10 ) then
      Phi = - pi / 2
    else
      Phi = atan( Q_lab(2) / Q_lab(3) )
      if( Q_lab(2) < 0._db ) Phi = Phi + pi
      Phi = pi / 2 - Phi
    endif
    Cos_p = cos( Phi )
    Sin_p = sin( Phi )
    Rot_1(1,1) = 1._db; Rot_1(1,2) = 0._db; Rot_1(1,3) = 0._db  
    Rot_1(2,1) = 0._db; Rot_1(2,2) = Cos_p; Rot_1(2,3) = - Sin_p  
    Rot_1(3,1) = 0._db; Rot_1(3,2) = Sin_p; Rot_1(3,3) = Cos_p  
  else
    Rot_1(1,1) = 1._db; Rot_1(1,2) = 0._db; Rot_1(1,3) = 0._db  
    Rot_1(2,1) = 0._db; Rot_1(2,2) = 1._db; Rot_1(2,3) = 0._db  
    Rot_1(3,1) = 0._db; Rot_1(3,2) = 0._db; Rot_1(3,3) = 1._db
  endif
  
  Theta = - pi/2 + acos( Q_lab(1) )   ! rotation is negative
  Sin_t = sin( Theta )
  Cos_t = cos( Theta )
  Rot_2(1,1) = Cos_t; Rot_2(1,2) = 0._db; Rot_2(1,3) = Sin_t  
  Rot_2(2,1) = 0._db; Rot_2(2,2) = 1._db; Rot_2(2,3) = 0._db  
  Rot_2(3,1) = - Sin_t; Rot_2(3,2) = 0._db; Rot_2(3,3) = Cos_t
  
  Rot = Matmul( Rot_2, Rot_1 ) 

! Origin of crystal rotation around Q is such that a is perpendicular to the incoming beam
  Q_dir = Matmul( Trans_rec_dir, Q_vec )

  Mat = Matmul( Rot, Mat_orth )
  
  if( abs( Q_dir(2) ) > eps10 .or. abs( Q_dir(3) ) > eps10 ) then
    Vec(1) = 1._db; Vec(2) = 0._db;; Vec(3) = 0._db; 
  else
    Vec(1) = 0._db; Vec(2) = 0._db;; Vec(3) = 1._db; 
  endif  
  Vec = Matmul( Mat, Vec )
  Vec(:) = Vec(:) / sqrt( sum( Vec(:)**2 ) )

  if( abs( Vec(2) ) > eps10 ) then
  
    if( abs( Vec(1) ) > eps10 ) then
      Phi = atan( Vec(2) / Vec(1) )
      if( Vec(2) < 0._db ) Phi = Phi + pi
    elseif( Vec(2) > eps10 ) then
      Phi = - pi / 2
    else
      Phi = pi / 2
    endif
  else
    Phi = 0._db
  endif
  
  Phi = Phi + Rot_sample 

  if( abs( Phi ) > eps10 ) then
    Cos_p = cos( Phi )
    Sin_p = sin( Phi )
    Rot_1(1,1) = Cos_p; Rot_1(1,2) = - Sin_p; Rot_1(1,3) = 0._db  
    Rot_1(2,1) = Sin_p; Rot_1(2,2) = Cos_p;   Rot_1(2,3) = 0._db   
    Rot_1(3,1) = 0._db; Rot_1(3,2) = 0._db;   Rot_1(3,3) = 1._db   

    Rot = Matmul( Rot_1, Rot ) 
  endif
  
  Trans_Lab_Dir_Q = Transpose( Rot )  ! it is to transform vec and pol in lab frame to crystal frame 

  if( icheck > 0 ) then
    write(3,110) Q_vec(:), Rot_sample / radian
    write(3,'(/A)') ' Tr Lab frame - Othonormal unit cell basis'
    do i = 1,3
      write(3,'(3f10.5)') Trans_Lab_Dir_Q(i,:)
    end do 
  endif
  
  return
  110 format(/' Q =',3f10.5,', Azimuthal rotation sample = ',f8.3,' degrees')
end

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

! Calculation of the Polarization and wave vector

subroutine Cal_Pol(icheck,Pol_i_s,Pol_i_p,Pol_s_s,Pol_s_p,Theta,Trans_Lab_Dir_Q,Two_theta_L,Vec_i,Vec_s)

  use declarations
  implicit none

  integer:: i, icheck
  
  real(kind=db):: Cos_2t, Cos_t, Sin_2t, Sin_t, Theta, Two_theta_L 
  real(kind=db), dimension(3):: Pol_i_s, Pol_i_p, Pol_s_s, Pol_s_p, Vec_i, Vec_s
  real(kind=db), dimension(3,3):: Rot, Trans_Lab_Dir_Q
  
  Cos_2t = cos( pi - Two_theta_L )
  Sin_2t = sin( pi - Two_theta_L )

  Cos_2t = cos( Two_theta_L )
  Sin_2t = sin( Two_theta_L )

! Wave vector and polarization in lab frame with 
! x vertical, y along the incoming beam, z horizontal perp to the incoming beam
! The scheme corresponds to a vertical sample, sigma polarization is perpendicular to the scattering plane,
! that is vertical in the lab, along x
  Vec_i(1) = 0._db;   Vec_i(2) = 1._db;  Vec_i(3) = 0._db  
  Vec_s(1) = 0._db;   Vec_s(2) = Cos_2t; Vec_s(3) = Sin_2t
  Pol_i_s(1) = 1._db; Pol_i_s(2) = 0._db; Pol_i_s(3) = 0._db   
  Pol_i_p(1) = 0._db; Pol_i_p(2) = 0._db; Pol_i_p(3) = 1._db   
  Pol_s_s(1) = 1._db; Pol_s_s(2) = 0._db; Pol_s_s(3) = 0._db   
  Pol_s_p(1) = 0._db; Pol_s_p(2) = - Sin_2t; Pol_s_p(3) = Cos_2t   

  Cos_t = cos( pi/2 - Theta )
  Sin_t = sin( pi/2 - Theta )  

  Cos_t = cos( Theta )
  Sin_t = sin( Theta )  

  Rot(1,1) = 1._db; Rot(1,2) = 0._db; Rot(1,3) = 0._db
  Rot(2,1) = 0._db; Rot(2,2) = Cos_t; Rot(2,3) = - Sin_t
  Rot(3,1) = 0._db; Rot(3,2) = Sin_t; Rot(3,3) = Cos_t
  Rot = Transpose( Rot )  ! it is to transform vec and pol in lab frame to crystal frame 
  
  Rot = Matmul( Trans_Lab_Dir_Q, Rot )
  
  Pol_i_s = Matmul( Rot, Pol_i_s )
  Pol_i_s(:) = Pol_i_s(:) / sqrt( sum( Pol_i_s(:)**2 ) ) 
  Pol_i_p = Matmul( Rot, Pol_i_p )
  Pol_i_p(:) = Pol_i_p(:) / sqrt( sum( Pol_i_p(:)**2 ) ) 
  Pol_s_s = Matmul( Rot, Pol_s_s )
  Pol_s_s(:) = Pol_s_s(:) / sqrt( sum( Pol_s_s(:)**2 ) ) 
  Pol_s_p = Matmul( Rot, Pol_s_p )
  Pol_s_p(:) = Pol_s_p(:) / sqrt( sum( Pol_s_p(:)**2 ) ) 
  Vec_i = Matmul( Rot, Vec_i )
  Vec_i(:) = Vec_i(:) / sqrt( sum( Vec_i(:)**2 ) ) 
  Vec_s = Matmul( Rot, Vec_s )
  Vec_s(:) = Vec_s(:) / sqrt( sum( Vec_s(:)**2 ) ) 

  if( icheck > 0 ) then
    write(3,110) Theta/radian, Two_theta_L/radian 
    write(3,'(/A)') '   Pol_i_sig  Pol_i_pi   Pol_s_sig  Pol_s_pi   WaveVec_i  WaveVec_s  (in orthonormal unit cell basis)'
    do i = 1,3
      write(3,'(7f11.5)') Pol_i_s(i), Pol_i_p(i), Pol_s_s(i), Pol_s_p(i), Vec_i(i), Vec_s(i)  
    end do   
  endif
  return
  110 format(/' Theta_in =',f10.5,', 2Theta =',f10.5,' degrees')
end

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

! Calculation of the radial matrix <g|o|n>

subroutine Cal_Rad_gon(alfpot,Diag_harm_basis,dV0bdcF,E_Fermi,Eclie,Eneg,Energ_s,Eseuil,Full_potential,Hubb_abs,Hubb_diag_abs, &
           icheck,ip0,ip_max,Lmax,Lmax_pot,m_hubb,nbseuil,nenerg_s,nlm_pot,nlm_p_fp,nlm_probe,nr,nrm,nspin,nspino,nspinp, &
           numat_abs,psii,r,Rad_gon,Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,rsato_abs,rsbdc,Spinorbite,V_hubb,V_intmax, &
           Vcato,Vhbdc,VxcbdcF,Vxcato,Ylm_comp)

  use declarations
  implicit none

  integer:: ich, icheck, ie, ip, ip0, ip_max, iseuil, iso, isp, Lm, Lmax, Lmax_pot, Lmp, m_hubb, nbseuil, nenerg_s, nlm_pot, &
    nlm_p_fp, nlm_probe, nr, nrm, nspin, nspino, nspinp, numat_abs

  character(len=4), dimension(16):: Lm_string
  character(len=1), dimension(2):: Spin

  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb
  complex(kind=db), dimension(nenerg_s,nlm_probe,nlm_p_fp,nspinp,nspino,ip0:ip_max,nbseuil):: Rad_gon
  complex(kind=db), dimension(:,:,:,:,:,:), allocatable:: rof

  logical:: Diag_harm_basis, Eneg, Final_tddft, Full_potential, Hubb_abs, Hubb_diag_abs, NRIXS, Relativiste, Renorm, &
            Spinorbite, Ylm_comp
       
  real(kind=db):: alfpot, E_Fermi, Eclie, Eimag, Rmtg_abs, Rmtsd_abs, rsbdc, V_intmax, Vhbdc
  real(kind=db):: Enervide
  real(kind=db), dimension(nspin):: dV0bdcF, Ecinetic, V0bdc, VxcbdcF
  real(kind=db), dimension(nr):: r, rsato_abs
  real(kind=db), dimension(nbseuil):: Eseuil
  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(nrm,nbseuil):: psii
  real(kind=db), dimension(nr,nlm_pot):: Vcato
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato, Vxcato
  real(kind=db), dimension(nr,ip0:ip_max):: r_or_bess

  data Lm_string/ '0,+0','1,-1','1,+0','1,+1','2,-2','2,-1','2,+0','2,+1','2,+2','3,-3','3,-2','3,-1','3,+0','3,+1','3,+2','3,+3' /
  data Spin/ 'u','d' /

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

  Eimag = 0._db
  Final_tddft = .false.
  NRIXS = .false.

  ich = max(0, icheck-1)

  if( icheck > 1 ) write(3,100)

  allocate( rof(nlm_probe,nlm_p_fp,nspinp,nspino,ip0:ip_max,nbseuil) )

  do ip = ip0,ip_max
    select case(ip)
      case(0)
        r_or_bess(1:nr,ip) = 1._db
      case(1)
        r_or_bess(1:nr,ip) = r(1:nr)
      case default
        r_or_bess(1:nr,ip) = r(1:nr)**ip
    end select
  end do

  Lmax = nint( sqrt( real( nlm_probe ) ) ) - 1
 
  do ie = 1,nenerg_s

    Enervide = Energ_s(ie) + E_Fermi

    call Potex_abs(alfpot,dV0bdcF,Enervide,ich,nlm_pot,nr,nspin,.false.,r,rsato_abs,rsbdc,V_intmax, &
                           V0bdc,Vcato,Vhbdc,Vrato,Vxcato,VxcbdcF)

    Ecinetic(:) = Enervide - V0bdc(:)
    if( .not. Eneg ) Ecinetic(:) = max( Ecinetic(:), Eclie )

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

    call Radial_RIXS(E_Fermi,Ecinetic,Eimag,Energ_s(ie),Enervide,Eseuil,Final_tddft,Full_potential,Hubb_abs,Hubb_diag_abs,ich, &
         1,ip_max,ip0,Lmax,Lmax_pot,m_hubb,nbseuil,nlm_pot,nlm_probe,nlm_p_fp,nr,NRIXS,nrm,nspin,nspino, &
         nspinp,numat_abs,psii,r,r_or_bess,Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,rof,Spinorbite,V_hubb,V_intmax,V0bdc,Vrato, &
         Ylm_comp)
         
    Rad_gon(ie,:,:,:,:,:,:) = rof(:,:,:,:,:,:)

  end do
  
  if( icheck > 1 ) then
    if( Diag_harm_basis .and. nbseuil == 1 .and. nspinp == 1 .and. nspino == 1 ) then
      write(3,110) (( Lm_string(Lm), ip, Lm = 1,nlm_probe), ip = ip0,ip_max )
    elseif( nlm_p_fp == 1 .and. nbseuil == 1 .and. nspinp == 1 ) then
      write(3,120) ((( Lm_string(Lm), Spin(isp), ip, Lm = 1,nlm_probe), isp = 1,nspinp), ip = ip0,ip_max )
    else
      write(3,130) (((((( Lm_string(Lm), Spin(isp), Spin(iso), ip, Lm = 1,nlm_probe), isp = 1,nspinp), iso = 1,nspino), &
                                                                 ip = ip0,ip_max ), Lmp = 1,nlm_p_fp), iseuil = 1,nbseuil ) 
    endif
    do ie = 1,nenerg_s
      write(3,140) Energ_s(ie)*rydb, (((((( real( Rad_gon(ie,Lm,Lmp,isp,iso,ip,iseuil) ), Lm = 1,nlm_probe),  &
                                        isp = 1,nspinp), iso = 1,nspino), ip = ip0,ip_max), Lmp = 1,nlm_p_fp), iseuil = 1,nbseuil )
    end do   
  endif
    
  deallocate( rof )
  
  return
  100 format(/'---------- Cal_Rad_gon ',80('-'))
  110 format(/10x,'Rad_gon(L,m,ip)   ip = dipole,...',/'    Energy',10000(3x,'(',a4,',',i1,')',2x))
  120 format(/10x,'Rad_gon(L,m,spin,ip)   ip = dipole,...',/'    Energy',10000(2x,'(',a4,a1,',',i1,')',2x))
  130 format(10x,'Rad_gon(L,m,spin,sol,ip)   ip = dipole,...',/'    Energy',10000(2x,'(',a4,a1,a1,',',i1,')',1x))
  140 format(f10.3,1p,10000e13.5)
end

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

! Calculation of radial integrals 

subroutine Radial_RIXS(E_Fermi,Ecinetic,Eimag,Energ,Enervide,Eseuil,Final_tddft,Full_potential,Hubb_abs,Hubb_diag_abs,icheck, &
         initlv,ip_max,ip0,Lmax,Lmax_pot,m_hubb,nbseuil,nlm_pot,nlma,nlma2,nr,NRIXS,nrm,nspin,nspino, &
         nspinp,numat_abs,psii,r,r_or_bess,Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,rof,Spinorbite,V_hubb,V_intmax,V0bdc,Vrato, &
         Ylm_comp)

  use declarations
  implicit none

  integer:: i, ich, icheck, initl, initlv, ip, ip_max, ip0, iseuil, isp, L, L_hubbard, lfin, lm, Lmax, &
    Lmax_pot, lmp, lp, m, m_hubb, nlm, nlm_fp, mp, nbseuil, nlm_V, nlm_pot, nlma, nlma2, nr, nrm, &
    nrmtsd, nrmtg, nspin, nspino, nspinp, numat_abs

  character(len=104):: mot

  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(nlma,nlma2,nspinp,nspino,ip0:ip_max,nbseuil):: rof
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb
  complex(kind=db), dimension(:,:,:,:), allocatable:: Tau, V

  logical:: Ecomp, Final_tddft, Full_potential, Hubb_abs, &
    Hubb_diag_abs, Hubb_m, NRIXS, Radial_comp, Relativiste, Renorm, Spinorbite, Ylm_comp

  real(kind=db):: E_Fermi, Eimag, Energ, Enervide, Ephoton, Rmtg_abs, Rmtsd_abs, V_intmax
  real(kind=db), dimension(nspin):: Ecinetic, V0bdc
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato

  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nbseuil):: Eseuil, Vecond
  real(kind=db), dimension(nrm,nbseuil):: psii
  real(kind=db), dimension(nr,ip0:ip_max):: r_or_bess
  real(kind=db), dimension(nspinp*(Lmax+1)**2):: E_kin, E_V

  real(kind=db), dimension(:,:), allocatable:: g0, gm, gp,  gso
  real(kind=db), dimension(:,:,:,:,:), allocatable:: ui, ur

  E_kin = 0._db; E_V(:) = 0._db
  
  konde(:) = sqrt( cmplx(Ecinetic(:), Eimag,db) )

  ich = icheck - 1
  
  allocate( g0(nr,nspin) )
  allocate( gm(nr,nspin) )
  allocate( gp(nr,nspin) )
  allocate( gso(nr,nspino) )
  
  if( icheck > 1 ) then
    if( nspin == 1 ) then
      write(3,110) Energ*rydb, Ecinetic(:)*rydb, ( V0bdc(:) - E_Fermi )*rydb, real(konde(:))
    else
      write(3,120) Energ*rydb, Ecinetic(:)*rydb, ( V0bdc(:) - E_Fermi )*rydb, real(konde(:))
    endif
  endif

  if( Full_potential ) then
    nlm_V = ( Lmax + 1 )**2
  else
    nlm_V = 1
  endif
  allocate( V(nr,nlm_V,nlm_V,nspin) )

  do i = 1,nbseuil
    if( Final_tddft ) then
      if( i /= nbseuil ) cycle
      Ephoton = Energ + Eseuil(nbseuil)
    else
      Ephoton = Energ + Eseuil(i)
    endif
    Ephoton = max( 0.001_db, Ephoton ) ! Optic case
! Multiplicative term for quadrupolar transitions
! In S.I. vecond = k = E*alfa_sf*4*pi*epsilon0 / (e*e)
! In a.u. and Rydberg : k = 0.5_db * alfa_sf * E
    Vecond(i) = 0.5_db * alfa_sf * Ephoton
  end do

  call mod_V(ich,Lmax,Lmax_pot,nlm_V,nlm_pot,nr,nrmtg,nrmtsd,nspin,r,Rmtg_abs,Rmtsd_abs,V,V_intmax,V0bdc,Vrato,Ylm_comp)

  call Coef_sch_rad(Enervide,f2,g0,gm,gp,gso,nlm_V,nr,nspin,nspino,numat_abs,r,Relativiste,Spinorbite,V)

  if( abs(Eimag) > eps10 .or. Ecinetic(1) < eps10 .or. Ecinetic(nspin) < eps10 ) then
    Ecomp = .true.
  else
    Ecomp = .false.
  endif

  if( Full_potential ) then
    lfin = 0
  else
    lfin = Lmax
  endif

  do L = 0,lfin

    if( Hubb_abs .and. L == L_hubbard( numat_abs ) )  then
      Hubb_m = .true.
    else
      Hubb_m = .false.
    endif
    Radial_comp = Ecomp .or. ( ( Hubb_m .or. Full_potential ) .and. Ylm_comp )

    if( Full_potential ) then
      nlm = nlm_V    ! = ( Lmax + 1 )**2
      nlm_fp = nlm_V
    elseif( Hubb_m .and. .not. Hubb_diag_abs ) then
      nlm = 2*L + 1
      nlm_fp = nlm
    elseif( Spinorbite .or. Hubb_m ) then
      nlm = 2*L + 1
      nlm_fp = 1
    else
      nlm = 1
      nlm_fp = 1
    endif

    allocate( ui(nr,nlm,nlm_fp,nspinp,nspino) )
    allocate( ur(nr,nlm,nlm_fp,nspinp,nspino) )
    allocate( Tau(nlm,nspinp,nlm,nspinp) )

    call Sch_radial( Ecomp, Eimag, f2, Full_potential, g0, gm, gp, gso, Hubb_abs, Hubb_diag_abs, ich, konde, L, Lmax, m_hubb, &
         nlm, nlm_fp, nlm_V, nr, nrmtg, nspin, nspino, nspinp, numat_abs, r, Radial_comp, Relativiste, Renorm, Rmtg_abs, &
         Spinorbite, Tau, ui, ur, V, V_hubb )

!    Call Kinetic_and_total_energy(E_elecZ,E_Fermi,E_kin2,E_tot,E_V2,Energ,Full_potential,Hubb_m,icheck,L,Lmax,nlm_V,nlm, &
!                        nlm_fp,nr,nspin,nspino,nspinp,r,Rmtsd_abs,Spinorbite,ur,V,Vc,numat_abs)

! Radial integral for the golden rule
    iseuil = 1
    call Radial_matrix(Final_tddft,initlv,ip_max,ip0,iseuil,L,nlm,nlm_fp,nbseuil, &
           nbseuil,nlma,nlma2,nr,NRIXS,nrm,nspino,nspinp,psii,r,r_or_bess,Radial_comp,Rmtsd_abs,rof,ui,ur,Vecond)

    deallocate( Tau, ui, ur )

  end do   ! end of loop over L

  if( icheck > 1 ) then
    mot = ' '
    if( Ecomp .and. nspino == 2 ) then
      mot(11:17) = 'up sol1'
      mot(37:43) = 'up sol2'
      mot(63:69) = 'dn sol1'
      mot(89:95) = 'dn sol2'
    elseif( nspino == 2 ) then
      mot(5:50) = 'up sol1      up sol2      dn sol1      dn sol2'
    elseif( nspinp == 2 ) then
      mot = '      up           dn'
    else
      mot = ' '
    endif

    do i = 1,nbseuil
      if( Final_tddft ) then
        if( i /= nbseuil ) cycle
        initl = initlv
      else
        initl = i
        if( nbseuil > 1 ) write(3,155) i
      endif

      do ip = ip0,ip_max
        select case(ip)
          case(0)
            Write(3,'(/A)') '    Radial monopole matrix'
          case(1)
            Write(3,'(/A)') '    Radial dipole matrix'
          case(2)
            Write(3,'(/A)') '    Radial quadrupole matrix'
          case(3)
            Write(3,'(/A)') '    Radial octupole matrix'
        end select
        if( Full_potential .or. Hubb_abs ) then
          write(3,170) '  L  m lp mp', mot
        else
          write(3,175) '  L  m', mot
        endif
        lm = 0
        do L = 0,Lmax
          do m = -L,L
            lm = lm + 1
            if( .not. ( Hubb_abs .or. Full_potential .or. Spinorbite ) .and. m /= 0 ) cycle
            lmp = 0
            do lp = 0,Lmax
              if( .not. Full_potential .and. L /= lp ) cycle
              do mp = -lp,lp
                if( .not. ( Hubb_abs .or. Full_potential .or. m == mp ) ) cycle
                lmp = lp**2 + lp + 1 + mp
                lmp = min(nlma2,lmp)
                if( Full_potential .or. Hubb_abs ) then
                  if( Ecomp) then
                    write(3,180) L, m, lp, mp, ( rof(lm,lmp,isp,:,ip,initl), isp = 1,nspinp)
                  else
                    write(3,180) L, m, lp, mp, ( real(rof(lm,lmp,isp,:,ip,initl)), isp = 1,nspinp)
                  endif
                else
                  if( Ecomp) then
                    write(3,185) L, m, ( rof(lm,lmp,isp,:,ip,initl), isp = 1,nspinp )
                  else
                    write(3,185) L, m, ( real(rof(lm,lmp,isp,:,ip,initl)), isp = 1,nspinp )
                  endif
                endif
              end do
            end do
          end do
        end do
      end do

    end do

  endif

  deallocate( g0, gm, gp, gso )
  deallocate( V )

  return
  110 format(/' Energ =',f8.3,', Ecinetic =',f8.3,', V0bdc =',f8.3,' eV, konde =',f8.5)
  120 format(/' Energ =',f8.3,', Ecinetic =',2f8.3,', V0bdc =',2f8.3,' eV, konde =',2f8.5)
  155 format(/' iseuil =',i2)
  170 format(3x,a12,a104)
  175 format(3x,a6,a104)
  180 format(3x,4i3,1p,8e13.5)
  185 format(3x,2i3,1p,8e13.5)
end

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

! Direct process. The standard xanes is also calculated

Subroutine Direct_process(Analyzer,Betalor,Coef_f,Coef_g,Core_resolved,Delta_Gauss_Rixs,Diag_harm_basis,E_cut_Rixs,E_Fermi, &
        Eclie,Eneg,Energ_in,Energ_emis,Energ_loss,Energ_s,Eseuil,File_name_rixs,Gamma,HERFD, &
        icheck,ie_min,ip0,ip_max,isymeq,L_emis,Lm1_mult,Lmax,Lmax_mult,Lmin_mult,Lmoins1,Lplus1,Lseuil,m_f,m_g,M1M1, &
        Moment_conservation,Monocrystal,Multipole_R,multi_run,n_multi_run,n_q_dim,n_theta_rixs,natomsym, &
        nb_Emis,nbseuil,nenerg_emis,nenerg_in,nenerg_loss,nenerg_oc,nenerg_s,nfinal,nfinal1,nfinalr,ninit,ninit1,ninitr, &
        nlm_mult,nlm_p_fp,nlm_probe,npl,npl_abs,nspin,nspino,nspinp,Pol_i_s_g,Pol_i_p_g,Pol_s_s_g,Pol_s_p_g,Powder, &
        Rad_gon,RadMat_Emis,Rot_atom,Shift,Spinorbite,Tau_abs,Temp,Theta_rixs,V0bdcF,Vec_i_g,Vec_s_g,Volume_maille,Ylm_comp)

  use declarations
  implicit none
  
  integer, parameter:: n_trans = 1

  integer:: i_g_1, i_g_2, icheck, ie, ie_in, ie_loss, ie_min, ie_min_e, index, index_loss, ip0, ip_max, L_emis, Lm1_mult, Lmax, &
    Lmax_mult, Lmin_mult, Lseuil, multi_run, n_multi_run, n_q_dim, n_theta_rixs, natomsym, nb_Emis, nbseuil, nenerg_emis, &
    nenerg_in, nenerg_loss, nenerg_oc, nenerg_s, nfinal, nfinal1, nfinalr, ninit, ninit2, ninit1, ninitr, ninitr_dir, &
    nlm_mult, nlm_p_fp, nlm_probe, npl, npl_abs, nsec, nspin, nspino, nspinp, nsym

  integer, dimension(nfinal,2):: m_f
  integer, dimension(ninit,2):: m_g
  integer, dimension(natomsym):: isymeq

  character(len=Length_name), dimension(n_multi_run):: File_name_rixs
  
  complex(kind=db), dimension(nenerg_s,nlm_probe,nlm_p_fp,nspinp,nspino,ip0:ip_max,nbseuil):: Rad_gon
  complex(kind=db), dimension(nenerg_s,nlm_probe,nspinp,nlm_probe,nspinp):: Tau_abs
  complex(kind=db), dimension(nenerg_s,npl,ninitr,n_theta_rixs,n_q_dim,1,n_trans):: Secabs_REXS

  complex(kind=db), dimension(:,:,:,:), allocatable:: Tr_gfg, Tr_gng
  complex(kind=db), dimension(:,:,:,:,:), allocatable:: Tr_gng_t
  complex(kind=db), dimension(:,:,:,:,:,:,:), allocatable:: Secabs, Secabs_f
  
  logical:: Analyzer, Core_resolved, Core_resolved_L, Diag_harm_basis, E1E1, E1E2, E1E3, E1M1, E2E2, E3E3, Elastic, Eneg, HERFD, &
    Indirect, Lmoins1, Lplus1, M1M1, Moment_conservation, Monocrystal, Powder, Spinorbite, Write_bav, Ylm_comp

  logical, dimension(13):: Multipole_R

  real(kind=db):: dE_Loss, Delta_Gauss_Rixs, E_cut_Rixs, E_emis, E_Fermi, E_i, E_loss, E_s, Eclie, Temp, Volume_maille 

  real(kind=db), dimension(3,3):: Rot_atom
  real(kind=db), dimension(nspin):: V0bdcF
  real(kind=db), dimension(nenerg_emis):: Energ_emis
  real(kind=db), dimension(nenerg_in):: Betalor, Energ_in
  real(kind=db), dimension(nenerg_loss):: Energ_loss
  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(nbseuil):: Eseuil
  real(kind=db), dimension(ninitr):: Gamma, Shift
  real(kind=db), dimension(nfinal,2):: Coef_f
  real(kind=db), dimension(ninit,2):: Coef_g
  real(kind=db), dimension(n_theta_rixs,2):: Theta_rixs
  real(kind=db), dimension(nb_Emis,nbseuil):: RadMat_Emis
  real(kind=db), dimension(3,n_theta_rixs,n_q_dim):: Pol_i_s_g, Pol_i_p_g, Pol_s_s_g, Pol_s_p_g, Vec_i_g, Vec_s_g

  real(kind=db), dimension(:,:,:,:), allocatable:: Int_RIXS
  real(kind=db), dimension(:,:,:,:,:,:), allocatable:: Int_out

  E1E1 = Multipole_R(1); E1E2 = Multipole_R(2); E1E3 = Multipole_R(3);
  E1M1 = Multipole_R(4); E2E2 = Multipole_R(6);
  E3E3 = Multipole_R(7); M1M1 = Multipole_R(8)

  Indirect = .false.
  
  ! Used for the direct process because it is absorption-emission which corresponds to the same core-state
  ! but not secabs 'abs-abs' or 'emis-emis' used for the indensity which cross the core-states.
  Core_resolved_L = .true.
  ninit2 = ninit**2

  allocate( Secabs(nenerg_s,npl,ninit2,n_theta_rixs,n_q_dim,natomsym,n_trans) )
    
  if( HERFD ) then
    allocate( Int_out(nenerg_in,nenerg_emis,npl,n_theta_rixs,n_q_dim,1) ) 
    allocate( Int_RIXS(npl,n_theta_rixs,n_q_dim,nenerg_emis) )
    ie_min_e = ie_min
  else
    allocate( Int_out(nenerg_in,nenerg_loss,npl,n_theta_rixs,n_q_dim,1) ) 
    allocate( Int_RIXS(npl,n_theta_rixs,n_q_dim,1) )
    ie_min_e = 1
  endif
    
  Int_out(:,:,:,:,:,:) = 0._db
  
  ninitr_dir = ninitr
  
  Write_bav = icheck > 1
  
  allocate( Tr_gng(ie_min_e:nenerg_s,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninit2) )

! Calculation of both XES and XANES transition
  E_loss = 0._db ! must be set at zero at this step
  call Transition_process(Coef_g,Core_resolved,Diag_harm_basis,E_cut_Rixs,E_loss,Energ_s,Eseuil,ie_min_e, &
            ip0,ip_max,Lm1_mult,Lmax,Lmax_mult,Lmin_mult,Lmoins1,Lplus1,Lseuil,m_g,nlm_p_fp,nbseuil,nenerg_oc,nenerg_s, &
            ninit,ninit1,ninit2,nlm_mult,nlm_probe,nspino,nspinp,Rad_gon,Spinorbite,Tau_abs,Tr_gng,Write_bav,Ylm_comp)

! This case is for the elastic process only
  if( .not. HERFD ) then
    Elastic = .true.
    nsym = 1
    nsec = ninitr
    allocate( Tr_gng_t(ie_min_e:nenerg_s,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninitr,1) )
    index = 0
    do i_g_1 = 1,ninitr
      do i_g_2 = 1,ninitr
        index = index + 1
        if( i_g_1 /= i_g_2 ) cycle
        Tr_gng_t(:,:,:,i_g_1,1) = Tr_gng(:,:,:,index)
      end do
    end do
    call Xtal_Tr_pol(E1E1,E2E2,Elastic,Energ_s,ie_min_e,isymeq,Lm1_mult,Lmax_mult,Lmin_mult,Monocrystal,n_q_dim,n_theta_rixs, &
                  n_trans,natomsym,nenerg_oc,nenerg_s,ninitr,ninitr,nlm_mult,npl,nsec,nsym,Pol_i_s_g,Pol_i_p_g,Pol_s_s_g, &
                  Pol_s_p_g,Rot_atom,Secabs_REXS,Theta_rixs,Tr_gng_t,Vec_i_g,Vec_s_g,Write_bav)
    deallocate( Tr_gng_t )
  endif

  Elastic = .false.    ! Only difference: occupied states  (<= nenerg_oc) are complex conjugate
  nsym = natomsym

  nsec = ninit2
  allocate( Tr_gng_t(ie_min_e:nenerg_s,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninit2,1) )
  Tr_gng_t(:,:,:,:,1) = Tr_gng(:,:,:,:)
  call Xtal_Tr_pol(E1E1,E2E2,Elastic,Energ_s,ie_min_e,isymeq,Lm1_mult,Lmax_mult,Lmin_mult,Monocrystal,n_q_dim,n_theta_rixs, &
                n_trans,natomsym,nenerg_oc,nenerg_s,ninit2,ninitr,nlm_mult,npl,nsec,nsym,Pol_i_s_g,Pol_i_p_g,Pol_s_s_g, &
                Pol_s_p_g,Rot_atom,Secabs,Theta_rixs,Tr_gng_t,Vec_i_g,Vec_s_g,Write_bav)
  deallocate( Tr_gng, Tr_gng_t )

  if( HERFD ) then
    allocate( Tr_gfg(nfinalr,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninit2) ) 
    allocate( Secabs_f(nfinal,npl,ninit2,n_theta_rixs,n_q_dim,natomsym,n_trans) ) 

    call Emission_process(Coef_f,Coef_g,Core_resolved,Energ_emis,L_emis,Lm1_mult,Lmax_mult,Lmin_mult,Lseuil, &
            m_f,m_g,nb_Emis,nbseuil,nenerg_emis,nfinal,nfinal1,nfinalr,ninit,ninit1,ninit2,ninitr,nlm_mult,RadMat_Emis,Tr_gfg, &
            Write_bav) 

 !   To be valid nenerg_oc, is set to nfinal, to take the complex conjugate, iemin_e == 1, nenerg_s = nfinalr
    nsym = natomsym
    nsec = ninit2
    allocate( Tr_gng_t(nfinalr,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninit2,n_trans) )
    Tr_gng_t(:,:,:,:,1) = Tr_gfg(:,:,:,:)
    call Xtal_Tr_pol(E1E1,E2E2,Elastic,Energ_emis,1,isymeq,Lm1_mult,Lmax_mult,Lmin_mult,Monocrystal,n_q_dim,n_theta_rixs, &
                  n_trans,natomsym,nfinalr,nfinalr,ninit2,ninitr,nlm_mult,npl,nsec,nsym,Pol_i_s_g,Pol_i_p_g,Pol_s_s_g, &
                  Pol_s_p_g,Rot_atom,Secabs_f,Theta_rixs,Tr_gng_t,Vec_i_g,Vec_s_g,Write_bav)
    deallocate( Tr_gfg, Tr_gng_t )
  endif

! Loop over photon incoming energy      
  do ie_in = 1,nenerg_in

    if( .not. HERFD ) then
      write(6,'(/a12,f9.3,a3)') ' Energy in =', Energ_in(ie_in) * Rydb, ' eV'
      if( Monocrystal ) then
        write(6,'(/A)') '    E_Loss     RIXS_s       RIXS_p'
      else 
        write(6,'(/A)') '    E_Loss     RIXS_xx      RIXS_yy      RIXS_zz'  
      endif
    endif

    E_i = Eseuil(nbseuil) + Energ_in(ie_in)

    if( HERFD ) then
      call Conv_over_energy_HERFD(Betalor(ie_in),E_cut_Rixs,Energ_in(ie_in),Energ_s,Gamma,Int_RIXS, &
            n_q_dim,n_theta_rixs,nenerg_oc,nenerg_s,nfinalr,ninitr,ninit2,npl,nsym,Secabs_f,Secabs,Shift,Temp,Write_bav)

      do ie = 1,nenerg_emis
        Int_out(ie_in,ie,:,:,:,1) = Int_RIXS(:,:,:,ie) 
        Int_out(ie_in,ie,:,:,:,1) = ( E_i / Energ_emis(ie) ) * Int_out(ie_in,ie,:,:,:,1)
      end do
      if( Volume_maille > eps10 ) Int_out(ie_in,:,:,:,:,:) = Int_out(ie_in,:,:,:,:,:) / Volume_maille   
      
    elseif( ( icheck > 1 .and. ie_in == 1 ) .or. icheck > 2 ) then

      write(3,'(/A)') ' ------------------------------------------------------------------------------------------ '
      write(3,'(/a27,f8.3,a3)') ' Incoming energy - E_edge =', Energ_in(ie_in) * Rydb, ' eV'

    endif

! When HERFD, nenerg_loss = 0
    index_loss = 0 
    do ie_loss = 1,nenerg_loss ! Loop over photon loss

      E_loss = Energ_loss(ie_loss)
      
      if( E_loss < - eps10 ) cycle
      index_loss = index_loss + 1
      
      E_emis = Energ_in(ie_in) - E_loss

      Write_bav = ( icheck > 1 .and. ie_in == 1 .and. index_loss < 3 ) .or. icheck > 2
                   
      Elastic = abs( E_loss ) < eps10
      
      E_s = E_i - E_loss
      
      if( Elastic ) then
        dE_Loss = 0._db
      elseif( nenerg_loss == 1 ) then
        dE_Loss = Energ_s(2) - Energ_s(1)  
      elseif( ie_loss == 1 ) then
        dE_Loss = ( Energ_loss(1) + Energ_loss(2) ) / 2  
      elseif( ie_loss == nenerg_loss ) then
        dE_loss = Energ_loss(ie_loss) - Energ_loss(ie_loss-1)
      else
        dE_loss = ( Energ_loss(ie_loss+1) - Energ_loss(ie_loss-1) ) / 2 
      endif

! Integral over energy
      if( abs( E_loss ) < eps10 ) then
        nsym = 1
        call Conv_over_energy(Betalor(ie_in),dE_loss,E_cut_Rixs,E_loss,Energ_in(ie_in),Energ_s,Gamma,Int_RIXS, &
            n_q_dim,n_theta_rixs,1,nenerg_oc,nenerg_s,ninitr,ninitr,npl,nsym,Secabs_REXS,Shift,Temp,Write_bav)
      else
        nsym = natomsym
        call Conv_over_energy(Betalor(ie_in),dE_loss,E_cut_Rixs,E_loss,Energ_in(ie_in),Energ_s,Gamma,Int_RIXS, &
            n_q_dim,n_theta_rixs,1,nenerg_oc,nenerg_s,ninitr,ninit2,npl,nsym,Secabs,Shift,Temp,Write_bav)
      endif

      if( Moment_conservation ) &
        call Check_Moment_conservation(E_i,E_Fermi,E_loss,E_s,Eclie,Eneg,Energ_in(ie_in),icheck,Int_RIXS,n_q_dim,n_theta_rixs, &
                                     1,npl,nspin,Theta_rixs,V0bdcF)

      Int_out(ie_in,ie_loss,:,:,:,1) = Int_out(ie_in,ie_loss,:,:,:,1) + Int_RIXS(:,:,:,1) 
      Int_out(ie_in,ie_loss,:,:,:,:) = ( E_i / E_s ) * Int_out(ie_in,ie_loss,:,:,:,:)
      if( Volume_maille > eps10 ) Int_out(ie_in,ie_loss,:,:,:,:) = Int_out(ie_in,ie_loss,:,:,:,:) / Volume_maille   

      if( Monocrystal ) then
        write(6,'(f11.3,1p,5e13.5)') E_loss * Rydb, Int_out(ie_in,ie_loss,1,1,1,1) + Int_out(ie_in,ie_loss,2,1,1,1), &
                                                   Int_out(ie_in,ie_loss,3,1,1,1) + Int_out(ie_in,ie_loss,4,1,1,1)
      else
        write(6,'(f11.3,1p,5e13.5)') E_loss * Rydb, Int_out(ie_in,ie_loss,1,1,1,1), Int_out(ie_in,ie_loss,2,1,1,1), &
                                                    Int_out(ie_in,ie_loss,3,1,1,1)
      endif

    end do ! end of loop over ie_loss

! Gaussian convolution over loss ennergy 
    if( .not. HERFD ) &
      Call Conv_over_loss(Delta_Gauss_Rixs,Energ_loss,ie_in,Int_out,n_theta_rixs,1,n_q_dim,nenerg_in,nenerg_loss,npl)

  end do ! end of loop over incoming energy

  deallocate( Int_RIXS, Secabs )

  if( HERFD ) then
    call Write_out_RIXS(Analyzer,Energ_emis,Energ_in,File_name_rixs,HERFD,1,Int_out,multi_run,n_multi_run, &
                        n_q_dim,n_theta_rixs,1,nenerg_emis,nenerg_in,npl,Powder)
  else
    call Write_out_RIXS(Analyzer,Energ_loss,Energ_in,File_name_rixs,HERFD,1,Int_out,multi_run,n_multi_run, &
                        n_q_dim,n_theta_rixs,1,nenerg_loss,nenerg_in,npl,Powder)
  endif
  
  deallocate( Int_out )

  return
end

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

! Convolution over loss energy by a gaussian

subroutine Conv_over_loss(Delta_Gauss_Rixs,Energ_loss,ie_in,Int_out,n_theta_rixs,n_trans,n_q_dim,nenerg_in,nenerg_loss,npl)

  use declarations
  implicit none

  integer, parameter:: nj = 0
  integer, parameter:: ns = 10
  
  integer:: i_theta, i_q, ie, ie_in, ipl, n_theta_rixs, n_trans, n_q_dim, ne, nenerg_in, nenerg_loss, npl
  
  real(kind=db):: dE, Delta_Gauss_Rixs
  
  real(kind=db), dimension(nenerg_loss):: Energ_loss
  real(kind=db), dimension(nenerg_in,nenerg_loss,npl,n_theta_rixs,n_q_dim,n_trans):: Int_out

  real(kind=db), dimension(:), allocatable:: E, Y, Z

  if( nenerg_loss < 2 .or. Delta_Gauss_Rixs < eps10 ) return
  
  ne = nenerg_loss + ns
  
  allocate( Y(ne) )
  allocate( Z(ne) )
  allocate( E(ne) )

  dE = Energ_loss(2) - Energ_loss(1)
  do ie = 1,ns
    E(ie) = - ( ns + 1 - ie ) * dE
  end do
  E(ns+1:ne) = Energ_loss(:)
   
  do i_q = 1,n_q_dim
    do i_theta = 1,n_theta_rixs
      do ipl = 1,npl
        Y(1:ns) = 0._db
        Y(ns+1:ne) = Int_out(ie_in,:,ipl,i_theta,i_q,1)
        Z(:) = Y(:)
        call Gaussi(Delta_Gauss_Rixs,E,ne,nj,Y)
        Int_out(ie_in,:,ipl,i_theta,i_q,1) = Y(ns+1:ne) 
      end do
    end do
  end do
  
  deallocate( E, Y, Z )
  
  return
end

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

! Evaluation of the amplitude of the g - n - g transition (Tr_gng) 

subroutine Transition_process(Coef_g,Core_resolved,Diag_harm_basis,E_cut_Rixs,E_loss,Energ_s,Eseuil,ie_min, &
            ip0,ip_max,Lm1_mult,Lmax,Lmax_mult,Lmin_mult,Lmoins1,Lplus1,Lseuil,m_g,nlm_p_fp,nbseuil,nenerg_oc,nenerg_s, &
            ninit,ninit1,ninit2,nlm_mult,nlm_probe,nspino,nspinp,Rad_gon,Spinorbite,Tau_abs,Tr_gng,Write_bav,Ylm_comp)

  use declarations
  implicit none

  integer:: i_g_1, i_g_2, i_rank_1, i_rank_2, ie, ie_min, ie_p, index, initr_1, initr_2, ip0, ip_max, ipr, is1, is2, iseuil_1, &
    iseuil_2, iso1, iso2, isp1, isp2, &
    ispp1, ispp2, isping1, isping2, L_mult_1, L_mult_2, L1, L2, Lm_mult_1, Lm_mult_2, Lm1, Lm1_mult, Lm2, Lmax, Lmax_mult, &
    Lmin_mult, Lmp1, Lmp2, Lms1, Lms2, Lp1, Lp2, Lseuil, m_mult_1, &
    m_mult_2, m1, m2, mg1, mg2, mp1, mp2, ms1, ms2, nlm_p_fp, nbseuil, nenerg_oc, &
    nenerg_s, ninit, ninit1, ninit2, nlm_mult, nlm_probe, nspino, nspinp

  integer, dimension(ninit,2), intent(in):: m_g
    
  complex(kind=db):: Cg, f, f_interp2_cp, f0, fm, fp, Gaunt_i, Gaunt_s, Gaunt_xrc, PseudoGaunt_M1

  complex(kind=db), dimension(ie_min:nenerg_s,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninit2):: Tr_gng
  complex(kind=db), dimension(nenerg_s,nlm_probe,nspinp,nlm_probe,nspinp):: Tau_abs
  complex(kind=db), dimension(nenerg_s,nlm_probe,nlm_p_fp,nspinp,nspino,ip0:ip_max,nbseuil):: Rad_gon

  logical:: Core_resolved, Diag_harm_basis, Elastic, Indirect, Interpol, Lmoins1, Lplus1, Spinorbite, Ylm_comp, Write_bav  
    
  real(kind=db):: Cg_1, Cg_2, Cgg, Conv_nelec, E, E_cut_Rixs, E_loss, E_oc, Eph_min, Eph1,  Eph2

  real(kind=db), dimension(nbseuil):: Eseuil
  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(ninit,2):: Coef_g

  Tr_gng(:,:,:,:) = (0._db, 0._db)
  
  Indirect = ninit2 /= ninit**2

! To avoid photon energy < 0 !  
  Eph_min = 0.001_db / Rydb

  do ie = ie_min, nenerg_s  ! Loop over non occupied electron states

! Loop over core states < g_1 ...  > < ... >
    do i_g_1 = 1,ninit

      if( Core_resolved ) then
        initr_1 = i_g_1
        if( initr_1 <= ninit1 ) then  
          iseuil_1 = 1
        else
          iseuil_1 = min(2, nbseuil)
        endif
      else
        if( i_g_1 <= ninit1 ) then
          initr_1 = 1
        else
          initr_1 = 2
        endif
        iseuil_1 = min( initr_1, nbseuil )
      endif

      do i_g_2 = 1,ninit
        if( Indirect .and. i_g_1 /= i_g_2 ) cycle
      
        if( Core_resolved ) then
          initr_2 = i_g_2
          if( initr_2 <= ninit1 ) then  
            iseuil_2 = 1
          else
            iseuil_2 = min(2, nbseuil)
          endif
        else
          if( i_g_2 <= ninit1 ) then
            initr_2 = 1
          else
            initr_2 = 2
        endif
          iseuil_2 = min( initr_2, nbseuil )
        endif
        
        if( indirect ) then
          index = initr_1
        else
          index = initr_2 + ninit * ( initr_1 - 1 )
        endif
                 
        Eph1 = max( Eseuil(iseuil_1) + Energ_s(ie), Eph_min )
        Eph2 = max( Eseuil(iseuil_2) + Energ_s(ie) - E_loss , Eph_min )
        Conv_nelec = 0.5_db * Eph1 * Eph2 

        interpol = .false.

        if( abs( E_loss ) < eps10 ) then
          Elastic = .true.    
          ie_p = ie
        else
    ! in fact, not anymore used
          Elastic = .false.
          E_oc = Energ_s(ie) - E_loss
          if( E_oc > E_cut_Rixs + eps10 .or. E_oc < Energ_s(1) - eps10 ) cycle
          do ie_p = 1,nenerg_oc
            if( Energ_s(ie_p) > E_oc - eps10 ) exit
          end do
          Interpol = abs( E_oc - Energ_s(ie_p) ) > eps10  
        endif

! Loop over core state spin < g_1 ...  > < ... >
        do isping1 = 1,2 
          mg1 = m_g(i_g_1,isping1)
          Cg_1 = Coef_g(i_g_1,isping1)

          if( abs( Cg_1 ) < eps6 ) cycle

! Loop over core state spin < ...  > < ... g_2 >
          do isping2 = 1,2  
        
            if( Lseuil == 0 .and. isping1 /= isping2 .and. Indirect ) cycle

            mg2 = m_g(i_g_2,isping2)
            Cg_2 = Coef_g(i_g_2,isping2)

            if( abs( Cg_2 ) < eps6 ) cycle

            Cgg = Cg_1 * Cg_2

            do isp1 = 1,2
! For non magnetic system with spin-orbit 
              ispp1 = min( isp1, nspinp )
 
              do L1 = 0,Lmax
                if( Lplus1 .and. L1 < Lseuil + 1 ) cycle
                if( Lmoins1 .and. L1 > Lseuil ) cycle
                do m1 = -L1,L1   ! m of the spherical harmonics
                  Lm1 = L1**2 + L1 + 1 + m1

                  Lmp1 = 0
                  do Lp1 = 0,Lmax
                    if( Diag_harm_basis .and. Lp1 /= L1 ) cycle
                    do mp1 = - Lp1,Lp1
                      if( nlm_p_fp == 1 ) then 
                        if( mp1 /= m1 ) cycle
                        Lmp1 = 1
                      else
                        Lmp1 = Lp1**2 + Lp1 + 1 + mp1
                      endif
                 
                      do iso1 = 1,nspino
                        if( Spinorbite .and. Diag_harm_basis ) then
                          ms1 = m1 + iso1 - isp1 !  m of the spinor (and multiple scattering amplitude)
                          if( ms1 > L1 .or. ms1 < - L1 ) cycle
                          Lms1 = Lm1 + ms1 - m1
                          is1 = iso1
                        else
                          ms1 = m1
                          is1 = ispp1
                          if( Diag_harm_basis ) then 
                            Lms1 = Lm1
                          else
                            Lms1 = Lmp1
                          endif
                        endif
 
                        do i_rank_1 = ip0,ip_max
                          if( ip0 == 0 .or. ip_max == 3 ) then
                            call write_error
                            do ipr = 6,9,3
                              write(ipr,'(//A//)') ' Magnetic monopole and electric octupole not yet possible in RIXS !'
                            end do
                            stop
                          endif 
                   ! Loop over multipole
                          do L_mult_1 = Lmin_mult,Lmax_mult
                            if( i_rank_1 < 2 .and. L_mult_1 /= 1 ) cycle
                            if( i_rank_1 == 2 .and. ( L_mult_1 /= 0 .and. L_mult_1 /= 2 ) ) cycle
                        
                            do m_mult_1 = - L_mult_1,L_mult_1
                     ! for i_rank_1 == 0, m_mult_1 is fake and means x, y or z
                              Lm_mult_1 = L_mult_1**2 + L_mult_1 + 1 + m_mult_1
                              if( L_mult_1 > 0 .and. isping1 /= isp1 ) exit 
                
                              if( i_rank_1 == 0 ) then
                                Gaunt_s = PseudoGaunt_M1(L1,m1,isp1,m_mult_1,Lseuil,mg1,isping1,Ylm_comp,.true.)
                              else
                                Gaunt_s = Gaunt_xrc(L1,m1,L_mult_1,m_mult_1,Lseuil,mg1,Ylm_comp)
                              endif
                              if( abs(Gaunt_s) < eps10 ) cycle
                
                ! incoming side
                              do isp2 = 1,2
                                if( .not. Spinorbite .and. isp1 /= isp2 ) cycle
                                ispp2 = min(isp2,nspinp)
                       
                                do L2 = 0,Lmax
                                  if( Lplus1 .and. L2 < Lseuil + 1 ) cycle
                                  if( Lmoins1 .and. L2 > Lseuil ) cycle
                                  do m2 = -L2,L2 ! m of the spherical harmonics
                                    Lm2 = L2**2 + L2 + 1 + m2

                                    Lmp2 = 0
                                    do Lp2 = 0,Lmax
                                      if( Diag_harm_basis .and. Lp2 /= L2 ) cycle
                                      do mp2 = - Lp2,Lp2
                                        if( Diag_harm_basis ) then 
                                          if( mp2 /= m2 ) cycle
                                          Lmp2 = 1
                                        else
                                          Lmp2 = Lp2**2 + Lp2 + 1 + mp2
                                        endif
                        
                                        do iso2 = 1,nspino
                                          if( Spinorbite .and. Diag_harm_basis ) then
                                            ms2 = m2 + iso2 - isp2 !  m of the spinor (and multiple scattering amplitude)
                                            if( ms2 > L2 .or. ms2 < - L2 ) cycle
                                            Lms2 = Lm2 + ms2 - m2
                                            is2 = iso2
                                          else
                                            ms2 = mp2
                                            is2 = ispp2
                                            if( Diag_harm_basis ) then 
                                              Lms2 = Lm2
                                            else
                                              Lms2 = Lmp2
                                            endif
                                          endif

                                          do i_rank_2 = ip0,ip_max
                                    
                                            do L_mult_2 = Lmin_mult,Lmax_mult
                                              if( i_rank_2 < 2 .and. L_mult_2 /= 1 ) cycle
                                              if( i_rank_2 == 2 .and. ( L_mult_2 /= 0 .and. L_mult_2 /= 2 ) ) cycle
                                              if( L_mult_2 > 0 .and. isping2 /= isp2 ) exit 
                                              do m_mult_2 = - L_mult_2,L_mult_2
                                                Lm_mult_2 = L_mult_2**2 + L_mult_2 + 1 + m_mult_2
                                    
                                                if( i_rank_2 == 0 ) then
                                                  Gaunt_i = PseudoGaunt_M1(L2,m2,isp2,m_mult_2,Lseuil,mg2,isping2,Ylm_comp,.true.)
                                                else
                                                  Gaunt_i = Gaunt_xrc(L2,m2,L_mult_2,m_mult_2,Lseuil,mg2,Ylm_comp)
                                                endif
                                                if( abs(Gaunt_i) < eps10 ) cycle
                                      
                                                Cg = Cgg * conjg( Gaunt_s ) * Gaunt_i
                                      
                                                if( .not. Interpol ) then
                                                  f = Conjg( Rad_gon(ie_p,Lm1,Lmp1,ispp1,iso1,i_rank_1,iseuil_1) ) &
                                                    * Tau_abs(ie,Lms1,is1,Lms2,is2) &
                                                    * Rad_gon(ie,Lm2,Lmp2,ispp2,iso2,i_rank_2,iseuil_2)             
                                  ! inelastic case          
                                                else
                                                  fm = Conjg( Rad_gon(ie_p-1,Lm1,Lmp1,ispp1,iso1,i_rank_1,iseuil_1) ) &
                                                    * Tau_abs(ie,Lms1,is1,Lms2,is2) &
                                                    * Rad_gon(ie,Lm2,Lmp2,ispp2,iso2,i_rank_2,iseuil_2)             
                                                  f0 = Conjg( Rad_gon(ie_p,Lm1,Lmp1,ispp1,iso1,i_rank_1,iseuil_1) ) &
                                                    * Tau_abs(ie,Lms1,is1,Lms2,is2) &
                                                    * Rad_gon(ie,Lm2,Lmp2,ispp2,iso2,i_rank_2,iseuil_2)             
                                                  fp = Conjg( Rad_gon(ie_p+1,Lm1,Lmp1,ispp1,iso1,i_rank_1,iseuil_1) ) &
                                                    * Tau_abs(ie,Lms1,is1,Lms2,is2) &
                                                    * Rad_gon(ie,Lm2,Lmp2,ispp2,iso2,i_rank_2,iseuil_2)             
                                                  f = f_interp2_cp(E,Energ_s(ie_p-1),Energ_s(ie_p),Energ_s(ie_p+1),fm,f0,fp)
                                                endif
                                                                                                 
                                                Tr_gng(ie,Lm_mult_1,Lm_mult_2,index) = Tr_gng(ie,Lm_mult_1,Lm_mult_2,index) &
                                                                                     + Cg * Conv_nelec * f            
                                     
                                              end do
                                            end do ! end of loop on L_mult_2
                                          end do ! end of loop on i_rank_2
                                        end do
                                      end do
                                    end do
                                  end do
                            
                                end do
                              end do ! end of loop on isp2
                           
                            end do
                          end do  ! end of loop on L_mult_1
                        end do  ! end of loop on i_rank_1
                      
                      end do
                    end do

                  end do   ! end of loop on Lp1
                end do    ! end of loop on m1
              end do      ! end of loop on L1               
            end do  ! end of loop on isp1
          
          end do    ! end of loop on isping2
        end do      ! end of loop on isping1
        
      end do ! end of loop on ie 

    end do ! end of loop on i_g_2
  end do ! end of loop on i_g_1
  
  if( Write_bav ) then
    write(3,'(/A)') ' ----- Transition Process -----------------------------------------------------------------------------------'
    if( Indirect ) then
      write(3,'(/A)') ' Transition matrix(L1,m1,L2,m2,initr), indirect'
    else
      write(3,'(/a47,f10.3)') ' Transition matrix(L1,m1,L2,m2,initr), E_loss =', E_loss * Rydb
    endif 
    write(3,110) '    Energy', ((((( L_mult_1, m_mult_1, L_mult_2, m_mult_2, index, m_mult_2 = - L_mult_2, L_mult_2 ), &
                                         L_mult_2 = Lmin_mult, Lmax_mult), m_mult_1 = - L_mult_1, L_mult_1 ), &
                                         L_mult_1 = Lmin_mult, Lmax_mult), index = 1,ninit2 ) 
    do ie = ie_min,nenerg_s
      write(3,120) Energ_s(ie)*rydb, (( Tr_gng(ie,Lm_mult_1,:,index), Lm_mult_1 = Lm1_mult,nlm_mult ), index = 1,ninit2 )
    end do
  endif
    
  return
  110 format(/a10,500(7x,2i2,1x,2i2,i3,8x))
  120 format(f10.3,1p,500(1x,2e13.5))
end

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

! Evaluation of the amplitude of the g - n - g transition (Tr_gng) 

subroutine Emission_process(coef_f,Coef_g,Core_resolved,Energ_emis,L_emis,Lm1_mult,Lmax_mult,Lmin_mult,Lseuil, &
            m_f,m_g,nb_Emis,nbseuil,nenerg_emis,nfinal,nfinal1,nfinalr,ninit,ninit1,ninit2,ninitr,nlm_mult,RadMat_Emis,Tr_gfg, &
            Write_bav)

  use declarations
  implicit none

  integer:: i_emis, i_g_1, i_g_2, ifinal, ifinalr, index, initr_1, initr_2, iseuil_1, iseuil_2, isp1, isp2, isping1, isping2, &
    L_emis, L_mult_1, L_mult_2, Lm_mult_1, Lm_mult_2, Lm1_mult, Lmax_mult, Lmin_mult, Lseuil, m_mult_1, m_mult_2, m1, mg1, mg2, &
    nb_Emis, nbseuil, nenerg_emis, nfinal, nfinal1, nfinalr, ninit, ninit1, ninit2, ninitr, nlm_mult

  integer, dimension(ninit,2), intent(in):: m_g
  integer, dimension(nfinal,2), intent(in):: m_f
    
  complex(kind=db):: Cg, Gaunt_i, Gaunt_xrc, Gaunt_s

  complex(kind=db), dimension(nfinalr,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninit2):: Tr_gfg

  logical:: Core_resolved, Write_bav  
    
  real(kind=db):: Cff, Cg_1, Cg_2, Cgg, Conv_nelec

  real(kind=db), dimension(nfinal,2):: coef_f
  real(kind=db), dimension(ninit,2):: Coef_g
  real(kind=db), dimension(nenerg_emis):: Energ_emis
  real(kind=db), dimension(nb_Emis,nbseuil):: RadMat_Emis

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

!  do ie = 1,nenerg_emis  ! Loop over emission energies
  do ifinal = 1,nfinal  ! Loop over emission energies

    if( ifinal <= nfinal1 ) then
      i_emis = 1
    else
      i_emis = 2
    endif
    if( nfinal == nfinalr ) then
      ifinalr = ifinal
    else
      ifinalr = i_emis
    endif
    Conv_nelec = 0.5_db * Energ_emis(ifinalr)**2

! Loop over core states < g_1 ...  > < ... >
    do i_g_1 = 1,ninit

      if( Core_resolved ) then
        initr_1 = i_g_1
        if( initr_1 <= ninit1 ) then  
          iseuil_1 = 1
        else
          iseuil_1 = min(2, nbseuil)
        endif
      else
        if( i_g_1 <= ninit1 ) then
          initr_1 = 1
        else
          initr_1 = 2
        endif
        iseuil_1 = min(initr_1, nbseuil)
      endif

! Loop over core state spin < g_1 ...  > < ... >
      do isping1 = 1,2 
        mg1 = m_g(i_g_1,isping1)
        Cg_1 = Coef_g(i_g_1,isping1)

        if( abs( Cg_1 ) < eps6 ) cycle

! Loop over core state spin < ...  > < ... g_2 >
! Loop over core states < g_1 ...  > < ... >
        do i_g_2 = 1,ninit
   
          if( Core_resolved ) then
            initr_2 = i_g_2
            if( initr_2 <= ninit1 ) then  
              iseuil_2 = 1
            else
              iseuil_2 = min(2, nbseuil)
            endif
          else
            if( i_g_2 <= ninit1 ) then
              initr_2 = 1
            else
              initr_2 = 2
            endif
            iseuil_2 = min(initr_2, nbseuil)
          endif
   
          index = initr_2 + ninit * ( initr_1 - 1 )
          
          do isping2 = 1,2  
          
            if( Lseuil == 0 .and. isping1 /= isping2 ) cycle
   
            mg2 = m_g(i_g_2,isping2)
            Cg_2 = Coef_g(i_g_2,isping2)
   
            if( abs( Cg_2 ) < eps6 ) cycle
   
            Cff = Coef_f(ifinal,isping1) * Coef_f(ifinal,isping2)
   
            if( abs( Cff ) < eps6 ) cycle
             
            Cgg = Cg_1 * Cg_2 * Cff 
            
            do isp1 = 1,2
   
              if( isp1 /= isping1 ) cycle
       
              m1 = m_f(ifinal,isp1)
   
         ! Loop over multipole
              do L_mult_1 = Lmin_mult,Lmax_mult
                if( L_mult_1 /= 1 ) cycle
                do m_mult_1 = - L_mult_1,L_mult_1
                  Lm_mult_1 = L_mult_1**2 + L_mult_1 + 1 + m_mult_1
                  
                  Gaunt_s = Gaunt_xrc(L_emis,m1,L_mult_1,m_mult_1,Lseuil,mg1,.false.)
                  
                  if( abs(Gaunt_s) < eps10 ) cycle
                  
                  ! incoming side
                  do isp2 = 1,2
                    if( isp2 /= isping2 ) cycle
                                         
                    do L_mult_2 = Lmin_mult,Lmax_mult
                      if( L_mult_2 /= 1 ) cycle
                      do m_mult_2 = - L_mult_2,L_mult_2
                        Lm_mult_2 = L_mult_2**2 + L_mult_2 + 1 + m_mult_2
   
                        Gaunt_i = Gaunt_xrc(L_emis,m1,L_mult_2,m_mult_2,Lseuil,mg2,.false.)
                        if( abs(Gaunt_i) < eps10 ) cycle
                                
                        Cg = Cgg * conjg( Gaunt_s ) * Gaunt_i
   
                        Tr_gfg(ifinalr,Lm_mult_1,Lm_mult_2,index) = Tr_gfg(ifinalr,Lm_mult_1,Lm_mult_2,index) + Cg * Conv_nelec &
                                                                   * RadMat_Emis(i_emis,iseuil_1) * RadMat_Emis(i_emis,iseuil_2)            
                                
                      end do
                    end do ! end of loop on L_mult_2
                                    
                  end do
                           
                end do
              end do  ! end of loop on L_mult_1
                        
            end do  ! end of loop on isp1
            
          end do    ! end of loop on isping2
        end do      ! end of loop on i_g_2
 
      end do   ! end of loop on isping1     
    end do ! end of loop on i_g_1 

  end do ! end of loop on ifinal
  
  if( Write_bav ) then
    write(3,'(/A)') ' ----- Emission Process -----------------------------------------------------------------------------------'
    write(3,'(/A)') ' Transition matrix(L1,m1,L2,m2,initr)'
    write(3,110) '  i_emis', ((((( L_mult_1, m_mult_1, L_mult_2, m_mult_2, index, m_mult_2 = - L_mult_2, L_mult_2 ), &
                                         L_mult_2 = Lmin_mult, Lmax_mult), m_mult_1 = - L_mult_1, L_mult_1 ), &
                                         L_mult_1 = Lmin_mult, Lmax_mult), index = 1,ninitr**2 ) 
    do ifinalr = 1,nfinalr
      write(3,120) ifinalr, (( Tr_gfg(ifinalr,Lm_mult_1,:,index), Lm_mult_1 = Lm1_mult,nlm_mult ), index = 1,ninitr**2 ) 
    end do
  endif
    
  return
  110 format(/a8,500(7x,2i2,1x,2i2,i3,8x))
  120 format(i8,1p,500(1x,2e13.5))
end

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

! In case of HERFD, Energ_s is in fact Energ_emis
!                   nenerg_oc = nenerg_s are nfinalr = nb_emis
!                   ie_min = 1

! nsym = 1 when elastic and = natomsym when not, that is for indirect process

subroutine Xtal_Tr_pol(E1E1,E2E2,Elastic,Energ_s,ie_min,isymeq,Lm1_mult,Lmax_mult,Lmin_mult,Monocrystal,n_q_dim,n_theta_rixs, &
                  n_trans,natomsym,nenerg_oc,nenerg_s,ninit2,ninitr,nlm_mult,npl,nsec,nsym,Pol_i_s_g,Pol_i_p_g,Pol_s_s_g, &
                  Pol_s_p_g,Rot_atom,Secabs,Theta_rixs,Tr_gng,Vec_i_g,Vec_s_g,Write_bav)

  use declarations
  implicit none
  
  integer:: i, i_q, i_theta, i_trans, ia, ie, ie_min, index, initr_1, initr_2, ipl, irank, isym, ji, js, ki, ks, L1, L2, Li, Ls, &
    Lm1, Lm1_mult, Lm2, Lmax_mult, Lmi, Lmin_mult, Lms, mi, ms, n_theta_rixs, n_q_dim, n_trans, natomsym, nenerg_oc, nenerg_s, &
    ninit2, ninitr, nlm_mult, npl, nsec, nsym

  integer, dimension(natomsym):: isymeq

  complex(kind=db):: Amplitude 

  complex(kind=db), dimension(3,npl):: Pol_i, Pol_s 
  complex(kind=db), dimension(3,3):: Tens_E1E1
  complex(kind=db), dimension(3,3,3,3):: Tens_E2E2
  complex(kind=db), dimension(ie_min:nenerg_s,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninit2,n_trans):: Tr_gng
  complex(kind=db), dimension(nenerg_s,npl,nsec,n_theta_rixs,n_q_dim,nsym,n_trans):: Secabs

  complex(kind=db), dimension(:,:,:), allocatable:: Dlmm
  complex(kind=db), dimension(:,:), allocatable:: Dmm1, Dmm2, G
  complex(kind=db), dimension(:,:,:,:,:,:), allocatable:: Tr_gng_ia
  
  logical:: E1E1, E2E2, Elastic, HERFD, Monocrystal, Rot_a, Write_bav

  real(kind=db):: c2, clmi, clms, Fac, Fac_E2E2, Fac2, Sin2_2t, Theta
  
  real(kind=db), dimension(3):: Vec_i, Vec_s
  real(kind=db), dimension(3,3):: Mat, Rot_atom
  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(3,n_theta_rixs,n_q_dim):: Pol_i_s_g, Pol_i_p_g, Pol_s_s_g, Pol_s_p_g, Vec_i_g, Vec_s_g
  real(kind=db), dimension(n_theta_rixs,2):: Theta_rixs
  real(kind=db), dimension(0:Lmax_mult,3,3,3,nlm_mult):: clm

  allocate( Tr_gng_ia(ie_min:nenerg_s,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninit2,n_trans,natomsym) ) 

  Secabs(:,:,:,:,:,:,:) = (0._db, 0._db )
  Tr_gng_ia(:,:,:,:,:,:) = (0._db, 0._db )
  
  allocate( Dlmm(-Lmax_mult:Lmax_mult,-Lmax_mult:Lmax_mult,0:Lmax_mult) )

  Rot_a = abs(Rot_atom(1,1) - 1._db) > eps10 .or. abs(Rot_atom(2,2) - 1._db) > eps10 .or. abs(Rot_atom(3,3) - 1._db) > eps10  

! for emission from core states (HERFD), complex harmonics are used  
  HERFD = nenerg_oc == nenerg_s

  do ia = 1,natomsym

    isym = abs( isymeq(ia) )
    
    if( isym == 1 .and. .not. Rot_a .and. isymeq(ia) > 0 ) then
      Tr_gng_ia(:,:,:,:,:,ia) = Tr_gng_ia(:,:,:,:,:,ia) + Tr_gng(:,:,:,:,:)  
    elseif( isym == 1 .and. .not. Rot_a ) then
      Tr_gng_ia(:,:,:,:,:,ia) = Tr_gng_ia(:,:,:,:,:,ia) + conjg( Tr_gng(:,:,:,:,:) )  
    else
      call opsym(isym,Mat)
! .false. because the harmonic is the one of the interaction operator, not the one of the material 
      call Rotation_mat(Dlmm,0,Mat,Lmax_mult,.false.)
      if( Rot_a ) Mat = Matmul( Mat, Rot_atom )

      do L1 = Lmin_mult,Lmax_mult
        Lm1 = L1**2 + L1 + 1
        allocate( Dmm1(-L1:L1,-L1:L1) )
        Dmm1(-L1:L1,-L1:L1) = Dlmm(-L1:L1,-L1:L1,L1)
        do L2 = Lmin_mult,Lmax_mult
          Lm2 = L2**2 + L2 + 1
          allocate( Dmm2(-L2:L2,-L2:L2) )
          allocate( G(-L1:L1,-L2:L2) )
          Dmm2(-L2:L2,-L2:L2) = Dlmm(-L2:L2,-L2:L2,L2)
          do ie = ie_min,nenerg_s
            do index = 1,ninit2
              do i_trans = 1,n_trans
                G(-L1:L1,-L2:L2) = Tr_gng(ie,Lm1-L1:Lm1+L1,Lm2-L2:Lm2+L2,index,i_trans)
                G = Matmul( Dmm1, Matmul( G, Transpose( Dmm2 ) ) )
                if( isymeq(ia) > 0 ) then
                  Tr_gng_ia(ie,Lm1-L1:Lm1+L1,Lm2-L2:Lm2+L2,index,i_trans,ia) = &
                                                                  Tr_gng_ia(ie,Lm1-L1:Lm1+L1,Lm2-L2:Lm2+L2,index,i_trans,ia) &
                                                                + G(-L1:L1,-L2:L2)
                else
                  Tr_gng_ia(ie,Lm1-L1:Lm1+L1,Lm2-L2:Lm2+L2,index,i_trans,ia) = &
                                                                   Tr_gng_ia(ie,Lm1-L1:Lm1+L1,Lm2-L2:Lm2+L2,index,i_trans,ia) &
                                                                 + conjg( G(-L1:L1,-L2:L2) )
                endif
              end do
            end do  
          end do   
          deallocate( Dmm2, G )
        end do
        deallocate( Dmm1 )
      end do
      
    endif
    
  end do

! Calculation of tensors and projection on the polarization directions
  call Coef_Sph_Car(clm,Lmax_mult,nlm_mult)

  do i_q = 1,n_q_dim
    do i_theta = 1,n_theta_rixs
      Theta = Theta_rixs(i_theta,1)      

      if( Monocrystal ) then

        do ipl = 1,npl
  
          select case(ipl)
            case(1)
              pol_i(:,ipl) = cmplx( Pol_i_s_g(:,i_theta,i_q), 0._db, db )
              pol_s(:,ipl) = cmplx( Pol_s_s_g(:,i_theta,i_q), 0._db, db )
            case(2)
              pol_i(:,ipl) = cmplx( Pol_i_s_g(:,i_theta,i_q), 0._db, db )
              pol_s(:,ipl) = cmplx( Pol_s_p_g(:,i_theta,i_q), 0._db, db )
            case(3)
              pol_i(:,ipl) = cmplx( Pol_i_p_g(:,i_theta,i_q), 0._db, db )
              pol_s(:,ipl) = cmplx( Pol_s_s_g(:,i_theta,i_q), 0._db, db )
            case(4)
              pol_i(:,ipl) = cmplx( Pol_i_p_g(:,i_theta,i_q), 0._db, db )
              pol_s(:,ipl) = cmplx( Pol_s_p_g(:,i_theta,i_q), 0._db, db )
            case(5)
              pol_i(:,ipl) = ( Pol_i_s_g(:,i_theta,i_q) + img * Pol_i_p_g(:,i_theta,i_q) ) * sqrt_1o2 
              pol_s(:,ipl) = cmplx( Pol_s_s_g(:,i_theta,i_q), 0._db, db )
            case(6)
              pol_i(:,ipl) = ( Pol_i_s_g(:,i_theta,i_q) - img * Pol_i_p_g(:,i_theta,i_q) ) * sqrt_1o2 
              pol_s(:,ipl) = cmplx( Pol_s_s_g(:,i_theta,i_q), 0._db, db )
            case(7)
              pol_i(:,ipl) = ( Pol_i_s_g(:,i_theta,i_q) + img * Pol_i_p_g(:,i_theta,i_q) ) * sqrt_1o2 
              pol_s(:,ipl) = cmplx( Pol_s_p_g(:,i_theta,i_q), 0._db, db )
            case(8)
              pol_i(:,ipl) = ( Pol_i_s_g(:,i_theta,i_q) - img * Pol_i_p_g(:,i_theta,i_q) ) * sqrt_1o2 
              pol_s(:,ipl) = cmplx( Pol_s_p_g(:,i_theta,i_q), 0._db, db )
          end select
  
        end do
        
        Vec_i(:) = Vec_i_g(:,i_theta,i_q)     
        Vec_s(:) = Vec_s_g(:,i_theta,i_q)

      else

        c2 = ( quatre_pi / 3 )**2
        sin2_2t = sin( 2 * Theta )**2 
        Fac = sqrt( c2 * ( 1._db / 5._db ) * ( 1 - ( 2._db / 3._db ) * sin2_2t ) + 1._db / 15._db )  

        Fac2 = sqrt( c2 * ( 1._db / 30._db ) * ( 2 + 3 * sin2_2t ) )  

! not checked, I just take the spherical contribution
        Fac_E2E2 = 1 / ( 90._db * sqrt( 5._db) ) 
  
      endif

      do ia = 1,natomsym
        do ie = ie_min,nenerg_s
          do i_trans = 1,n_trans
            index = 0
            do initr_1 = 1,ninitr
              do initr_2 = 1,ninitr
                if( Elastic .and. initr_1 /= initr_2 ) cycle  
                index = index + 1
        
                if( E1E1 ) then
        
                  irank = 1
                  
                  Tens_E1E1(:,:) = ( 0._db, 0._db )
                    
                  do ks = 1,3
                    
                    Ls = irank
                    do ms = -Ls,Ls
                      Lms = Ls**2 + Ls + 1 + ms
                      clms = clm(irank,ks,1,1,Lms)
                      if( abs( clms ) < eps10 ) cycle
        
                      do ki = 1,3
                    
                        Li = irank
                        do mi = -Li,Li
                          Lmi = Li**2 + Li + 1 + mi
                          clmi = clm(irank,ki,1,1,Lmi)
                          if( abs( clmi ) < eps10 ) cycle
                      
                          Tens_E1E1(ks,ki) = Tens_E1E1(ks,ki) + clms * clmi * Tr_gng_ia(ie,Lms,Lmi,index,i_trans,ia) 
                  
                        end do
                      end do
                    end do
                  end do

                  if( HERFD .and. Write_bav ) then
                    Write(3,'(/a20,i2,a9,i2)') ' Tens_E1E1, i_emis =', ie, ', index =', index
                    do i = 1,3 
                      write(3,'(1p,3(1x,2e13.5))') Tens_E1E1(i,:)
                    end do 
                  endif
                  
                  do ipl = 1,npl
                                
                    Amplitude = ( 0._db, 0._db )
        
                    if( Monocrystal ) then
        
                      do ks = 1,3
                        do ki = 1,3
                          if( Elastic ) then
                            Amplitude = Amplitude + conjg( Pol_s(ks,ipl) ) * Pol_i(ki,ipl) * Tens_E1E1(ks,ki)
                          elseif( ie <= nenerg_oc ) then
                            Amplitude = Amplitude + conjg( Pol_s(ks,ipl) ) * Pol_s(ki,ipl) * Tens_E1E1(ks,ki)
                          else
                            Amplitude = Amplitude + conjg( Pol_i(ks,ipl) ) * Pol_i(ki,ipl) * Tens_E1E1(ks,ki)
                          endif
                        end do
                      end do
        
                    else  
        
                      select case(ipl)
                        case(1,2,3)
                          Amplitude = Fac * Tens_E1E1(ipl,ipl) 
                        case(4)
                          if( ie <= nenerg_oc ) then
                            Amplitude = Fac2 * Tens_E1E1(1,2)
                          else
                            Amplitude = Fac2 * Tens_E1E1(2,1)
                          endif 
                        case(5)
                          if( ie <= nenerg_oc ) then
                            Amplitude =  Fac2 * Tens_E1E1(3,3)
                          else
                            Amplitude =  Fac2 * Tens_E1E1(1,1)
                          endif 
                        case(6)
                          if( ie <= nenerg_oc ) then
                            Amplitude =  Fac2 * Tens_E1E1(3,3)
                          else
                            Amplitude =  Fac2 * Tens_E1E1(2,2)
                          endif 
                      end select 
                  
                    endif ! Monocrystal
        
                    if( Elastic ) then    
                      Secabs(ie,ipl,index,i_theta,i_q,1,i_trans) = Secabs(ie,ipl,index,i_theta,i_q,1,i_trans) + Amplitude
                    elseif( ie <= nenerg_oc ) Then
                      Secabs(ie,ipl,index,i_theta,i_q,ia,i_trans) = Secabs(ie,ipl,index,i_theta,i_q,ia,i_trans) + conjg( Amplitude )
                    else
                      Secabs(ie,ipl,index,i_theta,i_q,ia,i_trans) = Secabs(ie,ipl,index,i_theta,i_q,ia,i_trans) + Amplitude
                    endif
        
                  end do ! enf og loop over ipl
                   
                endif ! E1E1
              
                if( E2E2 .and. .not. HERFD ) then
        
                  Tens_E2E2(:,:,:,:) = ( 0._db, 0._db )
                  
                  irank = 2
                    
                  do ks = 1,3
                    do js = 1,3
                    
                      do Ls = 0,irank,2
                        do ms = -Ls,Ls
                          Lms = Ls**2 + Ls + 1 + ms
                          clms = clm(irank,ks,js,1,Lms)
        
                          if( abs( clms ) < eps10 ) cycle
                          
                          do ki = 1,3
                            do ji = 1,3
                    
                              do Li = 0,irank,2
                                do mi = -Li,Li
                                  Lmi = Li**2 + Li + 1 + mi
                                  clmi = clm(irank,ki,ji,1,Lmi)
        
                                  if( abs( clmi ) < eps10 ) cycle
                          
                                  Tens_E2E2(ks,js,ki,ji) = Tens_E2E2(ks,js,ki,ji) + clms * clmi &
                                                                                  * Tr_gng_ia(ie,Lms,Lmi,index,ia,i_trans) 
        
                                end do
                              end do
                            end do
                          end do
        
                        end do
                      end do
                    end do
                  end do
        
                  do ipl = 1,npl
                                
                    Amplitude = ( 0._db, 0._db )
        
                    if( Monocrystal ) then
        
                      do ki = 1,3
                        do ji = 1,3
                          do ks = 1,3
                           if( Elastic ) then
                             Amplitude = Amplitude + conjg( Pol_s(ks,ipl) ) * Pol_i(ki,ipl) &
                                                          * Vec_i(ji) * sum( Vec_s(:) * Tens_E2E2(ks,:,ki,ji) )
                            elseif( ie <= nenerg_oc ) then
                              Amplitude = Amplitude + Pol_s(ks,ipl) * conjg( Pol_s(ki,ipl) ) &
                                                          * Vec_s(ji) * sum( Vec_s(:) * Tens_E2E2(ks,:,ki,ji) )
                            else
                              Amplitude = Amplitude + conjg( Pol_i(ks,ipl) ) * Pol_i(ki,ipl) &
                                                          * Vec_i(ji) * sum( Vec_i(:) * Tens_E2E2(ks,:,ki,ji) )
                            endif
                          end do
                        end do
                      end do
                      
                    else
                    
! not checked, I just take the spherical contribution
                      Amplitude = Amplitude + Fac_E2E2 &
                                     * ( 6 * ( Tens_E2E2(1,3,1,3) + Tens_E2E2(2,3,2,3) + Tens_E2E2(1,2,1,2) ) &
                                       + 2 * ( Tens_E2E2(1,1,1,1) + Tens_E2E2(2,2,2,2) + Tens_E2E2(3,3,3,3) ) ) 
!                                           - ( Tens_E2E2(1,1,2,2) + Tens_E2E2(1,1,3,3) + Tens_E2E2(3,3,2,2) &
!                                             + Tens_E2E2(2,2,1,1) + Tens_E2E2(3,3,1,1) + Tens_E2E2(2,2,3,3) ) )
                   
                    endif
        
                    if( Elastic ) then
                      Secabs(ie,ipl,index,i_theta,i_q,1,i_trans) = Secabs(ie,ipl,index,i_theta,i_q,1,i_trans) + Amplitude
                    elseif( ie <= nenerg_oc ) Then
                      Secabs(ie,ipl,index,i_theta,i_q,ia,i_trans) = Secabs(ie,ipl,index,i_theta,i_q,ia,i_trans) + conjg( Amplitude)
                    else                
                      Secabs(ie,ipl,index,i_theta,i_q,ia,i_trans) = Secabs(ie,ipl,index,i_theta,i_q,ia,i_trans) + Amplitude
                    endif
        
                  end do
                  
                endif ! E2E2
                
              end do  ! end of loop over initr_2
            end do  ! end of loop over initr_1
          end do ! end of loop over i_trans
        end do ! end of loop over ie
  
      end do ! end of loop over i_theta
    end do ! end of loop over i_q
  end do ! end of loop over ia
  
  deallocate( Dlmm, Tr_gng_ia )

  if( Write_bav ) then
    if( n_trans > 1 ) then
      write(3,'(/A)') ' Crystal transition matrix(ipl,index,i_theta,i_q,i_trans), indirect case'
    elseif( Elastic ) then
      write(3,'(/A)') ' Crystal transition matrix(ipl,index,i_theta,i_q), Elastic case'
    else
      write(3,'(/A)') ' Crystal transition matrix(ipl,index,i_theta,i_q)'
    endif
    if( npl == 4 .and. HERFD .and. Monocrystal ) then
      write(3,'(A)') '    E_emis           Pol(s)                    Pol(p)                     Pol(s)                    Pol(p)'
    elseif( npl == 4 .and. Monocrystal ) then
      write(3,'(A)') '    Energy           Pol(s)                    Pol(s)                     Pol(p)                    Pol(p)'
    else
      write(3,'(A)') '    Energy           Pol(1)                    Pol(2)                     Pol(3)                    Pol(4)'
    endif
    ia = 1 
    do ie = ie_min,nenerg_s
      write(3,120) Energ_s(ie)*rydb, (((( Secabs(ie,:,index,i_theta,i_q,1,i_trans), index = 1,ninit2), i_trans = 1,n_trans), &
                                                                                     i_theta = 1,n_theta_rixs), i_q = 1,n_q_dim )  
    end do
  endif
    
  return
  110 format(/a10,500(7x,2i2,1x,2i2,i3,8x))
  120 format(f10.3,1p,500(1x,2e13.5))
end

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

Subroutine Coef_Sph_Car(clm,Lmax_mult,nlm_mult)

  use declarations
  implicit none

  real(kind=db), parameter:: p0 = sqrt( quatre_pi )
  real(kind=db), parameter:: p1 = sqrt( quatre_pi / 3._db )
  real(kind=db), parameter:: p2 = sqrt( quatre_pi / 15._db )
  real(kind=db), parameter:: p3 = sqrt( quatre_pi / 35._db )

  integer:: i, irank, j, k, Lmax_mult, nlm_mult 

  real(kind=db):: c, c1, c5, c3, c8, c12, c120
   
  real(kind=db), dimension(0:Lmax_mult,3,3,3,nlm_mult):: clm

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

  do irank = 0,Lmax_mult

    select case(irank)

      case(0)
! Magnetic dipole
        c = sqrt( quatre_pi )
! Does not correspond to (irank,m), but used to define  x, y and z
        clm(irank,1,:,:,4) = c
        clm(irank,2,:,:,2) = c
        clm(irank,3,:,:,3) = c

      case(1)
! Dipole
        clm(irank,1,:,:,4) = p1
        clm(irank,2,:,:,2) = p1
        clm(irank,3,:,:,3) = p1

      case(2)
! Quadrupole
        c3 = p2 / sqrt( 3._db )

        clm(irank,1,1,:,1) = p0 / 3._db
        clm(irank,1,1,:,7) = - c3;   clm(irank,1,1,:,9) = p2
        clm(irank,1,2,:,5) = p2
        clm(irank,1,3,:,8) = p2
        clm(irank,2,2,:,1) = p0 / 3._db
        clm(irank,2,2,:,7) = - c3;   clm(irank,2,2,:,9) = - p2
        clm(irank,2,3,:,6) = p2
        clm(irank,3,3,:,1) = p1
        clm(irank,3,3,:,7) = 2 * c3

        do i = 1,3
          do j = i+1,3
            clm(irank,j,i,:,:) = clm(irank,i,j,:,:)
          end do
        end do

      case(3)
! Octupole
        c1 = p1 / 5._db
        c5 = p3 / sqrt( 5._db )
        c8 = p3 / sqrt( 2._db )
        c12 = p3 / sqrt( 3._db )
        c120 = p3 / sqrt( 30._db )

        clm(irank,1,1,1,4) = 3 * c1
        clm(irank,1,1,1,14) = - 3 * c120; clm(irank,1,1,1,16) = c8
        clm(irank,2,2,2,2) = 3 * c1
        clm(irank,2,2,2,12) = - 3 * c120; clm(irank,2,2,2,10) = - c8
        clm(irank,3,3,3,3) = 3 * c1
        clm(irank,3,3,3,13) = 2 * c5
        clm(irank,1,1,2,2) = c1
        clm(irank,1,1,2,10) = c8;        clm(irank,1,1,2,12) = - c120
        clm(irank,1,2,2,4) = c1
        clm(irank,1,2,2,16) = - c8;      clm(irank,1,2,2,14) = - c120
        clm(irank,1,1,3,3) = c1
        clm(irank,1,1,3,13) = - c5;      clm(irank,1,1,3,15) = c12
        clm(irank,2,2,3,3) = c1
        clm(irank,2,2,3,13) = - c5;      clm(irank,2,2,3,15) = - c12
        clm(irank,2,3,3,2) = c1
        clm(irank,2,3,3,12) = 4 * c120
        clm(irank,1,3,3,4) = c1
        clm(irank,1,3,3,14) = 4 * c120
        clm(irank,1,2,3,11) = c12

        do i = 1,3
          do j = i,3
            do k = j,3
              if( i == j .and. i == k ) cycle
              clm(irank,i,k,j,:) = clm(irank,i,j,k,:)
              clm(irank,j,i,k,:) = clm(irank,i,j,k,:)
              clm(irank,k,i,j,:) = clm(irank,i,j,k,:)
              clm(irank,j,k,i,:) = clm(irank,i,j,k,:)
              clm(irank,k,j,i,:) = clm(irank,i,j,k,:)
            end do
          end do
        end do

    end select

  end do

  return
end

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

! Integral over energy to get the RIXS Intensity 

subroutine Conv_over_energy(Betalor,dE_loss,E_cut_Rixs,E_loss,Energ_in,Energ_s,Gamma,Int_RIXS, &
            n_q_dim,n_theta_rixs,n_tr,nenerg_oc,nenerg_s,ninitr,ninit2,npl,nsym,Secabs,Shift,Temp,Write_bav)

  use declarations
  implicit none

  integer:: i_q, i_theta, i_tr, ia, ie, ie_min, ie_p, index, initr, initr_1, initr_2, je, n_e, n_q_dim, n_theta_rixs, n_tr, &
    nenerg_e, nenerg_oc, nenerg_s, ninitr, ninit2, npl, nsym

  complex(kind=db):: Cf, Coef_Lorentz
  complex(kind=db), dimension(npl,n_theta_rixs,n_q_dim,n_tr):: Ampl_REXS
  complex(kind=db), dimension(nenerg_s,npl,ninit2,n_theta_rixs,n_q_dim,nsym,1):: Secabs

  logical:: Elastic, Interpol, Write_bav
  
  real(kind=db):: Betalor, Cfr, dE_loss, Delta, E_cut_Rixs, E_loss, E_oc, Energ_in, &
         Eph_min, Gamma_tot, p1, p2, Step, Temp

  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(ninitr):: Gamma, Shift
  real(kind=db), dimension(npl,n_theta_rixs,n_q_dim,n_tr):: Int_RIXS

  real(kind=db), dimension(:), allocatable:: Energ_e, E_inf, E_sup

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

  if( Temp > eps10 ) then
    ie_min = 1
  else
    ie_min = nenerg_oc + 1
  endif  
    
  if( nenerg_s > 1 ) then
    Step = max( Energ_s(nenerg_s) - Energ_s(nenerg_s-1), 2._db / Rydb ) 
    Delta = 50 * ( Betalor + max( 2 * Gamma(1), 1._db ) )   ! Gamma hole is already divided by 2
    n_e = nint( Delta / Step )
    Step = Delta / n_e
    nenerg_e = nenerg_s + n_e
  else
    n_e = 0
    nenerg_e = nenerg_s
  endif
  allocate( Energ_e(ie_min:nenerg_e) )
  Energ_e(ie_min:nenerg_s) =  Energ_s(ie_min:nenerg_s)
  do ie = 1,n_e
    Energ_e(nenerg_s+ie) = Energ_s(nenerg_s) + ie * Step 
  end do

! To avoid photon energy < 0 !  
  Eph_min = 0.001_db / Rydb

  allocate( E_inf(ie_min:nenerg_e) )
  allocate( E_sup(ie_min:nenerg_e) )
  
  if( nenerg_e - nenerg_oc == 1 ) then
    E_sup(ie_min) = Energ_e(nenerg_e) + 0.05_db / Rydb
    E_inf(ie_min) = Energ_e(nenerg_e) - 0.05_db / Rydb
  else
    if( Temp > eps10 ) then
      E_inf(ie_min) = 1.5_db * Energ_e(ie_min) - 0.5_db * Energ_e(ie_min+1)
    else
      E_inf(ie_min) = E_cut_Rixs
    endif  
    E_sup(ie_min) = ( Energ_e(ie_min+1) + Energ_e(ie_min) ) / 2
    do ie = ie_min+1,nenerg_e-1
      E_sup(ie) = ( Energ_e(ie+1) + Energ_e(ie) ) / 2
      E_inf(ie) = ( Energ_e(ie-1) + Energ_e(ie) ) / 2
    end do
    E_inf(nenerg_e) = ( Energ_e(nenerg_e-1) + Energ_e(nenerg_e ) ) / 2
    E_sup(nenerg_e) = 1.5_db * Energ_e(nenerg_e) - 0.5_db * Energ_e(nenerg_e-1) 
  endif

  Elastic = abs( E_loss ) < eps10

  if( Elastic ) then

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

    do initr = 1,ninitr
                 
      Gamma_tot = Betalor + Gamma(initr)

      do ie = ie_min, nenerg_e  ! Loop over non occupied electron states

        je = min(nenerg_s,ie)        
      
        Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),Energ_in,Gamma_tot,Shift(initr),Temp)

        Ampl_REXS(:,:,:,1) = Ampl_REXS(:,:,:,1) + Cf * Secabs(je,:,initr,:,:,1,1)
 
      end do
  
    end do
  
    Int_RIXS(:,:,:,:) = Ampl_REXS(:,:,:,:) * conjg( Ampl_REXS(:,:,:,:) ) 

  else

    index = 0  
    do initr_1 = 1,ninitr
                 
      Gamma_tot = Betalor + Gamma(initr_1)

      do initr_2 = 1,ninitr
        index = index + 1

        do ie = ie_min, nenerg_e  ! Loop over non occupied electron states

          je = min(nenerg_s,ie)        
      
! When the excited electron in the unoccupied state have more energy that the one comming from the photon,
! the occupied state electron making the transition down to the core must have 
!        E_oc = Energ_e(ie) - E_loss  - 2 * ( Energ_e(ie) - Energ_in )   
! Above is wrong. Conservation is given by:

          E_oc = Energ_e(ie) - E_loss          
        
          if( E_oc < Energ_s(1) - eps10 ) cycle
          if( E_oc > E_cut_Rixs + eps10 .and. ie_min /= 1 ) cycle
          do ie_p = 1,nenerg_oc
            if( Energ_s(ie_p) > E_oc - eps10 ) exit
          end do
          Interpol = abs( E_oc - Energ_s(ie_p) ) > eps10  

          Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),Energ_in,Gamma_tot,Shift(initr_1),Temp)
  
  ! Division below is because factor is 1/(Delta_E**2 + Gamma_tot**2)
  !                             and not 1/(Delta_E + i Gamma_tot) = (Delta_E -i Gamma_tot) / (Delta_E**2 + Gamma_tot**2)      
          Cfr = - aimag( Cf ) / Gamma_tot
      
          Cfr = dE_loss * Cfr
      
          if( Interpol ) then

            p2 = ( E_oc - Energ_s(ie_p) ) / ( Energ_s(ie_p+1) - Energ_s(ie_p) )
            p1 = 1._db - p2
            do ia = 1,nsym  
              Int_RIXS(:,:,:,1) = Int_RIXS(:,:,:,1) &
                                + Cfr * real( ( p1 * Secabs(ie_p,:,index,:,:,ia,1) + p2 * Secabs(ie_p+1,:,index,:,:,ia,1) ) &
                                            * Secabs(je,:,index,:,:,ia,1), db )
            end do
          else
            do ia = 1,nsym
              Int_RIXS(:,:,:,1) = Int_RIXS(:,:,:,1) + Cfr * real( Secabs(ie_p,:,index,:,:,ia,1) * Secabs(je,:,index,:,:,ia,1), db )
            end do
          endif
        
        end do
      end do ! end of loop on initr_2
    
    end do ! end of loop on initr_1
    
  endif
  
  if( Write_bav ) then
    write(3,110) Energ_in * Rydb, E_loss * Rydb
    if( n_tr > 1 ) then
      if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
        write(3,'(/A)') ' i_tr Int_RIXS(ipl)' 
      else
        write(3,'(/A)') ' i_tr  i_q i_th  Int_RIXS(ipl,i_q,i_theta)' 
      endif
    else 
      if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
        write(3,'(/A)') ' Int_RIXS(ipl)' 
      else
        write(3,'(/A)') '  i_q i_th  Int_RIXS(ipl,i_q,i_theta)' 
      endif
    endif
    do i_q = 1,n_q_dim
      do i_theta = 1,n_theta_rixs
        do i_tr = 1,n_tr
          if( n_tr > 1 ) then
            if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
              write(3,'(1p,i5,100e13.5)') i_tr, Int_RIXS(:,1,1,i_tr)
            else
              write(3,'(1p,3i5,100e13.5)') i_tr, i_q, i_theta, Int_RIXS(:,i_theta,i_q,i_tr)
            endif
          else
            if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
              write(3,'(1p,100e13.5)') Int_RIXS(:,1,1,i_tr)
            else
              write(3,'(1p,2i5,100e13.5)') i_q, i_theta, Int_RIXS(:,i_theta,i_q,i_tr)
            endif
          endif
        end do
      end do
    end do

  endif

  deallocate( E_inf, E_sup, Energ_e )
    
  return
  110 format(/' ------ Conv_over_energy ----------------------------------------------------------------------------------',// &  
              '  Energ_in =',f13.3,' eV, E_loss =', f13.3,' eV')
  120 format(5i3,1p,10000(1x,2e11.3))
end

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

! Integral over energy to get the RIXS Intensity 

subroutine Conv_over_energy_HERFD(Betalor,E_cut_Rixs,Energ_in,Energ_s,Gamma,Int_RIXS, &
            n_q_dim,n_theta_rixs,nenerg_oc,nenerg_s,nfinalr,ninitr,ninit2,npl,nsym,Secabs_f,Secabs,Shift,Temp,Write_bav)

  use declarations
  implicit none

  integer:: i_q, i_theta, ia, ifinalr, ie, ie_min, index, initr_1, initr_2, je, n_e, n_q_dim, n_theta_rixs, nenerg_e, nenerg_oc, &
    nenerg_s, nfinalr, ninit2, ninitr, npl, nsym

  complex(kind=db):: Cf, Coef_Lorentz
  complex(kind=db), dimension(nenerg_s,npl,ninit2,n_theta_rixs,n_q_dim,nsym,1):: Secabs
  complex(kind=db), dimension(nfinalr,npl,ninit2,n_theta_rixs,n_q_dim,nsym,1):: Secabs_f
   
  logical:: Write_bav
  
  real(kind=db):: Betalor, Cfr, Delta, E_cut_Rixs, Energ_in, Eph_min, Gamma_tot, Step, Temp

  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(ninitr):: Gamma, Shift
  real(kind=db), dimension(npl,n_theta_rixs,n_q_dim,nfinalr):: Int_RIXS

  real(kind=db), dimension(:), allocatable:: Energ_e, E_inf, E_sup

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

  if( Temp > eps10 ) then
    ie_min = 1
  else
    ie_min = nenerg_oc + 1
  endif  
    
  if( nenerg_s > 1 ) then
    Step = max( Energ_s(nenerg_s) - Energ_s(nenerg_s-1), 2._db / Rydb ) 
    Delta = 50 * ( Betalor + max( 2 * Gamma(1), 1._db ) )   ! Gamma hole is already divided by 2
    n_e = nint( Delta / Step )
    Step = Delta / n_e
    nenerg_e = nenerg_s + n_e
  else
    n_e = 0
    nenerg_e = nenerg_s
  endif
  allocate( Energ_e(ie_min:nenerg_e) )
  Energ_e(ie_min:nenerg_s) =  Energ_s(ie_min:nenerg_s)
  do ie = 1,n_e
    Energ_e(nenerg_s+ie) = Energ_s(nenerg_s) + ie * Step 
  end do

! To avoid photon energy < 0 !  
  Eph_min = 0.001_db / Rydb

  allocate( E_inf(ie_min:nenerg_e) )
  allocate( E_sup(ie_min:nenerg_e) )
  
  if( nenerg_e - nenerg_oc == 1 ) then
    E_sup(ie_min) = Energ_e(nenerg_e) + 0.05_db / Rydb
    E_inf(ie_min) = Energ_e(nenerg_e) - 0.05_db / Rydb
  else
    if( Temp > eps10 ) then
      E_inf(ie_min) = 1.5_db * Energ_e(ie_min) - 0.5_db * Energ_e(ie_min+1)
    else
      E_inf(ie_min) = E_cut_Rixs
    endif  
    E_sup(ie_min) = ( Energ_e(ie_min+1) + Energ_e(ie_min) ) / 2
    do ie = ie_min+1,nenerg_e-1
      E_sup(ie) = ( Energ_e(ie+1) + Energ_e(ie) ) / 2
      E_inf(ie) = ( Energ_e(ie-1) + Energ_e(ie) ) / 2
    end do
    E_inf(nenerg_e) = ( Energ_e(nenerg_e-1) + Energ_e(nenerg_e ) ) / 2
    E_sup(nenerg_e) = 1.5_db * Energ_e(nenerg_e) - 0.5_db * Energ_e(nenerg_e-1) 
  endif
  
  index = 0  
  do initr_1 = 1,ninitr
               
    Gamma_tot = Betalor + Gamma(initr_1)

    do initr_2 = 1,ninitr
      index = index + 1
    
      do ie = ie_min, nenerg_e  ! Loop over non occupied electron states

        je = min(nenerg_s,ie)
       
        if( Gamma_tot > eps10 ) then
          Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),Energ_in,Gamma_tot,Shift(initr_1),Temp)
          Cfr = - aimag( Cf ) / Gamma_tot   ! explainations in Conv_over_energy
        elseif( Energ_e(ie) < Energ_in - Shift(initr_1) - eps10 ) then
          cycle
        else
          Cfr = pi
        endif

        do ifinalr = 1,nfinalr
          do ia = 1,nsym
            Int_RIXS(:,:,:,ifinalr) = Int_RIXS(:,:,:,ifinalr) &
                                    + Cfr * real( Secabs_f(ifinalr,:,index,:,:,ia,1) * Secabs(je,:,index,:,:,ia,1), db )
          end do      
        end do
      
        if( Gamma_tot < eps10 ) exit 
        
      end do
    
    end do
  end do ! end of loop on initr
  
  if( Write_bav ) then
    write(3,110) Energ_in * Rydb
    if( nfinalr > 1 ) then
      if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
        write(3,'(/A)') ' i_fi Int_RIXS(ipl)' 
      else
        write(3,'(/A)') ' i_fi  i_q i_th  Int_RIXS(ipl,i_q,i_theta)' 
      endif
    else 
      if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
        write(3,'(/A)') ' Int_RIXS(ipl)' 
      else
        write(3,'(/A)') '  i_q i_th  Int_RIXS(ipl,i_q,i_theta)' 
      endif
    endif
    do i_q = 1,n_q_dim
      do i_theta = 1,n_theta_rixs
        do ifinalr = 1,nfinalr
          if( nfinalr > 1 ) then
            if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
              write(3,'(i5,1p,100e13.5)') ifinalr, Int_RIXS(:,1,1,ifinalr)
            else
              write(3,'(3i5,1p,100e13.5)') ifinalr, i_q, i_theta, Int_RIXS(:,i_theta,i_q,ifinalr)
            endif
          else
            if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
              write(3,'(1p,100e13.5)') Int_RIXS(:,1,1,ifinalr)
            else
              write(3,'(2i5,1p,100e13.5)') i_q, i_theta, Int_RIXS(:,i_theta,i_q,ifinalr)
            endif
          endif
        end do
      end do
    end do

  endif

  deallocate( E_inf, E_sup, Energ_e )
    
  return
  110 format(/' ------ Conv_over_energy_HERFD --------------------------------------------------------------------------',// &  
              '  Energ_in =',f13.3,' eV')
  120 format(5i3,1p,10000(1x,2e11.3))
end

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

! The factor CFac = Delta_E / (  Energ_in(ie_in) - Energ_s(ie) - Shift(initr) + img * Gamma_tot )
! is replaced by the corresponding integral over energy for this energy step
         
function Coef_Lorentz(E_cut_Rixs,E_inf,E_sup,Energ_e,Energ_in,Gamma_tot,Shift,Temp)

  use declarations
  implicit none

  complex(kind=db):: Coef_Lorentz
  
  real(kind=db):: Delta_E_inf, Delta_E_sup, E_cut_Rixs, E_inf, E_sup, Energ_e, Energ_in, F_TM, Gamma_tot, kBT_i, Lorentzian_i, &
                  Lorentzian_r, Shift, Temp

  Delta_E_inf = Energ_in - E_inf - Shift
  Delta_E_sup = Energ_in - E_sup - Shift
              
  if( Gamma_tot > eps10 ) then
    Lorentzian_i = atan( Delta_E_sup / Gamma_tot ) - atan( Delta_E_inf / Gamma_tot )
    Lorentzian_r = - 0.5_db * log( ( Gamma_tot**2 + Delta_E_sup**2 ) / ( Gamma_tot**2 + Delta_E_inf**2 ) )
  else
    if( Delta_E_inf * Delta_E_sup < eps10 ) then
      if( abs( Delta_E_inf + Delta_E_sup ) < eps10 ) then
        Lorentzian_r = 0._db
      elseif( abs( Delta_E_inf ) < eps10 .or. abs( Delta_E_sup ) < eps10 ) then
        Lorentzian_r = - log( 4._db )   ! limitation on divergence
      else
        Lorentzian_r = log( - Delta_E_inf / Delta_E_sup )
      endif
      Lorentzian_i = - pi
    else
      Lorentzian_r = log( Delta_E_inf / Delta_E_sup )
      Lorentzian_i = 0._db
    endif
  endif  

  Coef_Lorentz = cmplx( Lorentzian_r, Lorentzian_i, db ) / pi

! Fermi-Dirac  distribution (to avoid peak at E_F on f')
  if( Temp > eps10 ) then
    kBT_i = 10000 * e_electron * Rydb / ( k_Boltzmann * Temp )
    F_TM = 1 / ( 1 + exp( ( E_cut_Rixs - Energ_e ) * kBT_i ) )
    Coef_Lorentz = Coef_Lorentz * F_TM
  endif
  
  return
  
end
      
!*****************************************************************************************************************

subroutine Check_Moment_conservation(E_i,E_Fermi,E_loss,E_s,Eclie,Eneg,Energ_in,icheck,Int_RIXS,n_q_dim,n_theta_rixs, &
                                     n_trans,npl,nspin,Theta_rixs,V0bdcF)

  use declarations
  implicit none

  integer:: i_theta, i_q, icheck, n_q_dim, n_theta_rixs, n_trans, npl, nspin

  logical:: Eneg, k_not_possible
    
  real(kind=db):: E_Fermi, E_loss, E_i, E_s, Ecinetic_i, Ecinetic_s, Eclie, Energ_in, k_elec_i, k_elec_s,  Mod_Q, Theta, V0
  
  real(kind=db), dimension(nspin):: V0bdcF
  real(kind=db), dimension(n_theta_rixs,2):: Theta_rixs
  real(kind=db), dimension(npl,n_theta_rixs,n_q_dim,n_trans):: Int_RIXS
      
  do i_q = 1,n_q_dim
    do i_theta = 1,n_theta_rixs
      Theta = Theta_rixs(i_theta,1)      
        
      V0 = sum( V0bdcF(:) ) / nspin
      Ecinetic_s = Energ_in - E_loss + E_Fermi - V0
      if( .not. Eneg ) Ecinetic_s = max( Ecinetic_s, Eclie ) 
      k_elec_s = sqrt( Ecinetic_s )
      
      Ecinetic_i = Energ_in + E_Fermi - V0
      if( .not. Eneg ) Ecinetic_i = max( Ecinetic_i, Eclie ) 
      k_elec_i = sqrt( Ecinetic_i )
        
      Mod_Q = 0.5_db * alfa_sf * sqrt( E_s**2 + E_i**2 - 2 * E_s * E_i * cos( pi - Theta_rixs(i_theta,2) ) )
            
      if( k_elec_s + k_elec_i < Mod_Q ) then
        if( icheck > 0 ) Write(3,120) Energ_in*rydb, E_loss*rydb, k_elec_s, '+', k_elec_i, '<', Mod_Q
        k_not_possible = .true.
      endif
      
      if( abs( k_elec_i - k_elec_s ) > Mod_Q ) then
        if( icheck > 0 ) Write(3,130) Energ_in*rydb, E_loss*rydb, k_elec_s, '-', k_elec_i, '>', Mod_Q
        k_not_possible = .true.
      endif
      
      if( k_not_possible ) then
        if( icheck > 0 ) Write(3,'(5x,A)') 'No possible channel at this energy loss'    
        Int_RIXS(:,i_theta,i_q,1) = 0._db
      endif
          
    end do
  end do   

  return
  120 format(5x,'E_unoc =',f10.5,', E_occ =',f10.5,' eV, k_e_s =',f10.5,' ',a1,' k_e_i =',f10.5,' ',a1,' Q =',f10.5)
  130 format(5x,'E_unoc =',f10.5,', E_occ =',f10.5,' eV, abs( k_e_s =',f10.5,' ',a1,' k_e_i =',f10.5,') ',a1,' Q =',f10.5)
end

!******************************************************************************************************************
      
! Indirect process 

Subroutine Indirect_process(alfpot,Analyzer,Betalor,Coef_g,Core_resolved,Delta_Gauss_Rixs,Diag_harm_basis,dV0bdcF,E_cut_Rixs, &
      E_Fermi,Eclie,Eneg,Energ_in,Energ_loss,Energ_s,Eseuil,File_name_rixs,Full_potential, &
      Gamma,Hubb_abs,Hubb_diag_abs,icheck,ie_min,ip0,ip_max,isymeq,Lm1_mult,Lmax,Lmax_mult,Lmax_pot,Lmin_mult,Lmoins1,Lplus1, &
      Lseuil,m_g,m_hubb,M1M1,Moment_conservation,Monocrystal,Multipole_R,multi_run,n_multi_run,n_q_dim, &
      n_theta_rixs,n_trans,natomsym,nbseuil,nenerg_in,nenerg_loss,nenerg_oc,nenerg_s,ninit,ninit1, &
      ninitr,nlm_f,nlm_mult,nlm_p_fp,nlm_pot,nlm_probe,nlms_f,npl,npl_abs,nr,nspin, &
      nspino,nspinp,numat_abs,Pol_i_s_g,Pol_i_p_g,Pol_s_s_g,Pol_s_p_g,Powder,r,Rad_gon,Relativiste, &
      Renorm,Rmtg_abs,Rmtsd_abs,Rot_atom,rsato_abs,rsbdc,Shift,Spinorbite,Tau_abs,Temp,Theta_rixs,V_hubb,V_intmax, &
      V0bdcF,Vcato,Vec_i_g,Vec_s_g,Vhbdc,Volume_maille,VxcbdcF,Vxcato,Ylm_comp)

  use declarations
  implicit none

  integer:: i_trans, icheck, ie_in, ie_loss, ie_min, ie_min_e, ip_max, ip0, ipl, &
    L_hubb, L_hubbard, Lm1_mult, Lmax, Lmax_mult, Lmax_pot, Lmin_mult, Lseuil, m_hubb, multi_run, &
    n_multi_run, n_q_dim, n_theta_rixs, n_trans, n_trans_t, natomsym, nbseuil, &
    nenerg_in, nenerg_loss, nenerg_oc, nenerg_s, ninit, ninit1, ninit2, ninitr, ninitr_dir, ninitr_indir, &
    nlm_f, nlm_mult, nlm_p_fp, nlm_pot, nlm_probe, nlms_f, npl, npl_abs, nr, nsec, nspin, nspino, nspinp, nsym, numat_abs

  integer, dimension(ninit,2):: m_g
  integer, dimension(natomsym):: isymeq
  
  character(len=Length_name), dimension(n_multi_run):: File_name_rixs
  
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb
  complex(kind=db), dimension(nenerg_s,nlm_probe,nlm_p_fp,nspinp,nspino,ip0:ip_max,nbseuil):: Rad_gon
  complex(kind=db), dimension(nenerg_s,nlm_probe,nspinp,nlm_probe,nspinp):: Tau_abs
  complex(kind=db), dimension(nenerg_s,npl,ninitr,n_theta_rixs,n_q_dim,1,n_trans):: Secabs

  complex(kind=db), dimension(:,:,:,:), allocatable:: Tr_gng
  complex(kind=db), dimension(:,:,:,:,:), allocatable:: Tr_gng_t
  complex(kind=db), dimension(:,:,:,:,:,:,:), allocatable:: Secabs_t
  
  logical:: Analyzer, Core_resolved, Diag_harm_basis, E1E1, E1E2, E1E3, E1M1, E2E2, E3E3, Elastic, Eneg, Full_potential, HERFD, &
    Hubb_abs, Hubb_diag_abs, Hubb_not_diag, Indirect, Lmoins1, Lplus1, M1M1, Moment_conservation, Monocrystal, Powder, &
    Relativiste, Renorm, Spinorbite, With_scalar_prod, Write_bav, Ylm_comp

  logical, dimension(13):: Multipole_R

  real(kind=db):: alfpot, Delta_Gauss_Rixs, E_cut_rixs, E_emis, E_Fermi, E_i, E_loss, E_s, Eclie, Rmtg_abs, Rmtsd_abs, &
    rsbdc, Temp, V_intmax, Vhbdc, Volume_maille 

  real(kind=db), dimension(3,3):: Rot_atom
  real(kind=db), dimension(nspin):: dV0bdcF, V0bdcF, VxcbdcF
  real(kind=db), dimension(nenerg_loss):: Energ_loss
  real(kind=db), dimension(nenerg_in):: Betalor, Energ_in
  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(nbseuil):: Eseuil
  real(kind=db), dimension(ninitr):: Gamma, Shift
  real(kind=db), dimension(nr):: r, rsato_abs
!  real(kind=db), dimension(npl_abs):: Xanes
 ! real(kind=db), dimension(npl_abs,n_trans):: Xanes_ind, Xanes_sum
  real(kind=db), dimension(ninit,2):: coef_g
  real(kind=db), dimension(n_theta_rixs,2):: Theta_rixs
  real(kind=db), dimension(nr,nlm_pot):: Vcato
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vxcato
  real(kind=db), dimension(3,n_theta_rixs,n_q_dim):: Pol_i_s_g, Pol_i_p_g, Pol_s_s_g, Pol_s_p_g, Vec_i_g, Vec_s_g

  real(kind=db), dimension(:,:), allocatable:: Trans_coul
  real(kind=db), dimension(:,:,:,:), allocatable:: Int_RIXS
  real(kind=db), dimension(:,:,:,:,:,:), allocatable:: Int_out, Scalar_L

  Indirect = .true.

  E1E1 = Multipole_R(1); E1E2 = Multipole_R(2); E1E3 = Multipole_R(3);
  E1M1 = Multipole_R(4); E2E2 = Multipole_R(6);
  E3E3 = Multipole_R(7); M1M1 = Multipole_R(8)

  allocate( Int_out(nenerg_in,nenerg_loss,npl,n_theta_rixs,n_q_dim,n_trans) )

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

  HERFD = .false.
  With_scalar_prod = .true.
  ninitr_dir = 0
  ninitr_indir = ninitr

  nlms_f = nlm_f * nspinp 

  ie_min_e = 1

  E1E1 = Multipole_R(1); E1E2 = Multipole_R(2); E1E3 = Multipole_R(3);
  E1M1 = Multipole_R(4); E2E2 = Multipole_R(6);
  E3E3 = Multipole_R(7); M1M1 = Multipole_R(8)

  if( Hubb_abs ) then
    L_hubb = L_hubbard( numat_abs )
  else
    L_hubb = - 1
  endif
  Hubb_not_diag = Hubb_abs .and. .not. Hubb_diag_abs  
  
  allocate( Trans_coul(nenerg_loss,ie_min:nenerg_s) ) 
   
  call Coulomb_matrix(alfpot,Diag_harm_basis,dV0bdcF,E_Fermi,Eclie,Eneg,Energ_loss,Energ_s,Full_potential,Hubb_abs, &
         Hubb_diag_abs,icheck,ie_min,Lmax,Lmax_pot,Lseuil,m_hubb,nenerg_loss,nenerg_s, &
         nenerg_oc,nlm_pot,nlm_probe,nr,nspin,nspino,nspinp,numat_abs,r,Relativiste, &
         Renorm,Rmtg_abs,Rmtsd_abs,rsato_abs,rsbdc,Spinorbite,Tau_abs,Trans_coul, &
         V_hubb,V_intmax,V0bdcF,Vcato,Vhbdc,VxcbdcF,Vxcato,Ylm_comp)
  
  Write(6,'(A)') ' Coulomb transitions calculated'

  ninit2 = ninitr

  Write_bav = icheck > 1
  
  if( With_scalar_prod ) then
  
    allocate( Scalar_L(ie_min:nenerg_s,nlm_probe,nspino,nlm_probe,nspino,nspinp) ) 

    call Scalar_product(alfpot,Diag_harm_basis,dV0bdcF,E_Fermi,Eclie,Eneg,Energ_s,Full_potential,Hubb_abs, &
         Hubb_diag_abs,Hubb_not_diag,icheck,ie_min,L_hubb,Lmax,Lmax_pot,m_hubb,nenerg_s,nlm_pot, &
         nlm_probe,nr,nspin,nspino,nspinp,numat_abs,r,Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,rsato_abs, &
         rsbdc,Spinorbite,Scalar_L,V_hubb,V_intmax,V0bdcF,Vcato,Vhbdc,VxcbdcF,Vxcato,Ylm_comp)

    Write(6,'(A)') ' Scalar products calculated'

    allocate( Tr_gng_t(ie_min:nenerg_s,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninitr,n_trans) )

    call Transition_process_indirect(Coef_g,Core_resolved,Diag_harm_basis,Energ_s,Eseuil,Full_potential,Hubb_not_diag,ie_min, &
            ip0,ip_max,L_Hubb,Lm1_mult,Lmax,Lmax_mult,Lmin_mult,Lmoins1,Lplus1,Lseuil,m_g,n_trans,nlm_p_fp,nbseuil,nenerg_s,ninit, &
            ninit1,ninitr,nlm_mult,nlm_probe,nspino,nspinp,Rad_gon,Scalar_L,Spinorbite,Tau_abs,Tr_gng_t,Write_bav,Ylm_comp)

    deallocate( Scalar_L )

  else

    allocate( Tr_gng(ie_min:nenerg_s,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninitr) )

    E_loss = 0._db
    call Transition_process(Coef_g,Core_resolved,Diag_harm_basis,E_cut_Rixs,E_loss,Energ_s,Eseuil,ie_min, &
           ip0,ip_max,Lm1_mult,Lmax,Lmax_mult,Lmin_mult,Lmoins1,Lplus1,Lseuil,m_g,nlm_p_fp,nbseuil,nenerg_oc,nenerg_s, &
           ninit,ninit1,ninit2,nlm_mult,nlm_probe,nspino,nspinp,Rad_gon,Spinorbite,Tau_abs,Tr_gng,Write_bav,Ylm_comp)

    allocate( Tr_gng_t(ie_min:nenerg_s,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninitr,1) )
    Tr_gng_t(:,:,:,:,1) = Tr_gng(:,:,:,:)
    
    deallocate( Tr_gng )

  endif
  Write(6,'(A)') ' Transition process calculated'

  Elastic = .true.
  nsym = 1
  nsec = ninitr
  if( With_scalar_prod ) then
    call Xtal_Tr_pol(E1E1,E2E2,Elastic,Energ_s,ie_min,isymeq,Lm1_mult,Lmax_mult,Lmin_mult,Monocrystal,n_q_dim,n_theta_rixs, &
                  n_trans,natomsym,nenerg_oc,nenerg_s,ninit2,ninitr,nlm_mult,npl,nsec,nsym,Pol_i_s_g,Pol_i_p_g,Pol_s_s_g, &
                  Pol_s_p_g,Rot_atom,Secabs,Theta_rixs,Tr_gng_t,Vec_i_g,Vec_s_g,Write_bav)
  else
    ! false n_trans = 1
    n_trans_t = 1
    allocate( Secabs_t(nenerg_s,npl,ninitr,n_theta_rixs,n_q_dim,1,n_trans_t) )
    call Xtal_Tr_pol(E1E1,E2E2,Elastic,Energ_s,ie_min,isymeq,Lm1_mult,Lmax_mult,Lmin_mult,Monocrystal,n_q_dim,n_theta_rixs, &
                  n_trans_t,natomsym,nenerg_oc,nenerg_s,ninit2,ninitr,nlm_mult,npl,nsec,nsym,Pol_i_s_g,Pol_i_p_g,Pol_s_s_g, &
                  Pol_s_p_g,Rot_atom,Secabs_t,Theta_rixs,Tr_gng_t,Vec_i_g,Vec_s_g,Write_bav)
    do i_trans = 1,n_trans
      Secabs(:,:,:,:,:,1,i_trans) = Secabs_t(:,:,:,:,:,1,1)
    end do
    deallocate( Secabs_t ) 
  endif
  
  deallocate( Tr_gng_t )

  allocate( Int_RIXS(npl,n_theta_rixs,n_q_dim,n_trans) )

! Loop over photon incoming energy      
  do ie_in = 1,nenerg_in  

    write(6,'(/a12,f9.3,a3)') ' Energy in =', Energ_in(ie_in) * Rydb, ' eV'
    if( Monocrystal ) then
      write(6,'(/A)') '    E_Loss     RIXS_s       RIXS_p'
    else
      write(6,'(/A)') '    E_Loss     RIXS_xx      RIXS_yy      RIXS_zz'
    endif

    E_i = Eseuil(nbseuil) + Energ_in(ie_in)

    do ie_loss = 1,nenerg_loss

      E_loss = Energ_loss(ie_loss) 
      if( E_loss < eps10 ) cycle
               
      E_emis = Energ_in(ie_in) - E_loss 

      E_s = Eseuil(nbseuil) + E_emis

      Write_bav = ( icheck > 1 .and. ie_in < 5 .and. ie_loss < 3 ) .or. icheck > 2

      call Conv_over_energy_indirect(Betalor(ie_in),E_cut_Rixs,E_loss,Energ_in(ie_in),Energ_loss,Energ_s,Gamma,ie_loss, &
              ie_min,Int_RIXS,n_q_dim,n_theta_rixs,n_trans,nenerg_loss,nenerg_oc,nenerg_s,ninitr,npl,Secabs,Shift,Temp, &
              Trans_coul,Write_bav)

      if( Moment_conservation ) &
        call Check_Moment_conservation(E_i,E_Fermi,E_loss,E_s,Eclie,Eneg,Energ_in(ie_in),icheck,Int_RIXS,n_q_dim,n_theta_rixs, &
                                     n_trans,npl,nspin,Theta_rixs,V0bdcF)

      Int_out(ie_in,ie_loss,:,:,:,:) = ( E_i / E_s ) * Int_RIXS(:,:,:,:)
      if( Volume_maille > eps10 ) Int_out(ie_in,ie_loss,:,:,:,:) = Int_out(ie_in,ie_loss,:,:,:,:) / Volume_maille


! To convert in Mbarn
!      Xanes_ind(:,:) =  Xanes_ind(:,:) + quatre_pi * alfa_sf * 100 * bohr**2 * Xanes_sum(:,:) / ( 0.5 * E_i )
 
      if( Monocrystal ) then
        write(6,'(f11.3,1p,5e13.5)') Energ_loss(ie_loss) * Rydb, &
                                                sum( Int_out(ie_in,ie_loss,1,1,1,:) ) + sum( Int_out(ie_in,ie_loss,2,1,1,:) ), &
                                                sum( Int_out(ie_in,ie_loss,3,1,1,:) ) + sum( Int_out(ie_in,ie_loss,4,1,1,:) )
      else
        write(6,'(f11.3,1p,5e13.5)') Energ_loss(ie_loss) * Rydb, ( sum( Int_out(ie_in,ie_loss,ipl,1,1,:) ), ipl = 1,3 )
      endif
 
    end do ! end of loop over loss energy, ie_loss

! Gaussian convolution over loss ennergy 
    call Conv_over_loss(Delta_Gauss_Rixs,Energ_loss,ie_in,Int_out,n_theta_rixs,n_trans,n_q_dim,nenerg_in,nenerg_loss,npl)

    call Write_out_RIXS(Analyzer,Energ_loss,Energ_in,File_name_rixs,HERFD,2,Int_out,multi_run,n_multi_run, &
                      n_q_dim,n_theta_rixs,n_trans,nenerg_loss,nenerg_in,npl,Powder)
    
!    call Write_out_Xanes(Energ_in,File_name_rixs,ie_in,multi_run,n_multi_run,n_trans,nenerg_in,npl_abs,Xanes_ind,'ind')

!    write(6,'(/a12,f11.3,1p,10e13.5)' ) ' E_in, XAS =', Energ_in(ie_in)*Rydb, Xanes_ind(npl_abs,:)
    
  end do ! end of loop over incoming beam energy, ie_in
  
  deallocate( Trans_coul )
 
  return
  120 format(5x,'E_unoc =',f10.5,', E_occ =',f10.5,' eV, k_e_s =',f10.5,' ',a1,' k_e_i =',f10.5,' ',a1,' Q =',f10.5)
  130 format(5x,'E_unoc =',f10.5,', E_occ =',f10.5,' eV, abs( k_e_s =',f10.5,' ',a1,' k_e_i =',f10.5,') ',a1,' Q =',f10.5)
end

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

! Calculation of Coulomb interaction matrices
! Output is Trans_coul, dimension [Energy]**2, unit Rydberg**2 

subroutine Coulomb_matrix(alfpot,Diag_harm_basis,dV0bdcF,E_Fermi,Eclie,Eneg,Energ_loss,Energ_s,Full_potential,Hubb_abs, &
         Hubb_diag_abs,icheck,ie_min,Lmax,Lmax_pot,Lseuil,m_hubb,nenerg_loss,nenerg_s, &
         nenerg_oc,nlm_pot,nlm_probe,nr,nspin,nspino,nspinp,numat_abs,r,Relativiste, &
         Renorm,Rmtg_abs,Rmtsd_abs,rsato_abs,rsbdc,Spinorbite,Tau_abs,Trans_coul, &
         V_hubb,V_intmax,V0bdcF,Vcato,Vhbdc,VxcbdcF,Vxcato,Ylm_comp)

  use declarations
  implicit none

  integer:: ich, icheck, ie, ie_loss, ie_min, ie_min_1, ie_oc, ie_step, ie_unoc, &
    ie_unoc_max, iso1, iso12, iso2, iso3, iso4, isp, isp1, isp3, iss1, iss2, iss3, iss4, &
    L, L_hubbard, L_probe, L1, L2, Lm1, Lm2, Lm3, Lm4, Lmax, Lmax_pot, Lmp1, Lmp2, Lmv1, Lmv2, Lp1, Lseuil, m1, m2, &
    m_hubb, mp, mp1, mp2, mv1, mv2, nenerg_oc, nenerg_s, nenerg_loss, nlm_pot, nlm_probe, nlm0, nlm1, nlm2, &
    nr, nspin, nspino, nspinp, numat_abs

  complex(kind=db):: Tr

  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb
  complex(kind=db), dimension(nenerg_s,nlm_probe,nspinp,nlm_probe,nspinp):: Tau_abs

  complex(kind=db), dimension(:,:), allocatable:: Tr_coul, Tr_coul_res, Tr_coul_sum

  logical:: Diag_harm_basis, Ecomp, Eneg, Full_potential, Hubb_abs, Hubb_diag_abs, Hubb_m, m_depend, no_interp, Radial_comp, &
    Relativiste, Renorm, Resonant_state, Spinorbite, Ylm_comp
       
  real(kind=db):: alfpot, E, E_Fermi, E_loss_max, E_oc, Eclie, Eimag, Enervide, f_integr3, Fac, Fac_L, &
    p1, p2, Radial_integral, Rmtg_abs, Rmtsd_abs, rsbdc, V_intmax, Vhbdc

  real(kind=db), dimension(nspin):: dV0bdcF, Ecinetic, V0bdc, V0bdcF, VxcbdcF
  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(nenerg_loss):: Energ_loss
  real(kind=db), dimension(nr):: f, r, r1, r2, rsato_abs, t, t1, t2
  real(kind=db), dimension(nr,nlm_pot):: Vcato
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato, Vxcato
  real(kind=db), dimension(nenerg_loss,ie_min:nenerg_s):: Trans_coul

  real(kind=db), dimension(:), allocatable:: dE
  real(kind=db), dimension(:,:,:,:,:,:), allocatable:: uv_i, uv_r
  real(kind=db), dimension(:,:,:,:,:,:,:), allocatable:: Coulomb_LL

  Trans_coul(:,:) = 0._db
  
  L_probe = Lseuil + 1
  
  ich = max( 0, icheck - 1 )

  if( icheck > 2 ) then
    ie_step = 1
  else
    ie_step = 2
  endif

  E_loss_max = maxval( Energ_loss )

  do ie_oc = nenerg_oc,1,-1
    if( Energ_s(nenerg_oc+1) - Energ_s(ie_oc) > E_loss_max - eps10 ) exit
  end do
  ie_min_1 = max( ie_oc ,1 )

  do ie_unoc = nenerg_oc+1,nenerg_s
    if( Energ_s(ie_unoc) - Energ_s(nenerg_oc) > E_loss_max - eps10 ) exit
  end do
  
  ie_unoc_max = min(ie_unoc,nenerg_s)

  allocate( Coulomb_LL(ie_min_1:nenerg_oc,nenerg_oc+1:ie_unoc_max,nlm_probe,nspino,nlm_probe,nspino,nspinp) )
  
  Coulomb_LL(:,:,:,:,:,:,:) = 0._db

  if( icheck > 1 ) write(3,100)

  r2(1:nr) = r(1:nr)**2

  Eimag = 0._db

  Ecinetic(:) = Enervide - V0bdcF(:)
  if( abs(Eimag) > eps10 .or. Ecinetic(1) < eps10 .or. Ecinetic(nspin) < eps10 ) then
    Ecomp = .true.
  else
    Ecomp = .false.
  endif

  m_depend = Full_potential .or. Hubb_abs .or. Spinorbite
   
  if( m_depend ) then
    nlm1 = ( Lmax + 1 )**2
    nlm0 = 1
  else
    nlm0 = 0
    nlm1 = Lmax
  endif 
  if( Full_potential ) then
    nlm2 = nlm1
  elseif( Hubb_abs .and. .not. Hubb_diag_abs ) then
    nlm2 = nlm1
  else
    nlm2 = 1
  endif

  allocate( uv_i(nr,nlm0:nlm1,nlm2,nspinp,nspino,ie_min_1:ie_unoc_max) )
  allocate( uv_r(nr,nlm0:nlm1,nlm2,nspinp,nspino,ie_min_1:ie_unoc_max) )
  uv_i(:,:,:,:,:,:) = 0._db
  uv_r(:,:,:,:,:,:) = 0._db

  do ie = ie_min_1,ie_unoc_max

    E = Energ_s(ie)   

    call Radial_function(alfpot,dV0bdcF,E,E_Fermi,Eclie,Eimag,Eneg,Enervide,Full_potential,Hubb_abs,Hubb_diag_abs,ich,ie, &
             ie_min_1,Lmax,Lmax_pot,m_depend,m_hubb,ie_unoc_max,nlm_pot,nlm0,nlm1,nlm2,nr,nspin,nspino,nspinp,numat_abs,r, &
             Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,rsato_abs,rsbdc,Spinorbite,uv_i,uv_r,V_hubb,V_intmax,V0bdc,Vcato,Vhbdc, &
             Vrato,Vxcato,VxcbdcF,Ylm_comp)
    
  end do
  
  allocate( dE(ie_min_1:nenerg_oc) )
  
  do ie = ie_min_1,nenerg_oc
    if( ie == 1 ) then
      dE(ie) = Energ_s(2) - Energ_s(1) 
    else
      dE(ie) = 0.5_db * ( Energ_s(ie+1) - Energ_s(ie-1) ) 
    endif
  end do

! Coulomb transition
  do L1 = 0,Lmax

    Fac_L = 8 * pi / ( 2 * L1 + 1 )

    if( Hubb_abs .and. L1 == L_hubbard( numat_abs ) )  then
      Hubb_m = .true.
    else
      Hubb_m = .false.
    endif
    Radial_comp = Ecomp .or. ( ( Hubb_m .or. Full_potential ) .and. Ylm_comp )
 
 ! below contains the multiplications by "r" of "r.dr" in the integral 
    select case(L1)
      case( 0 )
        r1(1:nr) = r(1:nr)
        r2(1:nr) = 1._db
      case( 1 )
        r1(1:nr) = r(1:nr)**2
        r2(1:nr) = 1 / r(1:nr)
      case default
        r1(1:nr) = r(1:nr)**(L1+1)
        r2(1:nr) = r(1:nr)**(-L1)
    end select

    do m1 = -L1,L1
      if( m1 /= 0 .and. .not. m_depend ) cycle 

      Lm1 = L1**2 + L1 + 1 + m1
      
      do L2 = 0,Lmax
      
        if( .not. Full_potential .and. L2 /= L1 ) cycle

        do m2 = -L2,L2
          if( m2 /= 0 .and. .not. m_depend ) cycle 
      
          Lm2 = L2**2 + L2 + 1 + m2
      
          do Lp1 = 0,Lmax
            if( .not. Full_potential .and. Lp1 /= L1 ) cycle
            do mp1 = -Lp1,Lp1
              if( Diag_harm_basis ) then
                if( mp1 /= m1 ) cycle
                Lmp1 = 1
              else
                Lmp1 = Lp1**2 + Lp1 + mp1 + 1    
              endif

! off diagonal term is zero
              Lmp2 = Lmp1
              
              do isp = 1,nspinp

                iso12 = 0
                do iso1 = 1,nspino
                  if( Spinorbite .and. Diag_harm_basis ) then
                    mv1 = mp1 + isp - iso1  ! the m of the Ylm and radial function 
                    if( mv1 > L1 .or. mv1 < -L1 ) cycle
                    Lmv1 = Lm1 + mv1 - m1
                  else
                    mv1 = mp1
                    Lmv1 = Lm1
                  endif
              
                  do iso2 = 1,nspino
              
                    if( Spinorbite .and. Diag_harm_basis ) then
                      mv2 = mp2 + isp - iso2
                      if( mv2 > L2 .or. mv2 < -L2 ) cycle
          ! off diagonal term is zero
                      if( mv2 /= mv1 ) cycle
                      Lmv2 = Lm2 + mv2 - m2
                    else
                      Lmv2 = Lm2
                    endif

                    do ie_oc = ie_min_1, nenerg_oc  ! Loop over occupied electron states

                      Fac = Fac_L * dE(ie_oc)

                      if( m_depend ) then
                        f(1:nr) = r1(1:nr) * uv_r(1:nr,Lm1,Lmp1,isp,iso1,ie_oc)
                      else
                        f(1:nr) = r1(1:nr) * uv_r(1:nr,L1,Lmp1,isp,iso1,ie_oc)
                      endif
      
                      call ffintegr2_r(t1,f,r,nr,1,Rmtsd_abs)
      
                      if( m_depend ) then
                        f(1:nr) = r2(1:nr) * uv_r(1:nr,Lm1,Lmp1,isp,iso1,ie_oc)
                      else
                        f(1:nr) = r2(1:nr) * uv_r(1:nr,L1,1,isp,iso1,ie_oc)
                      endif
     
                      call ffintegr2_r(t2,f,r,nr,-1,Rmtsd_abs)
                      
                      t(1:nr) = r2(1:nr) * t1(1:nr) + r1(1:nr) * t2(1:nr) 

                      do ie_unoc = nenerg_oc+1, ie_unoc_max  ! Loop over non occupied electron states
 
                        if( m_depend ) then
                          f(1:nr) = uv_r(1:nr,Lm2,Lmp2,isp,iso2,ie_unoc) * t(1:nr)
                        else
                          f(1:nr) = uv_r(1:nr,L2,1,isp,iso2,ie_unoc) * t(1:nr)
                        endif
  
                        Radial_integral = f_integr3(r,f,1,nr,Rmtsd_abs)
                        Radial_integral = Fac * Radial_integral

! Coulomb_LL dimension is [Energy], unit is Rydberg, considering Tau without dimension,
!                                                                product of radial function: [L]**2 [Energy]**-1
!                                                                dE(ie_oc): [Energy]
!                                                                Coulomb Hamiltonian: [Energy]    
                        if( m_depend ) then
                          Coulomb_LL(ie_oc,ie_unoc,Lm1,iso1,Lm2,iso2,isp) = Coulomb_LL(ie_oc,ie_unoc,Lm1,iso1,Lm2,iso2,isp) &
                                                                          + Radial_integral
                        else
                          do mp = -L1,L1
                            Coulomb_LL(ie_oc,ie_unoc,Lm1+mp,iso1,Lm1+mp,iso2,isp) = Radial_integral
                          end do                 
                        endif

                      end do  
                    end do   

                  end do ! end of loop over iso2
                end do   ! end of loop over iso1
              end do     ! end of loop over isp

            end do ! end of loop over mp2
          end do   ! end of loop over Lp1
        end do     ! end of loop over mp1
      end do       ! end of loop over Lp1

    end do ! end of loop over m1
  end do   ! end of loop over L

  if( icheck > 2 ) then

    if( m_depend ) then
      write(3,'(/A)') ' Coulomb transition matrix (L1, m1, iso1, L2, m2, iso2, isp)'
      write(3,130) ((((((( L1, m1, iso1, L2, m2, iso2, isp, m1 = -L1,L1 ), L1 = 0,Lmax ), iso1 = 1,nspino ), m2 = -L2,L2 ), &
                                                            L2 = 0,Lmax ),  iso2 = 1,nspino) , isp = 1,nspinp )
    elseif( nspinp == 2 ) then
      write(3,'(/A)') ' Coulomb transition matrix (L, isp)'
      write(3,140) (( L, isp, L = 0,Lmax), isp = 1,nspinp)
    else
      write(3,'(/A)') ' Coulomb transition matrix (L)'
      write(3,150) ( L, L = 0,Lmax )
    endif 
    do ie_oc = 1,nenerg_oc,ie_step
      do ie_unoc = nenerg_oc+1,ie_unoc_max,ie_step
        if( m_depend ) then 
          write(3,160) Energ_s(ie_oc)*rydb, Energ_s(ie_unoc)*rydb, &
                         ((((( Coulomb_LL(ie_oc,ie_unoc,Lm1,iso1,Lm2,iso2,isp), Lm1 = 1,nlm_probe ), Lm2 = 1,nlm_probe ), &
                                                                  iso1 = 1,nspino ), iso2 = 1,nspino ), isp = 1,nspinp )
        else
          write(3,160) Energ_s(ie_oc)*rydb, Energ_s(ie_unoc)*rydb, (( Coulomb_LL(ie_oc,ie_unoc,L**2+L+1,1,L**2+L+1,1,isp), &
                                                                                            L = 0,Lmax), isp = 1,nspinp )
        endif 
      end do
    end do
  endif
   
  deallocate( dE, uv_i, uv_r )

  allocate( Tr_coul(nenerg_loss,ie_unoc_max) )
  allocate( Tr_coul_res(nenerg_loss,ie_min:ie_unoc_max) )
  allocate( Tr_coul_sum(nenerg_loss,ie_min:nenerg_s) )
  Tr_coul(:,:) = ( 0._db, 0._db )
  Tr_coul_res(:,:) = ( 0._db, 0._db )
  Tr_coul_sum(:,:) = ( 0._db, 0._db )
  
! Coulomb matrix transition
  
  do ie_loss = 1,nenerg_loss
  
    if( Energ_loss(ie_loss) < eps10 ) cycle

    Loop_ie_unoc: do ie_unoc = ie_min,ie_unoc_max

      E_oc = Energ_s(ie_unoc) - Energ_loss(ie_loss)
      if( E_oc < Energ_s(1) - eps10 ) cycle       
      if( E_oc > Energ_s(nenerg_oc+1) - eps10 ) exit       

      do ie_oc = 1,nenerg_oc
        if( Energ_s(ie_oc) > E_oc - eps10 ) exit
      end do
      if( ie_oc > nenerg_oc ) cycle

      if( abs( Energ_s(ie_oc) - E_oc ) < eps10 ) then
        no_interp = .true.
      else
        no_interp = .false.
        p1 = ( E_oc - Energ_s(ie_oc-1) ) / ( Energ_s(ie_oc) - Energ_s(ie_oc-1) )
        p2 = 1._db - p1    
      endif       
      
      do isp1 = 1,nspinp
        do Lm1 = 1,nlm_probe

          Resonant_state = .false.
          select case(Lm1)
            case(1)
              if( Lseuil == 1 ) Resonant_state = .true.
            case(2,3,4)
              if( Lseuil == 0 .or. Lseuil == 2 ) Resonant_state = .true.
            case(5,6,7,8,9)
              if( Lseuil == 1 .or. Lseuil == 3 ) Resonant_state = .true.
            case(10,11,12,13,14,15,16)
              if( Lseuil == 2 ) Resonant_state = .true.
          end select

          do iso1 = 1,nspino
            if( Spinorbite ) then
              iss1 = iso1
            else
              iss1 = isp1
            endif
           
            do Lm2 = 1,nlm_probe
              if( .not. Spinorbite .and. Lm1 /= Lm2 ) cycle
              do iso2 = 1,nspino
                if( Spinorbite ) then
                  iss2 = iso2
                else
                  iss2 = isp1
                endif

                do isp3 = 1,nspinp
                  do Lm3 = 1,nlm_probe
                    do iso3 = 1,nspino
                      if( Spinorbite ) then
                        iss3 = iso3
                      else
                        iss3 = isp3
                      endif
                     
                      do Lm4 = 1,nlm_probe
                        if( .not. Spinorbite .and. Lm3 /= Lm4 ) cycle
                        do iso4 = 1,nspino
                          if( Spinorbite ) then
                            iss4 = iso4
                          else
                            iss4 = isp3
                          endif
              
                          if( no_interp ) then         
                            Tr = conjg( Tau_abs(ie_unoc,Lm1,iss1,Lm2,iss2) ) * Tau_abs(ie_oc,Lm3,iss3,Lm4,iss4) &
                                 * Coulomb_LL(ie_oc,ie_unoc,Lm1,iso1,Lm3,iso3,isp1) &
                                 * Coulomb_LL(ie_oc,ie_unoc,Lm2,iso2,Lm4,iso4,isp3)
                          elseif( ie_oc > nenerg_oc )then
                            Tr = p2 * conjg( Tau_abs(ie_unoc,Lm1,iss1,Lm2,iss2) ) * Tau_abs(ie_oc-1,Lm3,iss3,Lm4,iss4) &
                                     * Coulomb_LL(ie_oc-1,ie_unoc,Lm1,iso1,Lm3,iso3,isp1) &
                                     * Coulomb_LL(ie_oc-1,ie_unoc,Lm2,iso2,Lm4,iso4,isp3)
                          else 
                            Tr = p1 * conjg( Tau_abs(ie_unoc,Lm1,iss1,Lm2,iss2) ) * Tau_abs(ie_oc,Lm3,iss3,Lm4,iss4) &
                                    * Coulomb_LL(ie_oc,ie_unoc,Lm1,iso1,Lm3,iso3,isp1) &
                                    * Coulomb_LL(ie_oc,ie_unoc,Lm2,iso2,Lm4,iso4,isp3) &
                               + p2 * conjg( Tau_abs(ie_unoc,Lm1,iss1,Lm2,iss2) ) * Tau_abs(ie_oc-1,Lm3,iss3,Lm4,iss4) &
                                    * Coulomb_LL(ie_oc-1,ie_unoc,Lm1,iso1,Lm3,iso3,isp1) &
                                    * Coulomb_LL(ie_oc-1,ie_unoc,Lm2,iso2,Lm4,iso4,isp3)
                          endif  

                          Tr_coul(ie_loss,ie_unoc) = Tr_coul(ie_loss,ie_unoc) + real( Tr, db )
                          if( Resonant_state ) cycle 
                          Tr_coul_res(ie_loss,ie_unoc) = Tr_coul_res(ie_loss,ie_unoc) + real( Tr, db ) 

                        end do
                      end do
                    end do
                  end do
                end do
              end do
            end do
          end do
        end do
      end do
    end do Loop_ie_unoc
  
  end do ! end of loop over ie_loss

! Total
  do ie_loss = 1,nenerg_loss
    if( Energ_loss(ie_loss) < eps10 ) cycle
    do ie_unoc = ie_min,ie_unoc_max
      Tr_coul_sum(ie_loss,ie_unoc) = sum( Tr_coul(ie_loss,ie_min:ie_unoc-1) )  
      Tr_coul_sum(ie_loss,ie_unoc) = Tr_coul_sum(ie_loss,ie_unoc) + Tr_coul_res(ie_loss,ie_unoc)  
      Tr_coul_sum(ie_loss,ie_unoc) = Tr_coul_sum(ie_loss,ie_unoc) + sum( Tr_coul(ie_loss,ie_unoc+1:ie_unoc_max) )  
    end do
    do ie_unoc = ie_unoc_max+1,nenerg_s
      Tr_coul_sum(ie_loss,ie_unoc) = sum( Tr_coul(ie_loss,ie_min:ie_unoc_max) )  
    end do   
  end do  

  if( icheck > 2 ) then
    write(3,'(/A)') 'Energ_loss Energ_unoc          Tr_coul                 Tr_coul_res                  Tr_coul_sum' 
    do ie_loss = 1,nenerg_loss,ie_step
      if( Energ_loss(ie_loss) < eps10 ) cycle
      do ie_unoc = ie_min,ie_unoc_max,ie_step
        write(3,'(2f10.3,1p,3(1x,2e13.5))') Energ_loss(ie_loss)*Rydb, Energ_s(ie_unoc)*Rydb, Tr_coul(ie_loss,ie_unoc), &
                                                                Tr_coul_res(ie_loss,ie_unoc), Tr_coul_sum(ie_loss,ie_unoc)
      end do
    end do
  endif

  Trans_coul(:,:) = sqrt( abs( Tr_coul_sum(:,:) ) )  
   
! Total

!  do ie_loss = 1,nenerg_loss 

!    if( Energ_loss(ie_loss) < eps10 ) cycle

!    E_lim = Energ_s(nenerg_oc+1) - Energ_loss(ie_loss) - eps10 
!    do ie_oc_1 = 1,nenerg_oc
!      if( Energ_s(ie_oc_1) > E_lim ) exit
!    end do 
    
!    Trans_coul(ie_loss) = sum( abs( Tr_coul(ie_loss,ie_oc_1:nenerg_oc) ) )

!  end do
  
  if( icheck > 1 ) then
    write(3,'(/A)') '  Trans_coul(ie_min:nenerg_s)' 
    write(3,'(/a8,1000f13.3)') ' E_loss',  Energ_s(ie_min:nenerg_s) * rydb
    do ie_loss = 1,nenerg_loss
      if( Energ_loss(ie_loss) < eps10 ) cycle
      write(3,'(f8.3,1p,1000e13.5)') Energ_loss(ie_loss)*Rydb, Trans_coul(ie_loss,:) 
    end do
  endif

  deallocate( Tr_coul, Tr_coul_res, Tr_coul_sum )
     
  return
  100 format(/'---------- Coulomb_matrix ',80('-'))
  130 format(/'        E_p         E     ',1000(1x,2(1x,3i2),i2))
  140 format(/'        E_p         E     ',1000('  L =',i2,', isp =',i2,1x))   
  150 format(/'        E_p         E     ',1000(6x,'L =',i2,6x))
  160 format(2f13.3,1p,1000e17.9)
end

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

subroutine Radial_function(alfpot,dV0bdcF,E,E_Fermi,Eclie,Eimag,Eneg,Enervide,Full_potential,Hubb_abs,Hubb_diag_abs,ich,ie, &
             ie_oc_min,Lmax,Lmax_pot,m_depend,m_hubb,ne_unoc_max,nlm_pot,nlm0,nlm1,nlm2,nr,nspin,nspino,nspinp,numat_abs,r, &
             Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,rsato_abs,rsbdc,Spinorbite,uv_i,uv_r,V_hubb,V_intmax,V0bdc,Vcato,Vhbdc, &
             Vrato,Vxcato,VxcbdcF,Ylm_comp)

  use declarations
  implicit none
  
  integer:: ich, ie, ie_oc_min, iso, isp, L, L_hubbard, Lfin, Lm, Lm1, Lm2, Lmax, Lmax_pot, m_hubb, n1, n2, ne_unoc_max, nlm, &
    nlm_pot, nlm0, nlm1, nlm2, nr, nrmtg, nrmtsd, nspin, nspino, nspinp, numat_abs

  logical:: Ecomp, Eneg, Hubb_abs, Hubb_diag_abs, Hubb_m, Full_potential, m_depend, Radial_comp, Relativiste, Renorm, Spinorbite, &
            Ylm_comp
 
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb
  complex(kind=db), dimension(nspin):: konde 
 
  complex(kind=db), dimension(:,:,:,:), allocatable:: Tau, V

  real(kind=db):: alfpot, E, E_Fermi, Eclie, Eimag, Enervide, Rmtg_abs, Rmtsd_abs, rsbdc, V_intmax, Vhbdc

  real(kind=db), dimension(nspin):: dV0bdcF, Ecinetic, V0bdc, VxcbdcF
  real(kind=db), dimension(nr):: f2, r, rsato_abs
  real(kind=db), dimension(nr,nlm_pot):: Vcato
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato, Vxcato
  real(kind=db), dimension(nr,nspin):: g0, gm, gp
  real(kind=db), dimension(nr,nspino):: gso
  real(kind=db), dimension(nr,nlm0:nlm1,nlm2,nspinp,nspino,ie_oc_min:ne_unoc_max):: uv_i, uv_r

  real(kind=db), dimension(:,:,:,:,:), allocatable:: ui, ur

  if( Full_potential ) then
    nlm = ( Lmax + 1 )**2
  else
    nlm = 1
  endif
  allocate( V(nr,nlm,nlm,nspin) ) 

  Enervide = E + E_Fermi

  call Potex_abs(alfpot,dV0bdcF,Enervide,ich,nlm_pot,nr,nspin,.false.,r,rsato_abs,rsbdc,V_intmax, &
                         V0bdc,Vcato,Vhbdc,Vrato,Vxcato,VxcbdcF)

  Ecinetic(:) = Enervide - V0bdc(:)
  if( .not. Eneg ) Ecinetic(:) = max( Ecinetic(:), Eclie )

  konde(:) = sqrt( cmplx(Ecinetic(:), Eimag,db) )
  
  if( ich > 1 ) then
    if( nspin == 1 ) then
      write(3,110) E*rydb, Ecinetic(:)*rydb, ( V0bdc(:) - E_Fermi )*rydb, real( konde(:) )
    else
      write(3,120) E*rydb, Ecinetic(:)*rydb, ( V0bdc(:) - E_Fermi )*rydb, real( konde(:) )
    endif
  endif

  call mod_V(ich,Lmax,Lmax_pot,nlm,nlm_pot,nr,nrmtg,nrmtsd,nspin,r,Rmtg_abs,Rmtsd_abs,V,V_intmax,V0bdc,Vrato,Ylm_comp)

  call Coef_sch_rad(Enervide,f2,g0,gm,gp,gso,nlm,nr,nspin,nspino,numat_abs,r,Relativiste,Spinorbite,V)
  
  if( abs(Eimag) > eps10 .or. Ecinetic(1) < eps10 .or. Ecinetic(nspin) < eps10 ) then
    Ecomp = .true.
  else
    Ecomp = .false.
  endif
  
  if( Full_potential ) then
    Lfin = 0
  else
    Lfin = Lmax
  endif
  
  do L = 0,Lfin
 
    if( Hubb_abs .and. L == L_hubbard( numat_abs ) )  then
      Hubb_m = .true.
    else
      Hubb_m = .false.
    endif
    Radial_comp = Ecomp .or. ( ( Hubb_m .or. Full_potential ) .and. Ylm_comp )
 
    if( Full_potential ) then
      n1 = nlm    ! = ( Lmax + 1 )**2
      n2 = nlm
    elseif( Hubb_m .and. .not. Hubb_diag_abs ) then
      n1 = 2*L + 1
      n2 = n1
    elseif( Spinorbite .or. Hubb_m ) then
      n1 = 2*L + 1
      n2 = 1
    else
      n1 = 1
      n2 = 1
    endif

    allocate( ui(nr,n1,n2,nspinp,nspino) )
    allocate( ur(nr,n1,n2,nspinp,nspino) )
    allocate( Tau(n1,nspinp,n1,nspinp) )

    call Sch_radial(Ecomp,Eimag,f2,Full_potential,g0,gm,gp,gso,Hubb_abs,Hubb_diag_abs,ich,konde, &
       L,Lmax,m_hubb,nlm,n1,n2,nr,nrmtg,nspin,nspino,nspinp,numat_abs,r,Radial_comp,Relativiste,Renorm,Rmtg_abs, &
       Spinorbite,Tau,ui,ur,V,V_hubb)

    if( Full_potential ) then
      uv_r(:,:,:,:,:,ie) = ur(:,:,:,:,:)
      if( Radial_comp ) uv_i(:,:,:,:,:,ie) = ui(:,:,:,:,:)
    elseif( Hubb_m .and. .not. Hubb_diag_abs ) then
      do isp = 1,nspinp
        do iso = 1,nspino
          do Lm1 = 1,n1
            do Lm2 = 1,n2
              uv_r(:,L**2+Lm1,L**2+Lm2,isp,iso,ie) = ur(:,Lm1,Lm2,isp,iso)
              if( Radial_comp ) uv_i(:,L**2+Lm1,L**2+Lm2,isp,iso,ie) = ui(:,Lm1,Lm2,isp,iso)
            end do
          end do
        end do
      end do
    elseif( Spinorbite .or. Hubb_m ) then
      do Lm = 1,n1
        uv_r(:,L**2+Lm,1,:,:,ie) = ur(:,Lm,1,:,:)
        if( Radial_comp ) uv_i(:,L**2+Lm,1,:,:,ie) = ui(:,Lm,1,:,:)
      end do
    elseif( m_depend ) then  ! Hubbard case with Hubbard_m = .false.
      do Lm = L**2+1,(L+1)**2
        uv_r(:,Lm,Lm,:,:,ie) = ur(:,1,1,:,:)
      end do
    else
      uv_r(:,L,1,:,:,ie) = ur(:,1,1,:,:)
      if( Radial_comp ) uv_i(:,L,1,:,:,ie) = ui(:,1,1,:,:)
    endif

    deallocate( Tau, ui, ur )

  end do   ! end of loop over L

  deallocate( V )
  
  return
  110 format(/' Energ =',f8.3,', Ecinetic =',f8.3,', V0bdc =',f8.3,' eV, konde =',f8.5)
  120 format(/' Energ =',f8.3,', Ecinetic =',2f8.3,', V0bdc =',2f8.3,' eV, konde =',2f8.5)
end

!*****************************************************************************************************************
  
  ! Calculation of the scalar product
  
  subroutine Scalar_product(alfpot,Diag_harm_basis,dV0bdcF,E_Fermi,Eclie,Eneg,Energ_s,Full_potential,Hubb_abs, &
           Hubb_diag_abs,Hubb_not_diag,icheck,ie_min,L_hubb,Lmax,Lmax_pot,m_hubb,nenerg_s,nlm_pot, &
           nlm_probe,nr,nspin,nspino,nspinp,numat_abs,r,Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,rsato_abs, &
           rsbdc,Spinorbite,Scalar_L,V_hubb,V_intmax,V0bdcF,Vcato,Vhbdc,VxcbdcF,Vxcato,Ylm_comp)
  
    use declarations
    implicit none
  
    integer:: ich, icheck, ie, ie_min, iso1, iso2, isp, L, L_hubb, L1, L2, Lm, Lm1, Lm2, Lmax, Lmax_pot, &
      Lmp1, Lmp2, Lms1, Lms2, Lp1, Lp2, m, m_hubb, m1, m2, mp1, mp2, ms1, ms2, nenerg_s, nlm_pot, nlm_probe, nlm0, &
      nlm1, nlm2, nr, nspin, nspino, nspinp, numat_abs
  
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb

  logical:: Diag_harm_basis, Ecomp, Eneg, Full_potential, Hubb_abs, Hubb_diag_abs, Hubb_m, Hubb_not_diag, m_depend, Radial_comp, &
    Relativiste, Renorm, Spinorbite, Ylm_comp
       
  real(kind=db):: alfpot, E, E_Fermi, Eclie, Eimag, Enervide, f_integr3, Integral, &
    Rmtg_abs, Rmtsd_abs, rsbdc, V_intmax, Vhbdc

  real(kind=db), dimension(nspin):: dV0bdcF, Ecinetic, V0bdc, V0bdcF, VxcbdcF
  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(nr):: f, r, r2, rsato_abs
  real(kind=db), dimension(ie_min:nenerg_s):: dE
  real(kind=db), dimension(nr,nlm_pot):: Vcato
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato, Vxcato
  real(kind=db), dimension(ie_min:nenerg_s,nlm_probe,nspino,nlm_probe,nspino,nspinp):: Scalar_L

  real(kind=db), dimension(:,:,:,:,:,:), allocatable:: uv_i, uv_r

  ich = max( icheck-1, 0 )

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

  if( icheck > 1 ) write(3,100)

  m_depend = Full_potential .or. Hubb_abs .or. Spinorbite

  r2(1:nr) = r(1:nr)**2

  Eimag = 0._db
 
  Ecinetic(:) = Enervide - V0bdcF(:)
  if( .not. Eneg ) Ecinetic(:) = max( Ecinetic(:), Eclie )
  
  if( abs(Eimag) > eps10 .or. Ecinetic(1) < eps10 .or. Ecinetic(nspin) < eps10 ) then
    Ecomp = .true.
  else
    Ecomp = .false.
  endif  

  if( m_depend ) then
    nlm1 = ( Lmax + 1 )**2
    nlm0 = 1
  else
    nlm0 = 0
    nlm1 = Lmax
  endif 
  if( Diag_harm_basis ) then
    nlm2 = 1
  else
    nlm2 = nlm1
  endif

  allocate( uv_i(nr,nlm0:nlm1,nlm2,nspinp,nspino,ie_min:nenerg_s) )
  allocate( uv_r(nr,nlm0:nlm1,nlm2,nspinp,nspino,ie_min:nenerg_s) )
  uv_i(:,:,:,:,:,:) = 0._db
  uv_r(:,:,:,:,:,:) = 0._db

  do ie = ie_min,nenerg_s

    E = Energ_s(ie)   

    call Radial_function(alfpot,dV0bdcF,E,E_Fermi,Eclie,Eimag,Eneg,Enervide,Full_potential,Hubb_abs,Hubb_diag_abs,ich,ie, &
             ie_min,Lmax,Lmax_pot,m_depend,m_hubb,nenerg_s,nlm_pot,nlm0,nlm1,nlm2,nr,nspin,nspino,nspinp,numat_abs,r, &
             Relativiste,Renorm,Rmtg_abs,Rmtsd_abs,rsato_abs,rsbdc,Spinorbite,uv_i,uv_r,V_hubb,V_intmax,V0bdc,Vcato,Vhbdc, &
             Vrato,Vxcato,VxcbdcF,Ylm_comp)

  end do

  do ie = ie_min,nenerg_s
    if( ie == 1 ) then
      dE(ie) = Energ_s(2) - Energ_s(1) 
    elseif( ie == nenerg_s ) then
      dE(ie) = Energ_s(ie) - Energ_s(ie-1) 
    else
      dE(ie) = 0.5_db * ( Energ_s(ie+1) - Energ_s(ie-1) ) 
    endif
  end do

  do L1 = 0,Lmax

    Hubb_m = Hubb_not_diag .and. L1 == L_hubb

    Radial_comp = Ecomp .or. ( ( Hubb_m .or. Full_potential ) .and. Ylm_comp )

    do m1 = -L1,L1
   !   the m of the Ylm
      if( m1 /= 0 .and. .not. m_depend ) cycle 
      
      Lm1 = L1**2 + L1 + 1 + m1

      do Lp1 = 0,Lmax
        if( .not. Full_potential .and. Lp1 /= L1 ) cycle
        do mp1 = -Lp1,Lp1
          if( Diag_harm_basis .and. mp1 /= m1 ) cycle
          if( .not. Full_potential .and. .not. Hubb_m .and. mp1 /= m1 ) cycle  
          if( Diag_harm_basis ) then
            Lmp1 = 1
          else
            Lmp1 = Lp1**2 + Lp1 + mp1 + 1    
          endif

          do isp = 1,nspinp

            do iso1 = 1,nspino
              if( Spinorbite .and. Diag_harm_basis ) then
                ms1 = mp1 - isp + iso1  ! the m of the amplitudes and multiple scattering amplitudes 
                if( ms1 > L1 .or. ms1 < -L1 ) cycle
                Lms1 = Lm1 + ms1 - m1
              else
                ms1 = mp1
                if( Diag_harm_basis ) then
                  Lms1 = Lm1
                else
                  Lms1 = Lmp1
                endif 
              endif
      
              L2 = L1 ! scalar product is diagonal in harmonics
              m2 = m1
              Lm2 = Lm1
      
              do Lp2 = 0,Lmax
                if( .not. Full_potential .and. Lp2 /= L2 ) cycle
                do mp2 = -Lp2,Lp2
                  if( Diag_harm_basis .and. mp2 /= m2 ) cycle
                  if( .not. Full_potential .and. .not. Hubb_m .and. mp2 /= m2 ) cycle  
                  if( Diag_harm_basis ) then
                    Lmp2 = 1
                  else
                    Lmp2 = Lp2**2 + Lp2 + mp2 + 1    
                  endif
              
                  do iso2 = 1,nspino
              
                    if( Spinorbite .and. Diag_harm_basis ) then
                      ms2 = mp2 - isp + iso2  ! the one of the amplitudes
                      if( ms2 > L2 .or. ms2 < -L2 ) cycle
                      Lms2 = Lm2 + ms2 - m2
                    else
                      if( Diag_harm_basis ) then
                        Lms2 = Lm2
                      else
                        Lms2 = Lmp2
                      endif 
                    endif

                    do ie = ie_min, nenerg_s  ! Loop over occupied electron states
                  
                      f(1:nr) = r2(1:nr) * uv_r(1:nr,Lm1,Lmp1,isp,iso1,ie) * uv_r(1:nr,Lm2,Lmp2,isp,iso2,ie)

                      Integral = f_integr3(r,f,1,nr,Rmtsd_abs)
                    
                      Integral = dE(ie) * Integral 
            
                      if( m_depend ) then 
                        Scalar_L(ie,Lms1,iso1,Lms2,iso2,isp) = Scalar_L(ie,Lms1,iso1,Lms2,iso2,isp) + Integral
                      else
                        do m = -L1,L1
                          Lm = Lm1 + m
                          Scalar_L(ie,Lm,1,Lm,1,isp) = Integral
                        end do                 
                      endif
                      
                    end do

                  end do

                end do
              end do
            end do
            
          end do
        end do
      end do

    end do
  end do ! end of loop over L
            
  if( icheck > 1 ) then

    if( m_depend ) then
      if( nspino == 1 ) then
        if( nspinp == 1 ) then
          write(3,'(/A)') '  Versus (L1, m1, L2, m2)'
          write(3,130) (((( L1, m1, L2, m2, m1 = -L1,L1), L1 = 0,Lmax), m2 = -L2,L2),  L2 = 0,Lmax)
        else
          write(3,'(/A)') '  Versus (L1, m1, L2, m2, isp)'
          write(3,132) ((((( L1, m1, L2, m2, isp, m1 = -L1,L1), L1 = 0,Lmax), m2 = -L2,L2), L2 = 0,Lmax), isp = 1,nspinp)
        endif
      else
        if( nspinp == 1 ) then
          write(3,'(/A)') '  Versus (L1, m1, iso1, L2, m2, iso2)'
          write(3,134) (((((( L1, m1, iso1, L2, m2, iso2, m1 = -L1,L1), L1 = 0,Lmax), iso1 = 1,nspino), &
                                                       m2 = -L2,L2),  L2 = 0,Lmax), iso2 = 1,nspino)
        else
          write(3,'(/A)') '  Versus (L1, m1, iso1, L2, m2, iso2, isp)'
          write(3,136) ((((((( L1, m1, iso1, L2, m2, iso2, isp, m1 = -L1,L1), L1 = 0,Lmax), iso1 = 1,nspino), &
                                                       m2 = -L2,L2),  L2 = 0,Lmax), iso2 = 1,nspino), isp = 1,nspinp)
        endif
      endif
    elseif( nspinp == 2 ) then
      write(3,'(/A)') '  Versus (L, isp)'
      write(3,140) (( L, isp, L = 0,Lmax), isp = 1,nspinp)
    else
      write(3,'(/A)') '  Versus (L)'
      write(3,150) ( L, L = 0,Lmax )
    endif 
    do ie = ie_min,nenerg_s
      if( m_depend ) then 
        write(3,160) Energ_s(ie)*rydb, ((((( Scalar_L(ie,Lm1,iso1,Lm2,iso2,isp), Lm1 = 1,nlm_probe), iso1 = 1,nspino), &
                                                                Lm2 = 1,nlm_probe), iso2 = 1,nspino), isp = 1,nspinp)
      else
        write(3,160) Energ_s(ie)*rydb, (( Scalar_L(ie,L**2+L+1,1,L**2+L+1,1,isp), L = 0,Lmax), isp = 1,nspinp)
      endif 
    end do
  endif
    
  deallocate( uv_i, uv_r )
    
  return
  100 format(/'---------- Scalar_product ',80('-'))
  130 format(/'      E   ',10000(5x,4i2,4x))
  132 format(/'      E   ',10000(4x,5i2,3x))
  134 format(/'      E   ',10000(3x,6i2,2x))
  136 format(/'      E   ',10000(2x,7i2,1x))
  140 format(/'      E   ',10000('  L =',i2,', isp =',i2,1x))   
  150 format(/'      E   ',10000(6x,'L =',i2,6x))
  160 format(f10.3,1p,10000e17.9)
end

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

! Evaluation of the amplitude of the g - n - g transition (Tr_gng) 

subroutine Transition_process_indirect(Coef_g,Core_resolved,Diag_harm_basis,Energ_s,Eseuil,Full_potential,Hubb_not_diag,ie_min, &
            ip0,ip_max,L_hubb,Lm1_mult,Lmax,Lmax_mult,Lmin_mult,Lmoins1,Lplus1,Lseuil,m_g,n_trans,nlm_p_fp,nbseuil,nenerg_s,ninit, &
            ninit1,ninitr,nlm_mult,nlm_probe,nspino,nspinp,Rad_gon,Scalar_L,Spinorbite,Tau_abs,Tr_gng,Write_bav,Ylm_comp)

  use declarations
  implicit none

  integer:: i_g, i_rank_1, i_rank_2, i_trans, ie, ie_min, initr, ip0, ip_max, ipr, is1, is2, &
    iseuil, iso1, iso2, isp1, isp2, ispp1, ispp2, isping1, isping2, &
    L_hubb, L_mult_1, L_mult_2, L1, L2, Lm_mult_1, Lm_mult_2, Lm1, Lm1_mult, Lm2, Lmax, Lmax_mult, &
    Lmin_mult, Lmp1, Lmp2, Lms1, Lms2, Lp1, Lp2, Lseuil, m_mult_1, &
    m_mult_2, m1, m2, mg1, mg2, mp1, mp2, ms1, ms2, n_trans, nlm_p_fp, nbseuil, &
    nenerg_s, ninit, ninit1, ninitr, nlm_mult, nlm_probe, nspino, nspinp

  integer, dimension(ninit,2), intent(in):: m_g
    
  complex(kind=db):: Cg, f, Gaunt_i, Gaunt_s, Gaunt_xrc, PseudoGaunt_M1

  complex(kind=db), dimension(ie_min:nenerg_s,n_trans):: TST
  complex(kind=db), dimension(ie_min:nenerg_s,Lm1_mult:nlm_mult,Lm1_mult:nlm_mult,ninitr,n_trans):: Tr_gng
  complex(kind=db), dimension(nenerg_s,nlm_probe,nspinp,nlm_probe,nspinp):: Tau_abs
  complex(kind=db), dimension(nenerg_s,nlm_probe,nlm_p_fp,nspinp,nspino,ip0:ip_max,nbseuil):: Rad_gon

  logical:: Core_resolved, Diag_harm_basis, Full_potential, Hubb_not_diag, Lmoins1, Lplus1, Spino, Spinorbite, Ylm_comp, Write_bav  
    
  real(kind=db):: Cg_1, Cg_2, Cgg, Eph_min, Eph

  real(kind=db), dimension(nbseuil):: Eseuil
  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(ninit,2):: Coef_g
  real(kind=db), dimension(ie_min:nenerg_s,nlm_probe,nspino,nlm_probe,nspino,nspinp):: Scalar_L
  real(kind=db), dimension(:,:), allocatable:: Conv_nelec

  if( ip0 == 0 .or. ip_max == 3 ) then
    call write_error
    do ipr = 6,9,3
      write(ipr,'(//A//)') ' Magnetic monopole and electric octupole not yet possible in RIXS !'
    end do
    stop
  endif 

  Tr_gng(:,:,:,:,:) = (0._db, 0._db)
  
  Spino = Spinorbite .and. Diag_harm_basis

! To avoid photon energy < 0 !
  allocate( Conv_nelec(ie_min:nenerg_s,nbseuil) )   
  Eph_min = 0.001_db / Rydb
  do ie = ie_min, nenerg_s  ! Loop over non occupied electron states
    do iseuil = 1,nbseuil
      Eph = max( Eseuil(iseuil) + Energ_s(ie), Eph_min )
      Conv_nelec(ie,iseuil) = 0.5_db * Eph**2
    end do
  end do 

! Loop over core states < g_1 ...  > < ... >
  do i_g = 1,ninit

    if( Core_resolved ) then
      initr = i_g
      if( initr <= ninit1 ) then  
        iseuil = 1
      else
        iseuil = min(2, nbseuil)
      endif
    else
      if( i_g <= ninit1 ) then
        initr = 1
      else
        initr = 2
      endif
      iseuil = min( initr, nbseuil )
    endif
               
! Loop over core state spin < g_1 ...  > < ... >
    do isping1 = 1,2 
      mg1 = m_g(i_g,isping1)
      Cg_1 = Coef_g(i_g,isping1)

      if( abs( Cg_1 ) < eps6 ) cycle

! Loop over core state spin < ...  > < ... g_2 >
      do isping2 = 1,2  
      
        if( Lseuil == 0 .and. isping1 /= isping2 ) cycle

        mg2 = m_g(i_g,isping2)
        Cg_2 = Coef_g(i_g,isping2)

        if( abs( Cg_2 ) < eps6 ) cycle

        Cgg = Cg_1 * Cg_2

        do isp1 = 1,2
! For non magnetic system with spin-orbit 
          ispp1 = min( isp1, nspinp )

          do L1 = 0,Lmax
            if( Lplus1 .and. L1 < Lseuil + 1 ) cycle
            if( Lmoins1 .and. L1 > Lseuil ) cycle
            do m1 = -L1,L1   ! m of the spherical harmonics
              Lm1 = L1**2 + L1 + 1 + m1

              Lmp1 = 0
              do Lp1 = 0,Lmax
                if( .not. Full_potential .and. Lp1 /= L1 ) cycle
                do mp1 = - Lp1,Lp1
                  if( Diag_harm_basis ) then 
                    if( mp1 /= m1 ) cycle
                    Lmp1 = 1
                  else
                    Lmp1 = Lmp1 + 1
                  endif
               
                  do iso1 = 1,nspino
                    if( Spino ) then
                      ms1 = m1 + iso1 - isp1 !  m of the spinor (and multiple scattering amplitude)
                      if( ms1 > L1 .or. ms1 < - L1 ) cycle
                      Lms1 = Lm1 + ms1 - m1
                      is1 = iso1
                    else
                      ms1 = m1
                      Lms1 = Lm1
                      is1 = ispp1
                    endif
                                                        
                        ! incoming side
                    do isp2 = 1,2
                      if( .not. Spinorbite .and. isp1 /= isp2 ) cycle
                      ispp2 = min(isp2,nspinp)
                    
                      do L2 = 0,Lmax
                        if( Lplus1 .and. L2 < Lseuil + 1 ) cycle
                        if( Lmoins1 .and. L2 > Lseuil ) cycle
                        do m2 = -L2,L2 ! m of the spherical harmonics
                          Lm2 = L2**2 + L2 + 1 + m2

                          Lmp2 = 0
                          do Lp2 = 0,Lmax
                            if( .not. Full_potential .and. Lp2 /= L2 ) cycle
                            do mp2 = - Lp2,Lp2
                              if( Diag_harm_basis ) then 
                                if( mp2 /= m2 ) cycle
                                Lmp2 = 1
                              else
                                Lmp2 = Lmp2 + 1
                              endif
                    
                              do iso2 = 1,nspino
                                if( Spino ) then
                                  ms2 = m2 + iso2 - isp2 !  m of the spinor (and multiple scattering amplitude)
                                  if( ms2 > L2 .or. ms2 < - L2 ) cycle
                                  Lms2 = Lm2 + ms2 - m2
                                  is2 = iso2
                                else
                                  ms2 = mp2
                                  Lms2 = Lm2
                                  is2 = ispp2
                                endif

                              call Multipole_Scal(Full_potential,Hubb_not_diag,ie_min,is1,is2,L_hubb,Lmax,Lms1,Lms2,n_trans, &
                                   nenerg_s,nlm_probe,nspino,nspinp,Scalar_L,Spino,Tau_abs,TST)

                              do i_rank_1 = ip0,ip_max
                                 ! Loop over multipole
                                do L_mult_1 = Lmin_mult,Lmax_mult
                                  if( i_rank_1 < 2 .and. L_mult_1 /= 1 ) cycle
                                  if( i_rank_1 == 2 .and. ( L_mult_1 /= 0 .and. L_mult_1 /= 2 ) ) cycle
                                
                                  do m_mult_1 = - L_mult_1,L_mult_1
                                   ! for i_rank_1 == 0, m_mult_1 is fake and means x, y or z
                                    Lm_mult_1 = L_mult_1**2 + L_mult_1 + 1 + m_mult_1
                                    if( L_mult_1 > 0 .and. isping1 /= isp1 ) exit 
                                
                                    if( i_rank_1 == 0 ) then
                                      Gaunt_s = PseudoGaunt_M1(Lp1,mp1,isp1,m_mult_1,Lseuil,mg1,isping1,Ylm_comp,.true.)
                                    else
                                      Gaunt_s = Gaunt_xrc(Lp1,mp1,L_mult_1,m_mult_1,Lseuil,mg1,Ylm_comp)
                                    endif
                                    if( abs(Gaunt_s) < eps10 ) cycle
                      
                                    do i_rank_2 = ip0,ip_max
                               
                                      do L_mult_2 = Lmin_mult,Lmax_mult
                                        if( i_rank_2 < 2 .and. L_mult_2 /= 1 ) cycle
                                        if( i_rank_2 == 2 .and. ( L_mult_2 /= 0 .and. L_mult_2 /= 2 ) ) cycle
                                        if( L_mult_2 > 0 .and. isping2 /= isp2 ) exit 
                                        do m_mult_2 = - L_mult_2,L_mult_2
                                          Lm_mult_2 = L_mult_2**2 + L_mult_2 + 1 + m_mult_2
                                
                                          if( i_rank_2 == 0 ) then
                                            Gaunt_i = PseudoGaunt_M1(Lp2,mp2,isp2,m_mult_2,Lseuil,mg2,isping2,Ylm_comp,.true.)
                                          else
                                            Gaunt_i = Gaunt_xrc(Lp2,mp2,L_mult_2,m_mult_2,Lseuil,mg2,Ylm_comp)
                                          endif
                                          if( abs(Gaunt_i) < eps10 ) cycle
                                  
                                          Cg = Cgg * conjg( Gaunt_s ) * Gaunt_i

                                          do ie = ie_min, nenerg_s  ! Loop over non occupied electron states

                                            f = Cg * Conv_nelec(ie,iseuil) &
                                              * Conjg( Rad_gon(ie,Lm1,Lmp1,ispp1,iso1,i_rank_1,iseuil) ) &
                                              * Rad_gon(ie,Lm2,Lmp2,ispp2,iso2,i_rank_2,iseuil)             

                                            Tr_gng(ie,Lm_mult_1,Lm_mult_2,initr,:) = &
                                                           Tr_gng(ie,Lm_mult_1,Lm_mult_2,initr,:) + f * TST(ie,:)            
                                          
                                          end do
                                        
                                        end do ! end of loop on m_mult_2
                                      end do   ! end of loop on L_mult_2
                                    end do     ! end of loop on i_rank_2

                                  end do  ! end of loop on m_mult_1
                                end do    ! end of loop on L_mult_1
                              end do      ! end of loop on i_rank_1
                
                              end do ! end of loop on iso2
                            end do   ! end of loop on mp2
                          end do     ! end of loop on Lp2
                        end do       ! end of loop on m2
                      end do         ! end of loop on L2
                    end do           ! end of loop on isp2
                        
                  end do ! end of loop on iso1 
                end do   ! end of loop on mp1
              end do     ! end of loop on Lp1
            end do       ! end of loop on m1
            if( n_trans > 2 ) write(6,'(a11,3i2)') ' L1, isp1 =' , L1, isp1
          end do         ! end of loop on L1               
        end do           ! end of loop on isp1
        if( n_trans > 2 ) write(6,'(/a20,3i2)') ' i_g, ispg1, ispg2 =' , i_g, isping1, isping2
      end do    ! end of loop on isping2
    end do      ! end of loop on isping1
    
    write(6,'(a6,i2,a2,i2)') ' i_g =' , i_g, ' /', ninit 
  end do ! end of loop over i_g
  
  deallocate( Conv_nelec )
  
  if( Write_bav ) then
    write(3,'(/A)') ' ----- Transition Process indirect ------------------------------------------------------------------------'
    write(3,'(/A)') ' Transition matrix(L1,m1,L2,m2,initr,i_trans)' 
    write(3,110) '    Energy', (((((( L_mult_1, m_mult_1, L_mult_2, m_mult_2, initr, i_trans, m_mult_2 = - L_mult_2, L_mult_2 ), &
                                         L_mult_2 = Lmin_mult, Lmax_mult), m_mult_1 = - L_mult_1, L_mult_1 ), &
                                         L_mult_1 = Lmin_mult, Lmax_mult), initr = 1,ninitr ), i_trans = 1,n_trans ) 
    do ie = ie_min,nenerg_s
      write(3,120) Energ_s(ie)*rydb, ((( Tr_gng(ie,Lm_mult_1,:,initr,i_trans), Lm_mult_1 = Lm1_mult,nlm_mult ), &
                                                                             initr = 1,ninitr ), i_trans = 1,n_trans )
    end do
  endif
    
  return
  110 format(/a10,500(6x,2i2,1x,2i2,i3,i2,7x))
  120 format(f10.3,1p,1000(1x,2e13.5))
end

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

subroutine Multipole_Scal(Full_potential,Hubb_not_diag,ie_min,is1,is2,L_hubb,Lmax,Lms1,Lms2,n_trans, &
                                   nenerg_s,nlm_probe,nspino,nspinp,Scalar_L,Spino,Tau_abs,TST)

  use declarations
  implicit none

  integer:: ie_min, is_L1, is_L2, is_L3, is_L4, is_R1, is_R2, is_R3, is_R4, is1, is2, &
    iso_L1, iso_L2, iso_L3, iso_L4, iso_R1, iso_R2, iso_R3, iso_R4, isp_1, isp_11, &
    isp_2, isp_22, isp_3, isp_33, isp_4, isp_44, L_1, L_2, L_3, L_4, L_hubb, L_L1, L_L2, L_L3, L_L4, L_R1, L_R2, L_R3, L_R4, &
    Lm_L1, Lm_L2, Lm_L3, Lm_L4, Lm_R1, Lm_R2, Lm_R3, Lm_R4, Lm0_1, Lm0_2, Lm0_3, Lm0_4, Lm0_L1, Lm0_L2, Lm0_L3, Lm0_L4, &
    Lm0_R1, Lm0_R2, Lm0_R3, Lm0_R4, Lms_1, Lms_2, Lms_3, Lms_4, &
    m_1, m_2, m_3, m_4, m_L1, m_L2, m_L3, m_L4, m_R1, m_R2, m_R3, m_R4, &
    Lmax, Lms1, Lms2, n_trans, nenerg_s, nlm_probe, nspino, nspinp

  complex(kind=db), dimension(ie_min:nenerg_s):: Tau_S_1, Tau_S_1_Tau, Tau_S_2, Tau_S_2_Tau, Tau_S_3, Tau_S_3_Tau, Tau_S_4
  complex(kind=db), dimension(ie_min:nenerg_s,n_trans):: TST
  complex(kind=db), dimension(nenerg_s,nlm_probe,nspinp,nlm_probe,nspinp):: Tau_abs
  
  logical:: Full_potential, Hubb_not_diag, Spino

  real(kind=db), dimension(ie_min:nenerg_s,nlm_probe,nspino,nlm_probe,nspino,nspinp):: Scalar_L

  TST(:,:) = ( 0._db, 0._db )
  
  if( Spino ) then
    
! left side of scalar product 
    do L_L1 = 0,Lmax
      Lm0_L1 = L_L1**2 + L_L1 + 1
      do m_L1 = - L_L1,L_L1  
        Lm_L1 = Lm0_L1 + m_L1
        do isp_1 = 1,2
          isp_11 = min( isp_1, nspinp )
          do iso_L1 = 1,nspino
          
    ! right side of scalar product          
            L_R1 = L_L1
            Lm0_R1 = Lm0_L1    
            do m_R1 = - L_R1,L_R1  
              Lm_R1 = Lm0_R1 + m_R1
              do iso_R1 = 1,nspino
                
                Tau_S_1(ie_min:nenerg_s) = Tau_abs(ie_min:nenerg_s,Lms1,is1,Lm_L1,iso_L1) &
                                         * Scalar_L(ie_min:nenerg_s,Lm_L1,iso_L1,Lm_R1,iso_R1,isp_11)
      ! i_trans = 1
                TST(ie_min:nenerg_s,1) = TST(ie_min:nenerg_s,1) + Tau_S_1(ie_min:nenerg_s) &
                                                                * Tau_abs(ie_min:nenerg_s,Lm_R1,iso_R1,Lms2,is2)
                
                if( n_trans == 1 ) cycle

  ! left side of second scalar product 
                do L_L2 = 0,Lmax
                  Lm0_L2 = L_L2**2 + L_L2 + 1
                  do m_L2 = - L_L2,L_L2  
                    Lm_L2 = Lm0_L2 + m_L2
                    do isp_2 = 1,2
                      isp_22 = min( isp_2, nspinp )
                      do iso_L2 = 1,nspino
                      
                        Tau_S_1_Tau(ie_min:nenerg_s) = Tau_S_1(ie_min:nenerg_s) * Tau_abs(ie_min:nenerg_s,Lm_R1,iso_R1,Lm_L2,iso_L2)
                      
                        L_R2 = L_L2
                        Lm0_R2 = Lm0_L2
                        do m_R2 = - L_R2,L_R2  ! of the harmonics
                          Lm_R2 = Lm0_R2 + m_R2
                          do iso_R2 = 1,nspino
                        
                            Tau_S_2(ie_min:nenerg_s) = Tau_S_1_Tau(ie_min:nenerg_s) &
                                                     * Scalar_L(ie_min:nenerg_s,Lm_L2,iso_L2,Lm_R2,iso_R2,isp_22)
                        
      ! i_trans = 2     
                            TST(ie_min:nenerg_s,2) = TST(ie_min:nenerg_s,2) &
                                                   + Tau_S_2(ie_min:nenerg_s) * Tau_abs(ie_min:nenerg_s,Lm_R2,iso_R2,Lms2,is2)
                        
                            if( n_trans == 2 ) cycle
  
  ! left side of third scalar product 
                            do L_L3 = 0,Lmax
                              Lm0_L3 = L_L3**2 + L_L3 + 1
                              do m_L3 = - L_L3,L_L3  ! of the harmonics
                                Lm_L3 = Lm0_L3 + m_L3
                                do isp_3 = 1,2
                                  isp_33 = min( isp_3, nspinp )
                                  do iso_L3 = 1,nspino
                                  
                                    Tau_S_2_Tau(ie_min:nenerg_s) = Tau_S_2(ie_min:nenerg_s) &
                                                                 * Tau_abs(ie_min:nenerg_s,Lm_R2,iso_R2,Lm_L3,iso_L3)
                                  
                                    L_R3 = L_L3
                                    Lm0_R3 = Lm0_L3
                                    do m_R3 = - L_R3,L_R3  ! of the harmonics
                                      Lm_R3 = Lm0_R3 + m_R3
                                      do iso_R3 = 1,nspino
                                    
                                        Tau_S_3(ie_min:nenerg_s) = Tau_S_2_Tau(ie_min:nenerg_s) &
                                                                 * Scalar_L(ie_min:nenerg_s,Lm_L3,iso_L3,Lm_R3,iso_R3,isp_33)
                                    
                                 ! i_trans = 3     
                                        TST(ie_min:nenerg_s,3) = TST(ie_min:nenerg_s,3) + Tau_S_3(ie_min:nenerg_s) &
                                                                 * Tau_abs(ie_min:nenerg_s,Lm_R3,iso_R3,Lms2,is2)
                                    
                                        if( n_trans == 3 ) cycle
  
                             ! left side of fourth scalar product 
                                        do L_L4 = 0,Lmax
                                          Lm0_L4 = L_L4**2 + L_L4 + 1
                                          do m_L4 = - L_L4,L_L4  ! of the harmonics
                                            Lm_L4 = Lm0_L4 + m_L4
                                            do isp_4 = 1,2
                                              isp_44 = min( isp_4, nspinp )
                                              do iso_L4 = 1,nspino
                                              
                                                Tau_S_3_Tau(ie_min:nenerg_s) = Tau_S_3(ie_min:nenerg_s) &
                                                                             * Tau_abs(ie_min:nenerg_s,Lm_R3,iso_R3,Lm_L4,iso_L4)
                                              
                                                L_R4 = L_L4
                                                Lm0_R4 = Lm0_L4
                                                do m_R4 = - L_R4,L_R4  ! of the harmonics
                                                  Lm_R4 = Lm0_R4 + m_R4
                                                  do iso_R4 = 1,nspino
                                                
                                                    Tau_S_4(ie_min:nenerg_s) = Tau_S_3_Tau(ie_min:nenerg_s) &
                                                                     * Scalar_L(ie_min:nenerg_s,Lm_L4,iso_L4,Lm_R4,iso_R4,isp_44)
                                                
                              ! i_trans = 4     
                                                    TST(ie_min:nenerg_s,4) = TST(ie_min:nenerg_s,4) + Tau_S_4(ie_min:nenerg_s) &
                                                                           * Tau_abs(ie_min:nenerg_s,Lm_R4,iso_R4,Lms2,is2)
                                                
                                                    if( n_trans == 4 ) cycle
                                        
                                                  end do
                                                end do
                                              end do
                                            end do
                                          end do
                                        end do ! end of loop over L_L4
                            
                                      end do
                                    end do
                                  end do
                                end do
                              end do
                            end do ! end of loop over L_L3
                            
                          end do
                        end do
                      end do
                    end do
                  end do
                end do ! end of loop over L_L2
  
              end do
            end do
          end do
        end do
      end do
    end do ! end of loop over L_L1

  elseif( Full_potential .or. Hubb_not_diag ) then

! left side of scalar product 
    do L_L1 = 0,Lmax
      Lm0_L1 = L_L1**2 + L_L1 + 1 
      do m_L1 = - L_L1,L_L1 
        Lm_L1 = Lm0_L1 + m_L1
        do isp_1 = 1,2
          isp_11 = min( isp_1, nspinp )
          do iso_L1 = 1,nspino
          
            if( nspino == 2 ) then
              is_L1 = iso_L1
            else
              is_L1 = isp_11
            endif    
            
    ! right side of scalar product          
            do L_R1 = 0,Lmax
              if( .not. Full_potential .and. L_R1 /= L_L1 ) cycle 
              Lm0_R1 = L_R1**2 + L_R1 + 1 
              do m_R1 = - L_R1,L_R1
                if( .not. Full_potential .and. L_R1 /= L_hubb .and. m_R1 /= m_L1 ) cycle 
                Lm_R1 = Lm0_R1 + m_R1

                do iso_R1 = 1,nspino
              
                  if( nspino == 2 ) then
                    is_R1 = iso_R1
                  else
                    is_R1 = isp_11
                  endif
                
                  Tau_S_1(ie_min:nenerg_s) = Tau_abs(ie_min:nenerg_s,Lms1,is1,Lm_L1,is_L1) &
                                           * Scalar_L(ie_min:nenerg_s,Lm_L1,iso_L1,Lm_R1,iso_R1,isp_11)
      ! i_trans = 1
                  TST(ie_min:nenerg_s,1) = TST(ie_min:nenerg_s,1) + Tau_S_1(ie_min:nenerg_s) &
                                                                  * Tau_abs(ie_min:nenerg_s,Lm_R1,is_R1,Lms2,is2)
                
                  if( n_trans == 1 ) cycle

  ! left side of second scalar producf 
                  do L_L2 = 0,Lmax
                    Lm0_L2 = L_L2**2 + L_L2 + 1 
                    do m_L2 = - L_L2,L_L2  ! of the harmonics
                      Lm_L2 = Lm0_L2 + m_L2
                      do isp_2 = 1,2
                        isp_22 = min( isp_2, nspinp )
                        do iso_L2 = 1,nspino
                      
                          if( nspino == 2 ) then
                            is_L2 = iso_L2
                          else
                            is_L2 = isp_22
                          endif    
  
                          Tau_S_1_Tau(ie_min:nenerg_s) = Tau_S_1(ie_min:nenerg_s) &
                                                       * Tau_abs(ie_min:nenerg_s,Lm_R1,is_R1,Lm_L2,is_L2)
                      
    ! right side of scalar product          
                          do L_R2 = 0,Lmax
                            if( .not. Full_potential .and. L_R2 /= L_L2 ) cycle 
                            Lm0_R2 = L_R2**2 + L_R2 + 1 
                            do m_R2 = - L_R2,L_R2  ! of the harmonics
                              if( .not. Full_potential .and. L_R2 /= L_hubb .and. m_R2 /= m_L2 ) cycle 
                              Lm_R2 = Lm0_R2 + m_R2
                            
                              do iso_R2 = 1,nspino
                        
                                if( nspino == 2 ) then
                                  is_R2 = iso_R2
                                else
                                  is_R2 = isp_22
                                endif    
                            
                                Tau_S_2(ie_min:nenerg_s) = Tau_S_1_Tau(ie_min:nenerg_s) &
                                                         * Scalar_L(ie_min:nenerg_s,Lm_L2,iso_L2,Lm_R2,iso_R2,isp_22)
                        
                          ! i_trans = 2     
                                TST(ie_min:nenerg_s,2) = TST(ie_min:nenerg_s,2) &
                                                       + Tau_S_2(ie_min:nenerg_s) * Tau_abs(ie_min:nenerg_s,Lm_R2,is_R2,Lms2,is2)
                        
                                if( n_trans == 2 ) cycle
  
  ! left side of third scalar product 
                                do L_L3 = 0,Lmax
                                  Lm0_L3 = L_L3**2 + L_L3 + 1 
                                  do m_L3 = - L_L3,L_L3  ! of the harmonics
                                    Lm_L3 = Lm0_L3 + m_L3
                                    do isp_3 = 1,2
                                      isp_33 = min( isp_3, nspinp )
                                      do iso_L3 = 1,nspino
                                  
                                        if( nspino == 2 ) then
                                          is_L3 = iso_L3
                                        else
                                          is_L3 = isp_33
                                        endif    

                                        Tau_S_2_Tau(ie_min:nenerg_s) = Tau_S_2(ie_min:nenerg_s) &
                                                                     * Tau_abs(ie_min:nenerg_s,Lm_R2,is_R2,Lm_L3,is_L3)
                                  
    ! right side of scalar product          
                                        do L_R3 = 0,Lmax
                                          if( .not. Full_potential .and. L_R3 /= L_L3 ) cycle 
                                          Lm0_R3 = L_R3**2 + L_R3 + 1 
                                          do m_R3 = - L_R3,L_R3  ! of the harmonics
                                            if( .not. Full_potential .and. L_R3 /= L_hubb .and. m_R3 /= m_L3 ) cycle 
                                            Lm_R3 = Lm0_R3 + m_R3
                                         
                                            do iso_R3 = 1,nspino
                                    
                                              if( nspino == 2 ) then
                                                is_R3 = iso_R3
                                              else
                                                is_R3 = isp_33
                                              endif    
                                        
                                              Tau_S_3(ie_min:nenerg_s) = Tau_S_2_Tau(ie_min:nenerg_s) &
                                                                       * Scalar_L(ie_min:nenerg_s,Lm_L3,iso_L3,Lm_R3,iso_R3,isp_33)  
                                    
                                 ! i_trans = 3     
                                              TST(ie_min:nenerg_s,3) = TST(ie_min:nenerg_s,3) + Tau_S_3(ie_min:nenerg_s)&
                                                                     * Tau_abs(ie_min:nenerg_s,Lm_R3,is_R3,Lms2,is2)
                                    
                                              if( n_trans == 3 ) cycle
  
  ! left side of fourth scalar product 
                                              do L_L4 = 0,Lmax
                                                Lm0_L4 = L_L4**2 + L_L4 + 1 
                                                do m_L4 = - L_L4,L_L4  ! of the harmonics
                                                  Lm_L4 = Lm0_L4 + m_L4
                                                  do isp_4 = 1,2
                                                    isp_44 = min( isp_4, nspinp )
                                                    do iso_L4 = 1,nspino
                                              
                                                      if( nspino == 2 ) then
                                                        is_L4 = iso_L4
                                                      else
                                                        is_L4 = isp_44
                                                      endif    
  
                                                      Tau_S_3_Tau(ie_min:nenerg_s) = Tau_S_3(ie_min:nenerg_s) &
                                                                               * Tau_abs(ie_min:nenerg_s,Lm_R3,is_R3,Lm_L4,is_L4)
                                              
                                 ! right side of scalar product          
                                                      do L_R4 = 0,Lmax
                                                        if( .not. Full_potential .and. L_R4 /= L_L4 ) cycle 
                                                        Lm0_R4 = L_R4**2 + L_R4 + 1 
                                                        do m_R4 = - L_R4,L_R4  ! of the harmonics
                                                          if( .not. Full_potential .and. L_R4 /= L_hubb .and. m_R4 /= m_L4 ) cycle 
                                                          Lm_R4 = Lm0_R4 + m_R4
                                                          
                                                          do iso_R4 = 1,nspino
                                                
                                                            if( nspino == 2 ) then
                                                              is_R4 = iso_R4
                                                            else
                                                              is_R4 = isp_44
                                                            endif    
                                                           
                                                            Tau_S_4(ie_min:nenerg_s) = Tau_S_3_Tau(ie_min:nenerg_s) &
                                                                      * Scalar_L(ie_min:nenerg_s,Lm_L4,iso_L4,Lm_R4,iso_R4,isp_44)
                                                
                              ! i_trans = 4     
                                                            TST(ie_min:nenerg_s,4) = TST(ie_min:nenerg_s,4) &
                                                                      + Tau_S_4(ie_min:nenerg_s) &
                                                                      * Tau_abs(ie_min:nenerg_s,Lm_R4,is_R4,Lms2,is2)
                                                
                                                            if( n_trans == 4 ) cycle
                                        
                                                          end do
                                                        end do
                                                      end do
                                                    end do
                                                  end do
                                                end do
                                              end do ! end of loop over L_L4
                                              
                                            end do
                                          end do
                                        end do 
                                      end do
                                    end do
                                  end do
                                end do ! end of loop over L_L3
                                
                              end do
                            end do 
                          end do
                        end do
                      end do
                    end do
                  end do ! end of loop over L_L2
                  
                end do 
              end do
            end do
          end do
        end do
      end do
    end do ! end of loop over L_L1

  else

    do L_1 = 0,Lmax
      Lm0_1 = L_1**2 + L_1 + 1 
      do m_1 = - L_1,L_1  ! of the harmonics
        Lms_1 = Lm0_1 + m_1
          
        Tau_S_1(ie_min:nenerg_s) = Tau_abs(ie_min:nenerg_s,Lms1,is1,Lms_1,is1) * Scalar_L(ie_min:nenerg_s,Lms_1,1,Lms_1,1,is1)
                
      ! i_trans = 1
        TST(ie_min:nenerg_s,1) = TST(ie_min:nenerg_s,1) + Tau_S_1(ie_min:nenerg_s) * Tau_abs(ie_min:nenerg_s,Lms_1,is1,Lms2,is2)
                
        if( n_trans == 1 ) cycle

        do L_2 = 0,Lmax
          Lm0_2 = L_2**2 + L_2 + 1 
          do m_2 = - L_2,L_2  ! of the harmonics
            Lms_2 = Lm0_2 + m_2
              
            Tau_S_2(ie_min:nenerg_s) = Tau_S_1(ie_min:nenerg_s) * Tau_abs(ie_min:nenerg_s,Lms_1,is1,Lms_2,is1) &
                                                                * Scalar_L(ie_min:nenerg_s,Lms_2,1,Lms_2,1,is1)
                    
          ! i_trans = 2
            TST(ie_min:nenerg_s,2) = TST(ie_min:nenerg_s,2) + Tau_S_2(ie_min:nenerg_s) * Tau_abs(ie_min:nenerg_s,Lms_2,is1,Lms2,is2)
                    
            if( n_trans == 2 ) cycle
  
            do L_3 = 0,Lmax
              Lm0_3 = L_3**2 + L_3 + 1 
              do m_3 = - L_3,L_3  ! of the harmonics
                Lms_3 = Lm0_3 + m_3
                  
                Tau_S_3(ie_min:nenerg_s) = Tau_S_2(ie_min:nenerg_s) * Tau_abs(ie_min:nenerg_s,Lms_2,is1,Lms_3,is1) &
                                         * Scalar_L(ie_min:nenerg_s,Lms_3,1,Lms_3,1,is1)
                        
              ! i_trans = 3
                TST(ie_min:nenerg_s,3) = TST(ie_min:nenerg_s,3) + Tau_S_3(ie_min:nenerg_s) &
                                                                * Tau_abs(ie_min:nenerg_s,Lms_3,is1,Lms2,is2)
                        
                if( n_trans == 3 ) cycle
      
                 do L_4 = 0,Lmax
                  Lm0_4 = L_4**2 + L_4 + 1 
                  do m_4 = - L_4,L_4  ! of the harmonics
                    Lms_4 = Lm0_4 + m_4
                      
                    Tau_S_4(ie_min:nenerg_s) = Tau_S_3(ie_min:nenerg_s) * Tau_abs(ie_min:nenerg_s,Lms_3,is1,Lms_4,is1) &
                                                                        * Scalar_L(ie_min:nenerg_s,Lms_4,1,Lms_4,1,is1)
                            
                  ! i_trans = 4
                    TST(ie_min:nenerg_s,4) = TST(ie_min:nenerg_s,4) + Tau_S_4(ie_min:nenerg_s) &
                                                                    * Tau_abs(ie_min:nenerg_s,Lms_4,is1,Lms2,is2)
                            
                    if( n_trans == 4 ) cycle
        
                  end do
                end do
     
              end do
            end do

  
          end do
        end do

      end do
    end do

  endif
    
  return
end
  
!*****************************************************************************************************************

! Integral over energy to get the RIXS Intensity in the indirect mode, with multiplication by the coulomb matrices 
! Must not be multiplied by dE_loss, because Trans_coul dimension is [Energy]**2

subroutine Conv_over_energy_indirect(Betalor,E_cut_Rixs,E_loss,Energ_in,Energ_loss,Energ_s,Gamma,ie_loss, &
              ie_min,Int_RIXS,n_q_dim,n_theta_rixs,n_trans,nenerg_loss,nenerg_oc,nenerg_s,ninitr,npl,Secabs,Shift,Temp, &
              Trans_coul,Write_bav)

  use declarations
  implicit none

  real(kind=db), parameter:: Third = 1._db / 3._db
  real(kind=db), parameter:: Sqrt_3 = sqrt( Third )
  
  integer:: i_q, i_theta, i_trans, ie, ie_loss, ie_loss_1, ie_loss_2, ie_loss_3, ie_loss_4, ie_min, initr, je, n_e, n_q_dim, &
    n_theta_rixs, n_trans, nenerg_e, nenerg_loss, nenerg_oc, nenerg_s, ninitr, npl

  complex(kind=db):: Cf, Coef_Lorentz
  complex(kind=db), dimension(npl,n_theta_rixs,n_q_dim):: Amplitude
  complex(kind=db), dimension(nenerg_s,npl,ninitr,n_theta_rixs,n_q_dim,1,n_trans):: Secabs

  logical:: Dif_E12, Dif_E13, Dif_E14, Dif_E23, Dif_E24, Dif_E34, Eq_E12, Eq_E13, Eq_E14, Eq_E23, Eq_E24, Eq_E34, Write_bav
  
  real(kind=db):: Betalor, Delta, Delta_E, Delta_loss, E, E_cut_Rixs, E_in_minus_S, E_loss, E_loss_1_2, E_loss_1_2_3, &
      Energ_in, Eph_min, Gamma_tot, p1, Step, Temp

  real(kind=db), dimension(nenerg_s):: Energ_s
  real(kind=db), dimension(ninitr):: Gamma, Shift
  real(kind=db), dimension(nenerg_loss):: Energ_loss
  real(kind=db), dimension(n_trans):: E_mloss
  real(kind=db), dimension(ie_min:nenerg_s):: Tr_coul
  real(kind=db), dimension(nenerg_loss,ie_min:nenerg_s):: Trans_coul
  real(kind=db), dimension(npl,n_theta_rixs,n_q_dim,n_trans):: Int_RIXS

  real(kind=db), dimension(:), allocatable:: Energ_e, E_inf, E_sup

  Int_RIXS(:,:,:,:) = 0._db
  
  if( nenerg_loss > 1 ) Delta_loss = Energ_loss(2) - Energ_loss(1)
    
  if( nenerg_s > 1 ) then
    Step = max( Energ_s(nenerg_s) - Energ_s(nenerg_s-1), 2._db / Rydb ) 
    Delta = Betalor + max( 2 * Gamma(1), 1._db )   ! Gamma hole is already divided by 2
    n_e = nint( Delta / Step )
    Step = Delta / n_e
    nenerg_e = nenerg_s + n_e
  else
    n_e = 0
    nenerg_e = nenerg_s
  endif
  allocate( Energ_e(ie_min:nenerg_e) )
  Energ_e(ie_min:nenerg_s) =  Energ_s(ie_min:nenerg_s)
  do ie = 1,n_e
    Energ_e(nenerg_s+ie) = Energ_s(nenerg_s) + ie * Step 
  end do

! To avoid photon energy < 0 !  
  Eph_min = 0.001_db / Rydb

  allocate( E_inf(ie_min:nenerg_e) )
  allocate( E_sup(ie_min:nenerg_e) )
  
  if( nenerg_e - nenerg_oc == 1 ) then
    E_sup(ie_min) = Energ_e(nenerg_e) + 0.05_db / Rydb
    E_inf(ie_min) = Energ_e(nenerg_e) - 0.05_db / Rydb
  else
    if( Temp > eps10 ) then
      E_inf(ie_min) = 1.5_db * Energ_e(ie_min) - 0.5_db * Energ_e(ie_min+1)
    else
      E_inf(ie_min) = E_cut_Rixs
    endif  
    E_sup(ie_min) = ( Energ_e(ie_min+1) + Energ_e(ie_min) ) / 2
    do ie = ie_min+1,nenerg_e-1
      E_sup(ie) = ( Energ_e(ie+1) + Energ_e(ie) ) / 2
      E_inf(ie) = ( Energ_e(ie-1) + Energ_e(ie) ) / 2
    end do
    E_inf(nenerg_e) = ( Energ_e(nenerg_e-1) + Energ_e(nenerg_e ) ) / 2
    E_sup(nenerg_e) = 1.5_db * Energ_e(nenerg_e) - 0.5_db * Energ_e(nenerg_e-1) 
  endif

  do i_trans = 1,n_trans

    select case( i_trans )
          
      Case(1)
  
        Amplitude(:,:,:) = (0._db, 0._db )
  
        do initr = 1,ninitr
                   
          Gamma_tot = Betalor + Gamma(initr)
          E_in_minus_S = Energ_in - Shift(initr)  
  
          do ie = ie_min, nenerg_e  ! Loop over non occupied electron states
  
            je = min(nenerg_s,ie)
  
            if( abs( E_in_minus_S - Energ_e(ie) ) <= abs( E_in_minus_S - E_loss - Energ_e(ie) ) ) then
              Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),Energ_in,Gamma_tot,Shift(initr),Temp)
              Cf = Cf / ( E_in_minus_S - E_loss - Energ_e(ie) + img * Gamma_tot )
            else
              E = Energ_in - E_loss 
              Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),E,Gamma_tot,Shift(initr),Temp)
              Cf = Cf / ( E_in_minus_S - Energ_e(ie) + img * Gamma_tot )
            endif
  
            Amplitude(:,:,:) = Amplitude(:,:,:) + Cf * Secabs(je,:,initr,:,:,1,i_trans) * Trans_coul(ie_loss,je)
        
          end do

        end do ! end of loop on initr
        
        Int_RIXS(:,:,:,i_trans) = Amplitude(:,:,:) * conjg( Amplitude(:,:,:) ) 

      case(2)
  
        Amplitude(:,:,:) = (0._db, 0._db )
  
        do ie_loss_1 = 1,nenerg_loss
          if( Energ_loss(ie_loss_1) < E_loss / i_trans - eps10 ) cycle
  
          E_mloss(1) = Energ_loss(ie_loss_1)
          E_mloss(2) = Energ_loss(ie_loss) - E_mloss(1)
          
          if( E_mloss(2) < eps10 ) cycle
              
          do ie_loss_2 = 1,nenerg_loss
            if( Energ_loss(ie_loss_2) > E_mloss(2) - eps10 ) exit
          end do
          if( ie_loss_2 == nenerg_loss + 1 ) cycle

          if( abs( Energ_loss(ie_loss_2) - E_mloss(2) ) < eps10 ) then
            Tr_coul(:) = Trans_coul(ie_loss_2,:)
          else
            if( ie_loss_2 == 1 ) then
              p1 = ( E_mloss(2) - ( Energ_loss(1) - Delta_loss )  ) / Delta_loss
        !   stop
              Tr_coul(:) = sqrt( p1 ) * Trans_coul(ie_loss_2,:)  
            else
              p1 = ( E_mloss(2) - Energ_loss(ie_loss_2-1) ) / ( Energ_loss(ie_loss_2) - Energ_loss(ie_loss_2-1) )
              Tr_coul(:) = sqrt( p1 * Trans_coul(ie_loss_2,:)**2 + ( 1._db - p1 ) * Trans_coul(ie_loss_2-1,:)**2 )  
            endif
          endif 
          if( abs( E_mloss(1) - E_mloss(2) ) < eps10 ) Tr_coul(:) = Tr_coul(:) / sqrt_2
 
          Amplitude(:,:,:) = (0._db, 0._db )
  
          do initr = 1,ninitr
                   
            Gamma_tot = Betalor + Gamma(initr)
            E_in_minus_S = Energ_in - Shift(initr)  
  
            do ie = ie_min, nenerg_e  ! Loop over non occupied electron states
  
              je = min(nenerg_s,ie)
              
              Delta_E = E_in_minus_S - Energ_e(ie) 
  
              if( abs( Delta_E ) <= abs( Delta_E - E_loss ) .and. abs( Delta_E ) <= abs( Delta_E - E_mloss(1) ) ) then
                Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),Energ_in,Gamma_tot,Shift(initr),Temp)
                Cf = Cf / ( Delta_E - E_loss + img * Gamma_tot )
                Cf = Cf / ( Delta_E - E_mloss(1) + img * Gamma_tot )
              elseif( abs( Delta_E - E_loss ) <= abs( Delta_E ) .and. abs( Delta_E - E_loss ) <= abs( Delta_E - E_mloss(1) ) ) then
                E = Energ_in - E_loss 
                Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),E,Gamma_tot,Shift(initr),Temp)
                Cf = Cf / ( Delta_E + img * Gamma_tot )
                Cf = Cf / ( Delta_E - E_mloss(1) + img * Gamma_tot )
              else
                E = Energ_in - E_mloss(1) 
                Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),E,Gamma_tot,Shift(initr),Temp)
                Cf = Cf / ( Delta_E + img * Gamma_tot )
                Cf = Cf / ( Delta_E - E_loss + img * Gamma_tot )
              endif
  
              Amplitude(:,:,:) = Amplitude(:,:,:) + Cf * Secabs(je,:,initr,:,:,1,i_trans) * Trans_coul(ie_loss_1,je) * Tr_coul(je) 
          
            end do ! over ie
          end do ! over ie_loss_1
  
          Int_RIXS(:,:,:,i_trans) = Int_RIXS(:,:,:,i_trans) + Amplitude(:,:,:) * conjg( Amplitude(:,:,:) ) 
  
        end do ! over ie_loss_1
        
      case(3)
          
        Amplitude(:,:,:) = (0._db, 0._db )
  
        do ie_loss_1 = 1,nenerg_loss
          if( Energ_loss(ie_loss_1) < Energ_loss(ie_loss) / i_trans - eps10 ) cycle
  
          E_mloss(1) = Energ_loss(ie_loss_1)
  
          do ie_loss_2 = 1,nenerg_loss
            if( Energ_loss(ie_loss_2) > E_mloss(1) + eps10 ) exit
            E_mloss(2) = Energ_loss(ie_loss_2)
            E_loss_1_2 = E_mloss(1) + E_mloss(2) 
            E_mloss(3) = Energ_loss(ie_loss) - E_loss_1_2
  
            if( E_mloss(3) > E_mloss(2) + eps10 ) cycle
            if( E_mloss(3) < eps10 ) cycle
                       
            do ie_loss_3 = 1,nenerg_loss
              if( Energ_loss(ie_loss_3) > E_mloss(3) - eps10 ) exit
            end do
  
            if( ie_loss_3 == nenerg_loss + 1 ) cycle

            if( abs( Energ_loss(ie_loss_3) - E_mloss(3) ) < eps10 ) then
              Tr_coul(:) = Trans_coul(ie_loss_3,:)
            elseif( ie_loss_3 == 1 ) then
              p1 = ( E_mloss(3) - ( Energ_loss(1) - Delta_loss )  ) / Delta_loss
              Tr_coul(:) = p1 * Trans_coul(ie_loss_3,:)  
            else
              p1 = ( E_mloss(3) - Energ_loss(ie_loss_3-1) ) / ( Energ_loss(ie_loss_3) - Energ_loss(ie_loss_3-1) )  
              Tr_coul(:) = p1 * Trans_coul(ie_loss_3,:) + ( 1._db - p1 ) * Trans_coul(ie_loss_3-1,:)  
            endif
            
            Dif_E12 = abs( E_mloss(1) - E_mloss(2) ) > eps10   
            Dif_E13 = abs( E_mloss(1) - E_mloss(3) ) > eps10   
            Dif_E23 = abs( E_mloss(2) - E_mloss(3) ) > eps10   
            if( .not. ( Dif_E12 .and. Dif_E13 .and. Dif_E23 ) ) then             
              if( ( Dif_E12 .and. Dif_E13 ) .or. ( Dif_E12 .and. Dif_E23 ) .or. ( Dif_E13 .and. Dif_E23 ) ) then
!                Tr_coul(:) = Tr_coul(:) / sqrt_2
                Tr_coul(:) = Tr_coul(:) / 2
              else 
                Tr_coul(:) = Tr_coul(:) * Third
!                Tr_coul(:) = Tr_coul(:) / sqrt_3
              endif
            endif  

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

            do initr = 1,ninitr
                   
              Gamma_tot = Betalor + Gamma(initr)
              E_in_minus_S = Energ_in - Shift(initr)  
  
              do ie = ie_min, nenerg_e  ! Loop over non occupied electron states
  
                je = min(nenerg_s,ie)
  
                Delta_E = E_in_minus_S - Energ_e(ie) 

                if( abs( Delta_E ) <= abs( Delta_E - E_loss ) .and. &
                    abs( Delta_E ) <= abs( Delta_E - E_mloss(1) ) .and. &
                    abs( Delta_E ) <= abs( Delta_E - E_loss_1_2 ) ) then
                  Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),Energ_in,Gamma_tot,Shift(initr),Temp)
                  Cf = Cf / ( Delta_E - E_loss + img * Gamma_tot )
                  Cf = Cf / ( Delta_E - E_mloss(1) + img * Gamma_tot )
                  Cf = Cf / ( Delta_E - E_loss_1_2 + img * Gamma_tot )
                                                                                     
                elseif( abs( Delta_E - E_loss ) <= abs( Delta_E ) .and. &
                        abs( Delta_E - E_loss ) <= abs( Delta_E - E_mloss(1) ) .and. &
                        abs( Delta_E - E_loss ) <= abs( Delta_E - E_loss_1_2 ) ) then
                  E = Energ_in - E_loss 
                  Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),E,Gamma_tot,Shift(initr),Temp)
                  Cf = Cf / ( Delta_E + img * Gamma_tot )
                  Cf = Cf / ( Delta_E - E_mloss(1) + img * Gamma_tot )
                  Cf = Cf / ( Delta_E - E_loss_1_2 + img * Gamma_tot )
                elseif( abs( Delta_E - E_mloss(1) ) <= abs( Delta_E ) .and. &
                        abs( Delta_E - E_mloss(1) ) <= abs( Delta_E - E_loss ) .and. &
                        abs( Delta_E - E_mloss(1) ) <= abs( Delta_E - E_loss_1_2 ) ) then
                  E = Energ_in - E_mloss(1) 
                  Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),E,Gamma_tot,Shift(initr),Temp)
                  Cf = Cf / ( Delta_E + img * Gamma_tot )
                  Cf = Cf / ( Delta_E - E_loss + img * Gamma_tot )
                  Cf = Cf / (Delta_E - E_loss_1_2 + img * Gamma_tot )
                else
                  E = Energ_in - E_loss_1_2 
                  Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),E,Gamma_tot,Shift(initr),Temp)
                  Cf = Cf / ( Delta_E + img * Gamma_tot )
                  Cf = Cf / ( Delta_E - E_loss + img * Gamma_tot )
                  Cf = Cf / ( Delta_E - E_mloss(1) + img * Gamma_tot )
                endif
  
                Amplitude(:,:,:) = Amplitude(:,:,:) + Cf * Secabs(je,:,initr,:,:,1,i_trans) * Trans_coul(ie_loss_1,je) &
                                                                                    * Trans_coul(ie_loss_2,je) * Tr_coul(je)
  
              end do
            end do
  
            Int_RIXS(:,:,:,i_trans) = Int_RIXS(:,:,:,i_trans) + Amplitude(:,:,:) * conjg( Amplitude(:,:,:) ) 
              
          end do ! over ie_loss_2 
        end do ! over ie_loss_1
  
      case(4)
          
        Amplitude(:,:,:) = (0._db, 0._db )
  
        do ie_loss_1 = 1,nenerg_loss
          if( Energ_loss(ie_loss_1) < Energ_loss(ie_loss) / i_trans - eps10 ) cycle
  
          E_mloss(1) = Energ_loss(ie_loss_1)
  
          do ie_loss_2 = 1,nenerg_loss
            if( Energ_loss(ie_loss_2) > E_mloss(1) + eps10 ) exit
         
            E_mloss(2) = Energ_loss(ie_loss_2)
            E_loss_1_2 = E_mloss(1) + E_mloss(2) 
  
            do ie_loss_3 = 1,nenerg_loss
              if( Energ_loss(ie_loss_3) > E_mloss(2) + eps10 ) exit
  
              E_mloss(3) = Energ_loss(ie_loss_3)
              E_loss_1_2_3 = E_loss_1_2 + E_mloss(3) 
              
              E_mloss(4) = Energ_loss(ie_loss) - E_loss_1_2_3
  
              if( E_mloss(4) > E_mloss(3) + eps10 ) cycle
              if( E_mloss(4) < eps10 ) exit
                             
              do ie_loss_4 = 1,nenerg_loss
                if( Energ_loss(ie_loss_4) > E_mloss(4) - eps10 ) exit
              end do
              if( ie_loss_4 == nenerg_loss + 1 ) exit

              if( abs( Energ_loss(ie_loss_4) - E_mloss(4) ) < eps10 ) then
                Tr_coul(:) = Trans_coul(ie_loss_4,:)
              elseif( ie_loss_4 == 1 ) then
                p1 = ( E_mloss(4) - ( Energ_loss(1) - Delta_loss )  ) / Delta_loss
                Tr_coul(:) = p1 * Trans_coul(ie_loss_4,:)  
              else
                p1 = ( E_mloss(4) - Energ_loss(ie_loss_4-1) ) / ( Energ_loss(ie_loss_4) - Energ_loss(ie_loss_4-1) )  
                Tr_coul(:) = p1 * Trans_coul(ie_loss_4,:) + ( 1._db - p1 ) * Trans_coul(ie_loss_4-1,:)
              endif 

              Dif_E12 = abs( E_mloss(1) - E_mloss(2) ) > eps10   
              Dif_E13 = abs( E_mloss(1) - E_mloss(3) ) > eps10   
              Dif_E14 = abs( E_mloss(1) - E_mloss(4) ) > eps10   
              Dif_E23 = abs( E_mloss(2) - E_mloss(3) ) > eps10   
              Dif_E24 = abs( E_mloss(2) - E_mloss(4) ) > eps10   
              Dif_E34 = abs( E_mloss(3) - E_mloss(4) ) > eps10
              Eq_E12 = .not. Dif_E12
              Eq_E13 = .not. Dif_E13
              Eq_E14 = .not. Dif_E14
              Eq_E23 = .not. Dif_E23
              Eq_E24 = .not. Dif_E24
              Eq_E34 = .not. Dif_E34
              if( .not. ( Dif_E12 .and. Dif_E13 .and. Dif_E14 .and. Dif_E23 .and. Dif_E24 .and. Dif_E34 ) ) then
                if( ( Eq_E12 .and. Dif_E13 .and. Dif_E14 .and. Dif_E23 .and. Dif_E24 .and. Dif_E34 ) .or. &
                      ( Dif_E12 .and. Eq_E13 .and. Dif_E14 .and. Dif_E23 .and. Dif_E24 .and. Dif_E34 ) .or. &
                      ( Dif_E12 .and. Dif_E13 .and. Eq_E14 .and. Dif_E23 .and. Dif_E24 .and. Dif_E34 ) .or. &
                      ( Dif_E12 .and. Dif_E13 .and. Dif_E14 .and. Eq_E23 .and. Dif_E24 .and. Dif_E34 ) .or. &
                      ( Dif_E12 .and. Dif_E13 .and. Dif_E14 .and. Dif_E23 .and. Eq_E24 .and. Dif_E34 ) .or. &
                      ( Dif_E12 .and. Dif_E13 .and. Dif_E14 .and. Dif_E23 .and. Dif_E24 .and. Eq_E34 ) ) then
                  Tr_coul(:) = Tr_coul(:) / 2
                elseif( ( Eq_E12 .and. Eq_E13 .and. Dif_E14 ) .or. ( Eq_E12 .and. Eq_E14 .and. Dif_E13 ) .or. &
                      ( Eq_E13 .and. Eq_E14 .and. Dif_E12 ) .or. ( Eq_E23 .and. Eq_E24 .and. Dif_E12 ) ) then
                  Tr_coul(:) = Tr_coul(:) * Third
                else  ! Four equal or 2 groups of 2.
                  Tr_coul(:) = Tr_coul(:) * 0.25_db
                endif
              endif  
  
              Amplitude(:,:,:) = (0._db, 0._db )
  
              do initr = 1,ninitr
                   
                Gamma_tot = Betalor + Gamma(initr)
                E_in_minus_S = Energ_in - Shift(initr)  
  
                do ie = ie_min, nenerg_e  ! Loop over non occupied electron states
  
                  je = min(nenerg_s,ie)

                  Delta_E = E_in_minus_S - Energ_e(ie) 
  
                  if( abs( Delta_E ) <= abs( Delta_E - E_loss ) .and. &
                      abs( Delta_E ) <= abs( Delta_E - E_mloss(1) ) .and. &
                      abs( Delta_E ) <= abs( Delta_E - E_loss_1_2 ) .and. &
                      abs( Delta_E ) <= abs( Delta_E - E_loss_1_2_3 ) ) then
                    Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),Energ_in,Gamma_tot,Shift(initr),Temp)
                    Cf = Cf / ( Delta_E - E_loss + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_mloss(1) + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_loss_1_2 + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_loss_1_2_3 + img * Gamma_tot )
                  elseif( abs( Delta_E - E_loss ) <= abs( Delta_E ) .and. &
                          abs( Delta_E - E_loss ) <= abs( Delta_E - E_mloss(1) ) .and. &
                          abs( Delta_E - E_loss ) <= abs( Delta_E - E_loss_1_2 ) .and. &
                          abs( Delta_E - E_loss ) <= abs( Delta_E - E_loss_1_2_3 ) ) then
                    E = Energ_in - E_loss 
                    Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),E,Gamma_tot,Shift(initr),Temp)
                    Cf = Cf / ( Delta_E + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_mloss(1) + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_loss_1_2 + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_loss_1_2_3 + img * Gamma_tot )
                  elseif( abs( Delta_E - E_mloss(1) ) <= abs( Delta_E ) .and. &
                          abs( Delta_E - E_mloss(1) ) <= abs( Delta_E - E_loss ) .and. &
                          abs( Delta_E - E_mloss(1) ) <= abs( Delta_E - E_loss_1_2 ) .and. &
                          abs( Delta_E - E_mloss(1) ) <= abs( Delta_E - E_loss_1_2_3 ) ) then
                    E = Energ_in - E_mloss(1) 
                    Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),E,Gamma_tot,Shift(initr),Temp)
                    Cf = Cf / ( Delta_E + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_loss + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_loss_1_2 + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_loss_1_2_3 + img * Gamma_tot )
                  elseif( abs( Delta_E - E_loss_1_2 ) <= abs( Delta_E ) .and. &
                          abs( Delta_E - E_loss_1_2 ) <= abs( Delta_E - E_loss ) .and. &
                          abs( Delta_E - E_loss_1_2 ) <= abs( Delta_E - E_mloss(1) ) .and. &
                          abs( Delta_E - E_loss_1_2 ) <= abs( Delta_E - E_loss_1_2_3 ) ) then
                    E = Energ_in - E_loss_1_2 
                    Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),E,Gamma_tot,Shift(initr),Temp)
                    Cf = Cf / ( Delta_E + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_loss + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_mloss(1) + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_loss_1_2_3 + img * Gamma_tot )
                  else
                    E = Energ_in - E_loss_1_2_3 
                    Cf = Coef_Lorentz(E_cut_Rixs,E_inf(ie),E_sup(ie),Energ_e(ie),E,Gamma_tot,Shift(initr),Temp)
                    Cf = Cf / ( Delta_E + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_loss + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_mloss(1) + img * Gamma_tot )
                    Cf = Cf / ( Delta_E - E_loss_1_2 + img * Gamma_tot )
                  endif
  
                  Amplitude(:,:,:) = Amplitude(:,:,:) + Cf * Secabs(je,:,initr,:,:,1,i_trans) * Trans_coul(ie_loss_1,je) &
                                                           * Trans_coul(ie_loss_2,je) * Trans_coul(ie_loss_3,je) * Tr_coul(je)
        
                end do
                
              end do

              Int_RIXS(:,:,:,i_trans) = Int_RIXS(:,:,:,i_trans) + Amplitude(:,:,:) * conjg( Amplitude(:,:,:) ) 
  
            end do ! over ie_loss_3
          end do ! over ie_loss_2
        end do ! over ie_loss_1
  
    end select

  end do ! over i_trans
        
  if( Write_bav ) then
    write(3,110) Energ_in * Rydb, E_loss * Rydb
    if( n_trans > 1 ) then
      if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
        write(3,'(/A)') ' i_tr Int_RIXS(ipl)' 
      else
        write(3,'(/A)') ' i_tr  i_q i_th  Int_RIXS(ipl,i_q,i_theta)' 
      endif
    else 
      if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
        write(3,'(/A)') ' Int_RIXS(ipl)' 
      else
        write(3,'(/A)') '  i_q i_th  Int_RIXS(ipl,i_q,i_theta)' 
      endif
    endif
    do i_q = 1,n_q_dim
      do i_theta = 1,n_theta_rixs
        do i_trans = 1,n_trans
          if( n_trans > 1 ) then
            if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
              write(3,'(1p,i5,100e13.5)') i_trans, Int_RIXS(:,1,1,i_trans)
            else
              write(3,'(1p,3i5,100e13.5)') i_trans, i_q, i_theta, Int_RIXS(:,i_theta,i_q,i_trans)
            endif
          else
            if( n_q_dim == 1 .and. n_theta_rixs == 1 ) then      
              write(3,'(1p,100e13.5)') Int_RIXS(:,1,1,i_trans)
            else
              write(3,'(1p,2i5,100e13.5)') i_q, i_theta, Int_RIXS(:,i_theta,i_q,i_trans)
            endif
          endif
        end do
      end do
    end do

  endif

  deallocate( E_inf, E_sup, Energ_e )
    
  return
  110 format(/' ------ Conv_over_energy_indirect ------------------------------------------------------------------------',// &  
              '  Energ_in =',f13.3,' eV, E_loss =', f13.3,' eV')
  120 format(5i3,1p,10000(1x,2e11.3))
end

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

subroutine Write_out_RIXS(Analyzer,Energ_loss,Energ_in,File_name_rixs,HERFD,i_process,Int_out_t,multi_run,n_multi_run, &
                          n_q_dim,n_theta_rixs,n_trans,nenerg_loss,nenerg_in,npl,Powder)
  use declarations
  implicit none
 
  integer:: i_process, i_q, i_theta, i_trans, ie, ie_b, ipl, L, multi_run, n_multi_run, &
    n_theta_rixs, n_q_dim, n_trans, n_trans_out, ne_a, ne_b, ne_out, nenerg_in, nenerg_loss, npl, npl_out

  character(len=Length_name):: File_name
  character(len=Length_name), dimension(n_multi_run):: File_name_rixs

 ! character(len=13), dimension(4):: pol_name_in
 ! character(len=13), dimension(8):: pol_name
  
  logical:: Analyzer, HERFD, Powder, Versus_loss
  
  real(kind=db):: Delta 
  real(kind=db), dimension(nenerg_in):: Energ_in
  real(kind=db), dimension(nenerg_loss):: Energ_loss
  real(kind=db), dimension(nenerg_in,nenerg_loss,npl,n_theta_rixs,n_q_dim,n_trans):: Int_out_t
  real(kind=db), dimension(:,:,:,:,:,:), allocatable:: Int_out

  real(kind=db), dimension(:), allocatable:: E_a, E_b
  real(kind=db), dimension(:,:,:,:), allocatable:: Sum_Int
  real(kind=db), dimension(:,:,:,:,:), allocatable:: Int_out_s

 ! data pol_name/ '  sigma-sigma', '    sigma-pi ', '    pi-sigma ', '     pi-pi   ','  right-sigma', '   left-sigma', &
 !                '    right-pi ', '    left-pi  ' /
 ! data pol_name_in/ '     sigma   ', '       pi    ', '     right   ', '      left   '/

  if( n_trans > 1 ) then
    n_trans_out = n_trans + 1
  else
    n_trans_out = n_trans
  endif
  
  Versus_loss = .not. HERFD
  
  allocate( Int_out(nenerg_in,nenerg_loss,npl,n_theta_rixs,n_q_dim,n_trans_out) )
 
  if( n_trans == 1 ) then
    Int_out(:,:,:,:,:,:) = Int_out_t(:,:,:,:,:,:)
  else
    Int_out(:,:,:,:,:,1) = 0._db
    do i_trans = 1,n_trans
      Int_out(:,:,:,:,:,i_trans+1) =  Int_out_t(:,:,:,:,:,i_trans)
      Int_out(:,:,:,:,:,1) = Int_out(:,:,:,:,:,1) + Int_out_t(:,:,:,:,:,i_trans)  
    end do
  endif
   
 ! Output file name   
  File_name = File_name_rixs(multi_run)
  L = Len_trim(File_name) - 4
  call File_name_extention(File_name,HERFD,i_process,L)
  open(2, file = File_name )

  if( Powder ) then
    npl_out = 1
  elseif( .not. Analyzer ) then
    npl_out = npl / 2
  else
    npl_out = npl
  endif

  if( Versus_loss ) then
    ne_a = nenerg_loss
    ne_b = nenerg_in
  else
    ne_a = nenerg_in
    ne_b = nenerg_loss
  endif
  if( ne_b > 1 .and. HERFD ) then
    ne_out = ne_b + 1
  else
    ne_out = ne_b
  endif

  allocate( E_a(ne_a) )
  allocate( E_b(ne_b) )

  if( Versus_loss ) then
    E_a(:) = - Energ_loss(:) * Rydb
    E_b(:) = Energ_in(:) * Rydb
  else
    E_a(:) = Energ_in(:) * Rydb
    E_b(:) = Energ_loss(:) * Rydb
  endif

! Column names
  call Column_RIXS_name(Analyzer,E_b,HERFD,n_theta_rixs,n_trans_out,ne_b,ne_out,npl_out,Versus_loss)

  if( ne_b > 1 ) allocate( Sum_int(npl,n_theta_rixs,n_q_dim,n_trans_out) )
  if( .not. Analyzer ) allocate( Int_out_s(ne_out,npl_out,n_theta_rixs,n_q_dim,n_trans_out) )    
  
  do ie = 1,ne_a

    if( ne_b > 1 .and. HERFD ) then
      Sum_Int(:,:,:,:) = 0._db
      Delta = 0._db  
      do ie_b = 1,ne_b
        Sum_Int(:,:,:,:) = Sum_Int(:,:,:,:) + Int_out(ie,ie_b,:,:,:,:)
      end do
    endif

    if( HERFD ) then
  
      if( Powder ) then

        if( ne_b > 1 ) then
          write(2,130) E_a(ie), ((( Int_out(ie,:,1,i_theta,i_q,i_trans), Sum_Int(1,i_theta,i_q,i_trans), &
                                                  i_trans = 1,n_trans_out), i_theta = 1,n_theta_rixs), i_q = 1,n_q_dim )
        else
          write(2,130) E_a(ie), ((( Int_out(ie,:,1,i_theta,i_q,i_trans), i_trans = 1,n_trans_out), i_theta = 1,n_theta_rixs), &
                                                                                                            i_q = 1,n_q_dim )
        endif
      elseif( .not. Analyzer ) then
        do ipl = 1,npl_out 
          Int_out_s(1:ne_b,ipl,:,:,:) = Int_out(ie,1:ne_b,2*ipl-1,:,:,:) + Int_out(ie,1:ne_b,2*ipl,:,:,:)
          if( ne_b > 1 ) Int_out_s(ne_out,ipl,:,:,:) = Sum_Int(2*ipl-1,:,:,:) + Sum_Int(2*ipl,:,:,:) 
        end do
        write(2,130) E_a(ie), (((( Int_out_s(:,ipl,i_theta,i_q,i_trans), i_trans = 1,n_trans_out), ipl = 1,npl_out), &
                                                                              i_theta = 1,n_theta_rixs), i_q = 1,n_q_dim)
      else
        if( ne_b > 1 ) then
          write(2,130) E_a(ie), (((( Int_out(ie,:,ipl,i_theta,i_q,i_trans), Sum_Int(ipl,i_theta,i_q,i_trans), &
                                             i_trans = 1,n_trans_out), ipl = 1,npl), i_theta = 1,n_theta_rixs), i_q = 1,n_q_dim)
        else
          write(2,130) E_a(ie), (((( Int_out(ie,:,ipl,i_theta,i_q,i_trans), i_trans = 1,n_trans_out), ipl = 1,npl), &
                                                                           i_theta = 1,n_theta_rixs), i_q = 1,n_q_dim)
        endif
      endif
    
    else

      if( Powder ) then
        write(2,130) E_a(ie), ((( Int_out(:,ie,1,i_theta,i_q,i_trans), i_trans = 1,n_trans_out), i_theta = 1,n_theta_rixs), &
                                                                                                            i_q = 1,n_q_dim)
      elseif( .not. Analyzer ) then
        do ipl = 1,npl_out 
          Int_out_s(1:ne_b,ipl,:,:,:) = Int_out(1:ne_b,ie,2*ipl-1,:,:,:) + Int_out(1:ne_b,ie,2*ipl,:,:,:)
        end do
        write(2,130) E_a(ie), (((( Int_out_s(:,ipl,i_theta,i_q,i_trans), i_trans = 1,n_trans_out), ipl = 1,npl_out), &
                                                                                  i_theta = 1,n_theta_rixs), i_q = 1,n_q_dim)
      else
        write(2,130) E_a(ie), (((( Int_out(:,ie,ipl,i_theta,i_q,i_trans), i_trans = 1,n_trans_out), ipl = 1,npl), &
                                                                                 i_theta = 1,n_theta_rixs), i_q = 1,n_q_dim)
      endif
  
    endif
    
  end do  
      
  Close(2)
  
  deallocate( E_a, E_b )
  if( ne_b > 1 ) deallocate( Sum_int )
  if( .not. Analyzer ) deallocate( Int_out_s )    
  
  deallocate( Int_out )
    
  return
  130 format(f10.3,1p,1000000e13.5)
end

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

! Column names

subroutine Column_RIXS_name(Analyzer,E_b,HERFD,n_theta_rixs,n_trans_out,ne_b,ne_out,npl_out,Versus_loss)

  use declarations
  implicit none
 
  integer:: i, i_t, i_trans, ie, ipl, Length, n_theta_rixs, n, n_trans_out, ne_b, ne_out, npl_out

  character(len=13):: Word
  character(len=2), dimension(4):: pol_suf_no_ana
  character(len=13), dimension(8):: pol_suf

  character(len=13), dimension(ne_out):: E_string
  character(len=13), dimension(n_trans_out*ne_out*npl_out*n_theta_rixs):: E_string_full
  
  logical:: Analyzer, HERFD, Versus_loss
  
  real(kind=db):: E
  
  real(kind=db), dimension(ne_b):: E_b

  data pol_suf/ '_ss', '_sp', '_ps', '_pp','_rs', '_ls', '_rp', '_lp' /
  data pol_suf_no_ana/ '_s', '_p', '_r', '_l' /

  i = 0
  do i_t = 1,n_theta_rixs
    do ipl = 1,npl_out
      do i_trans = 1,n_trans_out
        do ie = 1,ne_out
          i = i + 1
          Word = ' '
          if( ie == ne_out .and. ne_out /= 1 .and. HERFD ) then
            Word = ' Sum'
          else
            E = E_b(ie)
            if( abs( nint( 10*E ) - 10*E ) < eps10 ) then
              write(Word,'(f13.1)') E
            elseif( abs( nint( 100*E ) - 100*E ) < eps10 ) then
              write(Word,'(f13.2)') E
            elseif( abs( nint( 1000*E ) - 1000*E ) < eps10 .or. E > 999.99_db .or. ( n_trans_out > 1 .and. i_trans > 1 ) ) then
              write(Word,'(f13.3)') E
            elseif( abs( nint( 1000*E ) - 1000*E ) < eps10 ) then
              write(Word,'(f13.4)') E
            else
              write(Word,'(f13.5)') E
            endif
          endif
          Word = adjustr(Word)
          E_string(ie) = Word
    
          if( n_trans_out > 1 .and. i_trans > 1 ) then
            Word = adjustl(Word)
            Length = len_trim(Word)
            if( Length+3 < 13 ) then 
              Word(Length+1:Length+3) = '_t'
              call ad_number(i_trans-1,Word,13)
            elseif( Length+2 < 13 ) then 
              Word(Length+1:Length+1) = '_'
              call ad_number(i_trans-1,Word,13)
            endif
          endif

          if( npl_out > 1 ) then
            Word = adjustl(Word)
            Length = len_trim(Word)
            if( Analyzer ) then
              if( Length+3 < 13 ) Word(Length+1:Length+3) = pol_suf(ipl)
            else
              if( Length+2 < 13 ) Word(Length+1:Length+3) = pol_suf_no_ana(ipl)
            endif
          endif
    
          if( n_theta_rixs > 1 ) then
            Word = adjustl(Word)
            Length = len_trim(Word)
            if( Length+3 < 13 ) then 
              Word(Length+1:Length+2) = '_a'
              call ad_number(i_t,Word,13)
            elseif( Length+2 < 13 ) then 
              Word(Length+1:Length+1) = '_'
              call ad_number(i_t,Word,13)
            endif
          endif
    
          Word = adjustr(Word)
          E_string_full(i) = Word
        end do
      end do
    end do
  end do

  n = n_trans_out * npl_out * n_theta_rixs 
  if( Versus_loss ) then
    if( n == 1 ) then
      write(2,120) '   E_loss ', ( E_string(:), i = 1, n )
    else
      write(2,120) '   E_loss ', E_string_full(:)
    endif
  else
    if( n == 1 ) then
      write(2,120) '   E_incom', ( E_string(:), i = 1, n )
    else
      write(2,120) '   E_incom', E_string_full(:)
    endif
  endif

  return
  120 format(a10,1000000a13)
end

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

subroutine Write_out_RIXS_tot(File_name_rixs,multi_run,n_multi_run,nenerg_loss)

  use declarations
  implicit none
 
  integer:: i, i_process, ie, j, L, Length, multi_run, n_multi_run, n_trans_out, ne_a, nenerg_loss, nnombre
  
  integer, dimension(2):: ncol
  
  character(len=Length_name):: File_name
  character(len=10000):: Title
  character(len=Length_name), dimension(n_multi_run):: File_name_rixs

  logical:: HERFD
  
  real(kind=db), dimension(:), allocatable:: E_a
  real(kind=db), dimension(:,:,:), allocatable:: Int_out

 ! data pol_name/ '  sigma-sigma', '    sigma-pi ', '    pi-sigma ', '     pi-pi   ','  right-sigma', '   left-sigma', &
 !                '    right-pi ', '    left-pi  ' /
 ! data pol_name_in/ '     sigma   ', '       pi    ', '     right   ', '      left   '/

! One cannot be in HERFD here
  HERFD = .false.
  
  ne_a = nenerg_loss

  allocate( E_a(ne_a) )
 
 ! indirect process can have more columns 
  do i_process = 2,1,-1
  
 ! Output file name   
    File_name = File_name_rixs(multi_run)
    L = Len_trim(File_name) - 4
    call File_name_extention(File_name,HERFD,i_process,L)
    
    open(1, file = File_name )

    if( i_process == 2 ) then
      read(1,'(A)') Title
    else
      read(1,*)
    endif

    ncol(i_process) = nnombre(1,100000) - 1
    
    if( i_process == 2 ) then
      allocate( Int_out(ne_a,ncol(2),2) )
      Int_out(:,:,:) = 0._db
    endif
    
    do ie = 1,ne_a
      read(1,*) E_a(ie), Int_out(ie,1:ncol(i_process),i_process)
    end do
  
    Close(1)
  end do

  n_trans_out = ncol(2) / ncol(1)
  
  File_name(L+1:L+10) = '_total.txt'

  open(2, file = File_name )

  Length = Len_trim(Title)    
  write(2,'(A)') Title(1:Length)
  
  do ie = 1,ne_a
    do i = 1,ncol(1)
      j = ( n_trans_out ) * ( i - 1 ) + 1
      Int_out(ie,j,2) = Int_out(ie,j,2) + Int_out(ie,i,1) 
    end do 
    write(2,130) E_a(ie), Int_out(ie,1:ncol(2),2)
  end do

  deallocate( E_a, Int_out )
      
  return
  130 format(f10.3,1p,1000000e13.5)
end

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

subroutine Write_out_Xanes(Energ_in,File_name_rixs,ie_in,multi_run,n_multi_run,n_trans,nenerg_in,npl_abs,Xanes,Extension)

  use declarations
  implicit none
  
  integer:: i_trans, ie_in, ipl, L, multi_run, n_multi_run, n_trans, nenerg_in, npl_abs 

  character(len=3):: Extension
  character(len=13):: Word13
  character(len=13), dimension(npl_abs+n_trans):: Column_name
  character(len=Length_name):: File_name
  character(len=Length_name), dimension(n_multi_run):: File_name_rixs
  
  real(kind=db), dimension(nenerg_in):: Energ_in
  real(kind=db), dimension(npl_abs):: Xanes_tot
  real(kind=db), dimension(npl_abs,n_trans):: Xanes

 ! Output file name   
  File_name = File_name_rixs(multi_run)
  L = Len_trim(File_name) - 4
  File_name(L+1:L+5) = '_XAS'
  File_name(L+6:L+8) = Extension
  File_name(L+9:L+12) = '.txt'
  
  if( ie_in == 1 ) then    
    open(1, file = File_name )
  
    Column_name(:) = ' '
    Column_name(1) = ' XAS(100)_' // Extension
    Column_name(2) = ' XAS(010)_' // Extension
    Column_name(3) = ' XAS(001)_' // Extension
    Column_name(npl_abs) = '   <XAS>_' // Extension
    if( n_trans == 1 ) then
      write(1,'(a10,20a13)') '   Energy', Column_name(1:npl_abs)
    else
      do i_trans = 1,n_trans
        Word13 = '  <XAS>_tr_'
        call ad_number(i_trans,Word13,13)
        Column_name(npl_abs+i_trans) = Word13 
      end do
      write(1,'(a10,20a13)') '   Energy', Column_name(1:npl_abs+n_trans)
    endif
  else
    open(1, file = File_name, position='append' )
  endif  
  
  if( n_trans == 1 ) then
    write(1,'(f10.5,1p,10000e13.5)') Energ_in(ie_in) * rydb, Xanes(:,1)
  else
    do ipl = 1,npl_abs
      Xanes_tot(ipl) = sum( Xanes(ipl,:) )
    end do
    write(1,'(f10.5,1p,10000e13.5)') Energ_in(ie_in) * rydb, Xanes_tot(:), Xanes(npl_abs,:) 
  endif

  Close(1)
  
  return
end
 
!*****************************************************************************************************************

! Sum over the different sites
! Energ_emis and nenerg_emis are in fact Energ_loss and nenerg_loss when not HERFD 

subroutine Write_out_RIXS_sum(Analyzer,Energ_emis,Energ_in,File_name_rixs,HERFD,multi_run,n_multi_run,n_theta_rixs, &
                              n_trans,nenerg_emis,nenerg_in,npl,Only_indirect,Powder,Shift_vs_XANES)

  use declarations
  implicit none
 
  integer:: i_process, ie, L, Length, multi_run, n_multi_run, ncol, ncol_2, ne_a, ne_b, n_theta_rixs, &
    n_trans, n_trans_out, ne_out, nenerg_emis, nenerg_in, nnombre, npl, npl_out

  character(len=Length_name):: File_name
  character(len=Length_name), dimension(n_multi_run):: File_name_rixs

  logical:: Analyzer, HERFD, Only_indirect, Powder, Versus_loss
 
  real(kind=db):: Shift_vs_XANES, Shift_vs_XANES_L
   
  real(kind=db), dimension(nenerg_in):: Energ_in
  real(kind=db), dimension(nenerg_emis):: Energ_emis

  real(kind=db), dimension(:), allocatable:: E_a, E_b
  real(kind=db), dimension(:,:), allocatable:: Int_out, Int_out_tot

 ! data pol_name/ '  sigma-sigma', '    sigma-pi ', '    pi-sigma ', '     pi-pi   ','  right-sigma', '   left-sigma', &
 !                '    right-pi ', '    left-pi  ' /
 ! data pol_name_in/ '     sigma   ', '       pi    ', '     right   ', '      left   '/
 
  if( n_trans > 1 ) then
    n_trans_out = n_trans + 1
  else
    n_trans_out = n_trans
  endif
  
  Shift_vs_XANES_L = Shift_vs_XANES * Rydb

  Versus_loss = .not. HERFD   

  if( HERFD ) then
    ne_a = nenerg_in
    ne_b = nenerg_emis
  else
    ne_a = nenerg_emis
    ne_b = nenerg_in
  endif

  allocate( E_a(ne_a) )
  allocate( E_b(ne_b) )

  if( HERFD ) then
    E_b(:) = Energ_emis(:) * Rydb + Shift_vs_XANES_L
  else
    E_b(:) = Energ_in(:) * Rydb + Shift_vs_XANES_L
  endif

  if( ne_b > 1 .and. HERFD ) then
    ne_out = ne_b + 1
  else
    ne_out = ne_b
  endif

  if( Powder ) then
    npl_out = 1
  elseif( .not. Analyzer ) then
    npl_out = npl / 2
  else
    npl_out = npl
  endif

  do i_process = 1,3

    if( Only_indirect .and. i_process /= 2 ) cycle
    if( HERFD .and. i_process == 2 ) exit
     
    do multi_run = 1,n_multi_run
      
 ! input file name   
      File_name = File_name_rixs(multi_run)
      L = Len_trim(File_name) - 4
      call File_name_extention(File_name,HERFD,i_process,L)
      open(1, file = File_name )

      read(1,*)

      ncol = nnombre(1,100000) - 1
      
      if( multi_run == 1 .and. ( i_process == 1 .or. Only_indirect ) ) then
        if( i_process == 1 ) then
          ncol_2 = ncol * n_trans_out
        else
          ncol_2 = ncol
        endif
        allocate( Int_out(ne_a,ncol_2) )
        allocate( Int_out_tot(ne_a,ncol_2) )
      endif
      if( multi_run == 1 ) Int_out_tot(:,:) = 0._db

      do ie = 1,ne_a
        read(1,*) E_a(ie), Int_out(ie,1:ncol)
      end do

      Int_out_tot(:,1:ncol) = Int_out_tot(:,1:ncol) + Int_out(:,1:ncol)
      
      Close(1)
       
    end do

    File_name = File_name_rixs(1)
    Length = Len_trim(File_name)
    do L = Length,1,-1
      if( File_name(L:L) == '_' ) exit
    end do
    L = L - 1
    call File_name_extention(File_name,HERFD,i_process,L)
    open(2, file = File_name )

! Column names
    if( i_process == 1 ) then
      call Column_RIXS_name(Analyzer,E_b,HERFD,n_theta_rixs,1,ne_b,ne_out,npl_out,Versus_loss)
    else
      call Column_RIXS_name(Analyzer,E_b,HERFD,n_theta_rixs,n_trans_out,ne_b,ne_out,npl_out,Versus_loss)
    endif

    if( .not. Versus_loss ) E_a(:) = E_a(:) + Shift_vs_XANES_L
 
    do ie = 1,ne_a
      write(2,130) E_a(ie), Int_out_tot(ie,1:ncol)
    end do
    
    Close(2)

  end do
  
  deallocate( E_a, E_b, Int_out, Int_out_tot )
      
  return
  130 format(f10.3,1p,1000000e13.5)
end

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

! Extension of the file names

subroutine File_name_extention(File_name,HERFD,i_process,L)
  
  use declarations
 
  integer:: i_process, L

  character(len=Length_name):: File_name

  logical:: HERFD
  
  if( HERFD ) then
  
    File_name(L+1:L+10) = '_HERFD.txt'
  
  elseif( i_process == 1 ) then

    File_name(L+1:L+8) = '_dir.txt'

  elseif( i_process == 2 ) then

    File_name(L+1:L+10) = '_indir.txt'
    
  else
  
    File_name(L+1:L+10) = '_total.txt'
    
  endif

  return
end

