! FDMNES subroutine

! Calculate the absorption cross sections and the DAFS amplitudes
! Calculate on demand the spherical tensors
! Writng in the output file

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

  use declarations
  implicit none

  integer:: he, hs, i, i_z_SRXRD_abs, ia, iabsorig, ib, ic1, ic2, icheck, icn1, icn2, ie, &
    ie_computer, ii, ind_mu, initr, ip, ipl, ipldafs, iseuil, &
    isym, isym_1, ixandafs, j, j1, je, jhe, jhs, jpl, js, jseuil, ke, ks, l, ll, long, mpinodee, multi_0, n, n_abs_rgh, &
    n_bulk_sup, n_z_SRXRD, n_z_SRXRD_abs, n_z_SRXRD_abs_max, n_dim, n_header_info, n_mat_cal, n_max, n_multi_run, &
    n_oo, n_tens, n_tens_max, n1, n2, na, &
    nab, natomsym, nb, nbseuil, nc, nccm, ncolm, ncolr, ncolt, nenerg, ninit1, ninitr, nl, np, npldafs, &
    nphim, nplt, nplr, nplrm, nseuil, nspin, numat_abs, nxanout, nw

  integer, dimension(natomsym):: isymeq
  integer, dimension(npldafs):: nphi_dafs
  integer, dimension(2,npldafs):: isigpi
  integer, dimension(n_z_SRXRD_abs):: n_zc_SRXRD_abs
  integer, dimension(n_z_SRXRD_abs_max,n_z_SRXRD_abs):: index_z_SRXRD_abs

  character(len=length_word):: nomab
  character(len=length_word), dimension(ncolm):: nomabs
  character(len=length_word), dimension(ncolm*ninitr):: title
  character(len=5), dimension(nplrm):: ltypcal
  character(len=Length_name):: nomfich, nomfich_s, nomfich_t, nomfichdafst, File_out
  character(len=Length_name), dimension(n_multi_run+n_bulk_sup+n_abs_rgh):: nomfich_cal_conv
  character(len=Length_name), dimension(:), allocatable:: Header_info
  character(len=2310):: mot

  complex(kind=db):: cf, f_avantseuil, ph, ph_m, sec
  complex(kind=db), dimension(3):: plae, plas, uae, uas
  complex(kind=db), dimension(8*ninitr):: compnum
  complex(kind=db), dimension(3,3):: Tensor_rank_2
  complex(kind=db), dimension(3,3,3):: Tensor_rank_3
  complex(kind=db), dimension(3,3,3,3):: Tensor_rank_4
  complex(kind=db), dimension(3,3,3,3,3,3):: Tensor_rank_6
  complex(kind=db), dimension(3,3,ninitr,0:natomsym):: T_E1E1_ia, T_E1E1_ia_m, T_E1E1_ia_t, T_E1SP_ia, T_E1SP_ia_m, &
                                    T_SPSP_ia, T_SPSP_ia_m, T_E1M1_ia, T_E1M1_ia_m, T_E1M1_ia_t, T_M1M1_ia, T_M1M1_ia_m
  complex(kind=db), dimension(3,3,3,ninitr,0:natomsym):: T_E1E2_ia, T_E1E2_ia_m, T_E1E2_ia_t, T_E1M2_ia, T_E1M2_ia_m
  complex(kind=db), dimension(3,3,3,3,ninitr,0:natomsym):: T_E1E3_ia, T_E1E3_ia_m, T_E2E2_ia, T_E2E2_ia_m, T_E2E2_ia_t, &
                                                           T_E2M2_ia, T_E2M2_ia_m
  complex(kind=db), dimension(3,n_oo,3,n_oo,ninitr,0:natomsym):: T_E3E3_ia, T_E3E3_ia_m
  complex(kind=db), dimension(3,3,ninitr,0:mpinodee-1):: T_E1E1, T_E1E1_m, T_E1SP, T_E1SP_m, T_E1M1, T_E1M1_m, &
                                                         T_M1M1, T_M1M1_m, T_SPSP, T_SPSP_m
  complex(kind=db), dimension(3,3,3,ninitr,0:mpinodee-1):: T_E1E2, T_E1E2_m, T_E1M2, T_E1M2_m
  complex(kind=db), dimension(3,3,3,3,ninitr,0:mpinodee-1):: T_E1E3, T_E1E3_m, T_E2E2, T_E2E2_m, T_E2M2, T_E2M2_m
  complex(kind=db), dimension(3,n_oo,3,n_oo,ninitr,0:mpinodee-1):: T_E3E3, T_E3E3_m
  complex(kind=db), dimension(npldafs):: Bragg_abs_T, Sum_Bragg_abs_NR, phdt1
  complex(kind=db), dimension(3,nplrm):: pol
  complex(kind=db), dimension(npldafs,nphim):: Sum_Bragg_NR_Bulk, Sum_Bragg_NR_T
  complex(kind=db), dimension(npldafs,nphim,n_max):: Phdt
  complex(kind=db), dimension(npldafs,n_z_SRXRD_abs):: Sum_Bragg_abs_f0
  complex(kind=db), dimension(npldafs,n_z_SRXRD):: Sum_Bragg_nonabs_f
  complex(kind=db), dimension(natomsym,npldafs):: Bragg_abs
  complex(kind=db), dimension(3,npldafs,nphim):: poldafse, poldafss

  complex(kind=db), dimension(:,:,:,:), allocatable :: Ampldafs, Ampldafs_E1E1, Ampldafs_E1E2, Ampldafs_E1E3, Ampldafs_E1M1, &
                    Ampldafs_E1M2, Ampldafs_E1SP, Ampldafs_E2E2, Ampldafs_E2M2, Ampldafs_E3E3, Ampldafs_M1M1, Ampldafs_SPSP
  complex(kind=db), dimension(:,:,:,:,:), allocatable :: mu, mu_E1E1, mu_E1E2, mu_E1E3, mu_E1M1, mu_E1M2, mu_E1SP, mu_E2E2, &
                                                         mu_E2M2, mu_E3E3, mu_M1M1, mu_SPSP

  logical:: Abs_in_Bulk_roughness, Allsite, Bulk_roughness_case, Bulk_step, Cartesian_tensor, Cor_abs, Core_resolved, Dafs_cal, &
    E1E1, E1E2, E1SP, E1E3, E1M1, E1M2, E2E2, E2M2, E3E3, E_vec, Dafs, Dafs_bio, Final_tddft, Energphot, First_E, &
    Full_self_abs, Green_int, Green_int_mag, Header, M1M1, Magn_sens, Matper, More, Moyenne, mu_cal, &
    New_file, Non_resonant_Bulk, Self_abs, Spherical_signal, Spherical_tensor, Spinorbite_p, SPSP, Tens_comp, Tensor_eval, Xan_atom

  logical, dimension(n_Multipole_max):: Multipole

  real(kind=db):: Abs_cap, Abs_U_iso, ang, c_micro, c_milli, cst, conv_mbarn_nelec, dang, E_cut, &
    eph2, Ephoton, Ephseuil, natomsym_f, ptrans, Surface_ref, V0muf, Volume_maille

  real(kind=db), dimension(ninitr):: ct_nelec, Epsii
  real(kind=db), dimension(nbseuil):: Eseuil
  real(kind=db), dimension(3):: angxyz, axyz, voae, voas
  real(kind=db), dimension(3,3):: matopsym, matopsym_1
  real(kind=db), dimension(nenerg):: Energ
  real(kind=db), dimension(ninitr):: sec_atom, Sph_E2E2, Sph_E2M2
  real(kind=db), dimension(3,nplrm):: vec
  real(kind=db), dimension(nplrm,2):: pdp
  real(kind=db), dimension(3,npldafs):: hkl_dafs
  real(kind=db), dimension(npldafs):: Length_Abs
  real(kind=db), dimension(ncolm*ninitr):: tens
  real(kind=db), dimension(natomsym):: Taux_eq
  real(kind=db), dimension(n_tens_max*ninitr,0:natomsym):: Int_tens
  real(kind=db), dimension(ncolr,ninitr,0:natomsym):: Secabs, Secabs_E1E1, Secabs_E1E2, Secabs_E1E3, Secabs_E1M1, Secabs_E1M2, &
                                                      Secabs_E1SP, Secabs_E2E2, Secabs_E2M2, Secabs_E3E3, Secabs_M1M1, Secabs_SPSP 
  real(kind=db), dimension(3,npldafs,nphim):: vecdafse, vecdafss
  real(kind=db), dimension(n_z_SRXRD):: Abs_SRXRD, Pos_z_SRXRD
  real(kind=db), dimension(n_z_SRXRD_abs):: Abs_SRXRD_abs, Pos_z_SRXRD_abs

  real(kind=db), dimension(:,:), allocatable:: Abs_sum

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

  if( E1E1 ) Secabs_E1E1(:,:,:) = ( 0._db, 0._db )
  if( E1E2 ) Secabs_E1E2(:,:,:) = ( 0._db, 0._db )
  if( E1E3 ) Secabs_E1E3(:,:,:) = ( 0._db, 0._db )
  if( E1M1 ) Secabs_E1M1(:,:,:) = ( 0._db, 0._db )
  if( E1M2 ) Secabs_E1M2(:,:,:) = ( 0._db, 0._db )
  if( E1SP ) Secabs_E1SP(:,:,:) = ( 0._db, 0._db )
  if( E2E2 ) Secabs_E2E2(:,:,:) = ( 0._db, 0._db )
  if( E2M2 ) Secabs_E2M2(:,:,:) = ( 0._db, 0._db )
  if( E3E3 ) Secabs_E3E3(:,:,:) = ( 0._db, 0._db )
  if( M1M1 ) Secabs_M1M1(:,:,:) = ( 0._db, 0._db )
  if( SPSP ) Secabs_SPSP(:,:,:) = ( 0._db, 0._db )

  if( nspin == 2 .or. Spinorbite_p ) then
    Magn_sens = .true.
  else
    Magn_sens = .false.
  endif

  if( Green_int .and. Magn_sens ) then
    Green_int_mag = .true.
  else
    Green_int_mag = .false.
  endif

  Cor_abs = Full_self_abs .or. Self_abs

  Bulk_roughness_case = Abs_in_Bulk_roughness .and. .not. Bulk_step

  long = len_trim(nomfich_s)
  nomfich_t = nomfich_s 
  if( Final_tddft ) nomfich_t(long+1:long+6) = '_tddft'

  if( icheck > 0 .and. Bulk_roughness_case ) then
    write(3,110)
  elseif( icheck > 0 ) then
    write(3,115)
  endif
 
  natomsym_f = sum( Taux_eq(:) )
    
  if( Allsite ) then
    na = natomsym
    nb = natomsym
  else
    na = 0
    nb = 1
  endif
  if( n_z_SRXRD_abs > 1 .and. .not. Bulk_roughness_case ) then
    nab = natomsym
  else
    nab = na
  endif

  n_mat_cal = 0
  do ipl = 1,nplr
    if( ltypcal(ipl) == 'ss   ' .or. ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' &
                                .or. ltypcal(ipl) == 'pp   ' ) n_mat_cal = n_mat_cal + 1
  end do
 
  if( Dafs ) then

    allocate( Ampldafs(npldafs,nphim,ninitr,0:natomsym) )
    if( E1E1 ) allocate( Ampldafs_E1E1(npldafs,nphim,ninitr,0:natomsym) )
    if( E1E2 ) allocate( Ampldafs_E1E2(npldafs,nphim,ninitr,0:natomsym) )
    if( E1E3 ) allocate( Ampldafs_E1E3(npldafs,nphim,ninitr,0:natomsym) )
    if( E1M1 ) allocate( Ampldafs_E1M1(npldafs,nphim,ninitr,0:natomsym) )
    if( E1M2 ) allocate( Ampldafs_E1M2(npldafs,nphim,ninitr,0:natomsym) )
    if( E1SP ) allocate( Ampldafs_E1SP(npldafs,nphim,ninitr,0:natomsym) )
    if( E2E2 ) allocate( Ampldafs_E2E2(npldafs,nphim,ninitr,0:natomsym) )
    if( E2M2 ) allocate( Ampldafs_E2M2(npldafs,nphim,ninitr,0:natomsym) )
    if( E3E3 ) allocate( Ampldafs_E3E3(npldafs,nphim,ninitr,0:natomsym) )
    if( M1M1 ) allocate( Ampldafs_M1M1(npldafs,nphim,ninitr,0:natomsym) )
    if( SPSP ) allocate( Ampldafs_SPSP(npldafs,nphim,ninitr,0:natomsym) )
    if( E1E1 ) Ampldafs_E1E1(:,:,:,:) = ( 0._db, 0._db ) 
    if( E1E2 ) Ampldafs_E1E2(:,:,:,:) = ( 0._db, 0._db )
    if( E1E3 ) Ampldafs_E1E3(:,:,:,:) = ( 0._db, 0._db )
    if( E1M1 ) Ampldafs_E1M1(:,:,:,:) = ( 0._db, 0._db )
    if( E1M2 ) Ampldafs_E1M2(:,:,:,:) = ( 0._db, 0._db )
    if( E1SP ) Ampldafs_E1SP(:,:,:,:) = ( 0._db, 0._db )
    if( E2E2 ) Ampldafs_E2E2(:,:,:,:) = ( 0._db, 0._db )
    if( E2M2 ) Ampldafs_E2M2(:,:,:,:) = ( 0._db, 0._db )
    if( E3E3 ) Ampldafs_E3E3(:,:,:,:) = ( 0._db, 0._db )
    if( M1M1 ) Ampldafs_M1M1(:,:,:,:) = ( 0._db, 0._db )
    if( SPSP ) Ampldafs_SPSP(:,:,:,:) = ( 0._db, 0._db )
    if( Cor_abs ) then
      allocate( mu(npldafs,nphim,2,ninitr,0:natomsym) )
      if( E1E1 ) allocate( mu_E1E1(npldafs,nphim,2,ninitr,0:natomsym) )
      if( E1E2 ) allocate( mu_E1E2(npldafs,nphim,2,ninitr,0:natomsym) )
      if( E1E3 ) allocate( mu_E1E3(npldafs,nphim,2,ninitr,0:natomsym) )
      if( E1M1 ) allocate( mu_E1M1(npldafs,nphim,2,ninitr,0:natomsym) )
      if( E1M2 ) allocate( mu_E1M2(npldafs,nphim,2,ninitr,0:natomsym) )
      if( E1SP ) allocate( mu_E1SP(npldafs,nphim,2,ninitr,0:natomsym) )
      if( E1E3 ) allocate( mu_E1E3(npldafs,nphim,2,ninitr,0:natomsym) )
      if( E2E2 ) allocate( mu_E2E2(npldafs,nphim,2,ninitr,0:natomsym) )
      if( E2M2 ) allocate( mu_E2M2(npldafs,nphim,2,ninitr,0:natomsym) )
      if( E3E3 ) allocate( mu_E3E3(npldafs,nphim,2,ninitr,0:natomsym) )
      if( M1M1 ) allocate( mu_M1M1(npldafs,nphim,2,ninitr,0:natomsym) )
      if( SPSP ) allocate( mu_SPSP(npldafs,nphim,2,ninitr,0:natomsym) )
      if( E1E1 ) mu_E1E1(:,:,:,:,:) = ( 0._db, 0._db )
      if( E1E2 ) mu_E1E2(:,:,:,:,:) = ( 0._db, 0._db )
      if( E1E3 ) mu_E1E3(:,:,:,:,:) = ( 0._db, 0._db )
      if( E1M1 ) mu_E1M1(:,:,:,:,:) = ( 0._db, 0._db )
      if( E1M2 ) mu_E1M2(:,:,:,:,:) = ( 0._db, 0._db )
      if( E1SP ) mu_E1SP(:,:,:,:,:) = ( 0._db, 0._db )
      if( E2E2 ) mu_E2E2(:,:,:,:,:) = ( 0._db, 0._db )
      if( E2M2 ) mu_E2M2(:,:,:,:,:) = ( 0._db, 0._db )
      if( E3E3 ) mu_E3E3(:,:,:,:,:) = ( 0._db, 0._db )
      if( M1M1 ) mu_M1M1(:,:,:,:,:) = ( 0._db, 0._db )
      if( SPSP ) mu_SPSP(:,:,:,:,:) = ( 0._db, 0._db )
    endif

  endif

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

    if( Core_resolved .and. .not. Final_tddft ) then
      if( initr <= ninit1 ) then
        iseuil = 1
      else
        iseuil = min(2, nbseuil)
      endif
    elseif( Final_tddft ) then
      iseuil = min(2, nbseuil)
    else
      iseuil = min(initr, nbseuil)
    endif

    Ephseuil = Energ(ie)
    Ephoton = Ephseuil + Eseuil(iseuil)
! For very low energy edges:
    Ephoton = max(0.001_db/Rydb, Ephoton)
    if( Energphot ) Ephseuil = Ephoton

    ct_nelec(initr) = conv_mbarn_nelec(Ephoton)

    eph2 = 0.5_db * Ephoton**2
! To get tensors and cross sections in Megabarn
! ptrans = S02 fixed at 1.
    ptrans = 1._db
! alfa_sf = e*e/(2*epsilon0*h*c) is the fine structure constant
    cst = quatre_pi * pi * ptrans * alfa_sf * Ephoton
! To get result in Mbarn (10E-18 cm2)
    cst = 100 * bohr**2 * cst
    
    do ia = 1,natomsym

      isym = abs( isymeq(ia) )
      call opsym(isym,matopsym)

! For One_run_s case. Spin contribution already taken into account
      if( ia == 1 ) then
        isym_1 = isym
        if( isym /= 1 ) call invermat( matopsym, matopsym_1 )
      endif 
      if( isym_1 /= 1 ) matopsym = matmul( matopsym_1, matopsym )
      
      if( E1E1 ) then
        Tensor_rank_2(:,:) = T_E1E1(:,:,initr,ie_computer) * cst
        if( isym /= 1 ) call rot_tensor_2( Tensor_rank_2, matopsym )
        if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_2(:,:) = conjg( Tensor_rank_2(:,:) )
        T_E1E1_ia(:,:,initr,ia) = Tensor_rank_2(:,:)
        if( Green_int_mag ) then
          Tensor_rank_2(:,:) = T_E1E1_m(:,:,initr,ie_computer) * cst
          if( isym /= 1 ) call rot_tensor_2( Tensor_rank_2, matopsym )
          if( isymeq(ia) < 0 ) Tensor_rank_2(:,:) = - Tensor_rank_2(:,:)
          T_E1E1_ia_m(:,:,initr,ia) = Tensor_rank_2(:,:)
        endif
      endif

      if( E1E2 ) then
        Tensor_rank_3(:,:,:) = T_E1E2(:,:,:,initr,ie_computer) * cst
        if( isym /= 1 ) call rot_tensor_3( Tensor_rank_3, matopsym )
        if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_3(:,:,:) = conjg( Tensor_rank_3(:,:,:) )
        T_E1E2_ia(:,:,:,initr,ia) = Tensor_rank_3(:,:,:)
        if( Green_int_mag ) then
          Tensor_rank_3(:,:,:) = T_E1E2_m(:,:,:,initr,ie_computer) * cst
          if( isym /= 1 ) call rot_tensor_3( Tensor_rank_3, matopsym )
          if( isymeq(ia) < 0 ) Tensor_rank_3(:,:,:) = - Tensor_rank_3(:,:,:)
          T_E1E2_ia_m(:,:,:,initr,ia) = Tensor_rank_3(:,:,:)
        else
          T_E1E2_ia_m(:,:,:,initr,ia) = (0._db,0._db)
        endif
      endif

      if( E1E3 ) then
        Tensor_rank_4(:,:,:,:) = T_E1E3(:,:,:,:,initr,ie_computer) * cst
        if( isym /= 1 ) call rot_tensor_4( Tensor_rank_4, matopsym )
        if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_4(:,:,:,:) = conjg( Tensor_rank_4(:,:,:,:) )
        T_E1E3_ia(:,:,:,:,initr,ia) = Tensor_rank_4(:,:,:,:)
        if( Green_int_mag ) then
          Tensor_rank_4(:,:,:,:) = T_E1E3_m(:,:,:,:,initr,ie_computer) * cst
          if( isym /= 1 ) call rot_tensor_4( Tensor_rank_4, matopsym )
          if( isymeq(ia) < 0 ) Tensor_rank_4(:,:,:,:) = - Tensor_rank_4(:,:,:,:)
          T_E1E3_ia_m(:,:,:,:,initr,ia) = Tensor_rank_4(:,:,:,:)
        endif
      endif

      if( E1M1 ) then
        Tensor_rank_2(:,:) = T_E1M1(:,:,initr,ie_computer) * cst   ! no more change of sign (2025/06/25)
        if( isym /= 1 ) call Rot_tensor_2( Tensor_rank_2, matopsym )
! Symmetry operations are for position (x,y,z). Here one is substituted by magnetic operator, which changes the sign for inversion and plane symmetry 
        if( ( isym >= 25 .and. isym <= 48 ) .or. ( isym >= 53 .and. isym <= 57 ) .or. isym == 59  .or. isym == 61 &
                          .or. isym == 63 ) Tensor_rank_2(:,:) = - Tensor_rank_2(:,:)
! Magnetism is on the real part for E1M1
        if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_2(:,:) = - conjg( Tensor_rank_2(:,:) )
        T_E1M1_ia(:,:,initr,ia) = Tensor_rank_2(:,:)
        if( Green_int_mag ) then
          Tensor_rank_2(:,:) = T_E1M1_m(:,:,initr,ie_computer) * cst ! no more change of sign
          if( isym /= 1 ) call Rot_tensor_2( Tensor_rank_2, matopsym )
! rotation is for position (x,y,z). Here one is substituted by magnetic operator, which change the sign 
          if( ( isym >= 25 .and. isym <= 48 ) .or. ( isym >= 53 .and. isym <= 57 ) .or. isym == 59  .or. isym == 61 &
                          .or. isym == 63 ) Tensor_rank_2(:,:) = - Tensor_rank_2(:,:)
          if( isymeq(ia) < 0 ) Tensor_rank_2(:,:) = - Tensor_rank_2(:,:)
          T_E1M1_ia_m(:,:,initr,ia) = Tensor_rank_2(:,:)
        else
          T_E1M1_ia_m(:,:,initr,ia) = (0._db,0._db)
        endif
      endif

      if( E1M2 ) then
        Tensor_rank_3(:,:,:) = T_E1M2(:,:,:,initr,ie_computer) * cst
        if( isym /= 1 ) call Rot_tensor_3( Tensor_rank_3, matopsym )
! Symmetry operations are for position (x,y,z). Here one is substituted by magnetic operator, which changes the sign for inversion and plane symmetry 
        if( ( isym >= 25 .and. isym <= 48 ) .or. ( isym >= 53 .and. isym <= 57 ) .or. isym == 59  .or. isym == 61 &
                          .or. isym == 63 ) Tensor_rank_3(:,:,:) = - Tensor_rank_3(:,:,:)
! Contrary to E1M1, because of the multiplication by the "i" in front of "k" already done in "Tens_ab", the magnetic part is in the imaginary part 
        if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_3(:,:,:) = conjg( Tensor_rank_3(:,:,:) )
        T_E1M2_ia(:,:,:,initr,ia) = Tensor_rank_3(:,:,:)
        if( Green_int_mag ) then
          Tensor_rank_3(:,:,:) = T_E1M2_m(:,:,:,initr,ie_computer) * cst
          if( isym /= 1 ) call Rot_tensor_3( Tensor_rank_3, matopsym )
          if( isymeq(ia) < 0 ) Tensor_rank_3(:,:,:) = - Tensor_rank_3(:,:,:)
          T_E1M2_ia_m(:,:,:,initr,ia) = Tensor_rank_3(:,:,:)
        else
          T_E1M2_ia_m(:,:,:,initr,ia) = (0._db,0._db)
        endif
      endif

! E1SP is in fact E1SP + SPE1
      if( E1SP ) then
        Tensor_rank_2(:,:) = T_E1SP(:,:,initr,ie_computer) * cst
        if( isym /= 1 ) call rot_tensor_2( Tensor_rank_2, matopsym )
        if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_2(:,:) = conjg( Tensor_rank_2(:,:) )
        T_E1SP_ia(:,:,initr,ia) = Tensor_rank_2(:,:)
        if( Green_int_mag ) then
          Tensor_rank_2(:,:) = T_E1SP_m(:,:,initr,ie_computer) * cst
          if( isym /= 1 ) call rot_tensor_2( Tensor_rank_2, matopsym )
          if( isymeq(ia) < 0 ) Tensor_rank_2(:,:) = - Tensor_rank_2(:,:)
          T_E1SP_ia_m(:,:,initr,ia) = Tensor_rank_2(:,:)
        endif
      endif

      if( E2E2 ) then
        Tensor_rank_4(:,:,:,:) = T_E2E2(:,:,:,:,initr,ie_computer) * cst
        if( isym /= 1 ) call rot_tensor_4( Tensor_rank_4, matopsym )
        if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_4(:,:,:,:) = conjg( Tensor_rank_4(:,:,:,:) )
        T_E2E2_ia(:,:,:,:,initr,ia) = Tensor_rank_4(:,:,:,:)
        if( Green_int_mag ) then
          Tensor_rank_4(:,:,:,:) = T_E2E2_m(:,:,:,:,initr,ie_computer) * cst
          if( isym /= 1 ) call Rot_tensor_4( Tensor_rank_4, matopsym )
          if( isymeq(ia) < 0 ) Tensor_rank_4(:,:,:,:) = - Tensor_rank_4(:,:,:,:)
          T_E2E2_ia_m(:,:,:,:,initr,ia) = Tensor_rank_4(:,:,:,:)
        endif
      endif

      if( E2M2 ) then
        Tensor_rank_4(:,:,:,:) = T_E2M2(:,:,:,:,initr,ie_computer) * cst
        if( isym /= 1 ) call rot_tensor_4( Tensor_rank_4, matopsym )
! Symmetry operations are for position (x,y,z). Here one is substituted by magnetic operator, which changes the sign for inversion and plane symmetry 
        if( ( isym >= 25 .and. isym <= 48 ) .or. ( isym >= 53 .and. isym <= 57 ) .or. isym == 59  .or. isym == 61 &
                          .or. isym == 63 ) Tensor_rank_4(:,:,:,:) = - Tensor_rank_4(:,:,:,:)
  ! As for E1M2, the multiplication by "i" in front of the k of M2, makes that the magnetic part is the imaginary part
        if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_4(:,:,:,:) = conjg( Tensor_rank_4(:,:,:,:) )
        T_E2M2_ia(:,:,:,:,initr,ia) = Tensor_rank_4(:,:,:,:)
        if( Green_int_mag ) then
          Tensor_rank_4(:,:,:,:) = T_E2M2_m(:,:,:,:,initr,ie_computer) * cst
          if( isym /= 1 ) call Rot_tensor_4( Tensor_rank_4, matopsym )
          if( isymeq(ia) < 0 ) Tensor_rank_4(:,:,:,:) = - Tensor_rank_4(:,:,:,:)
          T_E2M2_ia_m(:,:,:,:,initr,ia) = Tensor_rank_4(:,:,:,:)
        endif
      endif

      if( E3E3 ) then
        jhe = 0
        do je = 1,3
          do he = 1,3
            jhe = jhe + 1
            jhs = 0
            do js = 1,3
              do hs = 1,3
                jhs = jhs + 1
                Tensor_rank_6(:,je,he,:,js,hs) = T_E3E3(:,jhe,:,jhs,initr,ie_computer) * cst
              end do
            end do
          end do
        end do
        if( isym /= 1 ) call rot_tensor_6( Tensor_rank_6, Matopsym )
        if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_6 = conjg( Tensor_rank_6 )
        jhe = 0
        do je = 1,3
          do he = 1,3
            jhe = jhe + 1
            jhs = 0
            do js = 1,3
              do hs = 1,3
                jhs = jhs + 1
                T_E3E3_ia(:,jhe,:,jhs,initr,ia) = Tensor_rank_6(:,je,he,:,js,hs)
              end do
            end do
          end do
        end do
        if( Green_int_mag ) then
          jhe = 0
          do je = 1,3
            do he = 1,3
              jhe = jhe + 1
              jhs = 0
              do js = 1,3
                do hs = 1,3
                  jhs = jhs + 1
                  Tensor_rank_6(:,je,he,:,js,hs) = T_E3E3_m(:,jhe,:,jhs,initr,ie_computer) * cst
                end do
              end do
            end do
          end do
          if( isym /= 1 ) call rot_tensor_6( Tensor_rank_6, Matopsym )
          if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_6 = conjg( Tensor_rank_6 )
          jhe = 0
          do je = 1,3
            do he = 1,3
              jhe = jhe + 1
              jhs = 0
              do js = 1,3
                do hs = 1,3
                  jhs = jhs + 1
                  T_E3E3_ia_m(:,jhe,:,jhs,initr,ia) = Tensor_rank_6(:,je,he,:,js,hs)
                end do
              end do
            end do
          end do
        endif
      endif

      if( M1M1 ) then
        Tensor_rank_2(:,:) = T_M1M1(:,:,initr,ie_computer) * cst
        if( isym /= 1 ) call rot_tensor_2( Tensor_rank_2, matopsym )
        if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_2(:,:) = conjg( Tensor_rank_2(:,:) )
        T_M1M1_ia(:,:,initr,ia) = Tensor_rank_2(:,:)
        if( Green_int_mag ) then
          Tensor_rank_2(:,:) = T_M1M1_m(:,:,initr,ie_computer) * cst
          if( isym /= 1 ) call rot_tensor_2( Tensor_rank_2, matopsym )
          if( isymeq(ia) < 0 ) Tensor_rank_2(:,:) = - Tensor_rank_2(:,:)
          T_M1M1_ia_m(:,:,initr,ia) = Tensor_rank_2(:,:)
        endif
      endif

      if( SPSP ) then
        Tensor_rank_2(:,:) = T_SPSP(:,:,initr,ie_computer) * cst
        if( isym /= 1 ) call rot_tensor_2( Tensor_rank_2, matopsym )
        if( isymeq(ia) < 0 .and. .not. Green_int ) Tensor_rank_2(:,:) = conjg( Tensor_rank_2(:,:) )
        T_SPSP_ia(:,:,initr,ia) = Tensor_rank_2(:,:)
        if( Green_int_mag ) then
          Tensor_rank_2(:,:) = T_SPSP_m(:,:,initr,ie_computer) * cst
          if( isym /= 1 ) call rot_tensor_2( Tensor_rank_2, matopsym )
          if( isymeq(ia) < 0 ) Tensor_rank_2(:,:) = - Tensor_rank_2(:,:)
          T_SPSP_ia_m(:,:,initr,ia) = Tensor_rank_2(:,:)
        endif
      endif

    end do ! end of loop over ia

  end do ! end of loop over initr

! Below is just for writing of spherical tensors
  if( Green_int_mag ) then
    T_E1E1_ia_t(:,:,:,:) = T_E1E1_ia(:,:,:,:) + T_E1E1_ia_m(:,:,:,:) 
    T_E1E2_ia_t(:,:,:,:,:) = T_E1E2_ia(:,:,:,:,:) + T_E1E2_ia_m(:,:,:,:,:) 
    T_E1M1_ia_t(:,:,:,:) = T_E1M1_ia(:,:,:,:) + T_E1M1_ia_m(:,:,:,:) 
    T_E2E2_ia_t(:,:,:,:,:,:) = T_E2E2_ia(:,:,:,:,:,:) + T_E2E2_ia_m(:,:,:,:,:,:) 
  else
    T_E1E1_ia_t(:,:,:,:) = T_E1E1_ia(:,:,:,:) 
    T_E1E2_ia_t(:,:,:,:,:) = T_E1E2_ia(:,:,:,:,:) 
    T_E1M1_ia_t(:,:,:,:) = T_E1M1_ia(:,:,:,:) 
    T_E2E2_ia_t(:,:,:,:,:,:) = T_E2E2_ia(:,:,:,:,:,:) 
  endif

! Evaluation of isotropical component in E2E2
! Factor 1.5 (not in spherical tensor) is in order to have the same than obtained by summing
! the 6 polarization-wave-vector directions
  if( E2E2 ) &
    Sph_E2E2(:) = natomsym_f * 1.5_db * ( 1 / 45._db ) &
                * real( 6 * ( T_E2E2_ia(1,3,1,3,:,1) + T_E2E2_ia(2,3,2,3,:,1) + T_E2E2_ia(1,2,1,2,:,1) ) &
                      + 2 * ( T_E2E2_ia(1,1,1,1,:,1) + T_E2E2_ia(2,2,2,2,:,1) + T_E2E2_ia(3,3,3,3,:,1) ) &
                          - ( T_E2E2_ia(1,1,2,2,:,1) + T_E2E2_ia(1,1,3,3,:,1) + T_E2E2_ia(3,3,2,2,:,1) &
                            + T_E2E2_ia(2,2,1,1,:,1) + T_E2E2_ia(3,3,1,1,:,1) + T_E2E2_ia(2,2,3,3,:,1) ), db )
  if( E2M2 ) &
    Sph_E2M2(:) = natomsym_f * 1.5_db * ( 1 / 45._db ) &
                * real( 6 * ( T_E2M2_ia(1,3,1,3,:,1) + T_E2M2_ia(2,3,2,3,:,1) + T_E2M2_ia(1,2,1,2,:,1) ) &
                      + 2 * ( T_E2M2_ia(1,1,1,1,:,1) + T_E2M2_ia(2,2,2,2,:,1) + T_E2M2_ia(3,3,3,3,:,1) ) &
                          - ( T_E2M2_ia(1,1,2,2,:,1) + T_E2M2_ia(1,1,3,3,:,1) + T_E2M2_ia(3,3,2,2,:,1) &
                            + T_E2M2_ia(2,2,1,1,:,1) + T_E2M2_ia(3,3,1,1,:,1) + T_E2M2_ia(2,2,3,3,:,1) ), db )
  
  if( Dafs ) then
    phdt1(:) = phdt(:,1,1)
    if( n_z_SRXRD_abs > 0 ) then
      Sum_Bragg_abs_NR(:) = Sum_Bragg_abs_f0(:,1)
    else
      Sum_Bragg_abs_NR(:) = Sum_Bragg_NR_T(:,1)
    endif
  endif

  if( Spherical_tensor ) call Spherical_tensor_cal(Abs_U_iso,Bragg_abs,ct_nelec,Core_resolved,Volume_maille,E_cut,E1E1,E1E2, &
            E1M1,E2E2,Energ,Ephseuil,Epsii,Eseuil(nbseuil),First_E,Header,icheck,ie,Int_tens,jseuil,Magn_sens,Moyenne, &
            n_tens_max,natomsym,nenerg,ninit1,ninitr,nomfich_t,nphim,npldafs,nplr,nplrm,nplt,nseuil,numat_abs, &
            pdp,Sum_Bragg_abs_NR,phdt1,pol,Poldafse,Poldafss,T_E1E1_ia_t,T_E1E2_ia_t,T_E1M1_ia_t,T_E2E2_ia_t, &
            Spherical_signal,Surface_ref,Taux_eq,V0muf,Vec,Vecdafse,Vecdafss)

! Logical setting that wave vector will be used
  E_vec = .false.
  do i = 2,n_Multipole_max
    if( .not. Multipole(i) ) cycle
    E_vec = .true.
    exit
  end do

  jpl = 0

  if( Cor_abs ) then
    nplt = nplr + 3*npldafs
  else
    nplt = nplr + npldafs
  endif
  
  do ixandafs = 1,2 !  = 1 absorption, = 2 DAFS

    do ipl = 1,nplt ! Loop over polarizations

      mu_cal = .false.
      Dafs_cal = .false.

      if( ipl > nplr ) then
        if( Cor_abs ) then
          ipldafs = ( ipl - nplr + 2 ) / 3
          ind_mu = mod(ipl - nplr + 2, 3)
          if( ind_mu == 0 ) then
            Dafs_cal = .true.
          else
            mu_cal = .true.
          endif
        else
          ipldafs = ipl - nplr
          Dafs_cal = .true.
        endif
      else
        if( ixandafs == 2 ) cycle
        Dafs_cal = .false.
        jpl = jpl + 1
        ipldafs = 0
        if( ipl == ncolr - 3 * n_mat_cal / 2 .and. Xan_atom ) jpl = jpl + 1
        if( ipl == ncolr - 3 * n_mat_cal / 2 .and. Moyenne ) jpl = jpl + 1
      endif

      if( Dafs_cal .and. ixandafs == 1 ) cycle
      if( .not. Dafs_cal .and. ixandafs == 2 ) cycle

      Tens_comp = Magn_sens .or. Green_int .or. Dafs_cal

      Tensor_eval = .true.
      if( Dafs_cal .and. ipldafs > 1 ) then
        if(     ( abs( hkl_dafs(1,ipldafs) - hkl_dafs(1,ipldafs-1) ) < eps10 ) &
          .and. ( abs( hkl_dafs(2,ipldafs) - hkl_dafs(2,ipldafs-1) ) < eps10 ) &
          .and. ( abs( hkl_dafs(3,ipldafs) - hkl_dafs(3,ipldafs-1) ) < eps10 ) ) Tensor_eval = .false.
      endif
      if( ipl > 1 .and. .not. Dafs_cal ) Tensor_eval = .false.

      if( Tensor_eval ) then

        T_E1E1_ia(:,:,:,0) = (0._db,0._db)
        T_E1E2_ia(:,:,:,:,0) = (0._db,0._db)
        T_E1E2_ia_m(:,:,:,:,0) = (0._db,0._db)
        T_E2E2_ia(:,:,:,:,:,0) = (0._db,0._db)
        T_E2M2_ia(:,:,:,:,:,0) = (0._db,0._db)
        T_E2M2_ia_m(:,:,:,:,:,0) = (0._db,0._db)
        T_E1E3_ia(:,:,:,:,:,0) = (0._db,0._db)
        T_E1SP_ia(:,:,:,0) = (0._db,0._db)
        if( E3E3 ) T_E3E3_ia(:,:,:,:,:,0) = (0._db,0._db)
        T_E1M1_ia(:,:,:,0) = (0._db,0._db)
        T_E1M1_ia_m(:,:,:,0) = (0._db,0._db)
        T_E1M2_ia(:,:,:,:,0) = (0._db,0._db)
        T_E1M2_ia_m(:,:,:,:,0) = (0._db,0._db)
        T_M1M1_ia(:,:,:,0) = (0._db,0._db)
        T_SPSP_ia(:,:,:,0) = (0._db,0._db)
        if( Green_int_mag ) then
          T_E1E1_ia_m(:,:,:,0) = (0._db,0._db)
          T_E2E2_ia_m(:,:,:,:,:,0) = (0._db,0._db)
          T_E1E3_ia_m(:,:,:,:,:,0) = (0._db,0._db)
          T_E1SP_ia_m(:,:,:,0) = (0._db,0._db)
          if( E3E3 ) T_E3E3_ia_m(:,:,:,:,:,0) = (0._db,0._db)
          T_M1M1_ia_m(:,:,:,0) = (0._db,0._db)
          T_SPSP_ia_m(:,:,:,0) = (0._db,0._db)
        endif

        do ia = 1,natomsym

          if( Dafs_cal ) then
! exp(iQr) is conjugated. One gets back the complex conjugate in convolution.
! Bragg_abs already contains Taux_eq.
            ph = conjg( Bragg_abs(ia,ipldafs) )
          else
            ph = (1._db, 0._db) * Taux_eq(ia)
          endif
          ph_m = img * ph

          if( Green_int ) then
            if( E1E1 ) T_E1E1_ia(:,:,:,0) = T_E1E1_ia(:,:,:,0) + ph * T_E1E1_ia(:,:,:,ia)
            if( E1E2 ) T_E1E2_ia(:,:,:,:,0) = T_E1E2_ia(:,:,:,:,0) + ph * T_E1E2_ia(:,:,:,:,ia)
            if( E1E3 ) T_E1E3_ia(:,:,:,:,:,0) = T_E1E3_ia(:,:,:,:,:,0) + ph * T_E1E3_ia(:,:,:,:,:,ia)
            if( E1M1 ) T_E1M1_ia(:,:,:,0) = T_E1M1_ia(:,:,:,0) + ph * T_E1M1_ia(:,:,:,ia)
            if( E1M2 ) T_E1M2_ia(:,:,:,:,0) = T_E1M2_ia(:,:,:,:,0) + ph * T_E1M2_ia(:,:,:,:,ia)
            if( E1SP ) T_E1SP_ia(:,:,:,0) = T_E1SP_ia(:,:,:,0) + ph * T_E1SP_ia(:,:,:,ia)
            if( E2E2 ) T_E2E2_ia(:,:,:,:,:,0) = T_E2E2_ia(:,:,:,:,:,0) + ph * T_E2E2_ia(:,:,:,:,:,ia)
            if( E2M2 ) T_E2M2_ia(:,:,:,:,:,0) = T_E2M2_ia(:,:,:,:,:,0) + ph * T_E2M2_ia(:,:,:,:,:,ia)
            if( E3E3 ) T_E3E3_ia(:,:,:,:,:,0 ) = T_E3E3_ia(:,:,:,:,:,0) + ph * T_E3E3_ia(:,:,:,:,:,ia)
            if( M1M1 ) T_M1M1_ia(:,:,:,0) = T_M1M1_ia(:,:,:,0) + ph * T_M1M1_ia(:,:,:,ia)
            if( SPSP ) T_SPSP_ia(:,:,:,0) = T_SPSP_ia(:,:,:,0) + ph * T_SPSP_ia(:,:,:,ia)
            if( Green_int_mag ) then
              if( E1E1 ) T_E1E1_ia_m(:,:,:,0) = T_E1E1_ia_m(:,:,:,0) + ph * T_E1E1_ia_m(:,:,:,ia)
              if( E1E2 ) T_E1E2_ia_m(:,:,:,:,0) = T_E1E2_ia_m(:,:,:,:,0) + ph * T_E1E2_ia_m(:,:,:,:,ia)
              if( E1E3 ) T_E1E3_ia_m(:,:,:,:,:,0) = T_E1E3_ia_m(:,:,:,:,:,0) + ph * T_E1E3_ia_m(:,:,:,:,:,ia)
              if( E1M1 ) T_E1M1_ia_m(:,:,:,0) = T_E1M1_ia_m(:,:,:,0) + ph * T_E1M1_ia_m(:,:,:,ia)
              if( E1M2 ) T_E1M2_ia_m(:,:,:,:,0) = T_E1M2_ia_m(:,:,:,:,0) + ph * T_E1M2_ia_m(:,:,:,:,ia)
              if( E1SP ) T_E1SP_ia_m(:,:,:,0) = T_E1SP_ia_m(:,:,:,0) + ph * T_E1SP_ia_m(:,:,:,ia)
              if( E2E2 ) T_E2E2_ia_m(:,:,:,:,:,0) = T_E2E2_ia_m(:,:,:,:,:,0) + ph * T_E2E2_ia_m(:,:,:,:,:,ia)
              if( E2M2 ) T_E2M2_ia_m(:,:,:,:,:,0) = T_E2M2_ia_m(:,:,:,:,:,0) + ph * T_E2M2_ia_m(:,:,:,:,:,ia)
              if( E3E3 ) T_E3E3_ia_m(:,:,:,:,:,0 ) = T_E3E3_ia_m(:,:,:,:,:,0) + ph * T_E3E3_ia_m(:,:,:,:,:,ia)
              if( M1M1 ) T_M1M1_ia_m(:,:,:,0) = T_M1M1_ia_m(:,:,:,0) + ph * T_M1M1_ia_m(:,:,:,ia)
              if( SPSP ) T_SPSP_ia_m(:,:,:,0) = T_SPSP_ia_m(:,:,:,0) + ph * T_SPSP_ia_m(:,:,:,ia)
            endif

          else

            if( E1E1 ) T_E1E1_ia(:,:,:,0) = T_E1E1_ia(:,:,:,0) + ph * T_E1E1_ia(:,:,:,ia)
  
  ! One sets the magnetic part of the "interference tensors" separately        
            if( E1E2 ) then
              T_E1E2_ia(:,:,:,:,0) = T_E1E2_ia(:,:,:,:,0) + ph * real( T_E1E2_ia(:,:,:,:,ia), db)
              if( Magn_sens ) T_E1E2_ia_m(:,:,:,:,0) = T_E1E2_ia_m(:,:,:,:,0) + ph_m * aimag( T_E1E2_ia(:,:,:,:,ia) )
            endif
       
            if( E1E3 ) T_E1E3_ia(:,:,:,:,:,0) = T_E1E3_ia(:,:,:,:,:,0) + ph * T_E1E3_ia(:,:,:,:,:,ia)
       
            if( E1M1 ) then
            ! Magnetism is on real part
              T_E1M1_ia(:,:,:,0) = T_E1M1_ia(:,:,:,0) + ph_m * aimag( T_E1M1_ia(:,:,:,ia) )
              if( Magn_sens ) T_E1M1_ia_m(:,:,:,0) = T_E1M1_ia_m(:,:,:,0) + ph * real( T_E1M1_ia(:,:,:,ia), db )
            endif
       
            if( E1M2 ) then
            ! versus M1, there is a multiplication by "i" (the one in front of k) already included in Gaunt_M2 and thus in the tensor.
            ! so, magnetism is on the imaginary part
              T_E1M2_ia(:,:,:,:,0) = T_E1M2_ia(:,:,:,:,0) + ph * T_E1M2_ia(:,:,:,:,ia)
              if( Magn_sens ) T_E1M2_ia_m(:,:,:,:,0) = T_E1M2_ia_m(:,:,:,:,0) + ph_m * aimag( T_E1M2_ia(:,:,:,:,ia) )
            endif

! E1SP is in fact E1SP + SPE1 (so, it is hermitic (when not Green_int) )
            if( E1SP ) T_E1SP_ia(:,:,:,0) = T_E1SP_ia(:,:,:,0) + ph * T_E1SP_ia(:,:,:,ia)
      
            if( E2E2 ) T_E2E2_ia(:,:,:,:,:,0) = T_E2E2_ia(:,:,:,:,:,0) + ph * T_E2E2_ia(:,:,:,:,:,ia)
      
            if( E2M2 ) then
              T_E2M2_ia(:,:,:,:,:,0) = T_E2M2_ia(:,:,:,:,:,0) + ph * real( T_E2M2_ia(:,:,:,:,:,ia), db )
              if( Magn_sens ) T_E2M2_ia_m(:,:,:,:,:,0) = T_E2M2_ia_m(:,:,:,:,:,0) + ph_m * aimag( T_E2M2_ia(:,:,:,:,:,ia) ) 
            endif
            
            if( E3E3 ) T_E3E3_ia(:,:,:,:,:,0) = T_E3E3_ia(:,:,:,:,:,0) + ph * T_E3E3_ia(:,:,:,:,:,ia)
      
            if( M1M1 ) T_M1M1_ia(:,:,:,0) = T_M1M1_ia(:,:,:,0) + ph * T_M1M1_ia(:,:,:,ia)
      
            if( SPSP ) T_SPSP_ia(:,:,:,0) = T_SPSP_ia(:,:,:,0) + ph * T_SPSP_ia(:,:,:,ia)
          
          endif

        end do

        if( Cartesian_tensor ) then
          do ib = 0,nb
            if( natomsym == 1 .and. ib > 0 ) cycle
            if( ib == 0 ) then
              ia = 1
            elseif( ib == 1 ) then
              ia = 0
            else
              ia = ib
            endif
            if( ia /= 0 .and. ( ipl > 1 .and. .not. Dafs_cal ) ) cycle
            call Write_cartesian_tensor(Abs_U_iso,Volume_maille,E_cut,E1E2,E2E2,Ephseuil,Epsii,Eseuil(nbseuil),First_E,Header, &
               ia,ipldafs,jseuil,M1M1,Magn_sens,natomsym,ninit1,ninitr,nomfich_t,nseuil,numat_abs,T_E1E1_ia,T_E1E2_ia, &
               T_E1E2_ia_m,T_E2E2_ia,T_E1M1_ia,Tens_comp,V0muf,Core_resolved)
          end do
        endif

      endif

      if( .not. Bulk_roughness_case .and. &
          (     ( ie == 1 .and. ( ( icheck > 0 .and. ipl == 1 ) .or. ( icheck > 1 .and. Dafs_cal ) )  ) &
           .or. (                 ( icheck > 1 .and. ipl == 1 ) .or. ( icheck > 2 .and. Dafs_cal )    )     ) ) &
        call Write_ten_bav( Core_resolved, Final_tddft, Green_int, Green_int_mag, icheck, &
                       Dafs_cal, ipl, ipldafs, jseuil, Magn_sens, Multipole, n_oo, natomsym, nb, nbseuil, ninit1, ninitr, &
                       nseuil, T_E1E1_ia, T_E1E1_ia_m, T_E1E2_ia, T_E1E2_ia_m, T_E1E3_ia, T_E1E3_ia_m, T_E1M1_ia, T_E1M1_ia_m, &
                       T_E1M2_ia, T_E1M2_ia_m, T_E1SP_ia, T_E1SP_ia_m, T_E2E2_ia, T_E2E2_ia_m, T_E2M2_ia, T_E2M2_ia_m, &
                       T_E3E3_ia, T_E3E3_ia_m, T_M1M1_ia, T_M1M1_ia_m, T_SPSP_ia, T_SPSP_ia_m, Tens_comp )

      if( Dafs_cal .or. mu_cal ) then
        np = nphi_dafs(ipldafs)
      else
        np = 1
      endif

      do ip = 1,np

        if( .not. ( Dafs_cal .or. mu_cal ) ) then

          if( ltypcal(ipl) == 'sp   ' ) then
            plae(:) = pol(:,ipl-1)
            plas(:) = pol(:,ipl)
          elseif( ltypcal(ipl) == 'ps   ' ) then
            plae(:) = pol(:,ipl+1)
            plas(:) = pol(:,ipl)
          else
            plae(:) = pol(:,ipl)
            plas(:) = pol(:,ipl)
          endif
          if( E_vec ) voae(:) = vec(:,ipl)
          if( E_vec ) voas(:) = vec(:,ipl)

        elseif( Dafs_cal ) then

          plae(:) = poldafse(:,ipldafs,ip)
          plas(:) = poldafss(:,ipldafs,ip)
          if( E_vec ) voae(:) = vecdafse(:,ipldafs,ip)
          if( E_vec ) voas(:) = vecdafss(:,ipldafs,ip)

        else ! calculation of mu

          if( Full_self_abs ) then

            select case(mod(ipldafs,4))
              case(1,0)
                if( ind_mu == 1 ) then   ! incoming
                  plae(:) = poldafse(:,ipldafs,ip)
                  plas(:) = poldafse(:,ipldafs,ip)
                  if( E_vec ) voae(:) = vecdafse(:,ipldafs,ip)
                  if( E_vec ) voas(:) = vecdafse(:,ipldafs,ip)
                else
                  plae(:) = poldafss(:,ipldafs,ip)
                  plas(:) = poldafss(:,ipldafs,ip)
                  if( E_vec ) voae(:) = vecdafss(:,ipldafs,ip)
                  if( E_vec ) voas(:) = vecdafss(:,ipldafs,ip)
                endif
              case(2)
                if( ind_mu == 1 ) then   ! incoming
                  plae(:) = poldafse(:,ipldafs,ip)
                  plas(:) = poldafse(:,ipldafs+1,ip)
                  if( E_vec ) voae(:) = vecdafse(:,ipldafs,ip)
                  if( E_vec ) voas(:) = vecdafse(:,ipldafs+1,ip)
                else
                  plae(:) = poldafss(:,ipldafs+1,ip)
                  plas(:) = poldafss(:,ipldafs+2,ip)
                  if( E_vec ) voae(:) = vecdafss(:,ipldafs+1,ip)
                  if( E_vec ) voas(:) = vecdafss(:,ipldafs+2,ip)
                endif
              case(3)
                if( ind_mu == 1 ) then   ! incoming
                  plae(:) = poldafse(:,ipldafs,ip)
                  plas(:) = poldafse(:,ipldafs-1,ip)
                  if( E_vec ) voae(:) = vecdafse(:,ipldafs,ip)
                  if( E_vec ) voas(:) = vecdafse(:,ipldafs-1,ip)
                else
                  plae(:) = poldafss(:,ipldafs+1,ip)
                  plas(:) = poldafss(:,ipldafs,ip)
                  if( E_vec ) voae(:) = vecdafss(:,ipldafs+1,ip)
                  if( E_vec ) voas(:) = vecdafss(:,ipldafs,ip)
                endif
            end select

          else  ! Self_abs

            if( ind_mu == 1 ) then
              plae(:) = poldafse(:,ipldafs,ip)
              plas(:) = poldafse(:,ipldafs,ip)
              if( E_vec ) voae(:) = vecdafse(:,ipldafs,ip)
              if( E_vec ) voas(:) = vecdafse(:,ipldafs,ip)
            else
              plae(:) = poldafss(:,ipldafs,ip)
              plas(:) = poldafss(:,ipldafs,ip)
              if( E_vec ) voae(:) = vecdafss(:,ipldafs,ip)
              if( E_vec ) voas(:) = vecdafss(:,ipldafs,ip)
            endif

          endif

        endif

        if( Dafs_cal .or. mu_cal ) then
! In convolution one take the complex conjugate of all the set "Polarisation x scattering"
          plae(:) = conjg( plae(:) )
          plas(:) = conjg( plas(:) )
        endif

! Unitary vector along the photon magnetic field direction
        if( M1M1 .or. E1M1 .or. E1M2 .or. E2M2 ) then
          uae(1) = voae(2) * plae(3) - voae(3) * plae(2)
          uae(2) = voae(3) * plae(1) - voae(1) * plae(3)
          uae(3) = voae(1) * plae(2) - voae(2) * plae(1)
          uas(1) = voas(2) * plas(3) - voas(3) * plas(2)
          uas(2) = voas(3) * plas(1) - voas(1) * plas(3)
          uas(3) = voas(1) * plas(2) - voas(2) * plas(1)
        endif

        do ia = 0,nab
          do initr = 1,ninitr

            if( Core_resolved .and. .not. Final_tddft ) then
              if( initr <= ninit1 ) then
                iseuil = 1
              else
                iseuil = min(2, nbseuil)
              endif
            elseif( Final_tddft ) then
              iseuil = min(2, nbseuil)
            else
              iseuil = initr
            endif

            Ephoton = Energ(ie) + Eseuil(iseuil)
! For very low energy edges (to avoid negative photon energy):
            Ephoton = max( 0.001_db/Rydb, Ephoton)

            if( E1E1 ) then
              sec = (0._db,0._db)
 
              do ke = 1,3
                sec = sec + plae(ke) * sum( conjg(plas(:) ) * T_E1E1_ia(:,ke,initr,ia))
              end do
              if( Green_int_mag ) then
                do ke = 1,3
                  sec = sec + plae(ke) * sum( conjg(plas(:) ) * T_E1E1_ia_m(:,ke,initr,ia) )
                end do
              endif
              
! A factor pi is missing, it has aleady been taken into account in routine Tens_ab.
              if( Dafs_cal ) then
                if( Green_int ) sec = pi * img * conjg( sec )
                Ampldafs_E1E1(ipldafs,ip,initr,ia) = sec
              elseif( mu_cal ) then
                mu_E1E1(ipldafs,ip,ind_mu,initr,ia) = sec
              else
                Secabs_E1E1(jpl,initr,ia) = real( sec, db )
                if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' ) Secabs_E1E1(jpl+1,initr,ia) = aimag( sec )
              endif
            endif

            if( E1E2 ) then
              sec = (0._db,0._db)
              do ke = 1,3
                do ks = 1,3
                  sec = sec + conjg( plas(ks) ) * plae(ke) &
                            * sum( voae(:) * T_E1E2_ia(ks,ke,:,initr,ia) - voas(:) * T_E1E2_ia(ke,ks,:,initr,ia) )
                  if( Magn_sens ) sec = sec + conjg( plas(ks) ) * plae(ke) &
                            * sum( voae(:) * T_E1E2_ia_m(ks,ke,:,initr,ia) + voas(:) * T_E1E2_ia_m(ke,ks,:,initr,ia) )
                end do
              end do

              sec = img * sec      ! Here one gets back img
              if( Dafs_cal ) sec = - sec

              if( Dafs_cal ) then
                if( Green_int ) sec = pi * img * conjg( sec )
                Ampldafs_E1E2(ipldafs,ip,initr,ia) = sec
              elseif( mu_cal ) then
                mu_E1E2(ipldafs,ip,ind_mu,initr,ia) = sec
              else
                Secabs_E1E2(jpl,initr,ia) = real( sec, db )
                if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' ) Secabs_E1E2(jpl+1,initr,ia) = aimag( sec )
              endif
            endif

            if( E1E3 ) then
              sec = (0._db,0._db)
              do ke = 1,3
                do ks = 1,3
                  do j1 = 1,3
                    sec = sec + conjg( plas(ks) ) * plae(ke) * ( voae(j1) * sum( voae(:) * T_E1E3_ia(ks,ke,j1,:,initr,ia) ) &
                                                               + voas(j1) * sum( voas(:) * T_E1E3_ia(ke,ks,j1,:,initr,ia) ) )
                    if( Magn_sens ) &
                      sec = sec + conjg( plas(ks) ) * plae(ke) * ( voae(j1) * sum( voae(:) * T_E1E3_ia_m(ks,ke,j1,:,initr,ia) ) &
                                                                 - voas(j1) * sum( voas(:) * T_E1E3_ia_m(ke,ks,j1,:,initr,ia) ) )
                  end do
                end do
              end do
              if( Dafs_cal ) then
                if( Green_int ) sec = pi * img * conjg( sec )
                Ampldafs_E1E3(ipldafs,ip,initr,ia)=sec
              elseif( mu_cal ) then
                mu_E1E3(ipldafs,ip,ind_mu,initr,ia) = sec
              else
                Secabs_E1E3(jpl,initr,ia) = real( sec, db )
                if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' ) Secabs_E1E3(jpl+1,initr,ia) = aimag( sec )
              endif
            endif

            if( E1M1 ) then
              sec = (0._db,0._db)
              do ks = 1,3
  ! Minus sign in front of conjg( uas(ks) ) because second line corresponds to M1E1 obtained by the Conj( transpose )
  ! and the non magnetic part is just imaginary (without eventual Bragg term). The Conj of an imaginary is just a change of sign. 
                sec = sec + conjg( plas(ks) ) * sum( uae(:) * T_E1M1_ia(ks,:,initr,ia) ) &
                          - conjg( uas(ks) ) * sum( plae(:) * T_E1M1_ia(:,ks,initr,ia) )  
  ! In the opposite way that above the conj magnetic part wich is pure real, does not give a change of sign. So there "+" in front of the second term.
                if( Magn_sens ) sec = sec + conjg( plas(ks) ) * sum( uae(:) * T_E1M1_ia_m(ks,:,initr,ia) ) &
                                          + conjg( uas(ks) ) * sum( plae(:) * T_E1M1_ia_m(:,ks,initr,ia) )
              end do

! A factor pi is missing, it has aleady been taken into account in routine Tens_ab.
              if( Dafs_cal ) then
                if( Green_int ) sec = pi * img * conjg( sec )
                Ampldafs_E1M1(ipldafs,ip,initr,ia) = sec
              elseif( mu_cal ) then
                mu_E1M1(ipldafs,ip,ind_mu,initr,ia) = sec
              else
                Secabs_E1M1(jpl,initr,ia) = real( sec, db )
                if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' ) Secabs_E1M1(jpl+1,initr,ia) = aimag( sec )
              endif
            endif

            if( E1M2 ) then
              sec = (0._db,0._db)
              ! Only the magnetic part change of sign in the transpose
              do ke = 1,3
                do ks = 1,3
                  sec = sec + conjg( plas(ks) ) * uae(ke) * sum( voae(:) * T_E1M2_ia(ks,ke,:,initr,ia) ) &
                            + plae(ke) * conjg( uas(ks) ) * sum( voas(:) * T_E1M2_ia(ke,ks,:,initr,ia) )
                  if( Magn_sens ) &
                    sec = sec + conjg( plas(ks) ) * uae(ke) * sum( voae(:) * T_E1M2_ia_m(ks,ke,:,initr,ia) ) &
                              - plae(ke) * conjg( uas(ks) ) * sum( voas(:) * T_E1M2_ia_m(ke,ks,:,initr,ia) )
                end do
              end do

              if( Dafs_cal ) then
                if( Green_int ) sec = pi * img * conjg( sec )
                Ampldafs_E1M2(ipldafs,ip,initr,ia) = sec
              elseif( mu_cal ) then
                mu_E1M2(ipldafs,ip,ind_mu,initr,ia) = sec
              else
                Secabs_E1M2(jpl,initr,ia) = real( sec, db )
                if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' ) Secabs_E1M2(jpl+1,initr,ia) = aimag( sec )
              endif
            endif

            if( E1SP ) then
              sec = (0._db,0._db)
 
              do ke = 1,3
                sec = sec + plae(ke) * sum( conjg( plas(:) ) * T_E1SP_ia(:,ke,initr,ia) )
                if( Green_int_mag ) &
                  sec = sec + plae(ke) * sum( conjg( plas(:) ) * T_E1SP_ia_m(:,ke,initr,ia) )
              end do
              
! A factor pi is missing, it has aleady been taken into account in routine Tens_ab.
              if( Dafs_cal ) then
                if( Green_int ) sec = pi * img * conjg( sec )
                Ampldafs_E1SP(ipldafs,ip,initr,ia) = sec
              elseif( mu_cal ) then
                mu_E1SP(ipldafs,ip,ind_mu,initr,ia) = sec
              else
                Secabs_E1SP(jpl,initr,ia) = real( sec, db )
                if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' ) Secabs_E1SP(jpl+1,initr,ia) = aimag( sec )
              endif
            endif

            if( E2E2 ) then
              sec = (0._db,0._db)
              do ke = 1,3
                do je = 1,3
                  do ks = 1,3
                    sec = sec + conjg( plas(ks) ) * plae(ke) * voae(je) * sum( voas(:) * T_E2E2_ia(ks,:,ke,je,initr,ia) )
                    if( Green_int_mag ) &
                      sec = sec + conjg( plas(ks) ) * plae(ke) * voae(je) * sum( voas(:) * T_E2E2_ia_m(ks,:,ke,je,initr,ia) )
                  end do
                end do
              end do
              if( Dafs_cal ) then
                if( Green_int ) sec = pi * img * conjg( sec )
                Ampldafs_E2E2(ipldafs,ip,initr,ia) = sec
              elseif( mu_cal ) then
                mu_E2E2(ipldafs,ip,ind_mu,initr,ia) = sec
              else
                Secabs_E2E2(jpl,initr,ia) = real( sec,db )
                if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' ) Secabs_E2E2(jpl+1,initr,ia) = aimag( sec )
              endif
            endif

            if( E2M2 ) then
            ! as in E1E2, there is a change of sign because of "i" in front of k. Here it is for the first terme because it is the k of E2
            ! The "i" in front of k of M2 is included in Gaunt_M2 and thus in the tensor
              sec = (0._db,0._db)
              do ks = 1,3
                do js = 1,3
                  do ke = 1,3
                    sec = sec - conjg( plas(ks) ) * voas(js) * uae(ke) * sum( voae(:) * T_E2M2_ia(ks,js,ke,:,initr,ia) ) &
                              + conjg( uas(ks) ) * voas(js) * plae(ke) * sum( voae(:) * T_E2M2_ia(ke,:,ks,js,initr,ia) )
                                  
 ! The change of sign in the transpose term corresponds to the complex conjugate of the complete tensor and "_m" is only its imaginary part 
                    if( Magn_sens ) &
                      sec = sec - conjg( plas(ks) ) * voas(js) * uae(ke) * sum( voae(:) * T_E2M2_ia_m(ks,js,ke,:,initr,ia) ) &
                                - conjg( uas(ks) ) * voas(js) * plae(ke) * sum( voae(:) * T_E2M2_ia_m(ke,:,ks,js,initr,ia) )                                
                  end do
                end do
              end do
 
              sec = img * sec      ! Here one gets back img of the E2
              if( Dafs_cal ) sec = - sec

              if( Dafs_cal ) then
                if( Green_int ) sec = pi * img * conjg( sec )
                Ampldafs_E2M2(ipldafs,ip,initr,ia) = sec
              elseif( mu_cal ) then
                mu_E2M2(ipldafs,ip,ind_mu,initr,ia) = sec
              else
                Secabs_E2M2(jpl,initr,ia) = real( sec,db )
                if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' ) Secabs_E2M2(jpl+1,initr,ia) = aimag( sec )
              endif
            endif

            if( E3E3 ) then
              sec = (0._db,0._db)
              do ke = 1,3
                do je = 1,3
                  do he = 1,3
                    jhe = 3 * ( je - 1 ) + he
                    do ks = 1,3
                      do js = 1,3
                        do hs = 1,3
                          jhs = 3 * ( js - 1 ) + hs
                          sec = sec + conjg( plas(ks) ) * voas(js) * voas(hs) * plae(ke) * voae(je) * voae(he) &
                                    * T_E3E3_ia(ks,jhs,ke,jhe,initr,ia)
                          if( Green_int_mag ) &
                            sec = sec + conjg( plas(ks) ) * voas(js) * voas(hs) * plae(ke) * voae(je) * voae(he) &
                                      * T_E3E3_ia_m(ks,jhs,ke,jhe,initr,ia)
                        end do
                      end do
                    end do
                  end do
                end do
              end do
              if( Dafs_cal ) then
                if( Green_int ) sec = pi * img * conjg( sec )
                Ampldafs_E3E3(ipldafs,ip,initr,ia) = sec
              elseif( mu_cal ) then
                mu_E3E3(ipldafs,ip,ind_mu,initr,ia) = sec
              else
                Secabs_E3E3(jpl,initr,ia) = real( sec, db )
                if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' ) Secabs_E3E3(jpl+1,initr,ia) = aimag( sec )
              endif
            endif

            if( M1M1 ) then
              sec = ( 0._db, 0._db )
              
              do ke = 1,3
                sec = sec + uae(ke) * sum( conjg(uas(:)) * T_M1M1_ia(:,ke,initr,ia) )
                if( Green_int_mag ) &
                  sec = sec + uae(ke) * sum( conjg(uas(:)) * T_M1M1_ia_m(:,ke,initr,ia) )
              end do
! A factor pi is missing, it has aleady been taken into account in routine Tens_ab.
              if( Dafs_cal ) then
                if( Green_int ) sec = pi * img * conjg( sec )
                Ampldafs_M1M1(ipldafs,ip,initr,ia)=sec
              elseif( mu_cal ) then
                mu_M1M1(ipldafs,ip,ind_mu,initr,ia) = sec
              else
                Secabs_M1M1(jpl,initr,ia) = real( sec, db )
                if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' ) Secabs_M1M1(jpl+1,initr,ia) = aimag( sec )
              endif
            endif

            if( SPSP ) then
              sec = (0._db,0._db)
 
              do ke = 1,3
                sec = sec + plae(ke) * sum( conjg(plas(:)) * T_SPSP_ia(:,ke,initr,ia) )
                if( Green_int_mag ) &
                  sec = sec + plae(ke) * sum( conjg(plas(:)) * T_SPSP_ia_m(:,ke,initr,ia) )
              end do
              
! A factor pi is missing, it has aleady been taken into account in routine Tens_ab.
              if( Dafs_cal ) then
                if( Green_int ) sec = pi * img * conjg( sec )
                Ampldafs_SPSP(ipldafs,ip,initr,ia) = sec
              elseif( mu_cal ) then
                mu_SPSP(ipldafs,ip,ind_mu,initr,ia) = sec
              else
                Secabs_SPSP(jpl,initr,ia) = real( sec, db )
                if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ' ) Secabs_SPSP(jpl+1,initr,ia) = aimag( sec )
              endif
            endif

          end do   ! End of loop over core states (initr)
        end do   ! End of loop over atoms

        if( ipl > nplr ) cycle
        if( ltypcal(ipl) == 'sp   ' .or. ltypcal(ipl) == 'ps   ') jpl = jpl + 1

      end do ! end of loop over ip (dafs azimuthal angles)

    end do   ! end of loop over polarizations
  end do

  if( Moyenne ) then
    i = ncolr - 3 * n_mat_cal / 2
    if( Xan_atom ) i = i - 1
    ipl = 0
    do j = 1,i
      ipl = ipl + 1
      if( E1E1 ) Secabs_E1E1(i,:,:) = Secabs_E1E1(i,:,:) + pdp(ipl,1) * Secabs_E1E1(j,:,:)
      if( E3E3 ) Secabs_E3E3(i,:,:) = Secabs_E3E3(i,:,:) + pdp(ipl,1) * Secabs_E3E3(j,:,:)
      if( M1M1 ) Secabs_M1M1(i,:,:) = Secabs_M1M1(i,:,:) + pdp(ipl,1) * Secabs_M1M1(j,:,:)
      if( SPSP ) Secabs_SPSP(i,:,:) = Secabs_SPSP(i,:,:) + pdp(ipl,1) * Secabs_SPSP(j,:,:)
      if( ipl == nplr ) exit
    end do
    if( E2E2 ) then
      Secabs_E2E2(i,:,0) = Sph_E2E2(:)
      do ia = 1,nab
        Secabs_E2E2(i,:,ia) = Taux_eq(ia) * Sph_E2E2(:) / natomsym_f
      end do
    endif
   ! For E2M2, I am not sure, I just took the same than in E2E2, I think that contrary to E1M1, monopole is electric.
    if( E2M2 ) then
      Secabs_E2M2(i,:,0) = Sph_E2M2(:)
      do ia = 1,nab
        Secabs_E2M2(i,:,ia) = Taux_eq(ia) * Sph_E2M2(:) / natomsym_f
      end do
    endif
    if( E1M1 ) then
      Secabs_E1M1(i,:,:) = real( T_E1M1_ia(1,1,:,:) + T_E1M1_ia(2,2,:,:) + T_E1M1_ia(3,3,:,:), db ) / 3._db 
    endif
  ! Other interference terms are zero in powder
  ! E1SP is vible only in XMCD, so probably true
  ! For E1M2, it could also be wrong, but formula must be found
    if( E1E2 ) Secabs_E1E2(i,:,:) = ( 0._db, 0._db )
    if( E1E3 ) Secabs_E1E3(i,:,:) = ( 0._db, 0._db )
    if( E1SP ) Secabs_E1SP(i,:,:) = ( 0._db, 0._db )
    if( E1M2 ) Secabs_E1M2(i,:,:) = ( 0._db, 0._db )
  endif

  do ipl = 1,nplr
    if( ltypcal(ipl)(1:4) /= 'left' ) cycle
    allocate( Abs_sum(ninitr,0:natomsym) )
    if( E1E1 ) then
      Abs_sum(:,:) = 0.5_db * ( Secabs_E1E1(ipl,:,:) + Secabs_E1E1(ipl+1,:,:) )
      Secabs_E1E1(ipl+1,:,:) = Secabs_E1E1(ipl,:,:) - Secabs_E1E1(ipl+1,:,:)
      Secabs_E1E1(ipl,:,:) = Abs_sum(:,:)
    endif
    if( E1E2 ) then
      Abs_sum(:,:) = 0.5_db * ( Secabs_E1E2(ipl,:,:) + Secabs_E1E2(ipl+1,:,:) )
      Secabs_E1E2(ipl+1,:,:) = Secabs_E1E2(ipl,:,:) - Secabs_E1E2(ipl+1,:,:)
      Secabs_E1E2(ipl,:,:) = Abs_sum(:,:)
    endif
    if( E2E2 ) then
      Abs_sum(:,:) = 0.5_db * ( Secabs_E2E2(ipl,:,:) + Secabs_E2E2(ipl+1,:,:) )
      Secabs_E2E2(ipl+1,:,:) = Secabs_E2E2(ipl,:,:) - Secabs_E2E2(ipl+1,:,:)
      Secabs_E2E2(ipl,:,:) = Abs_sum(:,:)
    endif
    if( E1E3 ) then
      Abs_sum(:,:) = 0.5_db * ( Secabs_E1E3(ipl,:,:) + Secabs_E1E3(ipl+1,:,:) )
      Secabs_E1E3(ipl+1,:,:) = Secabs_E1E3(ipl,:,:) - Secabs_E1E3(ipl+1,:,:)
      Secabs_E1E3(ipl,:,:) = Abs_sum(:,:)
    endif
    if( E1SP ) then
      Abs_sum(:,:) = 0.5_db * ( Secabs_E1SP(ipl,:,:) + Secabs_E1SP(ipl+1,:,:) )
      Secabs_E1SP(ipl+1,:,:) = Secabs_E1SP(ipl,:,:) - Secabs_E1SP(ipl+1,:,:)
      Secabs_E1SP(ipl,:,:) = Abs_sum(:,:)
    endif
    if( E3E3 ) then
      Abs_sum(:,:) = 0.5_db * ( Secabs_E3E3(ipl,:,:) + Secabs_E3E3(ipl+1,:,:) )
      Secabs_E3E3(ipl+1,:,:) = Secabs_E3E3(ipl,:,:) - Secabs_E3E3(ipl+1,:,:)
      Secabs_E3E3(ipl,:,:) = Abs_sum(:,:)
    endif
    if( M1M1 ) then
      Abs_sum(:,:) = 0.5_db * ( Secabs_M1M1(ipl,:,:) + Secabs_M1M1(ipl+1,:,:) )
      Secabs_M1M1(ipl+1,:,:) = Secabs_M1M1(ipl,:,:) - Secabs_M1M1(ipl+1,:,:)
      Secabs_M1M1(ipl,:,:) = Abs_sum(:,:)
    endif
    if( E1M1 ) then
      Abs_sum(:,:) = 0.5_db * ( Secabs_E1M1(ipl,:,:) + Secabs_E1M1(ipl+1,:,:) )
      Secabs_E1M1(ipl+1,:,:) = Secabs_E1M1(ipl,:,:) - Secabs_E1M1(ipl+1,:,:)
      Secabs_E1M1(ipl,:,:) = Abs_sum(:,:)
    endif
    if( E1M2 ) then
      Abs_sum(:,:) = 0.5_db * ( Secabs_E1M2(ipl,:,:) + Secabs_E1M2(ipl+1,:,:) )
      Secabs_E1M2(ipl+1,:,:) = Secabs_E1M2(ipl,:,:) - Secabs_E1M2(ipl+1,:,:)
      Secabs_E1M2(ipl,:,:) = Abs_sum(:,:)
    endif
    if( E2M2 ) then
      Abs_sum(:,:) = 0.5_db * ( Secabs_E2M2(ipl,:,:) + Secabs_E2M2(ipl+1,:,:) )
      Secabs_E2M2(ipl+1,:,:) = Secabs_E2M2(ipl,:,:) - Secabs_E2M2(ipl+1,:,:)
      Secabs_E2M2(ipl,:,:) = Abs_sum(:,:)
    endif
    if( SPSP ) then
      Abs_sum(:,:) = 0.5_db * ( Secabs_SPSP(ipl,:,:) + Secabs_SPSP(ipl+1,:,:) )
      Secabs_SPSP(ipl+1,:,:) = Secabs_SPSP(ipl,:,:) - Secabs_SPSP(ipl+1,:,:)
      Secabs_SPSP(ipl,:,:) = Abs_sum(:,:)
    endif
    deallocate( Abs_sum )
  end do

  if( Xan_atom ) then
    Secabs_E1E1(ncolr-3*n_mat_cal/2,:,0) = sec_atom(:) * natomsym_f * cst
    do ia = 1,nab
      Secabs_E1E1(ncolr-3*n_mat_cal/2,:,ia) = sec_atom(:) * Taux_eq(ia) * cst
    end do
  endif

  Secabs(:,:,:) = 0._db
  if( E1E1 ) Secabs(:,:,:) = Secabs(:,:,:) + Secabs_E1E1(:,:,:)
  if( E1E2 ) Secabs(:,:,:) = Secabs(:,:,:) + Secabs_E1E2(:,:,:)
  if( E2E2 ) Secabs(:,:,:) = Secabs(:,:,:) + Secabs_E2E2(:,:,:)
  if( E1E3 ) Secabs(:,:,:) = Secabs(:,:,:) + Secabs_E1E3(:,:,:)
  if( E1M2 ) Secabs(:,:,:) = Secabs(:,:,:) + Secabs_E1M2(:,:,:)
  if( E1SP ) Secabs(:,:,:) = Secabs(:,:,:) + Secabs_E1SP(:,:,:)
  if( E2M2 ) Secabs(:,:,:) = Secabs(:,:,:) + Secabs_E2M2(:,:,:)
  if( E3E3 ) Secabs(:,:,:) = Secabs(:,:,:) + Secabs_E3E3(:,:,:)
  if( M1M1 ) Secabs(:,:,:) = Secabs(:,:,:) + Secabs_M1M1(:,:,:)
  if( E1M1 ) Secabs(:,:,:) = Secabs(:,:,:) + Secabs_E1M1(:,:,:)
  if( SPSP ) Secabs(:,:,:) = Secabs(:,:,:) + Secabs_SPSP(:,:,:)

  if( Dafs ) then
    Ampldafs(:,:,:,:) = (0._db,0._db)
    if( E1E1 ) Ampldafs(:,:,:,:) = Ampldafs(:,:,:,:) + Ampldafs_E1E1(:,:,:,:)
    if( E1E2 ) Ampldafs(:,:,:,:) = Ampldafs(:,:,:,:) + Ampldafs_E1E2(:,:,:,:)
    if( E2E2 ) Ampldafs(:,:,:,:) = Ampldafs(:,:,:,:) + Ampldafs_E2E2(:,:,:,:)
    if( E1E3 ) Ampldafs(:,:,:,:) = Ampldafs(:,:,:,:) + Ampldafs_E1E3(:,:,:,:)
    if( E1M1 ) Ampldafs(:,:,:,:) = Ampldafs(:,:,:,:) + Ampldafs_E1M1(:,:,:,:)
    if( E1M2 ) Ampldafs(:,:,:,:) = Ampldafs(:,:,:,:) + Ampldafs_E1M2(:,:,:,:)
    if( E1SP ) Ampldafs(:,:,:,:) = Ampldafs(:,:,:,:) + Ampldafs_E1SP(:,:,:,:)
    if( E2M2 ) Ampldafs(:,:,:,:) = Ampldafs(:,:,:,:) + Ampldafs_E2M2(:,:,:,:)
    if( E3E3 ) Ampldafs(:,:,:,:) = Ampldafs(:,:,:,:) + Ampldafs_E3E3(:,:,:,:)
    if( M1M1 ) Ampldafs(:,:,:,:) = Ampldafs(:,:,:,:) + Ampldafs_M1M1(:,:,:,:)
    if( SPSP ) Ampldafs(:,:,:,:) = Ampldafs(:,:,:,:) + Ampldafs_SPSP(:,:,:,:)
  endif

  if( Cor_abs ) then
    mu(:,:,:,:,:) = (0._db,0._db)
    if( E1E1 ) mu(:,:,:,:,:) = mu(:,:,:,:,:) + mu_E1E1(:,:,:,:,:)
    if( E1E2 ) mu(:,:,:,:,:) = mu(:,:,:,:,:) + mu_E1E2(:,:,:,:,:)
    if( E2E2 ) mu(:,:,:,:,:) = mu(:,:,:,:,:) + mu_E2E2(:,:,:,:,:)
    if( E1E3 ) mu(:,:,:,:,:) = mu(:,:,:,:,:) + mu_E1E3(:,:,:,:,:)
    if( E1M1 ) mu(:,:,:,:,:) = mu(:,:,:,:,:) + mu_E1M1(:,:,:,:,:)
    if( E1M2 ) mu(:,:,:,:,:) = mu(:,:,:,:,:) + mu_E1M2(:,:,:,:,:)
    if( E1SP ) mu(:,:,:,:,:) = mu(:,:,:,:,:) + mu_E1SP(:,:,:,:,:)
    if( E2M2 ) mu(:,:,:,:,:) = mu(:,:,:,:,:) + mu_E2M2(:,:,:,:,:)
    if( E3E3 ) mu(:,:,:,:,:) = mu(:,:,:,:,:) + mu_E3E3(:,:,:,:,:)
    if( M1M1 ) mu(:,:,:,:,:) = mu(:,:,:,:,:) + mu_M1M1(:,:,:,:,:)
    if( SPSP ) mu(:,:,:,:,:) = mu(:,:,:,:,:) + mu_SPSP(:,:,:,:,:)
  endif

! Conversion in number of electrons
  if( dafs ) then
    do initr = 1,ninitr
      cst = ct_nelec(initr) / pi 
      Ampldafs(:,:,initr,:) = cst * Ampldafs(:,:,initr,:)
      if( E1E1 ) Ampldafs_E1E1(:,:,initr,:) = cst * Ampldafs_E1E1(:,:,initr,:)
      if( E1E2 ) Ampldafs_E1E2(:,:,initr,:) = cst * Ampldafs_E1E2(:,:,initr,:)
      if( E1E3 ) Ampldafs_E1E3(:,:,initr,:) = cst * Ampldafs_E1E3(:,:,initr,:)
      if( E1M1 ) Ampldafs_E1M1(:,:,initr,:) = cst * Ampldafs_E1M1(:,:,initr,:)
      if( E1M2 ) Ampldafs_E1M2(:,:,initr,:) = cst * Ampldafs_E1M2(:,:,initr,:)
      if( E1SP ) Ampldafs_E1SP(:,:,initr,:) = cst * Ampldafs_E1SP(:,:,initr,:)
      if( E2E2 ) Ampldafs_E2E2(:,:,initr,:) = cst * Ampldafs_E2E2(:,:,initr,:)
      if( E2M2 ) Ampldafs_E2M2(:,:,initr,:) = cst * Ampldafs_E2M2(:,:,initr,:)
      if( E3E3 ) Ampldafs_E3E3(:,:,initr,:) = cst * Ampldafs_E3E3(:,:,initr,:)
      if( M1M1 ) Ampldafs_M1M1(:,:,initr,:) = cst * Ampldafs_M1M1(:,:,initr,:)
      if( SPSP ) Ampldafs_SPSP(:,:,initr,:) = cst * Ampldafs_SPSP(:,:,initr,:)
    end do
  endif

! Conversion in micrometers
  if( Cor_abs ) then
    c_micro = 100 / ( Volume_maille * bohr**3 )
    mu(:,:,:,:,:) = c_micro * mu(:,:,:,:,:)
    if( E1E1 ) mu_E1E1(:,:,:,:,:) = c_micro * mu_E1E1(:,:,:,:,:)
    if( E1E2 ) mu_E1E2(:,:,:,:,:) = c_micro * mu_E1E2(:,:,:,:,:)
    if( E2E2 ) mu_E2E2(:,:,:,:,:) = c_micro * mu_E2E2(:,:,:,:,:)
    if( E1E3 ) mu_E1E3(:,:,:,:,:) = c_micro * mu_E1E3(:,:,:,:,:)
    if( E1M1 ) mu_E1M1(:,:,:,:,:) = c_micro * mu_E1M1(:,:,:,:,:)
    if( E1M2 ) mu_E1M2(:,:,:,:,:) = c_micro * mu_E1M2(:,:,:,:,:)
    if( E1SP ) mu_E1SP(:,:,:,:,:) = c_micro * mu_E1SP(:,:,:,:,:)
    if( E2M2 ) mu_E2M2(:,:,:,:,:) = c_micro * mu_E2M2(:,:,:,:,:)
    if( E3E3 ) mu_E3E3(:,:,:,:,:) = c_micro * mu_E3E3(:,:,:,:,:)
    if( M1M1 ) mu_M1M1(:,:,:,:,:) = c_micro * mu_M1M1(:,:,:,:,:)
    if( SPSP ) mu_SPSP(:,:,:,:,:) = c_micro * mu_SPSP(:,:,:,:,:)
  endif

  if( n_mat_cal > 0 .and. Matper .and. .not. nseuil == 0 ) then
    c_micro = 100 / ( Volume_maille * bohr**3 )
    i = ncolr - 3 * n_mat_cal / 2 + 1
    Secabs(i:ncolr,:,:) = c_micro * Secabs(i:ncolr,:,:)
    if( E1E1 ) Secabs_E1E1(i:ncolr,:,:) = c_micro * Secabs_E1E1(i:ncolr,:,:)
    if( E1E2 ) Secabs_E1E2(i:ncolr,:,:) = c_micro * Secabs_E1E2(i:ncolr,:,:)
    if( E2E2 ) Secabs_E2E2(i:ncolr,:,:) = c_micro * Secabs_E2E2(i:ncolr,:,:)
    if( E1E3 ) Secabs_E1E3(i:ncolr,:,:) = c_micro * Secabs_E1E3(i:ncolr,:,:)
    if( E1M1 ) Secabs_E1M1(i:ncolr,:,:) = c_micro * Secabs_E1M1(i:ncolr,:,:)
    if( E1M2 ) Secabs_E1M2(i:ncolr,:,:) = c_micro * Secabs_E1M2(i:ncolr,:,:)
    if( E1SP ) Secabs_E1SP(i:ncolr,:,:) = c_micro * Secabs_E1SP(i:ncolr,:,:)
    if( E2M2 ) Secabs_E2M2(i:ncolr,:,:) = c_micro * Secabs_E2M2(i:ncolr,:,:)
    if( E3E3 ) Secabs_E3E3(i:ncolr,:,:) = c_micro * Secabs_E3E3(i:ncolr,:,:)
    if( M1M1 ) Secabs_M1M1(i:ncolr,:,:) = c_micro * Secabs_M1M1(i:ncolr,:,:)
    if( SPSP ) Secabs_SPSP(i:ncolr,:,:) = c_micro * Secabs_SPSP(i:ncolr,:,:)
  endif

 ! Optic case: output in millimeter^-1, possible only for periodical system
  if( nseuil == 0 .and. Matper ) then
    c_milli = 100000 / ( Volume_maille * bohr**3 )
    Secabs(:,:,:) = c_milli * Secabs(:,:,:)
    if( E1E1 ) Secabs_E1E1(:,:,:) = c_milli * Secabs_E1E1(:,:,:)
    if( E1E2 ) Secabs_E1E2(:,:,:) = c_milli * Secabs_E1E2(:,:,:)
    if( E2E2 ) Secabs_E2E2(:,:,:) = c_milli * Secabs_E2E2(:,:,:)
    if( E1E3 ) Secabs_E1E3(:,:,:) = c_milli * Secabs_E1E3(:,:,:)
    if( E1M1 ) Secabs_E1M1(:,:,:) = c_milli * Secabs_E1M1(:,:,:)
    if( E1M2 ) Secabs_E1M2(:,:,:) = c_milli * Secabs_E1M2(:,:,:)
    if( E1SP ) Secabs_E1SP(:,:,:) = c_milli * Secabs_E1SP(:,:,:)
    if( E2M2 ) Secabs_E2M2(:,:,:) = c_milli * Secabs_E2M2(:,:,:)
    if( E3E3 ) Secabs_E3E3(:,:,:) = c_milli * Secabs_E3E3(:,:,:)
    if( M1M1 ) Secabs_M1M1(:,:,:) = c_milli * Secabs_M1M1(:,:,:)
    if( SPSP ) Secabs_SPSP(:,:,:) = c_milli * Secabs_SPSP(:,:,:)
  endif

! Writing ----------------------------------------------------------------------------------------------------

  if( icheck > 0 ) then
    if( Bulk_roughness_case ) write(3,'(/A)') ' Bulk roughness case'
    do ia = 0,nab
      if( ia == 0 ) then
        if( .not. ( nseuil == 0 .and. Matper ) ) then
          write(3,120) ct_nelec(:)
          if( n_mat_cal > 0 .and. Matper ) write(3,130) c_micro 
        else
          write(3,140) c_milli
       endif
        write(3,150)
      else
        write(3,290) ia
      endif
      do ipl = 1,ncolt
        nomab = nomabs(ipl)
        call center_word(nomab,Length_word)
        nomabs(ipl) = nomab
      end do
      nccm = 360
      nl = 1 + ( ncolr - 1 ) / nccm

      do initr = 1,ninitr

        if( ninitr > 1 ) then
          if( nseuil /= 0 ) then
            write(3,295) initr
          elseif( initr > 1 ) then
            write(3,297) initr - 2
          endif
        endif

        n = 0
        More = .false.
        do i = 1,n_Multipole_max
          if( Multipole(i) ) n = n + 1
          if( n < 2 ) cycle
          More = .true.
        end do    
          
        do i = 1,nl
          ic1 = 1 + ( i - 1 ) * nccm
          ic2 = min( i * nccm, ncolr )
          write(3,300) nomabs(ic1:ic2)
          write(3,310) Ephseuil*rydb, Secabs(ic1:ic2,initr,ia)
          if( E1E1 .and. More ) write(3,320) 'E1E1', Secabs_E1E1(ic1:ic2,initr,ia)
          if( E1E2 .and. More ) write(3,320) 'E1E2', Secabs_E1E2(ic1:ic2,initr,ia)
          if( E2E2 .and. More ) write(3,320) 'E2E2', Secabs_E2E2(ic1:ic2,initr,ia)
          if( E1E3 .and. More ) write(3,320) 'E1E3', Secabs_E1E3(ic1:ic2,initr,ia)
          if( E1M1 .and. More ) write(3,320) 'E1M1', Secabs_E1M1(ic1:ic2,initr,ia)
          if( E1M2 .and. More ) write(3,320) 'E1M2', Secabs_E1M2(ic1:ic2,initr,ia)
          if( E2M2 .and. More ) write(3,320) 'E2M2', Secabs_E2M2(ic1:ic2,initr,ia)
          if( E3E3 .and. More ) write(3,320) 'E3E3', Secabs_E3E3(ic1:ic2,initr,ia)
          if( M1M1 .and. More ) write(3,320) 'M1M1', Secabs_M1M1(ic1:ic2,initr,ia)
          if( E1SP .and. More ) write(3,320) 'E1SP', Secabs_E1SP(ic1:ic2,initr,ia)
          if( SPSP .and. More ) write(3,320) 'SPSP', Secabs_SPSP(ic1:ic2,initr,ia)
        end do
        if( dafs ) then
          if( self_abs ) then
            nc = 4
          elseif( Full_self_abs ) then
            nc = 6
          else
            nc = 2
          endif
          nl = 1 + ( nc * npldafs - 1 ) / nccm
          do i = 1,nl
            icn1 = 1 + ( i - 1 ) * nccm
            icn2 = min( i * nccm, nc * npldafs )
            ic1 = 1 + ( i - 1 ) * (nccm/nc)
            ic2 = min( i * (nccm/nc), npldafs )
            write(3,360) nomabs(ncolr+icn1:ncolr+icn2)
            if( self_abs ) then
              write(3,370) (Ampldafs(j,1,initr,ia), Real(mu(j,1,:,initr,ia)), j = ic1,ic2)
              if( E1E1 .and. More ) write(3,320) 'E1E1', ( Ampldafs_E1E1(j,1,initr,ia), Real(mu_E1E1(j,1,:,initr,ia)), j = ic1,ic2 )
              if( E1E2 .and. More ) write(3,320) 'E1E2', ( Ampldafs_E1E2(j,1,initr,ia), Real(mu_E1E2(j,1,:,initr,ia)), j = ic1,ic2 )
              if( E2E2 .and. More ) write(3,320) 'E2E2', ( Ampldafs_E2E2(j,1,initr,ia), Real(mu_E2E2(j,1,:,initr,ia)), j = ic1,ic2 )
              if( E1M1 .and. More ) write(3,320) 'E1M1', ( Ampldafs_E1M1(j,1,initr,ia), Real(mu_E1M1(j,1,:,initr,ia)), j = ic1,ic2 )
              if( E1M2 .and. More ) write(3,320) 'E1M2', ( Ampldafs_E1M2(j,1,initr,ia), Real(mu_E1M2(j,1,:,initr,ia)), j = ic1,ic2 )
              if( E1E3 .and. More ) write(3,320) 'E1E3', ( Ampldafs_E1E3(j,1,initr,ia), Real(mu_E1E3(j,1,:,initr,ia)), j = ic1,ic2 )
              if( E2M2 .and. More ) write(3,320) 'E2M2', ( Ampldafs_E2M2(j,1,initr,ia), Real(mu_E2M2(j,1,:,initr,ia)), j = ic1,ic2 )
              if( E3E3 .and. More ) write(3,320) 'E3E3', ( Ampldafs_E3E3(j,1,initr,ia), Real(mu_E1E3(j,1,:,initr,ia)), j = ic1,ic2 )
              if( M1M1 .and. More ) write(3,320) 'M1M1', ( Ampldafs_M1M1(j,1,initr,ia), Real(mu_M1M1(j,1,:,initr,ia)), j = ic1,ic2 )
              if( E1SP .and. More ) write(3,320) 'E1SP', ( Ampldafs_E1SP(j,1,initr,ia), Real(mu_E1SP(j,1,:,initr,ia)), j = ic1,ic2 )
              if( SPSP .and. More ) write(3,320) 'SPSP', ( Ampldafs_SPSP(j,1,initr,ia), Real(mu_SPSP(j,1,:,initr,ia)), j = ic1,ic2 )
            elseif(Full_self_abs ) then
              write(3,370) (Ampldafs(j,1,initr,ia), mu(j,1,:,initr,ia), j = ic1,ic2)
              if( E1E1 .and. More ) write(3,320) 'E1E1', ( Ampldafs_E1E1(j,1,initr,ia), mu_E1E1(j,1,:,initr,ia), j = ic1,ic2 )
              if( E1E2 .and. More ) write(3,320) 'E1E2', ( Ampldafs_E1E2(j,1,initr,ia), mu_E1E2(j,1,:,initr,ia), j = ic1,ic2 )
              if( E2E2 .and. More ) write(3,320) 'E2E2', ( Ampldafs_E2E2(j,1,initr,ia), mu_E2E2(j,1,:,initr,ia), j = ic1,ic2 )
              if( E1E3 .and. More ) write(3,320) 'E1E3', ( Ampldafs_E1E3(j,1,initr,ia), mu_E1E3(j,1,:,initr,ia), j = ic1,ic2 )
              if( E1M1 .and. More ) write(3,320) 'E1M1', ( Ampldafs_E1M1(j,1,initr,ia), mu_E1M1(j,1,:,initr,ia), j = ic1,ic2 )
              if( E1M2 .and. More ) write(3,320) 'E1M2', ( Ampldafs_E1M2(j,1,initr,ia), mu_E1M2(j,1,:,initr,ia), j = ic1,ic2 )
              if( E3E3 .and. More ) write(3,320) 'E3E3', ( Ampldafs_E3E3(j,1,initr,ia), mu_E1E3(j,1,:,initr,ia), j = ic1,ic2 )
              if( E2M2 .and. More ) write(3,320) 'E2M2', ( Ampldafs_E2M2(j,1,initr,ia), mu_E2M2(j,1,:,initr,ia), j = ic1,ic2 )
              if( M1M1 .and. More ) write(3,320) 'M1M1', ( Ampldafs_M1M1(j,1,initr,ia), mu_M1M1(j,1,:,initr,ia), j = ic1,ic2 )
              if( E1SP .and. More ) write(3,320) 'E1SP', ( Ampldafs_E1SP(j,1,initr,ia), mu_E1SP(j,1,:,initr,ia), j = ic1,ic2 )
              if( SPSP .and. More ) write(3,320) 'SPSP', ( Ampldafs_SPSP(j,1,initr,ia), mu_SPSP(j,1,:,initr,ia), j = ic1,ic2 )
            else
              write(3,370) Ampldafs(ic1:ic2,1,initr,ia)
              if( E1E1 .and. More ) write(3,320) 'E1E1', Ampldafs_E1E1(ic1:ic2,1,initr,ia)
              if( E1E2 .and. More ) write(3,320) 'E1E2', Ampldafs_E1E2(ic1:ic2,1,initr,ia)
              if( E2E2 .and. More ) write(3,320) 'E2E2', Ampldafs_E2E2(ic1:ic2,1,initr,ia)
              if( E1M1 .and. More ) write(3,320) 'E1M1', Ampldafs_E1M1(ic1:ic2,1,initr,ia)
              if( E1M2 .and. More ) write(3,320) 'E1M2', Ampldafs_E1M2(ic1:ic2,1,initr,ia)
              if( E1E3 .and. More ) write(3,320) 'E1E3', Ampldafs_E1E3(ic1:ic2,1,initr,ia)
              if( E2M2 .and. More ) write(3,320) 'E2M2', Ampldafs_E2M2(ic1:ic2,1,initr,ia)
              if( E3E3 .and. More ) write(3,320) 'E3E3', Ampldafs_E3E3(ic1:ic2,1,initr,ia)
              if( M1M1 .and. More ) write(3,320) 'M1M1', Ampldafs_M1M1(ic1:ic2,1,initr,ia)
              if( E1SP .and. More ) write(3,320) 'E1SP', Ampldafs_E1SP(ic1:ic2,1,initr,ia)
              if( SPSP .and. More ) write(3,320) 'SPSP', Ampldafs_SPSP(ic1:ic2,1,initr,ia)
            endif                    
          end do                     
        endif
      end do
    end do
  endif

  if( ie == 1 ) write(6,392) nenerg
  n_dim = ncolm * ninitr

  do ia = 0,na

! Loop over absorbing atoms in SRXRD, up to now in bulk case
    do i_z_SRXRD_abs = 1, max( n_z_SRXRD_abs, 1 )
    
      File_out = nomfich
      nomfichdafst = nomfich
  
      if( ia > 0 ) then
        long = len_trim(File_out)
        File_out(long+1:long+5) = '_atom'
        call ad_number(ia,File_out,Length_name)
        nomfichdafst(long+1:long+5) = '_atom'
        call ad_number(ia,nomfichdafst,Length_name)
      endif
      long = len_trim(File_out)
  
      if( Final_tddft ) then
        File_out(long+1:long+6) = '_tddft'
        nomfichdafst(long+1:long+11) = '_tddft_scan'
      else
        nomfichdafst(long+1:long+5) = '_scan'
      end if
  
      if( n_multi_run > 1 ) then
        l = len_trim(File_out)
        File_out(l+1:l+1) = '_'
        call ad_number(iabsorig,File_out,Length_name)
        l = len_trim(nomfichdafst)
        nomfichdafst(l+1:l+1) = '_'
        call ad_number(iabsorig,nomfichdafst,Length_name)
      endif
      if( n_z_SRXRD_abs > 1 .and. .not. Bulk_roughness_case ) then
        l = len_trim(File_out)
        File_out(l+1:l+1) = '_'
        call ad_number(i_z_SRXRD_abs,File_out,Length_name)
        l = len_trim(nomfichdafst)
        nomfichdafst(l+1:l+1) = '_'
        call ad_number(i_z_SRXRD_abs,nomfichdafst,Length_name)
      elseif( Bulk_roughness_case ) then ! bulk roughness case
        l = len_trim(File_out)
        File_out(l+1:l+2) = '_0'
      endif
      l = len_trim(File_out)
      File_out(l+1:l+4) = '.txt'
      l = len_trim(nomfichdafst)
      nomfichdafst(l+1:l+4) = '.txt'
  
      if( ie == 1 .and. ia == 0 ) nomfich_cal_conv(multi_0+i_z_SRXRD_abs) = File_out
  
      n_tens = 0
  
      do initr = 1,ninitr
  
        n1 = ( initr - 1 ) * ( ncolt-nxanout+1 ) + 1
        n2 = initr * ( ncolt-nxanout+1 )
        title(n1:n2) = nomabs(nxanout:ncolt)
  
        if( ninitr > 1 .and. .not. (initr == 1 .and. nseuil == 0 ) ) then
          do i = n1, n2
            nomab = adjustl(title(i))
            ll = len_trim( nomab )
            if( ll > length_word - 3 ) cycle
            if( nomab(ll:ll) /= '>' .and. n2-n1+1 /= ncolr ) cycle
            ll = ll + 1
            nomab(ll:ll) = '_'
            if( .not. Core_resolved ) then
              ll = ll + 1
              nomab(ll:ll) = achar(nseuil+74)
              ll = ll + 1
              nomab(ll:ll) = achar(jseuil+initr+47)
            else
              if( nseuil == 0 ) then
                call ad_number(initr-2,nomab,length_word)
              else
                call ad_number(initr,nomab,length_word)
              endif
            endif
            call center_word(nomab,Length_word)
            title(i) = nomab
          end do
        endif
  
        ipl = n_tens + ncolr - nxanout + 1
        if( ia == 0 .and. n_z_SRXRD_abs > 1 .and. .not. Bulk_roughness_case ) then
          Tens(n_tens+1:ipl) = 0._db
          do ib = 1,natomsym
            do i = 1,n_zc_SRXRD_abs(i_z_SRXRD_abs)
              if( index_z_SRXRD_abs(i,i_z_SRXRD_abs) == ib ) Tens(n_tens+1:ipl) = Tens(n_tens+1:ipl) &
                                                                                + Secabs(nxanout:ncolr,initr,ib)  
            end do
          end do
        else
          Tens(n_tens+1:ipl) = Secabs(nxanout:ncolr,initr,ia)
        endif
        do ipldafs = 1,npldafs
          if( ia == 0 .and. ( n_z_SRXRD_abs <= 1 .or. Bulk_roughness_case ) ) then
            cf = Ampldafs(ipldafs,1,initr,ia)
          elseif( ia == 0 ) then
            cf = ( 0._db, 0._db )
            do ib = 1,natomsym
              do i = 1,n_zc_SRXRD_abs(i_z_SRXRD_abs)
                if( index_z_SRXRD_abs(i,i_z_SRXRD_abs) == ib ) cf = cf + conjg( Bragg_abs(ib,ipldafs) ) &
                                                                       * Ampldafs(ipldafs,1,initr,ib)  
              end do
            end do
          else
! The exp(iQr) is conjugate. One get back its conjugate in convolution
            cf = conjg( Bragg_abs(ia,ipldafs) ) * Ampldafs(ipldafs,1,initr,ia)
          endif
          ipl = ipl + 1
          Tens(ipl) = real( cf,db )
          ipl = ipl + 1
          Tens(ipl) = aimag( cf )
          if( Full_self_abs ) then
            do i = 1,2
              ipl = ipl + 1
              Tens(ipl) = real( mu(ipldafs,1,i,initr,ia), db )
              ipl = ipl + 1
              Tens(ipl) = aimag( mu(ipldafs,1,i,initr,ia) )
            end do
          elseif( self_abs ) then
            do i = 1,2
              ipl = ipl + 1
              Tens(ipl) = real( mu(ipldafs,1,i,initr,ia), db )
            end do
          endif
        end do

        n_tens = ipl

      end do

      if( ia == 0 ) then
        Bragg_abs_T(:) = phdt(:,1,i_z_SRXRD_abs)
      else
        Bragg_abs_T(:) = Bragg_abs(ia,:)
      endif

      New_file = First_E

      if( First_E ) then
             
        if( Header ) then
          call Write_Header(File_out,Header_info,n_header_info)
          New_file = .false.
        endif

        call Write_first_out(Abs_U_iso,Core_resolved,f_avantseuil,File_out,E_cut,Epsii,Eseuil(nbseuil),Green_int, &
            jseuil,New_file,ninit1,ninitr,nseuil,numat_abs,V0muf,natomsym_f,Surface_ref,Volume_maille)

        if( npldafs > 0 )  call Write_out_Bragg(Bragg_abs_T,File_out,n_tens,npldafs,Sum_Bragg_NR_T)

! Writing in the output file
        if( Full_self_abs .or. Self_abs ) then

          call Write_self_abs_info(angxyz,axyz,File_out,hkl_dafs,npldafs)        

        elseif( n_z_SRXRD_abs >= 1 ) then

          call Write_SRXRD_info(Abs_cap,Abs_SRXRD,Abs_SRXRD_abs,Bulk_step,File_out,hkl_dafs,i_z_SRXRD_abs,Length_Abs,n_tens, &
                          n_z_SRXRD,n_z_SRXRD_abs,Non_resonant_Bulk,nphim,npldafs,Pos_z_SRXRD,Pos_z_SRXRD_abs,Sum_Bragg_abs_f0, &
                          Sum_Bragg_NR_Bulk,Sum_Bragg_nonabs_f)

        endif
      endif

      call Write_out_stand(Ephseuil,File_out,First_E,n_dim,n_tens,New_file,Title,4,Tens)

! Writing on the screen
      if( ia == 0 ) call Write_out_stand(Ephseuil,File_out,First_E,n_dim,n_tens,New_file,Title,6,Tens)
  
      if( Dafs .and. nphim > 1 ) then
        if( ie == 1 ) then
          open(7, file = nomfichdafst)
          do ipl = 1,npldafs
            write(7,400) nphi_dafs(ipl)
          end do
        else
          open(7, file = nomfichdafst, position='append')
        endif
        mot = ' '
        i = 6
        do initr = 1,ninitr
          do ii = 1,3
            select case(ii)
              case(1)
                nomab = 'Amplitude_'
              case(2)
                if( .not. ( Full_self_abs .or. Self_abs ) ) cycle
                if( Full_self_abs ) then
                  nomab = 'mu_in_'
                else
                  nomab = 'mu_io_'
                endif
              case(3)
                if( .not. Full_self_abs ) cycle
                nomab = 'mu_ou_'
            end select
            if( .not. Core_resolved ) then
              nomab(11:11) = achar(nseuil+74)
              nomab(12:12) = achar(jseuil+initr+47)
            else
              call ad_number(initr,nomab,length_word)
            endif
            l = len_trim(nomab)
            mot(i:i+l-1) = nomab(1:l)
            i = i+26
          end do
        end do
        i = i - 9
        mot(i+1:i+26) = '   Non-resonant Amplitude '
        i = i + 26
        mot(i+1:i+26) = ' e_s.e_i * Somme_exp(iQR) '
        i = i + 26
  
        l = len_trim(mot)
        write(7,405) Ephseuil*rydb, mot(1:l)
  
        do ipl = 1,npldafs
  
          if( Dafs_bio ) then
            write(7,407) nint( hkl_dafs(:,ipl) )
          else
            write(7,410) nint( hkl_dafs(:,ipl) ), isigpi(:,ipl)
          endif
          dang = 360._db / nphi_dafs(ipl)
  
          do ip = 1,nphi_dafs(ipl)
            ang = ( ip - 1 ) * dang
            if( ia == 0 ) then
              cf = (1._db,0._db)
            else
              cf = conjg( Bragg_abs(ia,ipl) )
            endif
            nw = 0
            do initr = 1,ninitr
              nw = nw + 1
              compnum(nw) = cf * Ampldafs(ipl,ip,initr,ia)
              if( Full_self_abs ) then
                do ind_mu = 1,2
                  nw = nw + 1
                  compnum(nw) = mu(ipl,ip,ind_mu,initr,ia)
                end do
              elseif( Self_abs ) then
                nw = nw + 1
                compnum(nw) = Cmplx( Real(mu(ipl,ip,1,initr,ia), db), Real(mu(ipl,ip,2,initr,ia),db),db)
              endif
            end do
            nw = nw + 1
            compnum(nw) = Sum_Bragg_NR_T(ipl,ip)
            nw = nw + 1
            compnum(nw) = phdt(ipl,ip,i_z_SRXRD_abs)
            if( Dafs_bio ) then
              write(7,420) compnum(1:nw)
            else
              write(7,430) ang, compnum(1:nw)
            endif
          end do
        end do
        close(7)
      endif

      if( Bulk_roughness_case ) exit
    end do
    
  end do  ! end of loop over atoms

  deallocate( Header_info )
  
  if( dafs ) then
    deallocate( Ampldafs )
    if( E1E1 ) deallocate( Ampldafs_E1E1 )
    if( E1E2 ) deallocate( Ampldafs_E1E2 )
    if( E2E2 ) deallocate( Ampldafs_E2E2 )
    if( E1E3 ) deallocate( Ampldafs_E1E3 )
    if( E3E3 ) deallocate( Ampldafs_E3E3 )
    if( M1M1 ) deallocate( Ampldafs_M1M1 )
    if( E1M1 ) deallocate( Ampldafs_E1M1 )
    if( E1M2 ) deallocate( Ampldafs_E1M2 )
    if( E1SP ) deallocate( Ampldafs_E1SP )
    if( E2M2 ) deallocate( Ampldafs_E2M2 )
    if( SPSP ) deallocate( Ampldafs_SPSP )
    if( Cor_abs ) then
      deallocate( mu )
      if( E1E1 ) deallocate( mu_E1E1 )
      if( E1E2 ) deallocate( mu_E1E2 )
      if( E2E2 ) deallocate( mu_E2E2 )
      if( E1E3 ) deallocate( mu_E1E3 )
      if( E3E3 ) deallocate( mu_E3E3 )
      if( M1M1 ) deallocate( mu_M1M1 )
      if( E1M1 ) deallocate( mu_E1M1 )
      if( E1M2 ) deallocate( mu_E1M2 )
      if( E1SP ) deallocate( mu_E1SP )
      if( E2M2 ) deallocate( mu_E2M2 )
      if( SPSP ) deallocate( mu_SPSP )
    endif
  endif

  return
  110 format(/' ---- Coab_rgh -----',100('-'))
  115 format(/' ---- Coabs --------',100('-'))
  120 format(/' Conversion factor (numb. of electron/Mbarn) =',10f10.5)
  130 format(' Conversion factor (microm^(-1)/Mbarn)       =',10f10.5)
  140 format(/' Output in mm^(-1), conversion factor =',f13.5,' mm^(-1)/Mbarn' )
  150 format(/'   Total signal')
  290 format(/'   Signal atom',i3)
  295 format(/'   Core state or edge',i3)
  297 format(/'   Contribution for valence state l =',i3)
  300 format(/4x,'Energy',3200a13)
  310 format(f10.3,1p,3200e13.5)
  320 format(6x,a4,1p,3200e13.5)
  360 format(/10x,1p,3200a13)
  370 format('  Ampldafs',1p,3200e13.5)
  392 format(' Number of Energies =',i5)
  400 format(i5,4x,' = Number of angles')
  405 format(f10.3,A)
  407 format(3i5,' = (h,k,l)')
  410 format(' (h,k,l) = ',3i3,', sigpi =',2i3)
  420 format(7x,1p,3200e13.5)
  430 format(f7.1,1p,3200e13.5)
end

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

! Writing of the cartesian tensors in the bav file

subroutine Write_ten_bav( Core_resolved, Final_tddft, Green_int, Green_int_mag, icheck, &
                       Dafs_cal, ipl, ipldafs, jseuil, Magn_sens, Multipole, n_oo, natomsym, nb, nbseuil, ninit1, ninitr, &
                       nseuil, T_E1E1_ia, T_E1E1_ia_m, T_E1E2_ia, T_E1E2_ia_m, T_E1E3_ia, T_E1E3_ia_m, T_E1M1_ia, T_E1M1_ia_m, &
                       T_E1M2_ia, T_E1M2_ia_m, T_E1SP_ia, T_E1SP_ia_m, T_E2E2_ia, T_E2E2_ia_m, T_E2M2_ia, T_E2M2_ia_m, &
                       T_E3E3_ia, T_E3E3_ia_m, T_M1M1_ia, T_M1M1_ia_m, T_SPSP_ia, T_SPSP_ia_m, Tens_comp )

  use declarations
  implicit none

  integer:: he, hs, ia, ib, icheck, index, initr, ipl, ipldafs, iseuil, j1, je, jhe, jhs, js, jseuil, &
            ki, ks, n_oo, natomsym, nb, nbseuil, ninit1, ninitr, nseuil

  Character(len=4):: Word
  Character(len=4), dimension(n_multipole_max):: Multipole_name
  
  complex(kind=db), dimension(3,3,ninitr,0:natomsym):: T_E1E1_ia, T_E1E1_ia_m, T_E1SP_ia, T_E1SP_ia_m, T_E1M1_ia, T_E1M1_ia_m, &
                                                       T_M1M1_ia, T_M1M1_ia_m, T_SPSP_ia, T_SPSP_ia_m
  complex(kind=db), dimension(3,3,3,ninitr,0:natomsym):: T_E1E2_ia, T_E1E2_ia_m, T_E1M2_ia, T_E1M2_ia_m
  complex(kind=db), dimension(3,3,3,3,ninitr,0:natomsym):: T_E1E3_ia, T_E1E3_ia_m, T_E2E2_ia, T_E2E2_ia_m, T_E2M2_ia, T_E2M2_ia_m
  complex(kind=db), dimension(3,n_oo,3,n_oo,ninitr,0:natomsym):: T_E3E3_ia, T_E3E3_ia_m

  logical:: Core_resolved, E1E1, E1E2, E1E3, E1M1, E1M2, E1SP, E2E2, E2M2, E3E3, Final_tddft, Green_int, Green_int_mag, &
            Dafs_cal, M1M1, Magn_sens, SPSP, Tens_comp

  logical, dimension(n_multipole_max):: Multipole
  
  data Multipole_name/ 'E1E1', 'E1E2', 'E1E3', 'E1M1', 'E1M2', 'E2E2', 'E3E3', 'M1M1', 'M1M2', 'M2M2', 'E1SP', 'SPSP', 'E2M2'/

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

    if( Core_resolved .and. .not. Final_tddft ) then
      if( initr <= ninit1 ) then
        iseuil = 1
      else
        iseuil = min(2, nbseuil)
      endif
    elseif( Final_tddft ) then
      iseuil = min(2, nbseuil)
    else
      iseuil = initr
    endif

    if( nseuil == 0 ) then  ! optic
      if( Core_resolved ) then
        if( initr == 1 ) then
          write(3,123) ninitr
        else
          write(3,125) initr-2, ninitr
        endif
      else
        write(3,120) 'Opt'
      endif
    elseif( Final_tddft ) then
      if( nbseuil == 2 ) then
        write(3,120) achar(nseuil+74) // achar(jseuil+iseuil+46) // achar(jseuil+iseuil+47)
      else
        write(3,120) achar(nseuil+74) // achar(jseuil+iseuil+46)
      endif
    else
      if( Core_resolved ) then
        write(3,130) initr, ninitr
      elseif( ninitr > 1 ) then
        write(3,135) initr, ninitr
      endif
    endif

    do ib = 0,nb
      if( natomsym == 1 .and. ib > 0 ) cycle
      if( ib == 0 ) then
        ia = 1
      elseif( ib == 1 ) then
        ia = 0
      else
        ia = ib
      endif
      if( ia /= 0 .and. ipl > 1 ) cycle
      if( ipl > 1 .and. .not. Dafs_cal ) cycle
      if( Dafs_cal .and. icheck < 2 ) cycle
      if( ipl > 1 ) write(3,140) ipldafs

      do index = 1,n_Multipole_max
      
        if( .not. Multipole(index) ) cycle
        Word = Multipole_name(index)

        if( index == 1 .or. index == 4 .or. index == 8 .or. index == 11 .or. index == 12 ) then

          if( ia == 1 ) then
            if( Green_int_mag ) then
              write(3,141) Word
            elseif( Green_int ) then
              write(3,142) Word
            else
              write(3,143) Word
            endif
          elseif( ia == 0 ) then
            if( Green_int_mag ) then
              write(3,144) Word
            elseif( Green_int ) then
              write(3,145) Word
            else
              write(3,146) Word
            endif
          else
            if( Green_int_mag ) then
              write(3,147) ia, Word
            elseif( Green_int ) then
              write(3,148) ia, Word
            else
              write(3,149) ia, Word
            endif
          endif
  
          if( index == 1 ) then        
            do ks = 1,3
              if( Green_int_mag ) then
                write(3,150) T_E1E1_ia(ks,:,initr,ia), T_E1E1_ia_m(ks,:,initr,ia)
              elseif( Tens_comp ) then
                write(3,150) T_E1E1_ia(ks,:,initr,ia)
              else
                write(3,150) real( T_E1E1_ia(ks,:,initr,ia) )
              endif
            end do

          elseif( index == 4 ) then        

            do ks = 1,3
              if( ( Magn_sens .and. ia == 0 ) .or. Green_int_mag ) then
                write(3,150) T_E1M1_ia(ks,:,initr,ia), T_E1M1_ia_m(ks,:,initr,ia)
              elseif( Tens_comp ) then
                write(3,150) T_E1M1_ia(ks,:,initr,ia)
              else
                write(3,150) aimag( T_E1M1_ia(ks,:,initr,ia) )
              endif
            end do
          
          elseif( index == 8 ) then        

            do ks = 1,3
              if( ( Magn_sens .and. ia == 0 ) .or. Green_int_mag ) then
                write(3,150) T_M1M1_ia(ks,:,initr,ia), T_M1M1_ia_m(ks,:,initr,ia)
              elseif( Tens_comp ) then
                write(3,150) T_M1M1_ia(ks,:,initr,ia)
              else
                write(3,150) aimag( T_M1M1_ia(ks,:,initr,ia) )
              endif
            end do
            
          elseif( index == 11 ) then        
! E1SP is in fact E1SP + SPE1
            do ks = 1,3
              if( Green_int_mag ) then
                write(3,150) T_E1SP_ia(ks,:,initr,ia), T_E1SP_ia_m(ks,:,initr,ia)
              elseif( Tens_comp ) then
                write(3,150) T_E1SP_ia(ks,:,initr,ia)
              else
                write(3,150) aimag( T_E1SP_ia(ks,:,initr,ia) )
              endif
            end do
            
          elseif( index == 12 ) then        

            do ks = 1,3
              if( Green_int_mag ) then
                write(3,150) T_SPSP_ia(ks,:,initr,ia), T_SPSP_ia_m(ks,:,initr,ia)
              elseif( Tens_comp ) then
                write(3,150) T_SPSP_ia(ks,:,initr,ia)
              else
                write(3,150) aimag( T_SPSP_ia(ks,:,initr,ia) )
              endif
            end do
            
          endif
      
        elseif( index == 2 .or. index == 5 .or. index == 9 ) then
 ! Rank 3 tensor 
          do ks = 1,3
            if( ia == 1 ) then
              if( Green_int_mag ) then
                write(3,160) Word, ks
              elseif( Green_int ) then
                write(3,161) Word, ks
              else
                write(3,162) Word, ks
              endif
            elseif( ia == 0 ) then
              if( Green_int_mag ) then
                write(3,163) Word, ks
              elseif( Green_int ) then
                write(3,164) Word, ks
              elseif( Magn_sens ) then
                write(3,165) Word, ks
              else
                write(3,166) Word, ks
              endif
            else
              if( Green_int_mag ) then
                write(3,167) ia, Word, ks
              elseif( Green_int ) then
                write(3,168) ia, Word, ks
              else
                write(3,169) ia, Word, ks
              endif
            endif

            if( index == 2 ) then      

              do ki = 1,3
                if( ( Magn_sens .and. ia == 0 ) .or. Green_int_mag ) then
                  write(3,150) T_E1E2_ia(ks,ki,:,initr,ia), T_E1E2_ia_m(ks,ki,:,initr,ia)
                elseif( Tens_comp ) then
                  write(3,150) T_E1E2_ia(ks,ki,:,initr,ia)
                else
                  write(3,150) real( T_E1E2_ia(ks,ki,:,initr,ia), db )
                endif
              end do
            
            elseif( index == 5 ) then      
           ! here, ki is the incoming "photon magnetic field direction" incoming
              do ki = 1,3
                if( ( Magn_sens .and. ia == 0 ) .or. Green_int_mag ) then
                  write(3,150) T_E1M2_ia(ks,ki,:,initr,ia), T_E1M2_ia_m(ks,ki,:,initr,ia)
                elseif( Tens_comp ) then
                  write(3,150) T_E1M2_ia(ks,ki,:,initr,ia)
                else
                  write(3,150) real( T_E1M2_ia(ks,ki,:,initr,ia), db )
                endif
              end do
            
            endif
          
          end do
        
        elseif( index == 3 .or. index == 6 .or. index == 13 ) then
 ! Rank 4 tensor 
 
          if( index == 6 .or. index == 13 ) then     
            do ks = 1,3
              do js = 1,3
                if( ia == 1 ) then
                  if( Green_int_mag ) then
                    write(3,171) Word, ks, js
                  elseif( Green_int ) then
                    write(3,172) Word, ks, js
                  else
                    write(3,173) Word, ks, js
                  endif
                elseif( ia == 0 ) then
                  if( Green_int_mag ) then
                    write(3,174) Word, ks, js
                  elseif( Green_int ) then
                    write(3,175) Word, ks, js
                  else
                    write(3,176) Word, ks, js
                  endif
                else
                  if( Green_int_mag ) then
                    write(3,177) ia, Word, ks, js
                  elseif( Green_int ) then
                    write(3,178) ia, Word, ks, js
                  else
                    write(3,179) ia, Word, ks, js
                  endif
                endif
                
                if( index == 6 ) then    
                  do ki = 1,3
                    if( Green_int_mag ) then
                      write(3,150) T_E2E2_ia(ks,js,ki,:,initr,ia), T_E2E2_ia_m(ks,js,ki,:,initr,ia)
                    elseif( Tens_comp ) then
                      write(3,150) T_E2E2_ia(ks,js,ki,:,initr,ia)
                    else
                      write(3,150) real( T_E2E2_ia(ks,js,ki,:,initr,ia), db )
                    endif
                  end do
                elseif( index == 13 ) then
                ! here ki is the incoming "photon magnetic field direction"     
                  do ki = 1,3
                    if( Green_int_mag ) then
                      write(3,150) T_E2M2_ia(ks,js,ki,:,initr,ia), T_E2M2_ia_m(ks,js,ki,:,initr,ia)
                    elseif( Tens_comp ) then
                      write(3,150) T_E2M2_ia(ks,js,ki,:,initr,ia)
                    else
                      write(3,150) real( T_E2M2_ia(ks,js,ki,:,initr,ia), db )
                    endif
                  end do
                endif
              end do
            end do

          elseif( index == 4 ) then
! E1E3        
            do ks = 1,3
              do ki = 1,3
                if( ia == 1 ) then
                  if( Green_int_mag ) then
                    write(3,181) Word, ks, ki
                  elseif( Green_int ) then
                    write(3,182) Word, ks, ki
                  else
                    write(3,183) Word, ks, ki
                  endif
                elseif( ia == 0 ) then
                  if( Green_int_mag ) then
                    write(3,184) Word, ks, ki
                  elseif( Green_int ) then
                    write(3,185) Word, ks, ki
                  else
                    write(3,186) Word, ks, ki
                  endif
                else
                  if( Green_int_mag ) then
                    write(3,187) ia, Word, ks, ki
                  elseif( Green_int ) then
                    write(3,188) ia, Word, ks, ki
                  else
                    write(3,189) ia, Word, ks, ki
                  endif
                endif
                do j1 = 1,3
                  if( Green_int_mag ) then
                    write(3,150) T_E1E3_ia(ks,ki,j1,:,initr,ia), T_E1E3_ia_m(ks,ki,j1,:,initr,ia)
                  elseif( Tens_comp ) then
                    write(3,150) T_E1E3_ia(ks,ki,j1,:,initr,ia)
                  else
                    write(3,150) real( T_E1E3_ia(ks,ki,j1,:,initr,ia) )
                  endif
                end do
              end do
            end do
          endif

        elseif( index == 7 ) then
 ! E3E3     
          do hs = 1,3
            do js = 1,3
              jhs = 3 * ( js - 1 ) + hs
              if( ia == 1 ) then
                if( Green_int_mag ) then
                  write(3,211) (ks, js, hs, ks = 1,3)
                elseif( Green_int ) then
                  write(3,212) (ks, js, hs, ks = 1,3)
                else
                  write(3,213) (ks, js, hs, ks = 1,3)
                endif
              elseif( ia == 0 ) then
                if( Green_int_mag ) then
                  write(3,214) (ks, js, hs, ks = 1,3)
                elseif( Green_int ) then
                  write(3,215) (ks, js, hs, ks = 1,3)
                else
                  write(3,216) (ks, js, hs, ks = 1,3)
                endif
              else
                if( Green_int_mag ) then
                  write(3,217) ia, (ks, js, hs, ks = 1,3)
                elseif( Green_int ) then
                  write(3,218) ia, (ks, js, hs, ks = 1,3)
                else
                  write(3,219) ia, (ks, js, hs, ks = 1,3)
                endif
              endif
              do he = 1,3
                do je = 1,3
                  jhe = 3 * ( je - 1 ) + he
                  if( Green_int_mag ) then
                    write(3,150) ( T_E3E3_ia(1:3,jhe,ks,jhs,initr,ia), T_E3E3_ia_m(1:3,jhe,ks,jhs,initr,ia), ks = 1,3 )
                  elseif( tens_comp ) then
                    write(3,150) ( T_E3E3_ia(1:3,jhe,ks,jhs,initr,ia), ks = 1,3 )
                  else
                    write(3,150) ( real( T_E3E3_ia(1:3,jhe,ks,jhs,initr,ia) ), ks = 1,3 )
                  endif
                end do
              end do
            end do
          end do
        
        endif
      
      end do  ! end of loop over multipole index

    end do

  end do

  return
  120 format(/' Threshold ',a3)
  123 format(/'   Valence state, all on',i3)
  125 format(/'   Valence state l =',i3,' on',i3)
  130 format(/'   Initial state =',i3,' on',i3)
  135 format(/'            Edge =',i3,' on',i3)
  140 format(/8x,' RXS polarization number',i3)
! Rank 2 tensor  
  141 format(/' Tensor_',a4,'(ks,ki), Prototypical atom,   Green integral, Non magnetic part',82x,'Magnetic part')
  142 format(/' Tensor_',a4,'(ks,ki), Prototypical atom,   Green integral')
  143 format(/' Tensor_',a4,'(ks,ki), Prototypical atom')
  144 format(/' Crystal Tensor_',a4,'(ks,ki), Green integral, Non magnetic part',93x,'Magnetic part')
  145 format(/' Crystal Tensor_',a4,'(ks,ki), Green integral')
  146 format(/' Crystal Tensor_',a4,'(ks,ki)')
  147 format(/' Atom ',i3,' Tensor_',a4,'(ks,ki), Green integral, Non magnetic part',78x,'Magnetic part')
  148 format(/' Atom ',i3,' Tensor_',a4,'(ks,ki), Green integral')
  149 format(/' Atom ',i3,' Tensor_',a4,'(ks,ki)')
  150 format(1p,12(6e18.10,2x))
 ! rank 3 tensor 
  160 format(/' Tensor_',a4,'(',i1,',ki,j2), Prototypical atom, Green integral, Non magnetic part',80x,'Magnetic part')
  161 format(/' Tensor_',a4,'(',i1,',ki,j2), Prototypical atom, Green integral')
  162 format(/' Tensor_',a4,'(',i1,',ki,j2), Prototypical atom')
  163 format(/' Crystal Tensor_',a4,'(',i1,',ki,j2), Green integral, Non magnetic part',89x,'Magnetic part')
  164 format(/' Crystal Tensor_',a4,'(',i1,',ki,j2), Green integral')
  165 format(/' Crystal Tensor_',a4,'(',i1,',kis,j2),                 Non magnetic part',87x,'Magnetic part')
  166 format(/' Crystal Tensor_',a4,'(',i1,',ki,j2)')
  167 format(/' Atom ',i3,' Tensor_',a4,'(ks,ki), Green integral, Non magnetic part',78x,'Magnetic part')
  168 format(/' Atom ',i3,' Tensor_',a4,'(',i1,',ki,j2), Green integral')
  169 format(/' Atom ',i3,' Tensor_',a4,'(',i1,',ki,j2)')
 ! rank 4 tensor
  171 format(/' Tensor_',a4,'(',i1,',',i1,',ki,ji), Prototypical atom, Green integral, Non magnetic part',76x,'Magnetic part')
  172 format(/' Tensor_',a4,'(',i1,',',i1,',ki,ji), Prototypical atom, Green integral')
  173 format(/' Tensor_',a4,'(',i1,',',i1,',ki,ji), Prototypical atom')
  174 format(/' Crystal Tensor_',a4,'(',i1,',',i1,',ki,ji), Green integral, Non magnetic part',84x,'Magnetic part')
  175 format(/' Crystal Tensor_',a4,'(',i1,',',i1,',ki,ji), Green integral')
  176 format(/' Crystal Tensor_',a4,'(',i1,',',i1,',ki,ji)')
  177 format(/' Atom ',i3,' Tensor_',a4,'(',i1,',',i1,',ki,ji), Green integral, Non magnetic part',78x,'Magnetic part')
  178 format(/' Atom ',i3,' Tensor_',a4,'(',i1,',',i1,',ki,ji), Green integral')
  179 format(/' Atom ',i3,' Tensor_',a4,'(',i1,',',i1,',ki,ji)')
 ! rank 4 tensor E1E3
  181 format(/' Tensor_',a4,'(',i1,',',i1,',j1,j2), Prototypical atom, Green integral, Non magnetic part',76x,'Magnetic part')
  182 format(/' Tensor_',a4,'(',i1,',',i1,',j1,j2), Prototypical atom, Green integral')
  183 format(/' Tensor_',a4,'(',i1,',',i1,',j1,j2), Prototypical atom')
  184 format(/' Crystal Tensor_',a4,'(',i1,',',i1,',j1,j2), Green integral, Non magnetic part',87x,'Magnetic part')
  185 format(/' Crystal Tensor_',a4,'(',i1,',',i1,',j1,j2), Green integral')
  186 format(/' Crystal Tensor_',a4,'(',i1,',',i1,',j1,j2)')
  187 format(/' Atom ',i3,' Tensor_',a4,'(',i1,',',i1,',j1,j2), Green integral, Non magnetic part',78x,'Magnetic part')
  188 format(/' Atom ',i3,' Tensor_',a4,'(',i1,',',i1,',j1,j2), Green integral')
  189 format(/' Atom ',i3,' Tensor_',a4,'(',i1,',',i1,',j1,j2)')
! E3E3
  211 format(/3(' Tensor_',a4,'(ks,js,hs',3(',',i1),')',36x), ' Prototypical atom,', &
          ' Green integral, Non magnetic part',78x,'Magnetic part')
  212 format(/3(' Tensor_',a4,'(ks,js,hs',3(',',i1),')',34x), ' Prototypical atom, Green integral')
  213 format(/3(' Tensor_',a4,'(ks,js,hs',3(',',i1),')',34x), ' Prototypical atom')
  214 format(/3(' Crystal Tensor_',a4,'(ks,js,hs',3(',',i1),')',34x), ' Green integral, Non magnetic part',85x,'Magnetic part')
  215 format(/3(' Crystal Tensor_',a4,'(ks,js,hs',3(',',i1),')',34x), ' Green integral')
  216 format(/3(' Crystal Tensor_',a4,'(ks,js,hs',3(',',i1),')',34x))
  217 format(/' Atom ',i3,3(' Tensor_',a4,'(ks,js,hs',3(',',i1),')',34x), &
          ' Green integral, Non magnetic part',80x,'Magnetic part')
  218 format(/' Atom ',i3,3(' Tensor_E3E3(ks,js,hs',3(',',i1),')',34x), ' Green integral')
  219 format(/' Atom ',i3,3(' Tensor_E3E3(ks,js,hs',3(',',i1),')',34x))
end
      
!******************************************************************************************************************************

subroutine Write_RamanX(Abs_U_iso,All_nrixs,Allsite,axyz,Core_resolved,E_cut,Energ,Energphot, &
                  Epsii,Eseuil,f_avantseuil,Final_tddft,First_E,Green_int,Header, &
                  iabsorig,icheck,ie,ie_computer,isymeq,jseuil,l0_nrixs,lmax_nrixs,mpinodee,n_multi_run, &
                  natomsym,nbseuil,nenerg,ninit1,ninitr,nomfich,nomfich_cal_convt,nq_nrixs,nseuil,nspinp, &
                  numat_abs,Orthmatt,q_nrixs,Rot_atom_abs,Rot_cluster,S_nrixs,S_nrixs_m,Spinorbite,Taux_eq,V0muf,Volume_maille)
                  
  use declarations
  implicit none

  integer:: i, ia, iabsorig, icheck, ie, ie_computer, initr, iq, isym, jseuil, l, l_i, l_s, l0_nrixs, &
    lm, lm_i, lm_s, lmax_nrixs, long, m_i, m_s, mpinodee, n, n_dim, n_header_info, n_multi_run, n_tens, natomsym, nbseuil, &
    nenerg, ninit1, ninitr, nlmc, npldafs, nq_nrixs, nseuil, nspinp, numat_abs

  integer, dimension(natomsym):: isymeq

  character(len=length_word):: nomab
  character(len=Length_name) nomfich, nomfich_cal_convt, File_out
  character(len=length_word), dimension(:), allocatable:: title
  character(len=length_name), dimension(:), allocatable:: Header_info

  complex(kind=db):: cfac, f_avantseuil, Ylm_q_i, Ylm_q_s
  complex(kind=db), dimension(nq_nrixs,(1+lmax_nrixs)**2,(1+lmax_nrixs)**2,ninitr,0:mpinodee-1):: S_nrixs, S_nrixs_m
  complex(kind=db), dimension(:), allocatable:: Ylm_q
  
  logical:: All_nrixs, Allsite, Core_resolved, Final_tddft, First_E, Energphot, Green_int, Green_int_mag, &
    Header, Magn_sens, Monocrystal, New_file, Spinorbite

  real(kind=db):: Abs_U_iso, Surface_ref, E_cut, Ephoton, Ephseuil, natomsym_f, q, V0muf, Volume_maille

  real(kind=db), dimension(3):: axyz, q_vec, q_vec_a
  real(kind=db), dimension(3,3):: Matopsym, Orthmatt, Rot_atom_abs, Rot_cluster
  real(kind=db), dimension(ninitr) :: Epsii
  real(kind=db), dimension(nbseuil):: Eseuil
  real(kind=db), dimension(nenerg):: Energ
  real(kind=db), dimension(natomsym):: Taux_eq
  real(kind=db), dimension(nq_nrixs,ninitr,0:natomsym):: S_nrixs_T
  real(kind=db), dimension(nq_nrixs,l0_nrixs:lmax_nrixs,ninitr,0:natomsym):: S_nrixs_T_l
  real(kind=db), dimension(4,nq_nrixs):: q_nrixs
  real(kind=db), dimension(:), allocatable:: Tens

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

  n_header_info = 0
  
  allocate( Header_info(n_header_info) )
    
  npldafs = 0
  Surface_ref = 0._db
  natomsym_f = sum( Taux_eq(:) )

  Ephseuil = Energ(ie)
  Ephoton = Ephseuil + Eseuil(nbseuil)
! Pour les seuils de tres basse Energie:
  Ephoton = max(0.001_db/Rydb, Ephoton)
  if( Energphot ) Ephseuil = Ephoton

  if( ( jseuil > 1 .and. nspinp == 2 ) .or. Spinorbite ) then
    Magn_sens = .true.
  else
    Magn_sens = .false.
  endif

  if( Green_int .and. Magn_sens ) then
    Green_int_mag = .true.
  else
    Green_int_mag = .false.
  endif

  S_nrixs_T(:,:,:) = 0._db
  S_nrixs_T_l(:,:,:,:) = 0._db

  do iq = 1,nq_nrixs

    q_vec(:) = q_nrixs(1:3,iq)
    Monocrystal = sum( abs(q_vec(:)) ) > eps10

    if( icheck > 1 ) write(3,120) iq, q_nrixs(4,iq) / bohr

    if( Monocrystal ) then    
 
      if( icheck > 1 ) write(3,130) iq, q_nrixs(4,iq), q_vec(:) 
    
! Conversion to internal orthonormalized basis
      q_vec(:) = q_vec(:) / axyz(:)
      q_vec = matmul( Orthmatt, q_vec )
      q_vec(:) = q_vec(:) / sqrt( sum( q_vec(:)**2 ) )

      if( icheck > 1 ) write(3,140) q_vec(:) 

      nlmc = ( ( lmax_nrixs + 1 ) * ( lmax_nrixs + 2 ) ) / 2
      allocate( Ylm_q(nlmc) )
    
    else

      if( icheck > 1 ) write(3,140) iq, q_nrixs(4,iq)
        
    endif

    do ia = 1,natomsym

      if( Monocrystal ) then
        isym = abs( isymeq(ia) )
        call opsym(isym,Matopsym)
        q_vec_a = Matmul( Transpose(Matopsym), q_vec )
! Rotation to the absorbing atom basis
        q_vec_a = Matmul( Rot_atom_abs, Matmul( Transpose( Rot_cluster ), q_vec_a ) )

        call cYlm(lmax_nrixs,q_vec_a,1._db,Ylm_q,nlmc)
      endif

      lm_s = 0   
      do l_s = l0_nrixs,lmax_nrixs
        do m_s = -l_s,l_s
          lm_s = lm_s + 1

          if( Monocrystal ) then    
            lm = l_s * ( l_s + 1 ) / 2 + 1 + abs(m_s)
            if( m_s >= 0 ) then
              Ylm_q_s = Ylm_q(lm)
            else
              Ylm_q_s = (-1)**m_s * conjg( Ylm_q(lm) )
            endif
          endif
        
          lm_i = 0
          do l_i = l0_nrixs,lmax_nrixs
            do m_i = -l_i,l_i
              lm_i = lm_i + 1
    
              if( ( l_s /= l_i .or. m_s /= m_i ) .and. .not. Monocrystal ) cycle

              if( Monocrystal ) then    
                lm = l_i * ( l_i + 1 ) / 2 + 1 + abs(m_i)
                if( m_i >= 0 ) then
                  Ylm_q_i = Ylm_q(lm)
                else
                  Ylm_q_i = (-1)**m_i * conjg( Ylm_q(lm) )
                endif
              endif

              if( Monocrystal ) then
                cfac = Taux_eq(ia) * conjg( Ylm_q_s ) * Ylm_q_i 
              else
                cfac = cmplx( Taux_eq(ia) / quatre_pi, 0._db, db )  ! 4 pi is for the average  
              endif
              
              S_nrixs_T(iq,:,ia) = S_nrixs_T(iq,:,ia) + real( cfac * S_nrixs(iq,lm_s,lm_i,:,ie_computer), db ) 
              if( l_i == l_s ) &
                S_nrixs_T_l(iq,l_i,:,ia) = S_nrixs_T_l(iq,l_i,:,ia) + real( cfac * S_nrixs(iq,lm_s,lm_i,:,ie_computer), db )  
            
              if( Green_int_mag ) then
                if( isymeq(ia) < 0 ) then
                  S_nrixs_T(iq,:,ia) = S_nrixs_T(iq,:,ia) - real( cfac * S_nrixs_m(iq,lm_s,lm_i,:,ie_computer), db )
                  if( l_i == l_s ) &
                    S_nrixs_T_l(iq,l_i,:,ia) = S_nrixs_T_l(iq,l_i,:,ia) - real( cfac * S_nrixs_m(iq,lm_s,lm_i,:,ie_computer), db )
                else
                  S_nrixs_T(iq,:,ia) = S_nrixs_T(iq,:,ia) + real( cfac * S_nrixs_m(iq,lm_s,lm_i,:,ie_computer), db )
                  if( l_i == l_s ) &
                    S_nrixs_T_l(iq,l_i,:,ia) = S_nrixs_T_l(iq,l_i,:,ia) + real( cfac * S_nrixs_m(iq,lm_s,lm_i,:,ie_computer), db )
                endif
              endif
              
            end do
          end do
        end do
      end do
      
      S_nrixs_T(iq,:,0) =  S_nrixs_T(iq,:,0) + S_nrixs_T(iq,:,ia)
      S_nrixs_T_l(iq,:,:,0) =  S_nrixs_T_l(iq,:,:,0) + S_nrixs_T_l(iq,:,:,ia)
    
    end do

    if( Monocrystal ) deallocate( Ylm_q )
            
  end do

  File_out = nomfich
  long = len_trim(File_out)
  File_out(long+1:long+6) = '_nrixs'

  if( All_nrixs ) then
    n_dim = nq_nrixs * ninitr * ( lmax_nrixs - l0_nrixs + 2 )
  else
    n_dim = nq_nrixs * ninitr
  endif
  n_tens = n_dim
  allocate( Title( n_dim ) )
  allocate( Tens( n_dim ) )
    
  do ia = 0,natomsym
    if( .not. Allsite .and. ia == 1 ) exit

    File_out = nomfich
    long = len_trim(File_out)
    File_out(long+1:long+6) = '_nrixs'

    if( ia > 0 ) then
      long = len_trim(File_out)
      File_out(long+1:long+5) = '_atom'
      call ad_number(ia,File_out,Length_name)
    endif
    long = len_trim(File_out)

    if( Final_tddft ) File_out(long+1:long+6) = '_tddft'

    if( n_multi_run > 1 ) then
      long = len_trim(File_out)
      File_out(long+1:long+1) = '_'
      call ad_number(iabsorig,File_out,Length_name)
    endif

    long = len_trim(File_out)
    File_out(long+1:long+4) = '.txt'

    if( ie == 1 .and. ia == 0 ) nomfich_cal_convt = File_out

    i = 0
    do initr = 1,ninitr

      do l = l0_nrixs - 1, lmax_nrixs

        if( ( .not. All_nrixs ) .and. l > l0_nrixs - 1 ) exit 

        do iq = 1, nq_nrixs 
          i = i + 1
          nomab = 'q='
          q = q_nrixs(4,iq) / bohr
          n = int( q + eps10 )   
          call ad_number(n,nomab,length_word)
          long = len_trim( nomab )
          long = long + 1
          nomab(long:long) = '.'
          if( q < 0.001_db ) then
            n = nint( 10000 * q )
            call ad_number(0,nomab,length_word)
            call ad_number(0,nomab,length_word)
            call ad_number(0,nomab,length_word)
          elseif( q < 0.01_db ) then
            n = nint( 1000 * q )
            call ad_number(0,nomab,length_word)
            call ad_number(0,nomab,length_word)
          elseif( q < 0.1_db ) then
            n = nint( 100 * q )
            call ad_number(0,nomab,length_word)
          elseif( n < 10 ) then
            n = int( 1000 * ( q - n ) )
          elseif( n < 100 ) then
            n = int( 100 * ( q - n ) )
          elseif( n < 1000 ) then
            n = int( 10 * ( q - n ) )
          endif 
          call ad_number(n,nomab,length_word)
          if( l > l0_nrixs - 1 ) then
            long = len_trim( nomab )
            long = long + 1
            nomab(long:long+1) = '_l'
            call ad_number(l,nomab,length_word)
          endif
          if( ninitr > 1 .and. .not. (initr == 1 .and. nseuil == 0 ) ) then
            long = len_trim( nomab )
            if( long > length_word - 3 ) cycle
            long = long + 1
            nomab(long:long) = '_'
            if( .not. Core_resolved ) then
              long = long + 1
              nomab(long:long) = achar(nseuil+74)
              long = long + 1
              nomab(long:long) = achar(jseuil+initr+47)
            else
              if( nseuil == 0 ) then
                call ad_number(initr-2,nomab,length_word)
              else
                call ad_number(initr,nomab,length_word)
              endif
            endif
          endif
          call center_word(nomab,Length_word)
          title(i) = nomab

          if( l == l0_nrixs - 1 ) then
            Tens(i) = S_nrixs_T(iq,initr,ia)
          else
            Tens(i) = S_nrixs_T_l(iq,l,initr,ia)
          endif

        end do
      end do
    end do

    New_file = First_E

    if( First_E ) then
           
      if( Header ) then
        call Write_Header(File_out,Header_info,n_header_info)
        New_file = .false.
      endif

      call Write_first_out(Abs_U_iso,Core_resolved,f_avantseuil,File_out,E_cut,Epsii,Eseuil(nbseuil),Green_int, &
          jseuil,New_file,ninit1,ninitr,nseuil,numat_abs,V0muf,natomsym_f,Surface_ref,Volume_maille)

    endif

    call Write_out_stand(Ephseuil,File_out,First_E,n_dim,n_tens,New_file,Title,4,Tens)

! Writing on the screen
    if( ia == 0 ) call Write_out_stand(Ephseuil,File_out,First_E,n_dim,n_tens,New_file,Title,6,Tens)

  end do
  
  deallocate( Header_info, Tens, Title )
   
  return
  110 format(/' ---- Write_RamanX --------',100('-'))
  120 format(/'  iq =',i3,', q =',f6.3)
  130 format(/'  iq =',i3,', q =',f6.3,', q_vec =',3f10.5)
  140 format(/' Normalized q_vec in the absorbing atom local basis =',3f10.5)
end

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

! Conversion factor Megabarn --> nbr. of electron 

function Conv_Mbarn_nelec(Ephoton)

  use declarations
  implicit none
  
  real(kind=db):: Conv_Mbarn_nelec, Ephoton 

! alfa_sf = e*e/(2*epsilon0*h*c) is the fine structure constant
! Factor 100 * bohr**2 is to get in megaBarn (10E-18 cm2)
  Conv_Mbarn_nelec = 0.5_db * Ephoton / ( quatre_pi * alfa_sf * 100 * bohr**2  )

  return
end

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

subroutine Write_cartesian_tensor(Abs_U_iso,Volume_maille,E_cut,E1E2,E2E2,Ephseuil,Epsii,Eseuil,First_E,Header, &
                 ia,ipldafs,jseuil,M1M1,magn_sens,natomsym,ninit1,ninitr,nomfich_t,nseuil,numat_abs,T_E1E1_ia,T_E1E2_ia, &
                 T_E1E2_ia_m,T_E2E2_ia,T_E1M1_ia,tens_comp,v0muf,Core_resolved)

  use declarations
  implicit none

  integer, parameter:: n_dim=10*(168+12)

  integer:: i, ia, ijk, index, initr, ipldafs, j, Jseuil, k, L, Long, n_header_info, n_tens, natomsym, ninit1, ninitr, &
    nseuil, numat_abs

  character(len=Length_name):: File_out, nomfich_t
  character(len=Length_word):: mot
  character(len=Length_word), dimension(n_dim):: Title
  character(len=Length_name), dimension(:), allocatable:: Header_info

  complex(kind=db):: Zero_c
  
  complex(kind=db), dimension(3,3,ninitr,0:natomsym):: T_E1E1_ia, T_E1M1_ia
  complex(kind=db), dimension(3,3,3,ninitr,0:natomsym):: T_E1E2_ia, T_E1E2_ia_m
  complex(kind=db), dimension(3,3,3,3,ninitr,0:natomsym):: T_E2E2_ia

  logical:: Core_resolved, E1E2, E2E2, First_E, Header, M1M1, magn_sens, New_file, tens_comp

  real(kind=db):: Abs_U_iso, E_cut, Ephseuil, Eseuil, V0muf, Volume_maille
  
  real(kind=db):: natomsym_f, Surface_ref
  real(kind=db), dimension(ninitr):: Epsii
  real(kind=db), dimension(n_dim):: Tens

  n_header_info = 0
  allocate( Header_info(n_header_info) )
  
  File_out = nomfich_t
  Long = len_trim(File_out)
  if( ia == 0 ) then
    File_out(long+1:long+9) = '_car_xtal'
  else
    File_out(long+1:long+9) = '_car_atom'
    call ad_number(ia,File_out,Length_name)
  endif
  if( ipldafs > 0 ) then
    long = len_trim(File_out)
    File_out(long+1:long+4) = '_rxs'
    call ad_number(ipldafs,File_out,Length_name)
  endif
  long = len_trim(File_out)
  File_out(long+1:long+4) = '.txt'

  index = 0
  Surface_ref = 0._db

  do initr = 1,ninitr

    mot = ' '
    mot(1:2) = 'D_'
    do i = 1,3
      mot(3:3) = achar(i+119)
      do j = i,3
        index = index + 1
        mot(4:4) = achar(j+119)
        if( tens_comp ) mot(5:6) = '_r'
        Tens(index) = real( T_E1E1_ia(i,j,initr,ia),db )
        Title(index) = mot
        if( tens_comp ) then
          index = index + 1
          mot(6:6) = 'i'
          Title(index) = mot
          Tens(index) = aimag( T_E1E1_ia(i,j,initr,ia) )
        endif
      end do
    end do
    if( E1E2 ) then
      mot(1:2) = 'I_'
      do i = 1,3
        mot(3:3) = achar(i+119)
        do j = 1,3
          mot(4:4) = achar(j+119)
          do k = j,3
            mot(5:5) = achar(k+119)
            index = index + 1
            if( tens_comp ) mot(6:7) = '_r'
            Title(index) = mot
            Tens(index) = real( T_E1E2_ia(i,j,k,initr,ia),db )
            if( tens_comp ) then
              index = index + 1
              mot(7:7) = 'i'
              Title(index) = mot
              Tens(index) = aimag( T_E1E2_ia(i,j,k,initr,ia) )
            endif
            if( ia == 0 .and. magn_sens ) then
              index = index+1
              mot(7:11) = 'r_mag'
              Title(index) = mot
              Tens(index) = real( T_E1E2_ia_m(i,j,k,initr,ia),db )
              index = index+1
              mot(7:7) = 'i'
              Title(index) = mot
              mot(7:11) = '    '
              Tens(index) = aimag( T_E1E2_ia_m(i,j,k,initr,ia) )
            endif
          end do
        end do
      end do
    endif
    if( E2E2 ) then
      mot = ' '
      mot(1:2) = 'Q_'
      do i = 1,3
        mot(3:3) = achar(i+119)
        do j = i,3
          mot(4:4) = achar(j+119)
          do k = 1,3
            mot(5:5) = achar(k+119)
            do l = k,3
              mot(6:6) = achar(l+119)
              index = index + 1
              if( tens_comp ) mot(7:8) = '_r'
              Title(index) = mot
              Tens(index) = real( T_E2E2_ia(i,j,k,l,initr,ia),db )
              if( tens_comp ) then
                index = index + 1
                mot(8:8) = 'i'
                Title(index) = mot
                Tens(index) = aimag( T_E2E2_ia(i,j,k,l,initr,ia) )
              endif
            end do
          end do
        end do
      end do
      do ijk = 1,6
        index = index + 1
        select case(ijk)
          case(1)
            i = 1; j = 2; k = 1; l = 2
          case(2)
            i = 1; j = 2; k = 1; l = 3
          case(3)
            i = 1; j = 3; k = 1; l = 3
          case(4)
            i = 1; j = 3; k = 2; l = 2
          case(5)
            i = 1; j = 3; k = 2; l = 3
          case(6)
            i = 2; j = 3; k = 2; l = 3
        end select
        mot(3:3) = achar(i+119)
        mot(4:4) = achar(j+119)
        mot(5:5) = achar(k+119)
        mot(6:6) = achar(l+119)
        if( tens_comp ) mot(7:8) = '_r'
        Title(index) = mot
        Tens(index) = real( T_E2E2_ia(i,j,k,l,initr,ia),db )
        if( tens_comp ) then
          index = index + 1
          mot(8:8) = 'i'
          Title(index) = mot
          Tens(index) = aimag( T_E2E2_ia(i,j,k,l,initr,ia) )
        endif
      end do
    endif
    if( M1M1 ) then
      mot = ' '
      mot(1:2) = 'M_'
      do i = 1,3
        mot(3:3) = achar(i+119)
        do j = i,3
          index = index + 1
          mot(4:4) = achar(j+119)
          if( tens_comp ) mot(5:6) = '_r'
          Tens(index) = real( T_E1M1_ia(i,j,initr,ia),db )
          Title(index) = mot
          if( tens_comp ) then
            index = index + 1
            mot(6:6) = 'i'
            Title(index) = mot
            Tens(index) = aimag( T_E1M1_ia(i,j,initr,ia) )
          endif
        end do
      end do
    endif
    n_tens = index

  end do

  New_file = First_E

  if( First_E ) then
         
    if( Header ) then
      call Write_Header(File_out,Header_info,n_header_info)
      New_file = .false.
    endif

    Zero_c = (0._db, 0._db)
    natomsym_f = 0._db

    call Write_first_out(Abs_U_iso,Core_resolved,Zero_c,File_out,E_cut,Epsii,Eseuil,.false., &
        jseuil,New_file,ninit1,ninitr,nseuil,numat_abs,V0muf,natomsym_f,Surface_ref,Volume_maille)

  endif

  call Write_out_stand(Ephseuil,File_out,First_E,n_dim,n_tens,New_file,Title,4,Tens)

  deallocate( Header_info )

  return
end

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

! Writing of the header lines
 
subroutine Write_Header(File_out,Header_info,n_header_info)

  use declarations
  implicit none

  integer:: i, ipr, n_header_info 
  
  character(len=Length_name):: File_out
  character(len=8):: dat
  character(len=10):: tim
  character(len=50):: com_date, com_time
  character(len=Length_name), dimension(n_header_info):: Header_info

  ipr = 4
  
  open(ipr, file = File_out)

  call date_and_time( date = dat, time = tim )
  com_date = '   Date = ' // dat(7:8) // ' ' // dat(5:6) // ' ' // dat(1:4)
  com_time = '   Time = ' // tim(1:2)  // ' h ' // tim(3:4) // ' mn ' // tim(5:6) // ' s'
  write(ipr,'(a2,A/a2,A/a2,A)') '# ', Revision, '# ', com_date, '# ', com_time
  do i = 1,n_header_info
    write(ipr,'(A)') Header_info(i)
  end do

  close(ipr)

  return
end

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

! Writing of the first line of the output file with the info for the convolution
 
subroutine Write_first_out(Abs_U_iso,Core_resolved,f_avantseuil,File_out,E_cut,Epsii,Eseuil,Green_int, &
            jseuil,New_file,ninit1,ninitr,nseuil,Numat,V0muf,natomsym_f,Surface_ref,Volume_maille)

  use declarations
  implicit none

  integer:: icor, ipr, jseuil, ninit1, ninitr, nseuil, Numat 
  
  character(len=Length_name):: File_out
  character(len=92):: mot1
  character(len=65):: mot2

  complex(kind=db):: f_avantseuil

  logical:: Core_resolved, Green_int, New_file

  real(kind=db):: Abs_U_iso, E_cut, Eseuil, f0_forward, fpp_avantseuil, Surface, Surface_ref, natomsym_f, V0muf, &
                  Volume, Volume_maille

  real(kind=db), dimension(ninitr):: Epsii

  ipr = 4
  
  if( New_file ) then
    open(ipr, file = File_out)
  else
    open(ipr, file = File_out, position='append')
  endif
  New_file = .false.

  fpp_avantseuil = aimag( f_avantseuil )
  f0_forward = real( f_avantseuil, db )

  if( Core_resolved .and. nseuil /= 0 ) then
    icor = ninit1
  else
    icor = 1
  endif
  if( Green_int ) icor = - icor
  
  mot1 = '  = E_edge, Z, n_edge, j_edge, Abs_before_edge, VO_interstitial, E_cut, ninit, ninit1, Epsii'
  mot2 = ', UnitCell_Volume, Surface_ref, f0_forward, natomsym_f, abs_u_iso'

  Volume = Volume_maille * bohr**3
  Surface = Surface_ref * bohr**2
  
  if( nseuil == 0 ) then
    write(ipr,120) Eseuil*rydb, Numat, nseuil, jseuil, fpp_avantseuil, v0muf*rydb, &
      E_cut*rydb, 1, icor, Epsii(1)*rydb, Volume, Surface, f0_forward, natomsym_f, Abs_U_iso, mot1, mot2
  elseif( ninitr == 1 ) then
    write(ipr,120) Eseuil*rydb, Numat, nseuil, jseuil, fpp_avantseuil, v0muf*rydb, &
      E_cut*rydb, ninitr, icor, Epsii(:)*rydb, Volume, Surface, f0_forward, natomsym_f, Abs_U_iso, mot1, mot2
  elseif( ninitr == 2 ) then
    write(ipr,121) Eseuil*rydb, Numat, nseuil, jseuil, fpp_avantseuil, v0muf*rydb, &
      E_cut*rydb, ninitr, icor, Epsii(:)*rydb, Volume, Surface, f0_forward, natomsym_f, Abs_U_iso, mot1, ninitr, mot2
  elseif( ninitr == 4 ) then
    write(ipr,122) Eseuil*rydb, Numat, nseuil, jseuil, fpp_avantseuil, v0muf*rydb, &
      E_cut*rydb, ninitr, icor, Epsii(:)*rydb, Volume, Surface, f0_forward, natomsym_f, Abs_U_iso, mot1, ninitr, mot2
  elseif( ninitr == 6 ) then
    write(ipr,123) Eseuil*rydb, Numat, nseuil, jseuil, fpp_avantseuil, v0muf*rydb, &
      E_cut*rydb, ninitr, icor, Epsii(:)*rydb, Volume, Surface, f0_forward, natomsym_f, Abs_U_iso, mot1, ninitr, mot2
  elseif( ninitr == 8 ) then
    write(ipr,124) Eseuil*rydb, Numat, nseuil, jseuil, fpp_avantseuil, v0muf*rydb, &
      E_cut*rydb, ninitr, icor, Epsii(:)*rydb, Volume, Surface, f0_forward, natomsym_f, Abs_U_iso, mot1, ninitr, mot2
  elseif( ninitr == 10 ) then
    write(ipr,125) Eseuil*rydb, Numat, nseuil, jseuil, fpp_avantseuil, v0muf*rydb, &
      E_cut*rydb, ninitr, icor, Epsii(:)*rydb, Volume, Surface, f0_forward, natomsym_f, Abs_U_iso, mot1, ninitr, mot2
  else     ! 14
    write(ipr,126) Eseuil*rydb, Numat, nseuil, jseuil, fpp_avantseuil, v0muf*rydb, &
      E_cut*rydb, ninitr, icor, Epsii(:)*rydb, Volume, Surface, f0_forward, natomsym_f, Abs_U_iso, mot1, ninitr, mot2
  endif

  close(ipr)

  return
  120 format(f10.3,i5,2i3,1p,3e15.7,2i3,e15.7,5e15.7,a92,a65)
  121 format(f10.3,i5,2i3,1p,3e15.7,2i3,2e15.7,5e15.7,a92,'(1..',i1,')',a65)
  122 format(f10.3,i5,2i3,1p,3e15.7,2i3,4e15.7,5e15.7,a92,'(1..',i1,')',a65)
  123 format(f10.3,i5,2i3,1p,3e15.7,2i3,6e15.7,5e15.7,a92,'(1..',i1,')',a65)
  124 format(f10.3,i5,2i3,1p,3e15.7,2i3,8e15.7,5e15.7,a92,'(1..',i1,')',a65)
  125 format(f10.3,i5,2i3,1p,3e15.7,2i3,10e15.7,5e15.7,a92,'(1..',i2,')',a65)
  126 format(f10.3,i5,2i3,1p,3e15.7,2i3,14e15.7,5e15.7,a92,'(1..',i2,')',a65)
end

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

! Writing of the Bragg term for DAFS

subroutine Write_out_Bragg(Bragg_abs_T,File_out,n_tens,npldafs,Sum_Bragg_abs_NR)

  use declarations
  implicit none

  integer, parameter:: n_tens_max = 10000

  integer:: ipr, n_tens, npldafs
  
  character(len=Length_name):: File_out
  character(len=10+(n_tens-2*npldafs)*Length_word):: dummy

  complex(kind=db), dimension(npldafs):: Bragg_abs_T, Sum_Bragg_abs_NR

  dummy = ' '

  ipr = 4

  if( n_tens > n_tens_max ) then
    call write_error
    do ipr = 6,9,3
      write(ipr,105) n_tens
    end do
    stop
  endif

  open(ipr, file = File_out, position='append')

  select case(Length_word)
    case(11)
      write(ipr,131) dummy, Sum_Bragg_abs_NR(1:npldafs)
      write(ipr,131) dummy, Bragg_abs_T(1:npldafs)
    case(12)
      write(ipr,132) dummy, Sum_Bragg_abs_NR(1:npldafs)
      write(ipr,132) dummy, Bragg_abs_T(1:npldafs)
    case(13)
      write(ipr,133) dummy, Sum_Bragg_abs_NR(1:npldafs)
      write(ipr,133) dummy, Bragg_abs_T(1:npldafs)
    case(14)
      write(ipr,134) dummy, Sum_Bragg_abs_NR(1:npldafs)
      write(ipr,134) dummy, Bragg_abs_T(1:npldafs)
    case(15)
      write(ipr,135) dummy, Sum_Bragg_abs_NR(1:npldafs)
      write(ipr,135) dummy, Bragg_abs_T(1:npldafs)
    case(16)
      write(ipr,136) dummy, Sum_Bragg_abs_NR(1:npldafs)
      write(ipr,136) dummy, Bragg_abs_T(1:npldafs)
    case(17)
      write(ipr,137) dummy, Sum_Bragg_abs_NR(1:npldafs)
      write(ipr,137) dummy, Bragg_abs_T(1:npldafs)
    case default
      write(ipr,135) dummy, Sum_Bragg_abs_NR(1:npldafs)
      write(ipr,135) dummy, Bragg_abs_T(1:npldafs)
  end select

  close(ipr)

  return
  105 format(//' The number of column to be written is ',i5, // &
               ' This is greater than the maximum possible value given in the routine write_out in the file coabs.f !', / & 
               ' To change that you must modify the formats 121 up to 157 in this routine,', / &
               ' and increase to the same value the parameter n_tens_max.', / &
               ' Then you compile again.' //)
  131 format(A,1p,10000e11.3)
  132 format(A,1p,10000e12.4)
  133 format(A,1p,10000e13.5)
  134 format(A,1p,10000e14.6)
  135 format(A,1p,10000e15.7)
  136 format(A,1p,10000e16.8)
  137 format(A,1p,10000e17.9)
end

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

subroutine Write_self_abs_info(angxyz,axyz,File_out,hkl_dafs,npldafs)        

  use declarations
  implicit none

  integer:: i, ipr, npldafs

  character(len=Length_name):: File_out
  
  real(kind=db), dimension(3):: angxyz, axyz
  real(kind=db), dimension(3,npldafs):: hkl_dafs 

  ipr = 4

  open(ipr, file = File_out, position='append')
  
  write(4,100) axyz(:)*bohr, angxyz(:) / radian, ( nint( hkl_dafs(1:3,i) ), i = 1,npldafs )
  
  close(ipr)

  return
  100 format(3f10.5,3x,3f10.5,10000(14x,3i4))
end

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

subroutine Write_SRXRD_info(Abs_cap,Abs_SRXRD,Abs_SRXRD_abs,Bulk_step,File_out,hkl_dafs,i_z_SRXRD_abs,Length_Abs,n_tens, &
                          n_z_SRXRD,n_z_SRXRD_abs,Non_resonant_Bulk,nphim,npldafs,Pos_z_SRXRD,Pos_z_SRXRD_abs,Sum_Bragg_abs_f0, &
                          Sum_Bragg_NR_Bulk,Sum_Bragg_nonabs_f)

  use declarations
  implicit none

  integer:: i, i_z_SRXRD_abs, ipr, n_tens, n_z_SRXRD, n_z_SRXRD_abs, nphim, npldafs 
  
  character(len=Length_name):: File_out
  character(len=10+(n_tens-2*npldafs)*Length_word):: dummy

  complex(kind=db), dimension(npldafs,n_z_SRXRD_abs):: Sum_Bragg_abs_f0
  complex(kind=db), dimension(npldafs,n_z_SRXRD):: Sum_Bragg_nonabs_f
  complex(kind=db), dimension(npldafs,nphim):: Sum_Bragg_NR_Bulk

  logical:: Bulk_step, Non_resonant_Bulk

  real(kind=db):: Abs_cap
  real(kind=db), dimension(npldafs):: Length_Abs
  real(kind=db), dimension(3,npldafs):: hkl_dafs
  real(kind=db), dimension(n_z_SRXRD):: Abs_SRXRD, Pos_z_SRXRD
  real(kind=db), dimension(n_z_SRXRD_abs):: Abs_SRXRD_abs, Pos_z_SRXRD_abs

  dummy = ' '
  
  ipr = 4

  open(ipr, file = File_out, position='append')

  if( Bulk_step ) then
    if( i_z_SRXRD_abs == 1 ) then 
      write(ipr,110) Pos_z_SRXRD_abs(i_z_SRXRD_abs), Abs_SRXRD_abs(i_z_SRXRD_abs), Abs_cap, n_z_SRXRD, 1
    else
      write(ipr,110) Pos_z_SRXRD_abs(i_z_SRXRD_abs), Abs_SRXRD_abs(i_z_SRXRD_abs), Abs_cap, 0, 1
    endif
  elseif( Non_resonant_Bulk ) then
    write(ipr,115) Pos_z_SRXRD_abs(i_z_SRXRD_abs), Abs_SRXRD_abs(i_z_SRXRD_abs), Abs_cap, n_z_SRXRD, -1
  else
    write(ipr,120) Pos_z_SRXRD_abs(i_z_SRXRD_abs), Abs_SRXRD_abs(i_z_SRXRD_abs), Abs_cap, n_z_SRXRD, 0
  endif 

  select case(Length_word)
    case(11)
      write(ipr,121) dummy, Sum_Bragg_abs_f0(:,i_z_SRXRD_abs)
    case(12)
      write(ipr,122) dummy, Sum_Bragg_abs_f0(:,i_z_SRXRD_abs)
    case(13)
      write(ipr,123) dummy, Sum_Bragg_abs_f0(:,i_z_SRXRD_abs)
    case(14)
      write(ipr,124) dummy, Sum_Bragg_abs_f0(:,i_z_SRXRD_abs)
    case(15)
      write(ipr,125) dummy, Sum_Bragg_abs_f0(:,i_z_SRXRD_abs)
    case(16)
      write(ipr,126) dummy, Sum_Bragg_abs_f0(:,i_z_SRXRD_abs)
    case(17)
      write(ipr,127) dummy, Sum_Bragg_abs_f0(:,i_z_SRXRD_abs)
    case default
      write(ipr,125) dummy, Sum_Bragg_abs_f0(:,i_z_SRXRD_abs)
  end select

  if( i_z_SRXRD_abs == 1 ) then
    do i = 1,n_z_SRXRD
      write(ipr,130) Pos_z_SRXRD(i), Abs_SRXRD(i)
      select case(Length_word)
        case(11)
          write(ipr,121) dummy, Sum_Bragg_nonabs_f(:,i)
        case(12)
          write(ipr,122) dummy, Sum_Bragg_nonabs_f(:,i)
        case(13)
          write(ipr,123) dummy, Sum_Bragg_nonabs_f(:,i)
        case(14)
          write(ipr,124) dummy, Sum_Bragg_nonabs_f(:,i)
        case(15)
          write(ipr,125) dummy, Sum_Bragg_nonabs_f(:,i)
        case(16)
          write(ipr,126) dummy, Sum_Bragg_nonabs_f(:,i)
        case(17)
          write(ipr,127) dummy, Sum_Bragg_nonabs_f(:,i)
        case default
          write(ipr,125) dummy, Sum_Bragg_nonabs_f(:,i)
      end select
    end do
  endif
  
  if( Non_resonant_bulk ) then
    select case(Length_word)
      case(11)
        write(ipr,121) dummy, Sum_Bragg_NR_Bulk(:,1)
      case(12)
        write(ipr,122) dummy, Sum_Bragg_NR_Bulk(:,1)
      case(13)
        write(ipr,123) dummy, Sum_Bragg_NR_Bulk(:,1)
      case(14)
        write(ipr,124) dummy, Sum_Bragg_NR_Bulk(:,1)
      case(15)
        write(ipr,125) dummy, Sum_Bragg_NR_Bulk(:,1)
      case(16)
        write(ipr,126) dummy, Sum_Bragg_NR_Bulk(:,1)
      case(17)
        write(ipr,127) dummy, Sum_Bragg_NR_Bulk(:,1)
      case default
        write(ipr,125) dummy, Sum_Bragg_NR_Bulk(:,1)
    end select
  endif
  
  select case(Length_word)
    case(11)
      write(ipr,131) dummy, Length_abs(1:npldafs)
    case(12)
      write(ipr,132) dummy, Length_abs(1:npldafs)
    case(13)
      write(ipr,133) dummy, Length_abs(1:npldafs)
    case(14)
      write(ipr,134) dummy, Length_abs(1:npldafs)
    case(15)
      write(ipr,135) dummy, Length_abs(1:npldafs)
    case(16)
      write(ipr,136) dummy, Length_abs(1:npldafs)
    case(17)
      write(ipr,137) dummy, Length_abs(1:npldafs)
    case default
      write(ipr,135) dummy, Length_abs(1:npldafs)
  end select
  
  if( Bulk_step ) then
    select case(Length_word)
      case(11)
        write(ipr,131) dummy, hkl_dafs(3,1:npldafs)
      case(12)
        write(ipr,132) dummy, hkl_dafs(3,1:npldafs)
      case(13)
        write(ipr,133) dummy, hkl_dafs(3,1:npldafs)
      case(14)
        write(ipr,134) dummy, hkl_dafs(3,1:npldafs)
      case(15)
        write(ipr,135) dummy, hkl_dafs(3,1:npldafs)
      case(16)
        write(ipr,136) dummy, hkl_dafs(3,1:npldafs)
      case(17)
        write(ipr,137) dummy, hkl_dafs(3,1:npldafs)
      case default
        write(ipr,135) dummy, hkl_dafs(3,1:npldafs)
    end select
  endif

  close(ipr)

  return
  110 format(f14.8,1p,2e15.7,2i4,'  = Pos_z_abs, NR_Abs, NR_abs_cap, n_z_SRXRD, Bulk case with truncature')
  115 format(f14.8,1p,2e15.7,2i4,'  = Pos_z_abs, NR_Abs, NR_abs_cap, n_z_SRXRD, Surface case, non resonant bulk')
  120 format(f14.8,1p,2e15.7,2i4,'  = Pos_z_abs, NR_Abs, NR_abs_cap, n_z_SRXRD, Surface case')

  121 format(A,10000e11.3)
  122 format(A,10000e12.4)
  123 format(A,10000e13.5)
  124 format(A,10000e14.6)
  125 format(A,10000e15.7)
  126 format(A,10000e16.8)
  127 format(A,10000e17.9)

  130 format(f12.8,1p,e15.7,23x,'  = Pos_z_nonabs, NR_nonAbs')

  131 format(A,1p,10000(11x,e11.3))
  132 format(A,1p,10000(12x,e12.4))
  133 format(A,1p,10000(13x,e13.5))
  134 format(A,1p,10000(14x,e14.6))
  135 format(A,1p,10000(15x,e15.7))
  136 format(A,1p,10000(16x,e16.8))
  137 format(A,1p,10000(17x,e17.9))
end

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

subroutine Write_out_stand(Ephseuil,File_out,First_E,n_dim,n_tens,New_file,Title,jpr,Tens)

  use declarations
  implicit none

  integer, parameter:: n_tens_max = 10000

  integer:: i, ipr, jpr, n, n_dim, n_tens 
  
  character(len=Length_name):: File_out
  character(len=Length_word):: mot
  character(len=Length_word), dimension(n_dim):: title

  logical:: First_E, New_file

  real(kind=db):: Ephseuil
  
  real(kind=db), dimension(n_dim):: Tens

  if( jpr == 6 ) then
    n = min(n_tens,4)
    ipr = 6
  elseif( jpr < 0 ) then
    n = n_tens
    ipr = abs( jpr )
  else
    n = n_tens
    ipr = 4
  endif

  if( n_tens > n_tens_max ) then
    call write_error
    do ipr = 6,9,3
      write(ipr,105) n_tens
    end do
    stop
  endif

  if( First_E ) then

    if( jpr < 0 ) then
      open(ipr, status='scratch')
    elseif( jpr /= 6 ) then
      if( New_file ) then
        open(ipr, file = File_out)
      else
        open(ipr, file = File_out, position='append')
      endif
    endif

    do i = 1,n
      mot = title(i)
      call center_word( mot, Length_word )
      title(i) = mot
    end do
    write(ipr,160) title(1:n)
  
  elseif( jpr >= 0 .and. jpr /= 6 ) then
  
    open(ipr, file = File_out, position='append' )
  
  endif

  New_file = .false.
  
  if( abs( Ephseuil*rydb ) < 9.999995_db ) then
    select case(Length_word)
      case(11)
        write(ipr,161) Ephseuil*rydb, Tens(1:n)  
      case(12)
        write(ipr,162) Ephseuil*rydb, Tens(1:n)
      case(13)
        write(ipr,163) Ephseuil*rydb, Tens(1:n)
      case(14)
        write(ipr,164) Ephseuil*rydb, Tens(1:n)
      case(15)
        write(ipr,165) Ephseuil*rydb, Tens(1:n)
      case(16)
        write(ipr,166) Ephseuil*rydb, Tens(1:n)
      case(17)
        write(ipr,167) Ephseuil*rydb, Tens(1:n)
      case default
        write(ipr,165) Ephseuil*rydb, Tens(1:n)
    end select
  elseif( abs( Ephseuil*rydb ) < 99.99995_db ) then
    select case(Length_word)
      case(11)
        write(ipr,171) Ephseuil*rydb, Tens(1:n)  
      case(12)
        write(ipr,172) Ephseuil*rydb, Tens(1:n)
      case(13)
        write(ipr,173) Ephseuil*rydb, Tens(1:n)
      case(14)
        write(ipr,174) Ephseuil*rydb, Tens(1:n)
      case(15)
        write(ipr,175) Ephseuil*rydb, Tens(1:n)
      case(16)
        write(ipr,176) Ephseuil*rydb, Tens(1:n)
      case(17)
        write(ipr,177) Ephseuil*rydb, Tens(1:n)
      case default
        write(ipr,175) Ephseuil*rydb, Tens(1:n)
    end select
  elseif( abs( Ephseuil*rydb ) < 999.9995_db ) then
    select case(Length_word)
      case(11)
        write(ipr,181) Ephseuil*rydb, Tens(1:n)  
      case(12)
        write(ipr,182) Ephseuil*rydb, Tens(1:n)
      case(13)
        write(ipr,183) Ephseuil*rydb, Tens(1:n)
      case(14)
        write(ipr,184) Ephseuil*rydb, Tens(1:n)
      case(15)
        write(ipr,185) Ephseuil*rydb, Tens(1:n)
      case(16)
        write(ipr,186) Ephseuil*rydb, Tens(1:n)
      case(17)
        write(ipr,187) Ephseuil*rydb, Tens(1:n)
      case default
        write(ipr,185) Ephseuil*rydb, Tens(1:n)
    end select
  else
    select case(Length_word)
      case(11)
        write(ipr,191) Ephseuil*rydb, Tens(1:n)  
      case(12)
        write(ipr,192) Ephseuil*rydb, Tens(1:n)
      case(13)
        write(ipr,193) Ephseuil*rydb, Tens(1:n)
      case(14)
        write(ipr,194) Ephseuil*rydb, Tens(1:n)
      case(15)
        write(ipr,195) Ephseuil*rydb, Tens(1:n)
      case(16)
        write(ipr,196) Ephseuil*rydb, Tens(1:n)
      case(17)
        write(ipr,197) Ephseuil*rydb, Tens(1:n)
      case default
        write(ipr,195) Ephseuil*rydb, Tens(1:n)
    end select
  endif

  if( jpr >= 0 .and. jpr /= 6 ) close(ipr)

  return
  105 format(//' The number of column to be written is ',i5, // &
               ' This is greater than the maximum possible value given in the routine write_out in the file coabs.f !', / & 
               ' To change that you must modify the formats 121 up to 157 in this routine,', / &
               ' and increase to the same value the parameter n_tens_max.', / &
               ' Then you compile again.' //)

  145 format(3f10.5,3x,3f10.5,10000(14x,3i4))
  151 format(A,1p,10000(15x,e15.7))
  152 format(A,1p,10000(16x,e16.8))
  153 format(A,1p,10000(17x,e17.9))
  160 format('    Energy',10000A)
  161 format(f10.5,1p,10000e11.3)
  162 format(f10.5,1p,10000e12.4)
  163 format(f10.5,1p,10000e13.5)
  164 format(f10.5,1p,10000e14.6)
  165 format(f10.5,1p,10000e15.7)
  166 format(f10.5,1p,10000e16.8)
  167 format(f10.5,1p,10000e17.9)
  171 format(f10.4,1p,10000e11.3)
  172 format(f10.4,1p,10000e12.4)
  173 format(f10.4,1p,10000e13.5)
  174 format(f10.4,1p,10000e14.6)
  175 format(f10.4,1p,10000e15.7)
  176 format(f10.4,1p,10000e16.8)
  177 format(f10.4,1p,10000e17.9)
  181 format(f10.3,1p,10000e11.3)
  182 format(f10.3,1p,10000e12.4)
  183 format(f10.3,1p,10000e13.5)
  184 format(f10.3,1p,10000e14.6)
  185 format(f10.3,1p,10000e15.7)
  186 format(f10.3,1p,10000e16.8)
  187 format(f10.3,1p,10000e17.9)
  191 format(f10.3,1p,10000e11.3)
  192 format(f10.2,1p,10000e12.4)
  193 format(f10.2,1p,10000e13.5)
  194 format(f10.2,1p,10000e14.6)
  195 format(f10.2,1p,10000e15.7)
  196 format(f10.2,1p,10000e16.8)
  197 format(f10.2,1p,10000e17.9)
end

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

subroutine Spherical_tensor_cal(Abs_U_iso,Bragg_abs,ct_nelec,Core_resolved,Volume_maille,E_cut,E1E1,E1E2, &
            E1M1,E2E2,Energ,Ephseuil,Epsii,Eseuil,First_E,Header,icheck,ie,Int_tens,jseuil,Magn_sens,Moyenne, &
            n_tens_max,natomsym,nenerg,ninit1,ninitr,nomfich_t,nphim,npldafs,nplr,nplrm,nplt,nseuil,numat_abs, &
            pdp,Sum_Bragg_NR_T,phdt,pol,Poldafse,Poldafss,T_E1E1_ia,T_E1E2_ia,T_E1M1_ia,T_E2E2_ia, &
            Spherical_signal,Surface_ref,Taux_eq,V0muf,Vec,Vecdafse,Vecdafss)

  use declarations
  implicit none

  integer, parameter:: n_tens_dd = 9 
  integer, parameter:: n_tens_dq = 15 
  integer, parameter:: n_tens_qq = 25 
  integer, parameter:: n_tens_dm = 9 

  integer:: i, ib, icheck, ie, initr, ipl, ipldafs, jseuil, n_tens_max, natomsym, nenerg, &
            ninit1, ninitr, nphim, npldafs, nplr, nplrm, nplt, nseuil, numat_abs
  
  character(len=Length_name):: nomfich_t
  character(len=58), dimension(9):: Com_dd, com_dm, Com_dm_m
  character(len=58), dimension(15):: Com_dq, Com_dq_m
  character(len=58), dimension(25):: Com_qq

  complex(kind=db):: ph
  
  complex(kind=db), dimension(3):: Pl_i, Pl_s
  complex(kind=db), dimension(n_tens_dd,ninitr):: Sph_tensor_dd
  complex(kind=db), dimension(n_tens_dq,ninitr):: Sph_tensor_dq, Sph_tensor_dq_m
  complex(kind=db), dimension(n_tens_qq,ninitr):: Sph_tensor_qq
  complex(kind=db), dimension(n_tens_dm,ninitr):: Sph_tensor_dm, Sph_tensor_dm_m
  complex(kind=db), dimension(3,3,ninitr,0:natomsym):: T_E1E1_ia, T_E1M1_ia
  complex(kind=db), dimension(3,3,3,ninitr,0:natomsym):: T_E1E2_ia
  complex(kind=db), dimension(3,3,3,3,ninitr,0:natomsym):: T_E2E2_ia
  complex(kind=db), dimension(3,npldafs,nphim):: Poldafse, Poldafss
  complex(kind=db), dimension(3,nplrm):: Pol
  complex(kind=db), dimension(npldafs):: Sum_Bragg_NR_T, phdt
  complex(kind=db), dimension(natomsym,npldafs):: Bragg_abs
  
  complex(kind=db), dimension(:,:), allocatable:: Tensor_pol_dd, Tensor_pol_dq, Tensor_pol_qq, Tensor_pol_dm

  logical:: Core_resolved, E1E1, E1E2, E1M1, E2E2, First_E, Header, Magn_sens, Moyenne, Spherical_signal, Write_bav

  real(kind=db):: Abs_U_iso, Volume_maille, dph, E_cut, Ephseuil, Eseuil, Surface_ref, V0muf
  real(kind=db), dimension(3):: Vo_i, Vo_s
  real(kind=db), dimension(ninitr):: ct_nelec, Epsii
  real(kind=db), dimension(nenerg):: Energ
  real(kind=db), dimension(natomsym) :: Taux_eq
  real(kind=db), dimension(3,nplrm):: Vec
  real(kind=db), dimension(nplrm,2) :: pdp
  real(kind=db), dimension(3,npldafs,nphim):: Vecdafse, Vecdafss
  real(kind=db), dimension(n_tens_max*ninitr,0:natomsym):: Int_tens
  real(kind=db), dimension(n_tens_dd,0:natomsym,ninitr):: Sph_tensor_ia_dd
  real(kind=db), dimension(n_tens_dq,0:natomsym,ninitr):: Sph_tensor_ia_dq, Sph_tensor_ia_dq_m 
  real(kind=db), dimension(n_tens_qq,0:natomsym,ninitr):: Sph_tensor_ia_qq
  real(kind=db), dimension(n_tens_dm,0:natomsym,ninitr):: Sph_tensor_ia_dm, Sph_tensor_ia_dm_m

  data Com_dd/  ' l = 0, non-magnetic monopole:  D(00) = (Dxx+Dyy+Dzz)/3 =', &
                ' l = 1, magnetic dipole:          D(10)          = l_z  =', &
                '                                  D(11)          = l_x  =', &
                '                                 D(1-1)          = l_y  =', &
                ' l = 2, non-magnetic quadrupole:  D(20)         = d_z2  =', &
                '                                  D(21)         = d_xz  =', &
                '                                 D(2-1)         = d_yz  =', &
                '                                 D(2-2)         = d_xy  =', &
                '                                  D(22)      = d_x2-y2  ='/
  
  data Com_dq/  ' l = 1, dipole:           I(10)                 = d_z   =', &
                '                          I(11)                 = d_x   =', &
                '                         I(1-1)                 = d_y   =', &
                ' l = 2, quadrupole:       I(20)          = lz*Omega_z   =', &
                '                          I(21)          = (l,Omega)2   =', &
                '                         I(2-1)          = (l,Omega)2   =', &
                '                         I(2-2)          = (l,Omega)2   =', &
                '                          I(22)          = (l,Omega)2   =', &
                ' l = 3, octupole:         I(30)       d_z*(3lz2 - l2)   =', &
                '                          I(31)         = (n,(l,l)2)3   =', &
                '                         I(3-1)         = (n,(l,l)2)3   =', &
                '                         I(3-2)         = (n,(l,l)2)3   =', &
                '                          I(32)         = (n,(l,l)2)3   =', &
                '                         I(3-3)         = (n,(l,l)2)3   =', &
                '                          I(33)         = (n,(l,l)2)3   ='/
                                     
  data Com_dq_m/' l = 1, dipole:           I(10)               Omega_z   =', &
                '                          I(11)               Omega_x   =', &
                '                         I(1-1)               Omega_y   =', &
                ' l = 2, quadrupole:       I(20)               d_z*l_z   =', &
                '                          I(21)                (n,l)2   =', &
                '                         I(2-1)                (n,l)2   =', &
                '                         I(2-2)                (n,l)2   =', &
                '                          I(22)                (n,l)2   =', &
                ' l = 3, octupole:         I(30)   Omega_z*(3lz2 - l2)   =', &
                '                          I(31)       (Omega,(l,l)2)3   =', &
                '                         I(3-1)       (Omega,(l,l)2)3   =', &
                '                         I(3-2)       (Omega,(l,l)2)3   =', &
                '                          I(32)       (Omega,(l,l)2)3   =', &
                '                         I(3-3)       (Omega,(l,l)2)3   =', &
                '                          I(33)       (Omega,(l,l)2)3   ='/

  data Com_qq/  ' l = 0, non magn monopole:    Q(00)                     =', &
                ' l = 1, magnetic dipole:      Q(10)            l_qq_z   =', &
                '                              Q(11)            l_qq_x   =', &
                '                             Q(1-1)            l_qq_y   =', &
                ' l = 2, non magn quadrupole:  Q(20)                     =', &
                '                              Q(21)                     =', &
                '                             Q(2-1)                     =', &
                '                             Q(2-2)                     =', &
                '                              Q(22)                     =', &
                ' l = 3, magnetic octupole:    Q(30)                     =', &
                '                              Q(31)                     =', &
                '                             Q(3-1)                     =', &
                '                             Q(3-2)                     =', &
                '                              Q(32)                     =', &
                '                             Q(3-3)                     =', &
                '                              Q(33)                     =', &
                ' l = 4, non magn hexadecapol: Q(40)                     =', &
                '                              Q(41)                     =', &
                '                             Q(4-1)                     =', &
                '                             Q(4-2)                     =', &
                '                              Q(42)                     =', &
                '                             Q(4-3)                     =', &
                '                              Q(43)                     =', &
                '                             Q(4-4)                     =', &
                '                              Q(44)                     ='/

  data Com_dm/  ' l = 0, monopole:   T(00) = Im(Txx+Tyy+Tzz)/3           =', &
                ' l = 1, dipole:     T(10) = Im(Txy-Tyx )/2        = d_z =', &
                '                    T(11) = Im(Tyz-Tzy )/2        = d_x =', &
                '                    T(1-1) = Im(Tzx-Txz)/2        = d_y =', &
                ' l = 2, quadrupole: T(20) = Im(2Tzz-Txx-Tyy)/6    = dz2 =', &
                '                    T(21) = Im( Tzx + Txz )/2    = d_xz =', &
                '                    T(2-1) = Im( Tyz + Tzy )/2   = d_yz =', &
                '                    T(2-2) = Im( Txy + Tyx )/2   = d_xy =', &
                '                    T(22) = Im( Txx - Tyy )/2 = d_x2-y2 ='/

  data Com_dm_m/' l = 0, monopole:   T(00) = Re(Txx+Tyy+Tzz)/3           =', &
                ' l = 1, dipole:     T(10) = Re(Txy-Tyx )/2    = Omega_z =', &
                '                    T(11) = Re(Tyz-Tzy )/2    = Omega_x =', &
                '                    T(1-1) = Re(Tzx-Txz)/2    = Omega_y =', &
                ' l = 2, quadrupole: T(20) = Re(2Tzz-Txx-Tyy)/6          =', &
                '                    T(21) = Re( Tzx + Txz )/2           =', &
                '                    T(2-1) = Re( Tyz + Tzy )/2          =', &
                '                    T(2-2) = Re( Txy + Tyx )/2          =', &
                '                    T(22) = Re( Txx - Tyy )/2           ='/
  
! Calcul des tenseurs de l'absorption
  call Abs_Spherical_tensor(Com_dm,Com_dm_m,Com_dd,Com_dq,Com_dq_m,Com_qq,ct_nelec,E1E1,E1E2,E1M1,E2E2,First_E,icheck, &
       Magn_sens,natomsym,ninitr,T_E1E1_ia,T_E1E2_ia,T_E1M1_ia,T_E2E2_ia, &
       Sph_tensor_ia_dd,Sph_tensor_ia_dq,Sph_tensor_ia_dq_m,Sph_tensor_ia_qq,Sph_tensor_ia_dm,Sph_tensor_ia_dm_m,Taux_eq)

  call Write_Spherical_tensor(Abs_U_iso,Core_resolved,Volume_maille,E_cut,E1E1,E1E2,E1M1,E2E2,Energ,Ephseuil,Epsii, &
       Eseuil,First_E,Header,icheck,ie,Int_tens,jseuil,Magn_sens,n_tens_dd,n_tens_dm,n_tens_dq,n_tens_max,n_tens_qq, &
       natomsym,nenerg,ninit1,ninitr,nomfich_t,nseuil,numat_abs,Sph_tensor_ia_dd, &
       Sph_tensor_ia_dq,Sph_tensor_ia_dq_m,Sph_tensor_ia_dm,Sph_tensor_ia_dm_m,Sph_tensor_ia_qq,Surface_ref,V0muf)

  if( .not. Spherical_signal ) return
  
 ! Calcul des tenseurs de la polarisation
 
  nplt = nplr + npldafs

  allocate( Tensor_pol_dd(0:nplt,n_tens_dd) )
  allocate( Tensor_pol_dq(0:nplt,2*n_tens_dq) ) 
  allocate( Tensor_pol_qq(0:nplt,n_tens_qq) )
  allocate( Tensor_pol_dm(0:nplt,2*n_tens_dm) ) 
  
  do ipl = 1,nplt
      
    if( ipl <= nplr ) then
      Pl_i(:) = Pol(:,ipl)
      Pl_s(:) = Pol(:,ipl)
      Vo_i(:) = Vec(:,ipl)
      Vo_s(:) = Vec(:,ipl)
    else
! Dans convolution on reprend le complexe conjugue de l'ensemble polarisation x diffusion
      Pl_i(:) = Conjg( Poldafse(:,ipl-nplr,1) )
      Pl_s(:) = Conjg( Poldafss(:,ipl-nplr,1) )
      Vo_i(:) = Vecdafse(:,ipl-nplr,1)
      Vo_s(:) = Vecdafss(:,ipl-nplr,1)
    endif

    if( E1E1 ) call Tensor_pol_dd_cal(ipl,n_tens_dd,nplt,Pl_i,Pl_s,Tensor_pol_dd)

    if( E1E2 ) call Tensor_pol_dq_cal(ipl,n_tens_dq,nplt,Pl_i,Pl_s,Vo_i,Vo_s,Tensor_pol_dq)

    if( E2E2 ) call Tensor_pol_qq_cal(ipl,n_tens_qq,nplt,Pl_i,Pl_s,Vo_i,Vo_s,Tensor_pol_qq)
  
    if( E1M1 ) call Tensor_pol_dm_cal(ipl,n_tens_dm,nplt,Pl_i,Pl_s,Vo_i,Vo_s,Tensor_pol_dm)
    
  end do

  if( Moyenne ) then
   if( E1E1 ) then
     do i = 1,n_tens_dd
       Tensor_pol_dd(0,i) = sum( pdp(1:nplr,1) * Tensor_pol_dd(1:nplr,i) )
     end do 
   endif
   if( E1E2 ) Tensor_pol_dq(0,:) = ( 0._db, 0._db )
   if( E2E2 ) then 
     do i = 1,n_tens_qq
       Tensor_pol_qq(0,i) = sum( pdp(1:nplr,2) * Tensor_pol_qq(1:nplr,i) )
     end do 
   endif
   if( E1M1 ) then
     Tensor_pol_dm(0,:) = ( 0._db, 0._db ) 
     Tensor_pol_dm(0,1) = ( 1._db, 0._db ) 
     if( Magn_sens ) Tensor_pol_dm(0,n_tens_dm+1) = ( 1._db, 0._db ) 
   endif
  endif
  
  if( ie == 1 .and. icheck > 0 ) then
    
    if( E1E1 ) then
      write(3,110) 'E1E1'
      write(3,115) ( 'Abs', i, i = 1,nplr ), ( 'Rxs', i, i = 1,npldafs )
      do i = 1,n_tens_dd
        write(3,120) i, Tensor_pol_dd(1:nplt,i)
      end do
    endif
    
    if( E1E2 ) then
      write(3,110) 'E1E2'
      write(3,115) ( 'Abs', i, i = 1,nplr ), ( 'Rxs', i, i = 1,npldafs )
      do i = 1,n_tens_dq
        write(3,120) i, Tensor_pol_dq(1:nplt,i)
      end do
      if( Magn_sens ) then
        do i = n_tens_dq+1,2*n_tens_dq
          write(3,120) i, Tensor_pol_dq(1:nplt,i)
        end do
      endif
    endif
    
    if( E2E2 ) then
      write(3,110) 'E2E2'
      write(3,115) ( 'Abs', i, i = 1,nplr ), ( 'Rxs', i, i = 1,npldafs )
      do i = 1,n_tens_qq
        write(3,120) i, Tensor_pol_qq(1:nplt,i)
      end do
    endif
    
    if( E1M1 ) then
      write(3,110) 'E1M1'
      write(3,115) ( 'Abs', i, i = 1,nplr ), ( 'Rxs', i, i = 1,npldafs )
      do i = 1,n_tens_dm
        write(3,120) i, Tensor_pol_dm(1:nplt,i)
      end do
      if( Magn_sens ) then
        do i = n_tens_dm+1,2*n_tens_dm
          write(3,120) i, Tensor_pol_dm(1:nplt,i)
        end do
      endif
    endif

  endif

  do ipl = 0,nplt
    if( .not. Moyenne .and. ipl == 0 ) cycle 
    ipldafs = ipl - nplr
      
    if( ipl <= nplr ) then
  
      do initr = 1,ninitr
        Sph_tensor_dd(:,initr) = cmplx( Sph_tensor_ia_dd(:,0,initr), 0._db ) 
        Sph_tensor_dq(:,initr) = cmplx( Sph_tensor_ia_dq(:,0,initr), 0._db ) 
        Sph_tensor_dq_m(:,initr) = cmplx( 0._db, Sph_tensor_ia_dq_m(:,0,initr) ) 
        Sph_tensor_qq(:,initr) = cmplx( Sph_tensor_ia_qq(:,0,initr), 0._db ) 
        Sph_tensor_dm(:,initr) = cmplx( 0._db, Sph_tensor_ia_dm(:,0,initr) ) 
        Sph_tensor_dm_m(:,initr) = cmplx( Sph_tensor_ia_dm_m(:,0,initr), 0._db )
      end do
      
    else
    
      Sph_tensor_dd(:,:) = cmplx( 0._db, 0._db ) 
      Sph_tensor_dq(:,:) = cmplx( 0._db, 0._db ) 
      Sph_tensor_dq_m(:,:) = cmplx( 0._db, 0._db ) 
      Sph_tensor_qq(:,:) = cmplx( 0._db, 0._db ) 
      Sph_tensor_dm(:,:) = cmplx( 0._db, 0._db ) 
      Sph_tensor_dm_m(:,:) = cmplx( 0._db, 0._db )

      do ib = 1,natomsym

        ph = conjg( Bragg_abs(ib,ipldafs) )

        do initr = 1,ninitr
          Sph_tensor_dd(:,initr)   = Sph_tensor_dd(:,initr)   + ph * Sph_tensor_ia_dd(:,ib,initr) 
          Sph_tensor_dq(:,initr)   = Sph_tensor_dq(:,initr)   + ph * Sph_tensor_ia_dq(:,ib,initr) 
          Sph_tensor_dq_m(:,initr) = Sph_tensor_dq_m(:,initr) + img * ph * Sph_tensor_ia_dq_m(:,ib,initr) 
          Sph_tensor_qq(:,initr)   = Sph_tensor_qq(:,initr)   + ph * Sph_tensor_ia_qq(:,ib,initr) 
          Sph_tensor_dm(:,initr)   = Sph_tensor_dm(:,initr)   + img * ph * Sph_tensor_ia_dm(:,ib,initr) 
          Sph_tensor_dm_m(:,initr) = Sph_tensor_dm_m(:,initr) + ph * Sph_tensor_ia_dm_m(:,ib,initr)
        end do
      end do
 
      if( natomsym > 1 .and. ie == 1 .and. icheck > 0 ) then
        Write_bav = .true.
        if( ipldafs > 1 ) then
          dph = sum( abs( Bragg_abs(:,ipldafs) - Bragg_abs(:,ipldafs-1) ) )
          if( dph < eps10 ) Write_bav = .false.
        endif
        if( Write_bav ) then
          write(3,125) ipldafs
          if( E1E1 ) then
            write(3,128) ( initr, initr = 1,ninitr )
            do i = 1,n_tens_dd
              if( i == 1 .or. i == 2 .or. i == 5 ) write(3,*)
              write(3,130) Com_dd(i), Sph_tensor_dd(i,:)
            end do
          endif
          if( E1E2 ) then
            write(3,140) ( initr, initr = 1,ninitr )
            do i = 1,n_tens_dq
              if( i == 1 .or. i == 4 .or. i == 9 ) write(3,*)
              write(3,130) Com_dq(i), Sph_tensor_dq(i,:)
            end do
            if( Magn_sens ) then
              write(3,150) ( initr, initr = 1,ninitr )
              do i = 1,n_tens_dq
                if( i == 1 .or. i == 4 .or. i == 9 ) write(3,*)
                write(3,130) Com_dq_m(i), Sph_tensor_dq_m(i,:)
              end do
            endif
          endif
          if( E2E2 ) then
            write(3,160) ( initr, initr = 1,ninitr )
            do i = 1,n_tens_qq
              if( i == 1 .or. i == 2 .or. i == 5  .or. i == 10 .or. i == 17 ) write(3,*)
              write(3,130) Com_qq(i), Sph_tensor_qq(i,:)
            end do
          endif
          if( E1M1 ) then
            write(3,170) ( initr, initr = 1,ninitr )
            do i = 1,n_tens_dm
              if( i == 1 .or. i == 2 .or. i == 5 ) write(3,*)
              write(3,130) Com_dm(i), Sph_tensor_dm(i,:)
            end do
            if( Magn_sens ) then
              write(3,180) ( initr, initr = 1,ninitr )
              do i = 1,n_tens_dm
                if( i == 1 .or. i == 2 .or. i == 5 ) write(3,*)
                write(3,130) Com_dm_m(i), Sph_tensor_dm_m(i,:)
              end do
            endif
          endif
        endif
      endif 
    endif 

    call Write_Signal(Abs_U_iso,ct_nelec,Core_resolved,Volume_maille,E_cut,E1E1,E1E2,E1M1,E2E2,Ephseuil,Epsii, &
      Eseuil,First_E,Header,0,ipl,ipldafs,jseuil,Magn_sens,n_tens_dd,n_tens_dq,n_tens_dm, &
      n_tens_qq,ninit1,ninitr,nomfich_t,npldafs,nplt,nseuil,numat_abs,Sum_Bragg_NR_T,phdt, &
      Sph_tensor_dd,Sph_tensor_dq,Sph_tensor_dq_m,Sph_tensor_dm,Sph_tensor_dm_m,Sph_tensor_qq, &
      Surface_ref,Tensor_pol_dd,Tensor_pol_dq,Tensor_pol_dm,Tensor_pol_qq,V0muf)

  end do
  
  deallocate( Tensor_pol_dd,  Tensor_pol_dq,  Tensor_pol_qq, Tensor_pol_dm ) 

  return
  110 format(/1x,A,' polarisation tensor')
  115 format(3x,25(8x,a3,i3,5x))
  120 format(i3,25(1x,2f9.5))
  125 format(/' Crystal spherical tensor (numb. of electron), reflexion',i3)
  128 format(/' E1E1 spherical tensor,                           initl =',10(14x,i2,11x))
  130 format(1p,A,10(2e13.5,1x))
  140 format(/' E1E2 spherical tensor, non-magnetic part,        initl =',10(14x,i2,11x))
  150 format(/' E1E2 spherical tensor, magnetic part,            initl =',10(14x,i2,11x))
  160 format(/' E2E2 spherical tensor,                           initl =',10(14x,i2,11x))
  170 format(/' E1M1 spherical tensor, non-magnetic part,        initl =',10(14x,i2,11x))
  180 format(/' E1M1 spherical tensor, magnetic part,            initl =',10(14x,i2,11x))
end

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

subroutine Abs_Spherical_tensor(Com_dm,Com_dm_m,Com_dd,Com_dq,Com_dq_m,Com_qq,ct_nelec,E1E1,E1E2,E1M1,E2E2,First_E,icheck, &
       Magn_sens,natomsym,ninitr,T_E1E1_ia,T_E1E2_ia,T_E1M1_ia,T_E2E2_ia, &
       Sph_tensor_ia_dd,Sph_tensor_ia_dq,Sph_tensor_ia_dq_m,Sph_tensor_ia_qq,Sph_tensor_ia_dm,Sph_tensor_ia_dm_m,Taux_eq)

  use declarations
  implicit none

  integer, parameter:: n_tens_dd = 9 
  integer, parameter:: n_tens_dq = 15 
  integer, parameter:: n_tens_qq = 25 
  integer, parameter:: n_tens_dm = 9 

  integer:: i, ia, ib, icheck, initr, natomsym, ninitr
  
  character(len=58), dimension(9):: Com_dd, com_dm, Com_dm_m
  character(len=58), dimension(15):: Com_dq, Com_dq_m
  character(len=58), dimension(25):: Com_qq

  complex(kind=db), dimension(n_tens_dd):: Sph_tensor_dd
  complex(kind=db), dimension(n_tens_dq):: Sph_tensor_dq
  complex(kind=db), dimension(n_tens_qq):: Sph_tensor_qq
  complex(kind=db), dimension(n_tens_dm):: Sph_tensor_dm
  complex(kind=db), dimension(3,3):: Tensor_rank_2
  complex(kind=db), dimension(3,3,3):: Tensor_rank_3
  complex(kind=db), dimension(3,3,3,3):: Tensor_rank_4
  complex(kind=db), dimension(3,3,ninitr,0:natomsym):: T_E1E1_ia, T_E1M1_ia
  complex(kind=db), dimension(3,3,3,ninitr,0:natomsym):: T_E1E2_ia
  complex(kind=db), dimension(3,3,3,3,ninitr,0:natomsym):: T_E2E2_ia

  logical:: E1E1, E1E2, E1M1, E2E2, First_E, Magn_sens

  real(kind=db), dimension(ninitr):: ct_nelec
  real(kind=db), dimension(natomsym) :: Taux_eq
  real(kind=db), dimension(n_tens_dd,0:natomsym,ninitr):: Sph_tensor_ia_dd
  real(kind=db), dimension(n_tens_dq,0:natomsym,ninitr):: Sph_tensor_ia_dq, Sph_tensor_ia_dq_m 
  real(kind=db), dimension(n_tens_qq,0:natomsym,ninitr):: Sph_tensor_ia_qq
  real(kind=db), dimension(n_tens_dm,0:natomsym,ninitr):: Sph_tensor_ia_dm, Sph_tensor_ia_dm_m
  
  Sph_tensor_ia_dd(:,:,:) = 0._db
  Sph_tensor_ia_dq(:,:,:) = 0._db
  Sph_tensor_ia_dq_m(:,:,:) = 0._db
  Sph_tensor_ia_qq(:,:,:) = 0._db
  Sph_tensor_ia_dm(:,:,:) = 0._db
  Sph_tensor_ia_dm_m(:,:,:) = 0._db
  
  do initr = 1,ninitr

    do ia = 1,natomsym

      if( E1E1 ) then
        Tensor_rank_2(:,:) = T_E1E1_ia(:,:,initr,ia)
        call Sph_tensor_dd_cal(n_tens_dd,Tensor_rank_2,Sph_tensor_dd)
 ! conversion en nombre d'electrons
        Sph_tensor_ia_dd(:,ia,initr) = ct_nelec(initr) * real( Sph_Tensor_dd(:), db )
        Sph_tensor_ia_dd(:,0,initr) = Sph_tensor_ia_dd(:,0,initr) + Taux_eq(ia) * Sph_tensor_ia_dd(:,ia,initr) 
      endif

      if( E1E2 ) then
        Tensor_rank_3(:,:,:) = T_E1E2_ia(:,:,:,initr,ia)
        call Sph_tensor_dq_cal(n_tens_dq,Tensor_rank_3,Sph_tensor_dq)
        Sph_tensor_ia_dq(:,ia,initr) = ct_nelec(initr) * real( Sph_Tensor_dq(:), db )
        if( Magn_sens ) Sph_tensor_ia_dq_m(:,ia,initr) = ct_nelec(initr) * aimag( Sph_Tensor_dq(:) )
        Sph_tensor_ia_dq(:,0,initr) = Sph_tensor_ia_dq(:,0,initr) + Taux_eq(ia) * Sph_tensor_ia_dq(:,ia,initr)
        if( Magn_sens ) Sph_tensor_ia_dq_m(:,0,initr) = Sph_tensor_ia_dq_m(:,0,initr) &
                                                       + Taux_eq(ia) * Sph_tensor_ia_dq_m(:,ia,initr) 
      endif

      if( E2E2 ) then
        Tensor_rank_4(:,:,:,:) = T_E2E2_ia(:,:,:,:,initr,ia)
        call Sph_tensor_qq_cal(n_tens_qq,Tensor_rank_4,Sph_tensor_qq)
        Sph_tensor_ia_qq(:,ia,initr) = ct_nelec(initr) * real( Sph_Tensor_qq(:), db )
        Sph_tensor_ia_qq(:,0,initr) = Sph_tensor_ia_qq(:,0,initr) + Taux_eq(ia) * Sph_tensor_ia_qq(:,ia,initr)
      endif
     
      if( E1M1 ) then  ! for E1M1, the magnetic part is the real term
        Tensor_rank_2(:,:) = T_E1M1_ia(:,:,initr,ia)
        call Sph_tensor_dm_cal(n_tens_dm,Tensor_rank_2,Sph_tensor_dm)
        Sph_tensor_ia_dm(:,ia,initr) = ct_nelec(initr) * aimag( Sph_tensor_dm(:) )
        if( Magn_sens ) Sph_tensor_ia_dm_m(:,ia,initr) = ct_nelec(initr) * real( Sph_tensor_dm(:), db )
        Sph_tensor_ia_dm(:,0,initr) = Sph_tensor_ia_dm(:,0,initr) + Taux_eq(ia) * Sph_tensor_ia_dm(:,ia,initr)
        if( Magn_sens ) Sph_tensor_ia_dm_m(:,0,initr) = Sph_tensor_ia_dm_m(:,0,initr) &
                                                       + Taux_eq(ia) * Sph_tensor_ia_dm_m(:,ia,initr) 
      endif

    end do  ! fin boucle ia

  end do ! fin boucle initr

  do ib = 1,natomsym+1
    if( icheck == 0 .or. .not. First_E ) exit
    if( ib == natomsym+1 ) then
      if( natomsym == 1 ) exit
      ia = 0
      write(3,110)
    else
      ia = ib
      if( ia > 1 .and. icheck < 2 ) cycle
      write(3,120) ia
    endif

    if( E1E1 ) then
      write(3,128) ( initr, initr = 1,ninitr )
      do i = 1,n_tens_dd
        if( i == 1 .or. i == 2 .or. i == 5 ) write(3,*)
        write(3,130) Com_dd(i), Sph_tensor_ia_dd(i,ia,:)
      end do
    endif
    if( E1E2 ) then
      write(3,140) ( initr, initr = 1,ninitr )
      do i = 1,n_tens_dq
        if( i == 1 .or. i == 4 .or. i == 9 ) write(3,*)
        write(3,130) Com_dq(i), Sph_tensor_ia_dq(i,ia,:)
      end do
      if( Magn_sens ) then
        write(3,150) ( initr, initr = 1,ninitr )
        do i = 1,n_tens_dq
          if( i == 1 .or. i == 4 .or. i == 9 ) write(3,*)
          write(3,130) Com_dq_m(i), Sph_tensor_ia_dq_m(i,ia,:)
        end do
      endif
    endif
    if( E2E2 ) then
      write(3,160) ( initr, initr = 1,ninitr )
      do i = 1,n_tens_qq
        if( i == 1 .or. i == 2 .or. i == 5  .or. i == 10 .or. i == 17 ) write(3,*)
        write(3,130) Com_qq(i), Sph_tensor_ia_qq(i,ia,:)
      end do
    endif
    if( E1M1 ) then
      write(3,170) ( initr, initr = 1,ninitr )
      do i = 1,n_tens_dm
        if( i == 1 .or. i == 2 .or. i == 5 ) write(3,*)
        write(3,130) Com_dm(i), Sph_tensor_ia_dm(i,ia,:)
      end do
      if( Magn_sens ) then
        write(3,180) ( initr, initr = 1,ninitr )
        do i = 1,n_tens_dm
          if( i == 1 .or. i == 2 .or. i == 5 ) write(3,*)
          write(3,130) Com_dm_m(i), Sph_tensor_ia_dm_m(i,ia,:)
        end do
      endif
    endif

  end do

  return
  110 format(/' Crystal spherical tensor (numb. of electron)')
  120 format(/' Spherical tensor (numb. of electron), atome =',i3)
  128 format(/' E1E1 spherical tensor,                           initl =',10(7x,i2,5x))
  130 format(1p,A,10(e13.5,1x))
  140 format(/' E1E2 spherical tensor, non-magnetic part,        initl =',10(7x,i2,5x))
  150 format(/' E1E2 spherical tensor, magnetic part,            initl =',10(7x,i2,5x))
  160 format(/' E2E2 spherical tensor,                           initl =',10(7x,i2,5x))
  170 format(/' E1M1 spherical tensor, non-magnetic part,        initl =',10(7x,i2,5x))
  180 format(/' E1M1 spherical tensor, magnetic part,            initl =',10(7x,i2,5x))
end

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

subroutine Sph_tensor_dd_cal(n_tens_dd,Tensor_rank_2,Sph_tensor_dd)

  use declarations
  implicit none
  
  integer:: n_tens_dd

  complex(kind=db), dimension(n_tens_dd):: Sph_tensor_dd
  complex(kind=db), dimension(3,3):: Tensor_rank_2

! l = 0

  Sph_tensor_dd(1) = ( 1 / 3._db ) * ( Tensor_rank_2(1,1) + Tensor_rank_2(2,2) + Tensor_rank_2(3,3) )

! l = 1

! Multiplie par - img, equivalent a prendre la partie imaginaire 
! lz = D(1,0)
  Sph_tensor_dd(2) = - img * ( Tensor_rank_2(1,2) - Tensor_rank_2(2,1) ) / 2

! lx = D(1,1)
  Sph_tensor_dd(3) = - img * ( Tensor_rank_2(2,3) - Tensor_rank_2(3,2) ) / 2

! ly = D(1,-1)
  Sph_tensor_dd(4) = - img * ( Tensor_rank_2(3,1) - Tensor_rank_2(1,3) ) / 2

! l = 2

! D02 = ( 2*Dzz - Dxx - Dyy ) / 6
  Sph_tensor_dd(5) =( 2*Tensor_rank_2(3,3) - Tensor_rank_2(1,1)  - Tensor_rank_2(2,2) ) / 6

! D(2,1)
  Sph_tensor_dd(6) = ( Tensor_rank_2(1,3) + Tensor_rank_2(3,1) ) / 2

! D(2,-1)
  Sph_tensor_dd(7) = ( Tensor_rank_2(2,3) + Tensor_rank_2(3,2) ) / 2

! D(2,-2)
  Sph_tensor_dd(8) = ( Tensor_rank_2(1,2) + Tensor_rank_2(2,1) ) / 2

! D(2,2)
  Sph_tensor_dd(9) = ( Tensor_rank_2(1,1) - Tensor_rank_2(2,2) ) / 2

  return
end

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

subroutine Sph_tensor_dq_cal(n_tens_dq,Tensor_rank_3,Sph_tensor_dq)

  use declarations
  implicit none
  
  integer:: n_tens_dq

  complex(kind=db), dimension(3,3,3):: Tensor_rank_3
  complex(kind=db), dimension(n_tens_dq):: Sph_tensor_dq

  real(kind=db):: fac
  
! Tenseur 1

! I(10)
  Sph_tensor_dq(1) = ( 2 * Tensor_rank_3(3,3,3) - Tensor_rank_3(3,1,1) - Tensor_rank_3(3,2,2) + 3 * Tensor_rank_3(1,1,3) &
                                                                                              + 3 * Tensor_rank_3(2,2,3) ) / 15

! I(11)
  Sph_tensor_dq(2) = ( 2 * Tensor_rank_3(1,1,1) - Tensor_rank_3(1,2,2) - Tensor_rank_3(1,3,3) + 3 * Tensor_rank_3(2,1,2) &
                                                                                              + 3 * Tensor_rank_3(3,1,3) ) / 15

! I(1-1)
  Sph_tensor_dq(3) = ( 2 * Tensor_rank_3(2,2,2) - Tensor_rank_3(2,1,1) - Tensor_rank_3(2,3,3) + 3 * Tensor_rank_3(1,1,2) &
                                                                                              + 3 * Tensor_rank_3(3,2,3) ) / 15

! Tenseur 2

! -i*I(20)
  Sph_tensor_dq(4) = Tensor_rank_3(1,2,3) - Tensor_rank_3(2,1,3)

  fac = 1 / 3._db

! (-i/sqrt(2))*(I(21) - I(2-1))
  Sph_tensor_dq(5) = fac * ( Tensor_rank_3(2,1,1) - Tensor_rank_3(2,3,3) - Tensor_rank_3(1,1,2) + Tensor_rank_3(3,2,3) )

! (1/sqrt(2))*(I(21) + I(2-1))
  Sph_tensor_dq(6) = fac * ( Tensor_rank_3(1,2,2) - Tensor_rank_3(1,3,3) - Tensor_rank_3(2,1,2) + Tensor_rank_3(3,1,3) )

  Sph_tensor_dq(7) = fac * ( Tensor_rank_3(1,1,3) - Tensor_rank_3(2,2,3) - Tensor_rank_3(3,1,1) + Tensor_rank_3(3,2,2) )

! (-i/sqrt(2))*(I(22) + I(2-2))
  Sph_tensor_dq(8) = fac * ( Tensor_rank_3(1,2,3) + Tensor_rank_3(2,1,3) - Tensor_rank_3(3,1,2) - Tensor_rank_3(3,2,1) )

! Tenseur 3

  Sph_tensor_dq(9) = 1 / sqrt(10._db) * ( 2 * Tensor_rank_3(3,3,3) - 2 * Tensor_rank_3(1,1,3) - Tensor_rank_3(3,1,1) &
                   - 2 * Tensor_rank_3(2,2,3) - Tensor_rank_3(3,2,2) )

  fac = 1 / sqrt(60._db)

  Sph_tensor_dq(10) = fac * ( 3 * Tensor_rank_3(1,1,1) + Tensor_rank_3(1,2,2) + 2 * Tensor_rank_3(2,1,2) &
                            - 4 * Tensor_rank_3(1,3,3) - 8 * Tensor_rank_3(3,1,3) )

! (-i/sqrt(2))*(I(31) + I(3-1))
  Sph_tensor_dq(11) = fac * ( 3 * Tensor_rank_3(2,2,2) + Tensor_rank_3(2,1,1) + 2 * Tensor_rank_3(1,2,1) &
                            - 4 * Tensor_rank_3(2,3,3) - 8 * Tensor_rank_3(3,2,3) )

  fac = 1 / sqrt(6._db)

! (-i/sqrt(2))*(I(32) - I(3-2))
  Sph_tensor_dq(12) = 2 * fac * ( Tensor_rank_3(1,2,3) + Tensor_rank_3(2,1,3) + Tensor_rank_3(3,1,2) )

  Sph_tensor_dq(13) = fac * ( 2 * Tensor_rank_3(1,1,3) - 2 * Tensor_rank_3(2,2,3) + Tensor_rank_3(3,1,1) - Tensor_rank_3(3,2,2) )

  fac = 0.5_db

  Sph_tensor_dq(14) = fac * ( Tensor_rank_3(1,2,2) + 2 * Tensor_rank_3(2,1,2) - Tensor_rank_3(1,1,1) )

! (-i/sqrt(2))*(I(33) + I(3-3))
  Sph_tensor_dq(15) = - fac * ( Tensor_rank_3(2,1,1) + 2 * Tensor_rank_3(1,2,1) - Tensor_rank_3(2,2,2) )

  return
end

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

subroutine Sph_tensor_qq_cal(n_tens_qq,Tensor_rank_4,Sph_tensor_qq)

  use declarations
  implicit none
  
  integer:: n_tens_qq

  complex(kind=db), dimension(3,3,3,3):: Tensor_rank_4
  complex(kind=db), dimension(n_tens_qq):: Sph_tensor_qq

  real(kind=db):: fac
  
! La multiplication par - img correspond a la partie imaginaire quand le
! tenseur n'est pas multiplie par le terme de Bragg.

! Tenseur 0, scalaire, signal isotropique quadrupolaire

  fac = 1 / 45._db
! Q(00)
  Sph_tensor_qq(1) = fac * ( 6 * ( Tensor_rank_4(1,3,1,3) + Tensor_rank_4(2,3,2,3) + Tensor_rank_4(1,2,1,2) ) &
                           + 2 * ( Tensor_rank_4(1,1,1,1) + Tensor_rank_4(2,2,2,2) + Tensor_rank_4(3,3,3,3) ) &
                 - ( Tensor_rank_4(1,1,2,2) + Tensor_rank_4(1,1,3,3) + Tensor_rank_4(3,3,2,2) + Tensor_rank_4(2,2,1,1) &
                   + Tensor_rank_4(3,3,1,1) + Tensor_rank_4(2,2,3,3) ) )

! Tenseur 1, vecteur, lz, lx, ly, magnetique

  fac = 2 / 10._db

! Q(10)
  Sph_tensor_qq(2) = - img * fac * ( Tensor_rank_4(2,1,1,1) - Tensor_rank_4(1,2,2,2) + Tensor_rank_4(2,3,1,3) &
                                   - Tensor_rank_4(1,1,2,1) + Tensor_rank_4(2,2,1,2) - Tensor_rank_4(1,3,2,3) )

! Q(11)
  Sph_tensor_qq(3) = - img * fac * ( Tensor_rank_4(3,2,2,2) - Tensor_rank_4(2,3,3,3) + Tensor_rank_4(3,1,2,1) &
                                   - Tensor_rank_4(2,2,3,2) + Tensor_rank_4(3,3,2,3) - Tensor_rank_4(2,1,3,1) )

! Q(1-1)
  Sph_tensor_qq(4) = - img * fac * ( Tensor_rank_4(1,3,3,3) - Tensor_rank_4(3,1,1,1) + Tensor_rank_4(1,2,3,2) &
                                   - Tensor_rank_4(3,3,1,3) + Tensor_rank_4(1,1,3,1) - Tensor_rank_4(3,2,1,2) )

! Tenseur 2 : quadrupole non magnetique

  fac = 2 / ( 3 * sqrt(14._db) )
! Q(20)
  Sph_tensor_qq(5) = fac * ( 6 * Tensor_rank_4(1,2,1,2) - 3 * Tensor_rank_4(1,3,1,3) - 3 * Tensor_rank_4(2,3,2,3) &
                               + Tensor_rank_4(1,1,1,1) + Tensor_rank_4(2,2,2,2) &
           - 2 * Tensor_rank_4(1,1,2,2) - 2 * Tensor_rank_4(2,2,1,1) - 2 * Tensor_rank_4(3,3,3,3) + Tensor_rank_4(1,1,3,3) &
               + Tensor_rank_4(2,2,3,3) + Tensor_rank_4(3,3,1,1) + Tensor_rank_4(3,3,2,2) )

  fac = 2 / sqrt(42._db)

! (1/sqrt(2)) * ( Q(21) - Q(2-1) )_comp = Q(21) reel
  Sph_tensor_qq(6) = fac * ( 3 * Tensor_rank_4(2,3,1,2) + Tensor_rank_4(3,3,1,3) + Tensor_rank_4(1,1,1,3) &
                     - 2 * Tensor_rank_4(2,2,1,3) &
                     + 3 * Tensor_rank_4(1,2,2,3) + Tensor_rank_4(1,3,3,3) + Tensor_rank_4(1,3,1,1) - 2 * Tensor_rank_4(1,3,2,2) )

! (1/sqrt(2)) * ( Q(21) + Q(2-1) )
  Sph_tensor_qq(7) = fac * ( 3 * Tensor_rank_4(1,3,1,2) + Tensor_rank_4(3,3,2,3) + Tensor_rank_4(2,2,2,3) &
                     - 2 * Tensor_rank_4(1,1,2,3) &
                     + 3 * Tensor_rank_4(1,2,1,3) + Tensor_rank_4(2,3,3,3) + Tensor_rank_4(2,3,2,2) - 2 * Tensor_rank_4(2,3,1,1) )

  fac = 2 / sqrt( 42._db )

! (1/sqrt(2)) * ( Q(22) - Q(2-2) )
  Sph_tensor_qq(8) = fac * ( 2 * Tensor_rank_4(3,3,1,2) - Tensor_rank_4(1,1,1,2) - Tensor_rank_4(2,2,2,1) &
             - 3 * Tensor_rank_4(1,3,2,3) &
             + 2 * Tensor_rank_4(1,2,3,3) - Tensor_rank_4(1,2,1,1) - Tensor_rank_4(2,1,2,2) - 3 * Tensor_rank_4(2,3,1,3) )

! (1/sqrt(2)) * ( Q(22) + Q(2-2) )
  Sph_tensor_qq(9) = fac * ( Tensor_rank_4(3,3,1,1) - Tensor_rank_4(3,3,2,2) + Tensor_rank_4(1,1,3,3) - Tensor_rank_4(2,2,3,3) &
             + Tensor_rank_4(2,2,2,2) - Tensor_rank_4(1,1,1,1) + 3 * Tensor_rank_4(2,3,2,3) - 3 * Tensor_rank_4(1,3,1,3) )

! Tenseur 3 : octupole magnetique

  fac = 1 / sqrt(10._db)

! Q(30)
  Sph_tensor_qq(10) = - img * fac * ( Tensor_rank_4(1,2,1,1) - Tensor_rank_4(2,1,2,2) + 4 * Tensor_rank_4(1,3,2,3) &
           - Tensor_rank_4(1,1,1,2) + Tensor_rank_4(2,2,2,1) - 4 * Tensor_rank_4(2,3,1,3) )

  fac = 0.5_db / sqrt(15._db)

! (1/sqrt(2)) * ( Q(31) - Q(3-1) )
  Sph_tensor_qq(11) = - img *  fac * ( 6 * Tensor_rank_4(1,2,1,3) + 4 * Tensor_rank_4(3,3,2,3) - 5 * Tensor_rank_4(1,1,2,3) &
                      + Tensor_rank_4(2,2,2,3) &
                      - 6 * Tensor_rank_4(1,3,1,2) - 4 * Tensor_rank_4(2,3,3,3) + 5 * Tensor_rank_4(2,3,1,1) &
                      - Tensor_rank_4(2,3,2,2) )

! (1/sqrt(2)) * ( Q(31) + Q(3-1) )
  Sph_tensor_qq(12) = - img * fac * ( 6 * Tensor_rank_4(1,2,2,3) + 4 * Tensor_rank_4(3,3,1,3) - 5 * Tensor_rank_4(2,2,1,3) &
                      + Tensor_rank_4(1,1,1,3) &
                      - 6 * Tensor_rank_4(2,3,1,2) - 4 * Tensor_rank_4(1,3,3,3) + 5 * Tensor_rank_4(1,3,2,2) &
                       - Tensor_rank_4(1,3,1,1) )

  fac = 1 / sqrt(6._db)

! (1/sqrt(2)) * ( Q(32) - Q(3-2) )
  Sph_tensor_qq(13) = - img * fac * ( Tensor_rank_4(1,1,3,3) + Tensor_rank_4(2,2,1,1) + Tensor_rank_4(3,3,2,2) &
               - Tensor_rank_4(3,3,1,1) - Tensor_rank_4(1,1,2,2) - Tensor_rank_4(2,2,3,3) )

! (1/sqrt(2)) * ( Q(32) + Q(3-2) )
  Sph_tensor_qq(14) = - img * fac * ( 2 * Tensor_rank_4(1,2,3,3) - Tensor_rank_4(1,2,1,1) - Tensor_rank_4(1,2,2,2) &
           - 2 * Tensor_rank_4(3,3,1,2) + Tensor_rank_4(1,1,1,2) + Tensor_rank_4(2,2,1,2) )

  fac = 0.5_db

! (1/sqrt(2)) * ( Q(33) - Q(3-3) )
  Sph_tensor_qq(15) = - img * fac * ( Tensor_rank_4(2,3,1,1) - Tensor_rank_4(2,3,2,2) + 2 * Tensor_rank_4(1,3,1,2) &
           - Tensor_rank_4(1,1,2,3) + Tensor_rank_4(2,2,2,3) - 2 * Tensor_rank_4(1,2,1,3) )

! (1/sqrt(2)) * ( Q(33) + Q(3-3) )
  Sph_tensor_qq(16) = - img * fac * ( Tensor_rank_4(1,3,1,1) - Tensor_rank_4(1,3,2,2) + 2 * Tensor_rank_4(2,1,3,2) &
           - Tensor_rank_4(1,1,1,3) + Tensor_rank_4(2,2,1,3) - 2 * Tensor_rank_4(3,2,2,1) )

! Tenseur 4 : hexadecapole non magnetique

  fac = 1 / ( 2. * sqrt(70._db) )

! Q(40)
  Sph_tensor_qq(17) = fac * ( 3 * Tensor_rank_4(1,1,1,1) + 3 * Tensor_rank_4(2,2,2,2) &
           + 8 * Tensor_rank_4(3,3,3,3) + Tensor_rank_4(1,1,2,2) + Tensor_rank_4(2,2,1,1) - 4 * Tensor_rank_4(3,3,1,1) &
           - 4 * Tensor_rank_4(3,3,2,2) &
           - 4 * Tensor_rank_4(1,1,3,3) - 4 * Tensor_rank_4(2,2,3,3) + 4 * Tensor_rank_4(1,2,1,2) &
          - 16 * Tensor_rank_4(1,3,1,3) - 16 * Tensor_rank_4(2,3,2,3) )

  fac = 0.5_db / sqrt(7._db)

! (1/sqrt(2)) * ( Q(41) - Q(4-1) )
  Sph_tensor_qq(18) = fac * ( 3 * Tensor_rank_4(1,3,1,1) + Tensor_rank_4(1,3,2,2) - 4 * Tensor_rank_4(3,3,1,3) &
          + 2 * Tensor_rank_4(2,3,1,2) &
          + 3 * Tensor_rank_4(1,1,1,3) + Tensor_rank_4(2,2,1,3) - 4 * Tensor_rank_4(1,3,3,3) + 2 * Tensor_rank_4(1,2,2,3) )

! (1/sqrt(2)) * ( Q(41) + Q(4-1) )
  Sph_tensor_qq(19) = fac * ( 3 * Tensor_rank_4(2,3,2,2) + Tensor_rank_4(2,3,1,1) - 4 * Tensor_rank_4(2,3,3,3) &
          + 2 * Tensor_rank_4(1,3,1,2) &
          + 3 * Tensor_rank_4(2,2,2,3) + Tensor_rank_4(1,1,2,3) - 4 * Tensor_rank_4(3,3,2,3) + 2 * Tensor_rank_4(1,2,1,3) )

  fac = 0.5_db / sqrt(14._db)

! (1/sqrt(2)) * ( Q(42) - Q(4-2) )
  Sph_tensor_qq(20) = 2 * fac * ( 2 * Tensor_rank_4(3,3,1,2) - Tensor_rank_4(1,1,1,2) - Tensor_rank_4(2,2,2,1) &
          + 4 * Tensor_rank_4(1,3,2,3) &
          + 2 * Tensor_rank_4(1,2,3,3) - Tensor_rank_4(1,2,1,1) - Tensor_rank_4(2,1,2,2) + 4 * Tensor_rank_4(2,3,1,3) )

! (1/sqrt(2)) * ( Q(42) + Q(4-2) )
  Sph_tensor_qq(21) = fac * ( 2 * Tensor_rank_4(3,3,1,1) - 2 * Tensor_rank_4(3,3,2,2) + 2 * Tensor_rank_4(1,1,3,3) &
        - 2 * Tensor_rank_4(2,2,3,3) &
        - 2 * Tensor_rank_4(1,1,1,1) + 2 * Tensor_rank_4(2,2,2,2) + 8 * Tensor_rank_4(1,3,1,3) - 8 * Tensor_rank_4(2,3,2,3) )

  fac = 0.5_db

! (1/sqrt(2)) * ( Q(43) - Q(4-3) )
  Sph_tensor_qq(22) = fac * ( Tensor_rank_4(1,3,2,2) - Tensor_rank_4(1,3,1,1) + 2 * Tensor_rank_4(2,3,1,2) &
           + Tensor_rank_4(2,2,1,3) - Tensor_rank_4(1,1,1,3) + 2 * Tensor_rank_4(1,2,2,3) )

! (1/sqrt(2)) * ( Q(43) + Q(4-3) )
  Sph_tensor_qq(23) = fac * ( Tensor_rank_4(2,3,2,2) - Tensor_rank_4(2,3,1,1) - 2 * Tensor_rank_4(1,3,1,2) &
           + Tensor_rank_4(2,2,2,3) - Tensor_rank_4(1,1,2,3) - 2 * Tensor_rank_4(1,2,1,3) )

  fac = 1 / sqrt(2._db)

! (1/sqrt(2)) * ( Q(44) - Q(4-4) )
  Sph_tensor_qq(24) = fac * ( Tensor_rank_4(1,2,1,1) - Tensor_rank_4(1,2,2,2) + Tensor_rank_4(1,1,1,2) - Tensor_rank_4(2,2,1,2) )

! (1/sqrt(2)) * ( Q(44) + Q(4-4) )
  Sph_tensor_qq(25) = 0.5_db * fac * ( Tensor_rank_4(1,1,1,1) + Tensor_rank_4(2,2,2,2) - Tensor_rank_4(1,1,2,2) &
             - Tensor_rank_4(2,2,1,1) - 4 * Tensor_rank_4(1,2,1,2) )

  return
end

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

subroutine Sph_tensor_dm_cal(n_tens_dm,Tensor_rank_2,Sph_tensor_dm)

  use declarations
  implicit none
  
  integer:: n_tens_dm

  complex(kind=db), dimension(n_tens_dm):: Sph_tensor_dm
  complex(kind=db), dimension(3,3):: Tensor_rank_2

  real(kind=db):: fac
  
! Tenseur 0

  Sph_tensor_dm(1) = ( 1 / 3._db ) * ( Tensor_rank_2(1,1) + Tensor_rank_2(2,2) + Tensor_rank_2(3,3) )

! Tenseur 1
! Les composantes de ce tenseur sont en cas de seuil K : -lx, ly et lz.
  fac = 1 / 2._db

! Omega_z
  Sph_tensor_dm(2) = fac * ( Tensor_rank_2(1,2) - Tensor_rank_2(2,1) )

! Omega_x
  Sph_tensor_dm(3) = fac * ( Tensor_rank_2(2,3) - Tensor_rank_2(3,2) )

! Omega_y
  Sph_tensor_dm(4) = fac * ( Tensor_rank_2(3,1) - Tensor_rank_2(1,3) )

! Tenseur 2

! D02 = (1/sqrt(6))*(2*Dzz-Dxx-Dyy) = T_3z2-r2
  fac = 1 / 6._db
  Sph_tensor_dm(5) = fac * ( 2*Tensor_rank_2(3,3) - Tensor_rank_2(1,1)  - Tensor_rank_2(2,2) )

  fac = 1 / 2._db

! (-1/sqrt(2))*(D(12) - D(-12)) = T_xz
  Sph_tensor_dm(6) = fac * ( Tensor_rank_2(1,3) + Tensor_rank_2(3,1) )

! (i/sqrt(2))*(D(12) + D(-12)) = T_yz
  Sph_tensor_dm(7) = fac * ( Tensor_rank_2(2,3) + Tensor_rank_2(3,2) )

! (-i/sqrt(2))*(D(22) - D(-22)) = T_xy
  Sph_tensor_dm(8) = fac * ( Tensor_rank_2(1,2) + Tensor_rank_2(2,1) )

! (1/sqrt(2))*(D(22) + D(-22)) = T_x2-y2
  Sph_tensor_dm(9) = fac * ( Tensor_rank_2(1,1) - Tensor_rank_2(2,2) )

! Les tenseurs cartesiens sont definis par conjg(D).M, il faut conjg(M).D 
  Sph_tensor_dm(2:4) = - Sph_tensor_dm(2:4)
  Sph_tensor_dm(:) = Conjg( Sph_tensor_dm(:) ) 

  return
end

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

! Ecriture des tenseurs spheriques et de leur integrale

subroutine Write_Spherical_tensor(Abs_U_iso,Core_resolved,Volume_maille,E_cut,E1E1,E1E2,E1M1,E2E2,Energ,Ephseuil,Epsii, &
       Eseuil,First_E,Header,icheck,ie,Int_tens,jseuil,Magn_sens,n_tens_dd,n_tens_dm,n_tens_dq,n_tens_max,n_tens_qq, &
       natomsym,nenerg,ninit1,ninitr,nomfich_t,nseuil,numat_abs,Sph_tensor_ia_dd, &
       Sph_tensor_ia_dq,Sph_tensor_ia_dq_m,Sph_tensor_ia_dm,Sph_tensor_ia_dm_m,Sph_tensor_ia_qq,Surface_ref,V0muf)

  use declarations
  implicit none
  
  integer:: i, ia, ie, icheck, initr, j, jseuil, long, n_dim, n_header_info, n_tens, n_tens_dd, n_tens_dq, n_tens_max, &
      n_tens_dm, n_tens_qq, natomsym, nenerg, ninit1, ninitr, nseuil, numat_abs

  character(len=Length_word):: mot
  character(len=Length_name):: nomfich_t, File_out
  character(len=8), dimension(9):: Tens_name_D
  character(len=8), dimension(15):: Tens_name_I, Tens_name_I_m 
  character(len=8), dimension(25):: Tens_name_Q 
  character(len=8), dimension(9):: Tens_name_T, Tens_name_T_m 
  character(len=Length_word), dimension(n_tens_max*ninitr):: Title
  character(len=Length_name), dimension(:), allocatable:: Header_info

  complex(kind=db):: zero_c

  logical:: Core_resolved, E1E1, E1E2, E1M1, E2E2, First_E, Header, Magn_sens, New_file

  real(kind=db):: Abs_U_iso, de, Volume_maille, E_cut, Ephseuil, Eseuil, natomsym_f, Surface_ref, V0muf
  real(kind=db), dimension(n_tens_max*ninitr,0:natomsym):: Int_tens
  real(kind=db), dimension(n_tens_max*ninitr):: Int_tenst, Tens
  real(kind=db), dimension(nenerg):: Energ
  real(kind=db), dimension(ninitr):: Epsii
  real(kind=db), dimension(n_tens_dd,0:natomsym,ninitr):: Sph_tensor_ia_dd
  real(kind=db), dimension(n_tens_dq,0:natomsym,ninitr):: Sph_tensor_ia_dq, Sph_tensor_ia_dq_m 
  real(kind=db), dimension(n_tens_qq,0:natomsym,ninitr):: Sph_tensor_ia_qq
  real(kind=db), dimension(n_tens_dm,0:natomsym,ninitr):: Sph_tensor_ia_dm, Sph_tensor_ia_dm_m

  data Tens_name_D/ '  D(00) ','  lz_dd ','  lx_dd ','  ly_dd ','  D_z2  ','   D_xz ','  D_yz  ','  D_xy  ',' D_x2-y2'/
  data Tens_name_I/ '   I_z  ','   I_x  ','    I_y ','  I(20) ',' I(21)  ',' I(2-1) ','  I(22) ',' I(2-2) ', &
                    '  I(30) ',' I(31)  ',' I(3-1) ',' I(32)  ',' I(3-2) ','  I(33) ',' I(3-3) '/
  data Tens_name_I_m/ '  I_z_m ',' I_x_m  ','  I_y_m ',' I(20)_m',' I(21)_m','I(2-1)_m',' I(22)_m','I(2-2)_m', &
                      ' I(30)_m',' I(31)_m','I(3-1)_m',' I(32)_m','I(3-2)_m',' I(33)_m','I(3-3)_m'/
  data Tens_name_Q/ '  Q(00) ','  lz_qq ','  lx_qq ','  ly_qq ','  Q(20) ','  Q(21) ',' Q(2-1) ','  Q(22) ',' Q(2-2) ', &
                    '  Q(30) ','  Q(31) ',' Q(3-1) ','  Q(32) ',' Q(3-2) ','  Q(33) ',' Q(3-3) ','  Q(40) ','  Q(41) ', &
                    ' Q(4-1) ','  Q(42) ',' Q(4-2) ','  Q(43) ',' Q(4-3) ','  Q(44) ',' Q(4-4) '/
  data Tens_name_T/   '  T(00) ','  T_z   ','   T_x  ','    T_y ','  T_z2  ','  T_xz  ','  T_yz  ','  T_yz  ','T_x2-y2 '/
  data Tens_name_T_m/ ' T(00)_m','  T_z_m ','  T_x_m ','  T_y_m ',' T_z2_m ',' T_xz_m ',' T_yz_m ',' T_yz_m ','Tx2-y2_m'/

  n_header_info = 0
  allocate( Header_info(n_header_info) )
  
  zero_c = (0._db, 0._db)

  do ia = 0,natomsym
 
    if( natomsym == 1 .and. ia == 0 ) cycle
    if( icheck <= 1 .and. ia > 1 ) exit
    
    j = 0
     
    do initr = 1,ninitr
  
      if( E1E1 ) then
        do i = 1,n_tens_dd
          j = j + 1
          select case(i)
            case(1)
! On divise la premiere composante du tenseur spherique par rac(3) (premiere composante du tenseur de polarisation) pour obtenir le
! terme de diffusion isotrope
              Tens(j) = Sph_tensor_ia_dd(i,ia,initr)
            case(2,3,4)
! On divise les composantes 2, 3 et 4 du tenseur spherique par rac(2) (composantes du tenseur de polarisation) pour obtenir le
! moment magnetique
              Tens(j) = Sph_tensor_ia_dd(i,ia,initr)
            case default
              Tens(j) = Sph_tensor_ia_dd(i,ia,initr)
          end select
          mot = Tens_name_D(i) 
          if( ninitr > 1 ) call ad_sufix(Core_resolved,initr,jseuil,Length_word,mot,nseuil)
          Title(j) = mot
        end do 
      endif

      if( E1E2 ) then
        do i = 1,n_tens_dq
          j = j + 1
          Tens(j) = Sph_tensor_ia_dq(i,ia,initr)
          mot = Tens_name_I(i) 
          if( ninitr > 1 ) call ad_sufix(Core_resolved,initr,jseuil,Length_word,mot,nseuil)
          Title(j) = mot
          if( Magn_sens ) then
            j = j+1
            Tens(j) = Sph_tensor_ia_dq_m(i,ia,initr)
            mot = Tens_name_I_m(i) 
            if( ninitr > 1 ) call ad_sufix(Core_resolved,initr,jseuil,Length_word,mot,nseuil)
            Title(j) = mot
          endif
        end do 
      endif
    
      if( E2E2 ) then
        do i = 1,n_tens_qq
          j = j + 1
          select case(i)
            case(1)
! On divise la premiere composante du tenseur spherique par rac(3) (premiere composante du tenseur de polarisation) pour obtenir le
! terme de diffusion isotrope
              Tens(j) = Sph_tensor_ia_qq(i,ia,initr)
            case(2,3,4)
! On divise les composantes 2, 3 et 4 du tenseur spherique par rac(2) (composantes du tenseur de polarisation) pour obtenir le
! moment magnetique
              Tens(j) = Sph_tensor_ia_qq(i,ia,initr)
            case default
              Tens(j) = Sph_tensor_ia_qq(i,ia,initr)
          end select
          mot = Tens_name_Q(i) 
          if( ninitr > 1 ) call ad_sufix(Core_resolved,initr,jseuil,Length_word,mot,nseuil)
          Title(j) = mot
       end do 
      endif

      if( E1M1 ) then
        do i = 1,n_tens_dm
          j = j + 1
          Tens(j) = Sph_tensor_ia_dm(i,ia,initr)
          mot = Tens_name_T(i) 
          if( ninitr > 1 ) call ad_sufix(Core_resolved,initr,jseuil,Length_word,mot,nseuil)
          Title(j) = mot
          if( Magn_sens ) then
            j = j+1
            Tens(j) = Sph_tensor_ia_dm_m(i,ia,initr)
            mot = Tens_name_T_m(i) 
            if( ninitr > 1 ) call ad_sufix(Core_resolved,initr,jseuil,Length_word,mot,nseuil)
            Title(j) = mot
          endif
        end do 
      endif
     
    end do

    n_tens = j
    
    File_out = nomfich_t
    long = len_trim(File_out)
    File_out(long+1:long+4) = '_sph'
    if( ia > 0 ) then
      File_out(long+5:long+9) = '_atom'
      call ad_number(ia,File_out,Length_name)
    else
      File_out(long+5:long+9) = '_xtal'
    endif
    long = len_trim(File_out)
    File_out(long+1:long+4) = '.txt'
    
    n_dim = n_tens_max * ninitr 

    New_file = First_E

    if( First_E ) then
           
      if( Header ) then
        call Write_Header(File_out,Header_info,n_header_info)
        New_file = .false.
      endif

      Zero_c = (0._db, 0._db)
      natomsym_f = 0._db

      call Write_first_out(Abs_U_iso,Core_resolved,Zero_c,File_out,E_cut,Epsii,Eseuil,.false., &
          jseuil,New_file,ninit1,ninitr,nseuil,numat_abs,V0muf,natomsym_f,Surface_ref,Volume_maille)

    endif

    call Write_out_stand(Ephseuil,File_out,First_E,n_dim,n_tens,New_file,Title,4,Tens)

    if( nenerg == 1 ) cycle

! Integrale
  
    File_out = nomfich_t
    long = len_trim(File_out)
    File_out(long+1:long+4) = '_sph'
    if( ia > 0 ) then
      File_out(long+5:long+9) = '_atom'
      call ad_number(ia,File_out,Length_name)
    else
      File_out(long+5:long+9) = '_xtal'
    endif
    long = len_trim(File_out)
    File_out(long+1:long+8) = '_int.txt'

    if( First_E ) then
      do i = 1,n_tens
        mot = Title(i)
        mot = adjustl( mot )
        long = len_trim( mot )
        if( long < Length_word - 2 ) then
          mot(1:Length_word) = 'I_' // mot(1:Length_word-2)
        elseif( long == Length_word - 2 ) then
          mot(1:Length_word-1) = 'I' // mot(1:Length_word-1)
        endif
        Title(i) = mot
      end do
      de = Energ(ie+1) - Energ(ie)
      Int_tens(1:n_tens,ia) = de * Tens(1:n_tens)
    else
      if( ie == nenerg ) then
        de = Energ(ie) - Energ(ie-1)
      else
        de = 0.5_db * ( Energ(ie+1) -  Energ(ie-1) )
      endif
      Int_tens(1:n_tens,ia) = Int_tens(1:n_tens,ia) + de * Tens(1:n_tens)
    endif

    Int_tenst(1:n_tens) = Int_tens(1:n_tens,ia)

    n_dim = n_tens_max * ninitr 

    New_file = First_E

    if( First_E ) then
           
      if( Header ) then
        call Write_Header(File_out,Header_info,n_header_info)
        New_file = .false.
      endif

      call Write_first_out(Abs_U_iso,Core_resolved,Zero_c,File_out,E_cut,Epsii,Eseuil,.false., &
          jseuil,New_file,ninit1,ninitr,nseuil,numat_abs,V0muf,natomsym_f,Surface_ref,Volume_maille)

    endif

    call Write_out_stand(Ephseuil,File_out,First_E,n_dim,n_tens,New_file,Title,4,Int_tenst)

  end do

  deallocate( Header_info )
  
  return
end

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

subroutine Tensor_pol_dd_cal(ipl,n_tens_dd,nplt,pe,ps,Tensor_pol_dd)

  use declarations
  implicit none
  
  integer:: ipl, n_tens_dd, nplt

  complex(kind=db) Px, Py, Pz, Qx, Qy, Qz
  complex(kind=db), dimension(3):: pe, ps
  complex(kind=db), dimension(n_tens_dd):: Tens
  complex(kind=db), dimension(0:nplt,n_tens_dd):: Tensor_pol_dd

  Px = Pe(1); Qx = conjg( Ps(1) )
  Py = Pe(2); Qy = conjg( Ps(2) )
  Pz = Pe(3); Qz = conjg( Ps(3) )

  Tens(1) = ( Qx*Px + Qy*Py + Qz*Pz )

  Tens(2) = - img * ( Qx*Py - Qy*Px )

  Tens(3) = - img * ( Qy*Pz - Qz*Py )

  Tens(4) = - img * ( Qz*Px - Qx*Pz )

  Tens(5) = ( 2*Qz*Pz - Qx*Px - Qy*Py )

  Tens(6) = ( Qx*Pz + Qz*Px )

  Tens(7) = ( Qy*Pz + Qz*Py )

  Tens(8) = ( Qx*Py + Qy*Px )

  Tens(9) = ( Qx*Px - Qy*Py )

  Tensor_pol_dd(ipl,:) = Tens(:)

  return
end

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

subroutine Tensor_pol_dq_cal(ipl,n_tens_dq,nplt,pe,ps,ve,vs,Tensor_pol_dq)

  use declarations
  implicit none

  integer:: i, ipl, j, n_tens_dq, nplt
  
  complex(kind=db) Px, Py, Pz, Qx, Qy, Qz
  complex(kind=db), dimension(3):: pe, ps
  complex(kind=db), dimension(2*n_tens_dq):: Tens
  complex(kind=db), dimension(0:nplt,2*n_tens_dq):: Tensor_pol_dq

  real(kind=db):: fac, Vx, Vy, Vz, Wx, Wy, Wz
  
  real(kind=db), dimension(3):: ve, vs

  Px = Pe(1); Qx = conjg( Ps(1) )
  Py = Pe(2); Qy = conjg( Ps(2) )
  Pz = Pe(3); Qz = conjg( Ps(3) )

  Vx = Ve(1); Wx = Vs(1)
  Vy = Ve(2); Wy = Vs(2)
  Vz = Ve(3); Wz = Vs(3)

  Tens(:) = 0._db

  j = 0

  do i = 1,2

    if( i == 2 ) then
      Wx = - Wx; Wy = - Wy; Wz = - Wz
      j = n_tens_dq
    endif

! T(10)
    Tens(j+1) = ( 2*Qz*Pz + 1.5_db*Qx*Px + 1.5_db*Qy*Py ) * ( Vz - Wz ) &
              + ( 1.5_db*Qx*Pz - Qz*Px ) * Vx - ( 1.5_db*Qz*Px - Qx*Pz ) * Wx &
              + ( 1.5_db*Qy*Pz - Qz*Py ) * Vy - ( 1.5_db*Qz*Py - Qy*Pz ) * Wy

! (T(11)
    Tens(j+2) = ( 2*Qx*Px + 1.5_db*Qy*Py + 1.5_db*Qz*Pz ) * ( Vx - Wx ) &
              + ( 1.5_db*Qy*Px - Qx*Py ) * Vy - ( 1.5_db*Qx*Py - Qy*Px ) * Wy &
              + ( 1.5_db*Qz*Px - Qx*Pz ) * Vz - ( 1.5_db*Qx*Pz - Qz*Px ) * Wz

! T(1-1)
    Tens(j+3) = ( 2*Qy*Py + 1.5_db*Qx*Px + 1.5_db*Qz*Pz ) * ( Vy - Wy ) &
              + ( 1.5*Qx*Py - Qy*Px ) * Vx - ( 1.5_db*Qy*Px - Qx*Py ) * Wx &
              + ( 1.5*Qz*Py - Qy*Pz ) * Vz - ( 1.5_db*Qy*Pz - Qz*Py ) * Wz

! T(20)
    Tens(j+4) = 0.5_db * ( ( Qx*Py - Qy*Px ) * ( Vz + Wz ) - Qy*Pz*Vx + Qz*Py*Wx + Qx*Pz*Vy - Qz*Px*Wy )

    fac = 0.5_db

! (T(21)-T(2-1))/sqrt(2)
    Tens(j+5) = fac * ( ( Qz*Pz - Qx*Px ) * ( Vy - Wy ) + ( Qz*Py - 2*Qy*Pz ) * Vz - ( Qy*Pz - 2*Qz*Py ) * Wz &
            + ( 2*Qy*Px - Qx*Py ) * Vx - ( 2*Qx*Py - Qy*Px ) * Wx )

! (T(21)+T(2-1))/sqrt(2)
    Tens(j+6) = fac * ( ( Qz*Pz - Qy*Py ) * ( Vx - Wx ) + ( Qz*Px - 2*Qx*Pz ) * Vz - ( Qx*Pz - 2*Qz*Px ) * Wz &
            + ( 2*Qx*Py - Qy*Px ) * Vy - ( 2*Qy*Px - Qx*Py ) * Wy )

! (T(22)-T(2-2))/sqrt(2)
    Tens(j+7) = fac * ( ( Qx*Px - Qy*Py ) * ( Vz - Wz ) + ( Qx*Pz - 2*Qz*Px ) * Vx - ( Qz*Px - 2*Qx*Pz ) * Wx &
            + ( 2*Qz*Py - Qy*Pz ) * Vy - ( 2*Qy*Pz - Qz*Py ) * Wy )

! (T(22)+T(2-2))/sqrt(2)
    Tens(j+8) = fac * ( ( Qx*Py + Qy*Px ) * ( Vz - Wz ) + ( Qx*Pz - 2*Qz*Px ) * Vy - ( Qz*Px - 2*Qx*Pz ) * Wy &
            - ( 2*Qz*Py - Qy*Pz ) * Vx + ( 2*Qy*Pz - Qz*Py ) * Wx )

! T(30)
    Tens(j+9) = ( 1 / sqrt(10._db) ) * ( ( 2*Qz*Pz - Qx*Px - Qy*Py ) * ( Vz - Wz ) - ( Qx*Pz + Qz*Px ) * ( Vx - Wx ) &
                      - ( Qy*Pz + Qz*Py ) * ( Vy - Wy ) )

    fac = 1 / sqrt( 60._db )

! (T(31)-T(3-1))/sqrt(2)
    Tens(j+10) = fac * ( ( 3*Qx*Px + Qy*Py - 4*Qz*Pz ) * ( Vx - Wx ) + ( Qx*Py + Qy*Px ) * ( Vy - Wy ) &
                    - 4 * ( Qx*Pz + Qz*Px ) * ( Vz - Wz ) )

! (T(31)+T(3-1))/sqrt(2)
    Tens(j+11) = fac * ( ( 3*Qy*Py + Qx*Px - 4*Qz*Pz ) * ( Vy - Wy ) + ( Qx*Py + Qy*Px ) * ( Vx - Wx ) &
                    - 4 * ( Qy*Pz + Qz*Py ) * ( Vz - Wz ) )

    fac = 1 / sqrt( 6._db )

! (T(32)-T(3-2))/sqrt(2)
    Tens(j+12) = fac * ( ( Qx*Py + Qy*Px ) * ( Vz - Wz ) + ( Qx*Pz + Qz*Px ) * ( Vy - Wy ) &
                             + ( Qy*Pz + Qz*Py ) * ( Vx - Wx ) )

! (T(32)+T(3-2))/sqrt(2)
    Tens(j+13) = fac  * ( ( Qx*Px - Qy*Py ) * ( Vz - Wz ) + ( Qx*Pz + Qz*Px ) * ( Vx - Wx ) &
                        - ( Qy*Pz + Qz*Py ) * ( Vy - Wy ) )

! (T(33)-T(3-3))/sqrt(2)
    Tens(j+14) = 0.5_db * ( ( Qy*Py - Qx*Px ) * ( Vx - Wx ) + ( Qy*Px + Qx*Py ) * ( Vy - Wy ) )

! (T(33)+T(3-3))/sqrt(2)
    Tens(j+15) = 0.5_db * ( ( Qy*Py - Qx*Px ) * ( Vy - Wy ) - ( Qy*Px + Qx*Py ) * ( Vx - Wx ) )

  end do

  Tensor_pol_dq(ipl,:) = Tens(:)

  return
end

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

subroutine Tensor_pol_qq_cal(ipl,n_tens_qq,nplt,pe,ps,ve,vs, Tensor_pol_qq)

  use declarations
  implicit none
  
  integer:: ipl, n_tens_qq, nplt

  complex(kind=db) Px, Py, Pz, Qx, Qy, Qz
  complex(kind=db), dimension(3):: pe, ps
  complex(kind=db), dimension(n_tens_qq):: Tens
  complex(kind=db), dimension(0:nplt,n_tens_qq):: Tensor_pol_qq

  real(kind=db):: fac, Vx, Vy, Vz, Wx, Wy, Wz
  
  real(kind=db), dimension(3):: ve, vs

  Px = Pe(1); Qx = conjg( Ps(1) )
  Py = Pe(2); Qy = conjg( Ps(2) )
  Pz = Pe(3); Qz = conjg( Ps(3) )

  Vx = Ve(1); Wx = Vs(1)
  Vy = Ve(2); Wy = Vs(2)
  Vz = Ve(3); Wz = Vs(3)

! Scalaire

  Tens(1) = 1.5_db * ( Qx*Wz*Px*Vz + Qx*Wz*Pz*Vx + Qz*Wx*Px*Vz + Qz*Wx*Pz*Vx + Qy*Wz*Py*Vz + Qy*Wz*Pz*Vy &
                     + Qz*Wy*Py*Vz + Qz*Wy*Pz*Vy + Qx*Wy*Px*Vy + Qx*Wy*Py*Vx + Qy*Wx*Px*Vy + Qy*Wx*Py*Vx ) &
          + 2 * ( Qx*Wx*Px*Vx + Qy*Wy*Py*Vy + Qz*Wz*Pz*Vz ) &
          - ( Qx*Wx*Py*Vy + Qy*Wy*Px*Vx + Qx*Wx*Pz*Vz + Qz*Wz*Px*Vx + Qy*Wy*Pz*Vz + Qz*Wz*Py*Vy )

! Dipole magnetique

  Tens(2) = img * ( Qy*Wy*Px*Vy + Qy*Wy*Py*Vx + Qx*Wy*Px*Vx + Qy*Wx*Px*Vx &
                  - Qx*Wy*Py*Vy - Qy*Wx*Py*Vy - Qx*Wx*Px*Vy - Qx*Wx*Py*Vx ) &
          + 0.5_db * img * ( Qy*Wz*Px*Vz + Qy*Wz*Pz*Vx + Qz*Wy*Px*Vz + Qz*Wy*Pz*Vx &
                           - Qx*Wz*Py*Vz - Qx*Wz*Pz*Vy - Qz*Wx*Py*Vz - Qz*Wx*Pz*Vy )

  Tens(3) = img * ( Qz*Wz*Py*Vz + Qz*Wz*Pz*Vy + Qy*Wz*Py*Vy + Qz*Wy*Py*Vy &
                  - Qy*Wz*Pz*Vz - Qz*Wy*Pz*Vz - Qy*Wy*Py*Vz - Qy*Wy*Pz*Vy ) &
          + 0.5_db * img * ( Qx*Wz*Px*Vy + Qx*Wz*Py*Vx + Qz*Wx*Px*Vy + Qz*Wx*Py*Vx &
                           - Qx*Wy*Px*Vz - Qx*Wy*Pz*Vx - Qy*Wx*Px*Vz - Qy*Wx*Pz*Vx )

  Tens(4) = - img * ( Qz*Wz*Px*Vz + Qz*Wz*Pz*Vx + Qx*Wz*Px*Vx + Qz*Wx*Px*Vx &
                    - Qx*Wx*Px*Vz - Qx*Wx*Pz*Vx - Qx*Wz*Pz*Vz - Qz*Wx*Pz*Vz ) &
          + 0.5_db * img * ( Qx*Wy*Py*Vz + Qx*Wy*Pz*Vy + Qy*Wx*Py*Vz + Qy*Wx*Pz*Vy &
                           - Qy*Wz*Px*Vy - Qy*Wz*Py*Vx - Qz*Wy*Px*Vy - Qz*Wy*Py*Vx )

! Quadrupole non-magnetique

  fac = 1 / ( 3 * sqrt(14._db) )

  Tens(5) = 3 * fac * ( Qx*Wy*Px*Vy + Qx*Wy*Py*Vx + Qy*Wx*Px*Vy + Qy*Wx*Py*Vx ) - 1.5_db * fac &
     * ( Qx*Wz*Px*Vz + Qx*Wz*Pz*Vx + Qz*Wx*Px*Vz + Qz*Wx*Pz*Vx + Qy*Wz*Py*Vz + Qy*Wz*Pz*Vy + Qz*Wy*Py*Vz + Qz*Wy*Pz*Vy ) &
          + 2 * fac * ( Qx*Wx*Px*Vx + Qy*Wy*Py*Vy + Qx*Wx*Pz*Vz + Qz*Wz*Px*Vx + Qy*Wy*Pz*Vz + Qz*Wz*Py*Vy) - 4 * fac &
     * ( Qx*Wx*Py*Vy + Qy*Wy*Px*Vx + Qz*Wz*Pz*Vz )

  fac = 1 / sqrt( 42._db )

  Tens(6) = 1.5_db * fac * ( Qy*Wz*Px*Vy + Qz*Wy*Px*Vy + Qy*Wz*Py*Vx + Qz*Wy*Py*Vx &
       + Qx*Wy*Py*Vz + Qx*Wy*Pz*Vy + Qy*Wx*Py*Vz + Qy*Wx*Pz*Vy ) + fac &
     * ( Qz*Wz*Px*Vz + Qz*Wz*Pz*Vx + Qx*Wx*Px*Vz + Qx*Wx*Pz*Vx + Qx*Wz*Pz*Vz + Qz*Wx*Pz*Vz + Qx*Wz*Px*Vx + Qz*Wx*Px*Vx ) &
          - 2 * fac * ( Qy*Wy*Px*Vz + Qy*Wy*Pz*Vx + Qx*Wz*Py*Vy + Qz*Wx*Py*Vy )

  Tens(7) = 1.5_db * fac * ( Qx*Wz*Px*Vy + Qx*Wz*Py*Vx + Qz*Wx*Px*Vy + Qz*Wx*Py*Vx &
       + Qx*Wy*Px*Vz + Qx*Wy*Pz*Vx + Qy*Wx*Px*Vz + Qy*Wx*Pz*Vx ) + fac  &
     * ( Qz*Wz*Py*Vz + Qz*Wz*Pz*Vy + Qy*Wy*Py*Vz + Qy*Wy*Pz*Vy + Qy*Wz*Pz*Vz + Qz*Wy*Pz*Vz + Qy*Wz*Py*Vy + Qz*Wy*Py*Vy ) &
          - 2 * fac * ( Qx*Wx*Py*Vz + Qx*Wx*Pz*Vy + Qy*Wz*Px*Vx + Qz*Wy*Px*Vx )

  fac = 1 / sqrt( 42._db )

  Tens(8) = - fac * ( Qx*Wx*Px*Vy + Qx*Wx*Py*Vx + Qy*Wy*Px*Vy + Qy*Wy*Py*Vx &
       + Qx*Wy*Px*Vx + Qy*Wx*Px*Vx + Qx*Wy*Py*Vy + Qy*Wx*Py*Vy ) + 2 * fac &
     * ( Qz*Wz*Px*Vy + Qz*Wz*Py*Vx + Qx*Wy*Pz*Vz + Qy*Wx*Pz*Vz ) - 1.5_db * fac &
     * ( Qx*Wz*Py*Vz + Qx*Wz*Pz*Vy + Qz*Wx*Py*Vz + Qz*Wx*Pz*Vy + Qy*Wz*Px*Vz + Qy*Wz*Pz*Vx + Qz*Wy*Px*Vz + Qz*Wy*Pz*Vx )

  Tens(9) = 2 * fac * ( Qz*Wz*Px*Vx - Qz*Wz*Py*Vy + Qx*Wx*Pz*Vz - Qy*Wy*Pz*Vz + Qy*Wy*Py*Vy - Qx*Wx*Px*Vx ) + 1.5_db * fac &
     * ( Qy*Wz*Py*Vz + Qy*Wz*Pz*Vy + Qz*Wy*Py*Vz + Qz*Wy*Pz*Vy - Qx*Wz*Px*Vz - Qx*Wz*Pz*Vx - Qz*Wx*Px*Vz - Qz*Wx*Pz*Vx )

! Octupole magnetique

  fac = 1 / sqrt( 10._db )

  Tens(10) = 0.5_db * fac * img * ( Qx*Wy*Px*Vx - Qx*Wy*Py*Vy + Qy*Wx*Px*Vx - Qy*Wx*Py*Vy &
       - Qx*Wx*Px*Vy + Qy*Wy*Px*Vy - Qx*Wx*Py*Vx + Qy*Wy*Py*Vx ) + fac * img &
     * ( Qx*Wz*Py*Vz + Qx*Wz*Pz*Vy + Qz*Wx*Py*Vz + Qz*Wx*Pz*Vy - Qy*Wz*Px*Vz - Qz*Wy*Px*Vz - Qy*Wz*Pz*Vx - Qz*Wy*Pz*Vx )

  fac = 1 / ( 4 * sqrt( 15._db ) )

  Tens(11) = 3 * fac * img * ( Qx*Wy*Px*Vz + Qx*Wy*Pz*Vx + Qy*Wx*Px*Vz + Qy*Wx*Pz*Vx &
       - Qx*Wz*Px*Vy - Qx*Wz*Py*Vx - Qz*Wx*Px*Vy - Qz*Wx*Py*Vx ) + 4 * fac * img &
     * ( Qz*Wz*Py*Vz + Qz*Wz*Pz*Vy - Qy*Wz*Pz*Vz - Qz*Wy*Pz*Vz ) + 5 * fac * img &
     * ( Qy*Wz*Px*Vx + Qz*Wy*Px*Vx - Qx*Wx*Py*Vz - Qx*Wx*Pz*Vy ) + fac * img &
     * ( Qy*Wy*Py*Vz + Qy*Wy*Pz*Vy - Qy*Wz*Py*Vy - Qz*Wy*Py*Vy )

  Tens(12) = 3 * fac * img * ( Qx*Wy*Py*Vz + Qx*Wy*Pz*Vy + Qy*Wx*Py*Vz + Qy*Wx*Pz*Vy &
       - Qy*Wz*Px*Vy - Qy*Wz*Py*Vx - Qz*Wy*Px*Vy - Qz*Wy*Py*Vx ) + 4 * fac * img &
     * ( Qz*Wz*Px*Vz + Qz*Wz*Pz*Vx - Qx*Wz*Pz*Vz - Qz*Wx*Pz*Vz ) + 5 * fac * img &
     * ( Qx*Wz*Py*Vy + Qz*Wx*Py*Vy - Qy*Wy*Px*Vz - Qy*Wy*Pz*Vx ) + fac * img &
     * ( Qx*Wx*Px*Vz + Qx*Wx*Pz*Vx - Qx*Wz*Px*Vx - Qz*Wx*Px*Vx )

  fac = 1 / sqrt( 6._db )

  Tens(13) = fac * img * ( Qx*Wx*Pz*Vz - Qz*Wz*Px*Vx + Qy*Wy*Px*Vx - Qx*Wx*Py*Vy + Qz*Wz*Py*Vy - Qy*Wy*Pz*Vz )

  Tens(14) = fac * img * ( Qx*Wy*Pz*Vz + Qy*Wx*Pz*Vz - Qz*Wz*Px*Vy - Qz*Wz*Py*Vx ) + 0.5 * fac * img &
     * ( Qx*Wx*Px*Vy + Qx*Wx*Py*Vx + Qy*Wy*Px*Vy + Qy*Wy*Py*Vx - Qx*Wy*Px*Vx - Qy*Wx*Px*Vx - Qx*Wy*Py*Vy - Qy*Wx*Py*Vy )

  fac = 0.25_db

  Tens(15) = fac * img * ( Qy*Wz*Px*Vx - Qy*Wz*Py*Vy + Qz*Wy*Px*Vx - Qz*Wy*Py*Vy &
       + Qx*Wz*Px*Vy + Qx*Wz*Py*Vx + Qz*Wx*Px*Vy + Qz*Wx*Py*Vx - Qx*Wx*Py*Vz + Qy*Wy*Py*Vz - Qx*Wx*Pz*Vy + Qy*Wy*Pz*Vy &
       - Qx*Wy*Px*Vz - Qy*Wx*Px*Vz - Qx*Wy*Pz*Vx - Qy*Wx*Pz*Vx )

  Tens(16) = fac * img * ( Qx*Wz*Px*Vx - Qx*Wz*Py*Vy + Qz*Wx*Px*Vx - Qz*Wx*Py*Vy &
       - Qy*Wz*Px*Vy - Qy*Wz*Py*Vx - Qz*Wy*Px*Vy - Qz*Wy*Py*Vx - Qx*Wx*Px*Vz + Qy*Wy*Px*Vz - Qx*Wx*Pz*Vx + Qy*Wy*Pz*Vx &
       + Qx*Wy*Py*Vz + Qy*Wx*Py*Vz + Qx*Wy*Pz*Vy + Qy*Wx*Pz*Vy )

! Hexadecapole non-magnetique

  fac = 1 / ( 2 * sqrt( 70._db ) )

  Tens(17) = 3 * fac * ( Qx*Wx*Px*Vx + Qy*Wy*Py*Vy ) + fac * ( Qx*Wx*Py*Vy + Qy*Wy*Px*Vx + Qx*Wy*Px*Vy + Qx*Wy*Py*Vx &
       + Qy*Wx*Px*Vy + Qy*Wx*Py*Vx ) + 8 * fac * Qz*Wz*Pz*Vz - 4 * fac &
     * ( Qz*Wz*Px*Vx + Qz*Wz*Py*Vy + Qx*Wx*Pz*Vz + Qy*Wy*Pz*Vz + Qx*Wz*Px*Vz + Qx*Wz*Pz*Vx + Qz*Wx*Px*Vz + Qz*Wx*Pz*Vx &
       + Qy*Wz*Py*Vz + Qy*Wz*Pz*Vy + Qz*Wy*Py*Vz + Qz*Wy*Pz*Vy )

  fac = 1 / ( 4 * sqrt( 7._db ) )

  Tens(18) = 3 * fac * ( Qx*Wz*Px*Vx + Qz*Wx*Px*Vx + Qx*Wx*Px*Vz + Qx*Wx*Pz*Vx ) + fac &
     * ( Qx*Wz*Py*Vy + Qz*Wx*Py*Vy + Qy*Wy*Px*Vz + Qy*Wy*Pz*Vx + Qy*Wz*Px*Vy + Qy*Wz*Py*Vx + Qz*Wy*Px*Vy + Qz*Wy*Py*Vx &
       + Qy*Wx*Pz*Vy + Qx*Wy*Pz*Vy + Qx*Wy*Py*Vz + Qy*Wx*Py*Vz ) - 4 * fac &
     * ( Qz*Wz*Px*Vz + Qz*Wz*Pz*Vx + Qx*Wz*Pz*Vz + Qz*Wx*Pz*Vz )

  Tens(19) = 3 * fac * ( Qy*Wz*Py*Vy + Qz*Wy*Py*Vy + Qy*Wy*Py*Vz + Qy*Wy*Pz*Vy ) + fac &
     * ( Qy*Wz*Px*Vx + Qz*Wy*Px*Vx + Qx*Wx*Py*Vz + Qx*Wx*Pz*Vy + Qx*Wz*Px*Vy + Qx*Wz*Py*Vx + Qz*Wx*Px*Vy + Qz*Wx*Py*Vx &
       + Qx*Wy*Px*Vz + Qx*Wy*Pz*Vx + Qy*Wx*Px*Vz + Qy*Wx*Pz*Vx ) - 4 * fac &
     * ( Qy*Wz*Pz*Vz + Qz*Wy*Pz*Vz + Qz*Wz*Pz*Vy + Qz*Wz*Py*Vz )

  fac = 1 / sqrt( 14._db )

  Tens(20) = fac * ( Qz*Wz*Px*Vy + Qz*Wz*Py*Vx + Qx*Wy*Pz*Vz + Qy*Wx*Pz*Vz &
       + Qx*Wz*Py*Vz + Qx*Wz*Pz*Vy + Qz*Wx*Py*Vz + Qz*Wx*Pz*Vy + Qy*Wz*Px*Vz + Qy*Wz*Pz*Vx + Qz*Wy*Px*Vz + Qz*Wy*Pz*Vx ) &
           - 0.5_db * fac * ( Qx*Wx*Px*Vy + Qx*Wx*Py*Vx + Qy*Wy*Px*Vy + Qy*Wy*Py*Vx &
       + Qx*Wy*Px*Vx + Qy*Wx*Px*Vx + Qx*Wy*Py*Vy + Qy*Wx*Py*Vy )

  Tens(21) = fac * ( Qz*Wz*Px*Vx - Qz*Wz*Py*Vy - Qx*Wx*Px*Vx + Qy*Wy*Py*Vy &
       + Qx*Wx*Pz*Vz - Qy*Wy*Pz*Vz + Qx*Wz*Px*Vz + Qx*Wz*Pz*Vx + Qz*Wx*Px*Vz + Qz*Wx*Pz*Vx - Qy*Wz*Py*Vz - Qy*Wz*Pz*Vy &
       - Qz*Wy*Py*Vz - Qz*Wy*Pz*Vy )

  fac = 0.25_db

  Tens(22) = - fac * ( Qx*Wz*Px*Vx - Qx*Wz*Py*Vy + Qz*Wx*Px*Vx - Qz*Wx*Py*Vy &
       - Qy*Wz*Py*Vx - Qy*Wz*Px*Vy - Qz*Wy*Py*Vx - Qz*Wy*Px*Vy - Qx*Wy*Pz*Vy + Qx*Wx*Px*Vz - Qy*Wy*Px*Vz + Qx*Wx*Pz*Vx &
       - Qy*Wy*Pz*Vx - Qy*Wx*Py*Vz - Qx*Wy*Py*Vz - Qy*Wx*Pz*Vy )

  Tens(23) = - fac * ( Qy*Wz*Px*Vx - Qy*Wz*Py*Vy + Qz*Wy*Px*Vx - Qz*Wy*Py*Vy &
       + Qx*Wz*Px*Vy + Qx*Wz*Py*Vx + Qz*Wx*Px*Vy + Qz*Wx*Py*Vx + Qy*Wx*Pz*Vx + Qx*Wx*Py*Vz - Qy*Wy*Py*Vz + Qx*Wx*Pz*Vy &
       - Qy*Wy*Pz*Vy + Qx*Wy*Px*Vz + Qy*Wx*Px*Vz + Qx*Wy*Pz*Vx )

  fac = 1 / ( 2 * sqrt( 2._db ) )

  Tens(24) = fac * ( Qx*Wy*Px*Vx - Qx*Wy*Py*Vy + Qy*Wx*Px*Vx - Qy*Wx*Py*Vy &
       + Qx*Wx*Px*Vy + Qx*Wx*Py*Vx - Qy*Wy*Px*Vy - Qy*Wy*Py*Vx )

  Tens(25) = fac * ( Qx*Wx*Px*Vx + Qy*Wy*Py*Vy - Qx*Wx*Py*Vy - Qy*Wy*Px*Vx &
       - Qx*Wy*Px*Vy - Qx*Wy*Py*Vx - Qy*Wx*Px*Vy - Qy*Wx*Py*Vx )

  Tensor_pol_qq(ipl,:) = Tens(:)

  return
end

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

subroutine Tensor_pol_dm_cal(ipl,n_tens_dm,nplt,Pl_i,Pl_s,Vo_i,Vo_s,Tensor_pol_dm)

  use declarations
  implicit none
  
  integer:: i, ipl, is, j, k, n_tens_dm, nplt 

  complex(kind=db), dimension(3):: Pl_i, Pl_s, U_i, U_s
  complex(kind=db), dimension(2*n_tens_dm):: Tens
  complex(kind=db), dimension(3,3):: T
  complex(kind=db), dimension(0:nplt,2*n_tens_dm):: Tensor_pol_dm

  real(kind=db), dimension(3):: Vo_i, Vo_s
  
  Tens(:) = ( 0._db, 0._db )

  U_i(1) = Vo_i(2) * Pl_i(3) - Vo_i(3) * Pl_i(2)
  U_i(2) = Vo_i(3) * Pl_i(1) - Vo_i(1) * Pl_i(3)
  U_i(3) = Vo_i(1) * Pl_i(2) - Vo_i(2) * Pl_i(1)
  U_s(1) = Vo_s(2) * Pl_s(3) - Vo_s(3) * Pl_s(2)
  U_s(2) = Vo_s(3) * Pl_s(1) - Vo_s(1) * Pl_s(3)
  U_s(3) = Vo_s(1) * Pl_s(2) - Vo_s(2) * Pl_s(1)

! is = -1: non magnetique; is = 1 : magnetique
  do is = -1,1,2

    do i = 1,3
      do j = 1,3
        T(i,j) = Conjg( Pl_s(i) ) * U_i(j) + is * Pl_i(i) * Conjg( U_s(j) ) 
      end do
    end do

    if( is == - 1 ) then
      k = 0
    else
      k = n_tens_dm
    endif

    Tens(k+1) = ( T(1,1) + T(2,2) + T(3,3) )

    Tens(k+2) = ( T(1,2) - T(2,1) )

    Tens(k+3) = ( T(2,3) - T(3,2) )

    Tens(k+4) = ( T(3,1) - T(1,3) )

    Tens(k+5) = ( 2*T(3,3) - T(1,1) - T(2,2) )

    Tens(k+6) = ( T(1,3) + T(3,1) )

    Tens(k+7) = ( T(2,3) + T(3,2) )

    Tens(k+8) = ( T(1,2) + T(2,1) )

    Tens(k+9) = ( T(1,1) - T(2,2) )
  
  end do

  Tensor_pol_dm(ipl,:) = Tens(:)

  return
end

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

! Writing of the signal by tensor

subroutine Write_Signal(Abs_U_iso,ct_nelec,Core_resolved,Volume_maille,E_cut,E1E1,E1E2,E1M1,E2E2,Ephseuil,Epsii, &
      Eseuil,First_E,Header,ia,ipl,ipldafs,jseuil,magn_sens,n_tens_dd,n_tens_dq,n_tens_dm, &
      n_tens_qq,ninit1,ninitr,nomfich_t,npldafs,nplt,nseuil,numat_abs,Sum_Bragg_NR_T,phdt, &
      Sph_tensor_dd_ni,Sph_tensor_dq_ni,Sph_tensor_dq_m_ni,Sph_tensor_dm_ni,Sph_tensor_dm_m_ni,Sph_tensor_qq_ni, &
      Surface_ref,Tensor_pol_dd,Tensor_pol_dq,Tensor_pol_dm,Tensor_pol_qq,V0muf)

  use declarations
  implicit none
  
  integer:: i, ia, initr, ipl, ipldafs, is, j, j0, jdd, jdd0, jdm, jdmm, jdm0, jdmm0, &
      jdq, jdq0, jdqm, jdqm0, jqq, jqq0, jseuil, jtot, jtot0, long, n_header_info, n_tens, n_tens_dd, n_tens_dq, n_tens_dm, &
      n_tens_qq, n_tens2, ninit1, ninitr, npldafs, nplt, nseuil, numat_abs

  character(len=Length_name):: nomfich_t, File_out
  character(len=Length_word), dimension(:), allocatable:: Tens_name
  character(len=Length_name), dimension(:), allocatable:: Header_info

  complex(kind=db):: cf, cg, zero_c
  complex(kind=db), dimension(n_tens_dd):: Sph_tensor_dd
  complex(kind=db), dimension(n_tens_dq):: Sph_tensor_dq, Sph_tensor_dq_m
  complex(kind=db), dimension(n_tens_dm):: Sph_tensor_dm, Sph_tensor_dm_m
  complex(kind=db), dimension(n_tens_qq):: Sph_tensor_qq
  complex(kind=db), dimension(n_tens_dd,ninitr):: Sph_tensor_dd_ni
  complex(kind=db), dimension(n_tens_dq,ninitr):: Sph_tensor_dq_ni, Sph_tensor_dq_m_ni
  complex(kind=db), dimension(n_tens_dm,ninitr):: Sph_tensor_dm_ni, Sph_tensor_dm_m_ni
  complex(kind=db), dimension(n_tens_qq,ninitr):: Sph_tensor_qq_ni
  complex(kind=db), dimension(0:nplt,n_tens_dd):: Tensor_pol_dd
  complex(kind=db), dimension(0:nplt,2*n_tens_dq):: Tensor_pol_dq
  complex(kind=db), dimension(0:nplt,2*n_tens_dm):: Tensor_pol_dm
  complex(kind=db), dimension(0:nplt,n_tens_qq):: Tensor_pol_qq
  complex(kind=db), dimension(npldafs):: Sum_Bragg_NR_T, phdt
  complex(kind=db), dimension(:), allocatable:: ph0, phtem, Resul

  logical:: Core_resolved, Dafs, E1E1, E1E2, E1M1, E2E2, First_E, Header, Magn_sens, New_file
  
  real(kind=db):: Abs_U_iso, E_cut, Ephseuil, Eseuil, fac, natomsym_f, Surface_ref, V0muf, Volume_maille

  real(kind=db), dimension(ninitr):: ct_nelec, Epsii
  real(kind=db), dimension(:), allocatable:: Tens

  n_header_info = 0
  allocate( Header_info(n_header_info) )
  
  zero_c = (0._db, 0._db)
  Dafs = ipldafs > 0

! Nombre de colonnes sommes
  j0 = 0
  if( E1E1 ) j0 = j0 + 1
  if( E1E2 ) j0 = j0 + 1
  if( E1E2 .and. Magn_sens ) j0 = j0 + 1
  if( E2E2 ) j0 = j0 + 1
  if( E1M1 ) j0 = j0 + 1
  if( E1M1 .and. Magn_sens ) j0 = j0 + 1
  if( j0 > 1 ) j0 = j0 + 1 

  n_tens = j0
  
! Indices des colones sommes
  jtot0 = 1; jdd0 = 0; jdq0 = 0; jdqm0 = 0; jqq0 = 0; jdm0 = 0; jdmm0 = 0
  if( j0 == 1 ) then
    j = 0
  else
    j = 1
  endif
  if( E1E1 ) then
    j = j + 1
    jdd0 = j
    n_tens = n_tens + n_tens_dd
  endif
  if( E1E2 ) then
    j = j + 1
    jdq0 = j
    n_tens = n_tens + n_tens_dq
  endif
  if( E1E2 .and. Magn_sens) then
    j = j + 1
    jdqm0 = j
    n_tens = n_tens + n_tens_dq
  endif
  if( E2E2 ) then
    j = j + 1
    jqq0 = j
    n_tens = n_tens + n_tens_qq
  endif
  if( E1M1 ) then
    j = j + 1
    jdm0 = j
    n_tens = n_tens + n_tens_dm
  endif
  if( E1M1 .and. Magn_sens) then
    j = j + 1
    jdmm0 = j
    n_tens = n_tens + n_tens_dm
  endif

  n_tens = n_tens * ninitr
  allocate( Resul( n_tens ) )
!  allocate( Ph0( n_tens ) )
!  allocate( phtem( n_tens ) )
  
  Resul(:) = (0._db,0._db)
  
  if( Dafs ) n_tens = 2 * n_tens
  
  allocate( Tens( n_tens ) )
  allocate( Tens_name( n_tens ) )
  
  j = 0
  
  do initr = 1,ninitr
      
    jtot = jtot0 + j
    jdd = jdd0 + j
    jdq = jdq0 + j
    jdqm = jdqm0 + j
    jqq = jqq0 + j
    jdm = jdm0 + j
    jdmm = jdmm0 + j
    j = j + j0
  
! Xanes is in Megabarns
! For DAFS, in convolution one multiplies by pi
    if( Dafs ) then
      fac = 1 / pi
    else
      fac = 1 / ct_nelec(initr) 
    endif      

    Sph_tensor_dd(:) = fac * Sph_tensor_dd_ni(:,initr) 
    Sph_tensor_dq(:) = fac * Sph_tensor_dq_ni(:,initr) 
    Sph_tensor_dq_m(:) = fac * Sph_tensor_dq_m_ni(:,initr) 
    Sph_tensor_qq(:) = fac * Sph_tensor_qq_ni(:,initr)
    Sph_tensor_dm(:) = fac * Sph_tensor_dm_ni(:,initr) 
    Sph_tensor_dm_m(:) = fac * Sph_tensor_dm_m_ni(:,initr) 

    if( E1E1 ) then
      
      do i = 1,n_tens_dd

        j = j + 1
        Resul(j) = Tensor_pol_dd(ipl,i) * Sph_tensor_dd(i)

! Devant le produit, il faut mettre un signe -1 devant les tenseurs impairs (vient des 2 multiplications par -i)
        if( i >= 2 .and. i <= 4 ) Resul(j) = - Resul(j)

        call Fill_line( Core_resolved, 1, Dafs, i, initr, j, jseuil, n_tens, nseuil, ninitr, Resul(j), Tens, Tens_name )

        Resul(jdd) = Resul(jdd) + Resul(j)

      end do
 
      call Fill_line( Core_resolved, 1, Dafs, 0, initr, jdd, jseuil, n_tens, nseuil, ninitr, Resul(jdd), Tens, Tens_name )
      
    endif

    if( E1E2 ) then

      do is = 1,2 
        if( is == 2 .and. .not. Magn_sens ) exit
        do i = 1,n_tens_dq
        
          j = j + 1
! Les parties reelles et imaginaires sont a considerer avant la multiplication par le img eventuel.
          if( is == 1 ) then
            Resul(j) = Sph_tensor_dq(i) * Tensor_pol_dq(ipl,i)
          else
            Resul(j) = Sph_tensor_dq_m(i) * Tensor_pol_dq(ipl,i+n_tens_dq)
          endif

! On recupere le img exterieur au tenseur propre au dipole-quadrupole
          Resul(j) = img * Resul(j)

! Signe est oppose car complex conjugue fait dans conv
          if( Dafs ) Resul(j) = - Resul(j) 

          call Fill_line( Core_resolved, 1+is, Dafs, i, initr, j, jseuil, n_tens, nseuil, ninitr, Resul(j), Tens, Tens_name )

          if( is == 1 ) then
             Resul(jdq) = Resul(jdq) + Resul(j)
          else
             Resul(jdqm) = Resul(jdqm) + Resul(j)
          endif

        end do

        if( is == 1 ) then
          call Fill_line( Core_resolved, 2, Dafs, 0, initr, jdq, jseuil, n_tens, nseuil, ninitr, Resul(jdq), Tens, Tens_name )
        else
          call Fill_line( Core_resolved, 3, Dafs, 0, initr, jdqm, jseuil, n_tens, nseuil, ninitr, Resul(jdqm), Tens, Tens_name )
        endif
      
      end do
      
    endif
        
    if( E2E2 ) then

      do i = 1,n_tens_qq
      
        j = j + 1

        Resul(j) = Tensor_pol_qq(ipl,i) * Sph_tensor_qq(i)

        call Fill_line( Core_resolved, 4, Dafs, i, initr, j, jseuil, n_tens, nseuil, ninitr, Resul(j), Tens, Tens_name )

        Resul(jqq) = Resul(jqq) + Resul(j)

      end do

      call Fill_line( Core_resolved, 4, Dafs, 0, initr, jqq, jseuil, n_tens, nseuil, ninitr, Resul(jqq), Tens, Tens_name )
        
    endif
      
    if( E1M1 ) then

      do is = 1,2
        if( is == 2 .and. .not. Magn_sens ) exit
     
        do i = 1,n_tens_dm
        
          j = j + 1
! Modif pour que ca cole (je ne comprend pas vraiment), voir aussi fin de la routine Sph_tensor_dm_cal 
          if( is == 1 ) then
            Resul(j) = Sph_tensor_dm(i) * Tensor_pol_dm(ipl,i)
            if( Dafs .and. ( i >= 2 .and. i <= 4 )  ) Resul(j) = - Resul(j) 
          else
            Resul(j) = Sph_tensor_dm_m(i) * Tensor_pol_dm(ipl,i+n_tens_dm)
            if( i >= 2 .and. i <= 4 ) Resul(j) = - Resul(j) 
          endif

          call Fill_line( Core_resolved, 4+is, Dafs, i, initr, j, jseuil, n_tens, nseuil, ninitr, Resul(j), Tens, Tens_name )

          if( is == 1 ) then
             Resul(jdm) = Resul(jdm) + Resul(j)
          else
             Resul(jdmm) = Resul(jdmm) + Resul(j)
          endif

        end do

        if( is == 1 ) then
          call Fill_line( Core_resolved, 5, Dafs, 0, initr, jdm, jseuil, n_tens, nseuil, ninitr, Resul(jdm), Tens, Tens_name )
        else
          call Fill_line( Core_resolved, 6, Dafs, 0, initr, jdmm, jseuil, n_tens, nseuil, ninitr, Resul(jdmm), Tens, Tens_name )
        endif
      
      end do

    endif

    if( j0 > 1 ) then
      Resul(jtot) = sum( Resul(jtot+1:jtot+j0-1) )  
      call Fill_line( Core_resolved, 0, Dafs, 0, initr, jtot, jseuil, n_tens, nseuil, ninitr, Resul(jtot), Tens, Tens_name )
    endif    

  end do
  
! Writing of tensors

  File_out = nomfich_t

  long = len_trim(File_out)
  File_out(long+1:long+11) = '_sph_signal'
  if( ia > 0 ) then
    File_out(long+12:long+16) = '_atom'
    call ad_number(ia,File_out,Length_name)
  endif
  long = len_trim(File_out)
  if( ipldafs > 0 ) then
    File_out(long+1:long+4) = '_rxs'
    call ad_number(ipldafs,File_out,Length_name)
  elseif( ipl == 0 ) then
    File_out(long+1:long+4) = '_xan'
  else
    File_out(long+1:long+4) = '_pol'
    call ad_number(ipl,File_out,Length_name)
  endif
  long = len_trim(File_out)
  File_out(long+1:long+4) = '.txt'

  New_file = First_E
  
  if( First_E ) then
    
    if( Header ) then
      call Write_Header(File_out,Header_info,n_header_info)
      New_file = .false.
    endif
    
    natomsym_f = 0._db
!  write(6,'(/a10,2i2,L3)') 'ni1, nir =',ninit1,ninitr, Core_resolved         
    call Write_first_out(Abs_U_iso,Core_resolved,Zero_c,File_out,E_cut,Epsii,Eseuil,.false., &
          jseuil,New_file,ninit1,ninitr,nseuil,numat_abs,V0muf,natomsym_f,Surface_ref,Volume_maille)

    if( Dafs ) then
      if( ia == 0 ) then
        cf = phdt(ipldafs)
        cg = Sum_Bragg_NR_T(ipldafs)
      else
        cf = ( 1._db, 0._db )
        cg = ( 0._db, 0._db )
      endif
      n_tens2 = n_tens / ( 2 * ninitr )  ! number of tensor euivalent here to number of dafs
      allocate( Ph0( n_tens2 ) )
      allocate( Phtem( n_tens2 ) )
      phtem(:) = cf
      ph0(:) = cg
      call Write_out_Bragg(phtem,File_out,n_tens2,n_tens2,ph0)
      deallocate( Ph0, Phtem )
    endif

  endif

  call Write_out_stand(Ephseuil,File_out,First_E,n_tens,n_tens,New_file,Tens_name,4,Tens)

  deallocate( Header_info, Resul, Tens, Tens_name )

  return
end

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

! Filling value and name of the tensor

subroutine Fill_line( Core_resolved, index, Dafs, i, initr, j, jseuil, n_tens, nseuil, ninitr, Resul, Tens, Tens_name )

  use declarations
  implicit none
  
  integer:: i, index, initr, j, jj, jseuil, l, n_tens, ninitr, nseuil
  
  character(len=Length_word):: mot
  character(len=8), dimension(0:0):: Tens_name_tot
  character(len=8), dimension(0:9):: Tens_name_D
  character(len=8), dimension(0:15):: Tens_name_I, Tens_name_I_m 
  character(len=8), dimension(0:25):: Tens_name_Q 
  character(len=8), dimension(0:9):: Tens_name_T, Tens_name_T_m 
  character(len=Length_word), dimension(n_tens):: Tens_name

  complex(kind=db):: Resul
  
  logical:: Core_resolved, Dafs 

  real(kind=db), dimension(n_tens):: Tens
  
  data Tens_name_tot/ ' Sum_tot'/
  data Tens_name_D/ ' Sum_dd ','  D(00) ','  lz_dd ','  lx_dd ','  ly_dd ','  D_z2  ','   D_xz ','  D_yz  ','  D_xy  ',' D_x2-y2'/
  data Tens_name_I/ ' Sum_dq ','   I_z  ','   I_x  ','    I_y ','  I(20) ',' I(21)  ',' I(2-1) ','  I(22) ',' I(2-2) ', &
                    '  I(30) ',' I(31)  ',' I(3-1) ',' I(32)  ',' I(3-2) ','  I(33) ',' I(3-3) '/
  data Tens_name_I_m/ 'Sum_dq_m','  I_z_m ',' I_x_m  ','  I_y_m ',' I(20)_m',' I(21)_m','I(2-1)_m',' I(22)_m','I(2-2)_m', &
                      ' I(30)_m',' I(31)_m','I(3-1)_m',' I(32)_m','I(3-2)_m',' I(33)_m','I(3-3)_m'/
  data Tens_name_Q/ ' Sum_qq ','  Q(00) ','  lz_qq ','  lx_qq ','  ly_qq ','  Q(20) ','  Q(21) ',' Q(2-1) ','  Q(22) ',' Q(2-2) ', &
                    '  Q(30) ','  Q(31) ',' Q(3-1) ','  Q(32) ',' Q(3-2) ','  Q(33) ',' Q(3-3) ','  Q(40) ','  Q(41) ', &
                    ' Q(4-1) ','  Q(42) ',' Q(4-2) ','  Q(43) ',' Q(4-3) ','  Q(44) ',' Q(4-4) '/
  data Tens_name_T/   ' Sum_dm ','  T(00) ','  T_z   ','   T_x  ','    T_y ','  T_z2  ','  T_xz  ','  T_yz  ','  T_yz  ','T_x2-y2 '/
  data Tens_name_T_m/ 'Sum_dm_m',' T(00)_m','  T_z_m ','  T_x_m ','  T_y_m ',' T_z2_m ',' T_xz_m ',' T_yz_m ',' T_yz_m ','Tx2-y2_m'/

  mot = ' '
  
  Select case(index)
    case(0)
      mot = Tens_name_tot(i)
    case(1)
      mot = Tens_name_D(i)
    case(2)
      mot = Tens_name_I(i)
    case(3)
      mot = Tens_name_I_m(i)
    case(4)
      mot = Tens_name_Q(i)
    case(5)
      mot = Tens_name_T(i)
    case(6)
      mot = Tens_name_T_m(i)
  end select
  
  if( Dafs ) then
    jj = 2 * j - 1
  else
    jj = j
  endif
  
  Tens(jj) = real( Resul, db )
  
  if( Dafs ) then

    l = len_trim( mot )
    mot(l+1:l+2) = '_r'
    if( ninitr > 1 ) call ad_sufix(Core_resolved,initr,jseuil,Length_word,mot,nseuil)
    Tens_name(jj) = mot

    jj = jj + 1
    Tens(jj) = aimag( Resul )
    mot(l+2:l+2) = 'i'
    Tens_name(jj) = mot

  else

    if( ninitr > 1 ) call ad_sufix(Core_resolved,initr,jseuil,Length_word,mot,nseuil)
    Tens_name(jj) = mot

  endif

  return
end