! FDMNES subroutines
! File containing all concerning the solutions in the atomic sphere

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

! Resolution of the spherical Schrodinger equation in the atoms
! Full_pot is Ful_pot(iapr), true when Full_potential and the specific atom non diagonal

subroutine Sphere( Axe_Atom_gr, Ecinetic, Eimag, Energ, Enervide, Full_atom, Full_pot, &
              Green, Hubb_a, Hubb_d, iaabsi, iapr, iaprotoi, ibord, icheck, igreq, igroupi, iopsymr, Lmax, Lmax_pot, &
              m_hubb, n_atom_0, n_atom_ind, n_atom_proto, natome, nbord, nbtm, nbtm_fdm, neqm, ngroup_m, nlm_pot, nlmagm, &
              nlmmax, nphiato, nphiato_c, npsom, nr, nspin, nspino, nspinp, Numat, Phiato, Phiato_c, Posi,r, Relativiste, Renorm, &
              Rmtg, Rmtsd, Spin_axis_free, Spinorbite, Tau_ato, V_hubb, V_intmax, V0bd, Vrato, xyz, Ylm_comp, Ylmato )

  use declarations
  implicit none

  integer:: ia, iaabsi, iang, iapr, ib, icheck, iga, igr, kgr, L, &
    L_hubbard, lfin, Lm, Lm0, Lmax, Lmax_pot, Lmp, m, m_hubb, mp, n, &
    n_atom_0, n_atom_ind, n_atom_proto, natome, nbtm, nbtm_fdm, neqm, ngroup_m, nlm, nlm_fp, nlm_pot, nlm_V, &
    nlmagm, nlmmax, np, nphiato, nphiato_c, npsom, nr, nrmtg, nrmtsd, nspin, nspino, nspinp, Numat
    
  integer, dimension(natome):: iaprotoi, igroupi, nbord
  integer, dimension(nopsm):: iopsymr
  integer, dimension(nbtm,natome):: ibord
  integer, dimension(0:n_atom_proto,neqm):: igreq

  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(nphiato_c,nlmagm,nspinp,nspino,natome):: Phiato_c
  complex(kind=db), dimension(nlmagm,nspinp,nlmagm,nspinp,n_atom_0:n_atom_ind):: Tau_ato
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb
  complex(kind=db), dimension(:,:,:,:), allocatable:: Tau, V

  logical:: Ecomp, Full_atom, Full_pot, Green, Hubb_a, Hubb_d, Hubb_m, Radial_comp, Relativiste, Renorm, &
    Spin_axis_free, Spinorbite, Ylm_comp

  real(kind=db):: cosang, Eimag, Energ, Enervide, Rmtg, Rmtsd, V_intmax
  real(kind=db), dimension(nspin):: Ecinetic, V0bd
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato
  real(kind=db), dimension(3,ngroup_m):: Axe_atom_gr
  real(kind=db), dimension(nphiato,nlmagm,nspinp,nspino,natome):: Phiato

  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nr,nspin):: g0, gm, gp
  real(kind=db), dimension(nr,nspino):: gso
  real(kind=db), dimension(3,natome):: posi
  real(kind=db), dimension(4,npsom):: xyz
  real(kind=db), dimension(nbtm_fdm,nlmmax,natome):: Ylmato

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

  konde(:) = sqrt( cmplx(Ecinetic(:), Eimag, db) )

  if( icheck > 1 ) write(3,110) iapr, Numat, Lmax
  if( icheck > 1 ) write(3,120) Energ*rydb, Enervide*rydb
  if( icheck > 2 ) then
    write(3,130) Ecinetic(:)*rydb
    write(3,140) V0bd(:)*rydb
    write(3,150) konde(:)
  endif

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

  call mod_V(icheck,Lmax,Lmax_pot,nlm_V,nlm_pot,nr,nrmtg,nrmtsd,nspin,r,Rmtg,Rmtsd,V,V_intmax,V0bd,Vrato,Ylm_comp)

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

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

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

  do L = 0,lfin

    if( Hubb_a .and. L == L_hubbard( Numat ) )  then
      Hubb_m = .true.
    else
      Hubb_m = .false.
    endif

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

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

    call Sch_radial( Ecomp ,Eimag, f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, L, Lmax, m_hubb, &
         nlm, nlm_fp, nlm_V, nr, nrmtg, nspin, nspino, nspinp, Numat, r, Radial_comp, Relativiste, Renorm, Rmtg, &
         Spinorbite, Tau, ui, ur, V, V_hubb )

! Copy
    if( Full_pot ) then
      do Lm = 1,nlm
        do Lmp = 1,nlm_fp
          Tau_ato(Lm,:,Lmp,:,iapr) = Tau(Lm,:,Lmp,:)
        end do
      end do
    else
      Lm0 = L**2 + L + 1
       do m = -L,L
        if( nlm == 1 ) then
          n = 1
        else
          n = L + 1 + m
        endif
        do mp = -L,L
          if( nlm == 1 ) then
            if( m /= mp ) cycle
            np = 1
          else
            np = L + 1 + mp
          endif
          Tau_ato(Lm0+m,:,Lm0+mp,:,iapr) = Tau(n,:,np,:)
        end do
      end do
    endif

    deallocate( Tau )

 ! Calculation of the radial functions Phiato on the FDM grid points
    if( .not. Green ) then

      do ib = 1,natome
        if( Full_atom ) then
          if( ib > 1 ) exit
          ia = iapr
        else
          ia = ib
          if( iaprotoi(ia) /= iapr ) cycle
        endif

        if( nspin == 2 .and. .not. Spin_axis_free ) then
          igr = igroupi(ia)
          iga = igroupi(iaabsi)
          kgr = igreq(iaprotoi(ia),1)

          cosang = sum( Axe_Atom_gr(:,kgr) * Axe_Atom_gr(:,igr) )
          cosang = cosang * abs( sum( Axe_Atom_gr(:,iga) * Axe_Atom_gr(:,igr) ) )
          if( abs(cosang - 1) < eps4 ) then
            iang = 1
          elseif( abs(cosang + 1) < eps4 ) then
            iang = - 1
          else
            iang = 0
          endif
        else
          iang = 1
        endif

        call Cal_phiato( Full_pot, ia, iang, ibord, icheck, iopsymr, L, Lmax, nlm, nlm_fp, natome, nbord(ia), nbtm, &
             nbtm_fdm, nlmagm, nlmmax, nphiato, nphiato_c, npsom, nr, nspinp, nspino, Phiato, Phiato_c, Posi, r, &
             Radial_comp, Spinorbite, ui, ur, xyz, Ylm_comp, Ylmato)
      end do
      
    endif

    deallocate( ui, ur )

  end do   ! end of loop over L

  deallocate( V )

  return
  110 format(/' iapr =',i3,', Z =',i3,', Lmax =',i2)
  120 format(' Energ =',f10.3,' eV,  Enervide =',f10.3,' eV')
  130 format(' Ecinetic =',2f10.3)
  140 format(' V0bd  =',2f10.3)
  150 format(' konde =',2f12.5)
end

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

! Work on potential
! Evaluation of V(LL')
! The components V_0, and V_00 are multiplied by sqrt(4.pi)

Subroutine mod_V(icheck,Lmax,Lmax_pot,nlm_V,nlm_pot,nr,nrmtg,nrmtsd,nspin,r,Rmtg,Rmtsd,V,V_intmax,V0bd,Vrato,Ylm_comp)

  use declarations
  implicit none

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

  integer:: icheck, ir, is, ispin, L, L1, L2, l3, Lm, Lmp, Lmn, Lm1, Lm2, Lm3, Lmax, &
    Lmax_pot, m, m1, m2, m3, nlm_V, nlm_pot, nlma, nr, nrmtg, nrmtsd, nspin

  complex(kind=db), dimension(nr,nlm_V,nlm_V,nspin):: V
  complex(kind=db), dimension(:,:,:), allocatable:: Vrato_c

  logical:: Ylm_comp

  real(kind=db):: g, Gaunt_r, gauntcp, Rmtg, Rmtsd, V_intmax
  real(kind=db), dimension(nr):: r
  real(kind=db), dimension(nspin):: V0bd
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato

  V(:,:,:,:) = ( 0._db, 0._db )
  
  if( Ylm_comp .and. nlm_V > 1 ) then
    allocate( Vrato_c(nr,nlm_pot,nspin) )
    Vrato_c(:,:,:) = ( 0._db, 0._db ) 
    do L = 0,Lmax_pot
      Lm = L**2 + L + 1
      Vrato_c(:,Lm,:) = cmplx( Vrato(:,Lm,:), 0._db, db ) 
      do m = 1,L
        is = (-1)**m
        Lmp = Lm + m 
        Lmn = Lm - m 
        Vrato_c(:,Lmp,:) = One_on_sqrt_2 * is * cmplx( Vrato(:,Lmp,:), - Vrato(:,Lmn,:), db )
        Vrato_c(:,Lmn,:) = One_on_sqrt_2 * cmplx( Vrato(:,Lmp,:), Vrato(:,Lmn,:), db )
      end do
    end do
  endif

  do ispin = 1,nspin
    do Lm = 1,nlm_V
      if( V_intmax < 1000._db ) then
        do ir = 1,nr 
          V(ir,Lm,Lm,ispin) = cmplx( min( Vrato(ir,1,ispin), V_intmax ), 0._db, db )
        end do
      else
        V(1:nr,Lm,Lm,ispin) = cmplx( Vrato(1:nr,1,ispin), 0._db, db )
      endif
    end do
  end do

  do ir = 1,nr-1
    if( r(ir) > Rmtg + eps10 ) exit
  end do
  nrmtg = ir
  do ir = 1,nr-1
    if( r(ir) > Rmtsd + eps10 ) exit
  end do
  nrmtsd = ir

! No effect for FDM
  if( abs( V0bd(1) ) > eps10 ) then
    do ir = 1,nr-1
      if( r(ir) > Rmtg - eps10 ) exit
    end do
    do ispin = 1,nspin
      do Lm = 1,nlm_V
        V(ir:nr,Lm,Lm,ispin) = cmplx( V0bd(ispin), 0._db, db )
      end do
    end do
  endif

  Lm1 = 0
  do L1 = 0,Lmax
    do m1 = -L1,L1
      Lm1 = Lm1 + 1
      Lm2 = 0
      do L2 = 0,Lmax
        do m2 = -L2,L2
          Lm2 = Lm2 + 1
          if( Lm1 == Lm2 .or. nlm_V == 1 ) cycle

          Lm3 = 1
          do L3 = 1,Lmax_pot
            do m3 = -L3,L3
              Lm3 = Lm3 + 1

              if( Ylm_comp ) then
                g = gauntcp(L1,m1,L2,m2,L3,m3)
              else
                g = Gaunt_r(L1,m1,L2,m2,L3,m3)
              endif

              if( Ylm_comp .and. nlm_V > 1 ) then
                V(1:nr,Lm1,Lm2,:) = V(1:nr,Lm1,Lm2,:) + g * Vrato_c(1:nr,Lm3,:)
              else 
                V(1:nr,Lm1,Lm2,:) = V(1:nr,Lm1,Lm2,:) + cmplx( g * Vrato(1:nr,Lm3,:), 0._db )
              endif
            end do
          end do

        end do
      end do
    end do
  end do

  if( icheck > 2 ) then
    nlma = min( nlm_V, 9 )
    if( nlm_V == 1 ) then
      if( nspin == 1 ) then
        write(3,'(/A)') '    Radius      V'
      else
        write(3,'(/A)') '    Radius     V(up)      V(dn)'
      endif
    else
      if( nspin == 1 .and. Ylm_comp ) then
        write(3,100) ( ( Lm1, Lm2, Lm1, Lm2, Lm2 = 1,nlma ), Lm1 = 1,nlma )
      elseif( nspin == 1 ) then
        write(3,110) ( ( lm1, lm2, lm2 = 1,nlma ), lm1 = 1,nlma )
      elseif( nspin == 2 .and. Ylm_comp ) then
        write(3,120) ( ( ( Lm1, Lm2, Lm1, Lm2, lm2 = 1,nlma ), ispin = 1,nspin), lm1 = 1,nlma )
      else
        write(3,130) ( ( ( lm1, lm2, lm2 = 1,nlma ), ispin = 1,nspin), lm1 = 1,nlma )
      endif
    endif
    do ir = 1,nr
      if( Ylm_comp .and. nlm_V > 1 ) then
        write(3,140) r(ir)*bohr, ( ( V(ir,lm1,lm2,:)*rydb, lm2 = 1,nlma ), lm1 = 1,nlma )
      else
        write(3,150) r(ir)*bohr, ( ( real( V(ir,lm1,lm2,:) )*rydb, lm2 = 1,nlma ), lm1 = 1,nlma )
      endif
    end do
  endif

  if( Ylm_comp .and. nlm_V > 1 ) deallocate( Vrato_c )

  return
  100 format(/'    Radius    ',1000('Vr(',i2,',',i2,')',3x,'Vi(',i2,',',i2,')',2x))
  110 format(/'    Radius    ',1000('V(',i2,',',i2,')',3x))
  120 format(/'    Radius    ',1000(' Vr(',i2,',',i2,')u Vi(',i2,',',i2,')u',&
                                   ' Vr(',i2,',',i2,')d Vi(',i2,',',i2,')d') )
  130 format(/'    Radius    ',1000(' V(',i2,',',i2,',u) V(',i2,',',i2,',d)') )
  140 format(1p,1000(1x,2e11.3))
  150 format(1p,1000e11.3)
end

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

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

  use declarations
  implicit none

  integer:: ir, ispin, nlm_V, nr, nspin, nspino, Numat

  complex(kind=db), dimension(nr,nlm_V,nlm_V,nspin):: V

  logical:: Relativiste, Spinorbite

  real(kind=db):: a2s4, bder, dr, dvr, Enervide, fac, r0, rm, rp, VmE

  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nr,nspin):: g0, gm, gp, Vr
  real(kind=db), dimension(nr,nspino):: gso

  real(kind=db), dimension(:), allocatable:: cgrad0, cgradm, cgradp, clapl0, claplm, claplp

  allocate( cgrad0(nr) )
  allocate( cgradm(nr) )
  allocate( cgradp(nr) )
  allocate( clapl0(nr) )
  allocate( claplm(nr) )
  allocate( claplp(nr) )
  
  Vr(:,:) = real( V(:,1,1,:), db )
 
  gso(:,:) = 0._db

  do ir = 1,nr
    if( ir == nr ) then
      rp = r(nr)**2 / r(nr-1)
    else
      rp = r(ir+1)
    endif
    if( ir == 1 ) then
      rm = r(1)**2 / r(2)
    else
      rm = r(ir-1)
    endif
    r0 = r(ir)
    dr = 0.5_db * ( rp - rm )
    claplm(ir) = 1 / ( ( r0 - rm ) * dr )
    claplp(ir) = 1 / ( ( rp - r0 ) * dr )
    clapl0(ir) = - claplm(ir) - claplp(ir)
    if( Spinorbite .or. Relativiste ) then
      cgradm(ir) = ( rp - r0 ) / ( ( rm - r0 ) * ( rp - rm ) )
      cgradp(ir) = ( rm - r0 ) / ( ( rp - r0 ) * ( rm - rp ) )
      cgrad0(ir) = - cgradm(ir) - cgradp(ir)
    endif
    f2(ir) = 1 / r(ir)**2
  end do

! alfa_sf = fine structure constant
  a2s4 = 0.25_db * alfa_sf**2

  do ir = 1,nr
    do ispin = 1,nspin

      VmE = Vr(ir,ispin) - Enervide
      g0(ir,ispin) = - clapl0(ir) + Vme
      gm(ir,ispin) = - claplm(ir)
      gp(ir,ispin) = - claplp(ir)

      if( Relativiste .or. Spinorbite ) then

        bder = 1 / ( 1 - a2s4 * VmE )
        if( ir == 1 ) then
          dvr = 2 * Numat / r(1)**2
        elseif( ir == nr ) then
          dvr = cgradm(ir) * Vr(ir-1,ispin) + cgrad0(ir) * Vr(ir,ispin) + cgradp(ir) * Vr(ir,ispin)
        else
          dvr = cgradm(ir) * Vr(ir-1,ispin) + cgrad0(ir) * Vr(ir,ispin) + cgradp(ir) * Vr(ir+1,ispin)
        endif
        fac = a2s4 * bder * dvr

        if( Relativiste ) then
          g0(ir,ispin) = g0(ir,ispin) - a2s4 * Vme**2 - fac * ( cgrad0(ir) - 1 / r(ir) )
          gm(ir,ispin) = gm(ir,ispin) - fac * cgradm(ir)
          gp(ir,ispin) = gp(ir,ispin) - fac * cgradp(ir)
        endif
        if( Spinorbite ) gso(ir,ispin) = fac / r(ir)

      endif

    end do
  end do

  if( nspin < nspino ) gso(:,nspino) = gso(:,nspin)

  deallocate( cgrad0, cgradm, cgradp, clapl0, claplm, claplp )

  return
end

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

! Resolution of the radial Schrodinger equation. Include the case of the non spherical potential
! Called by Sphere, radial, radial_sd
! In ur(ir,m,mp,isp,isol) : (mp, isol) define the basis state
!                           (m, isp) are the real moment and spin

subroutine Sch_radial( Ecomp ,Eimag, f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, LL, Lmax, m_hubb, &
         nlm, nlm_fp, nlm_V, nr, nrmtg, nspin, nspino, nspinp, Numat, r, Radial_comp, Relativiste, Renorm, Rmtg, &
         Spinorbite, Tau, ui, ur, V, V_hubb )

  use declarations
  implicit none

  integer:: Factorial_Lp2, icheck, im, ip, ir, iso, iso_p, iso_s, isp, isq, isr, L, L_hubbard, L_Lplus1, Li, LL, Lf, Lm, Lm_orb, &
    Lm_orb_p, Lm0, Lmax, Lm_s, m, m_hubb, m_orb, m_orb_p, m_orb_s, mp, nlm, nlm_fp, nlm_V, nr, nrmtg, nspin, &
    nspino, nspinp, Numat, Two_J_z

  logical:: Ecomp, Failed, Full_pot, Full_potential_loc, Hubb_a, Hubb_d, Hubb_m, Hubb_nd, J_plus, &
    Normal_tau, Radial_comp, Renorm, Relativiste, Spino_simple, Spinorbite

  complex(kind=db):: V_h
  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(nlm,nspinp,nlm,nspinp):: Tau
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb
  complex(kind=db), dimension(nr,nlm_V,nlm_V,nspin):: V

  real(kind=db):: br, Eimag, fac, J_z, p, q, Rmtg, s, td
  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nlm,nspino):: Fac_up_dn
  real(kind=db), dimension(nr,nspin):: g0, gm, gp
  real(kind=db), dimension(nr,nspino):: gso
  real(kind=db), dimension(nr,nlm,nlm_fp,nspinp,nspino):: ui, ur
  real(kind=db), dimension(0:Lmax,-2*Lmax-1:2*Lmax+1,2,2):: Fac_Spinor

  real(kind=db), dimension(:,:,:,:,:), allocatable:: wi, wr

  Full_potential_loc = Full_pot
  Failed = .false.
  Normal_tau = .true.

  if( Spinorbite ) call PreFac_Spinor( Fac_Spinor, Lmax ) 

  if( Spinorbite .and. nlm_fp > 1 ) then  
    allocate( wr(nr,nlm,nspino*nlm_fp,nspinp,nspino) )
    allocate( wi(nr,nlm,nspino*nlm_fp,nspinp,nspino) )
  else
    allocate( wr(nr,nlm,nlm_fp,nspinp,nspino) )
    allocate( wi(nr,nlm,nlm_fp,nspinp,nspino) )
  endif
  
! Point de retour si La normalisation en cas de full-potential a les elements non diagonaux plus grands que les diagonaux
  do

    ur(:,:,:,:,:) = 0._db
    ui(:,:,:,:,:) = 0._db

    wr(:,:,:,:,:) = 0._db
    wi(:,:,:,:,:) = 0._db

    Spino_simple = Spinorbite .and. nlm_fp == 1

    if( Full_pot ) then
      Li = 0  
      Lf = Lmax
    else
      Li = LL
      Lf = LL
    endif

  Factorial_Lp2 = 1
  do L = 0,Li - 1
    Factorial_Lp2 = Factorial_Lp2 * ( L + 2 )
  end do

  do L = Li,Lf
  
    if( Hubb_a .and. L == L_hubbard( Numat ) )  then
      Hubb_m = .true.
    else
      Hubb_m = .false.
    endif
    Hubb_nd = Hubb_m .and. .not. Hubb_d

    if( Full_pot ) then
      Lm0 = L**2 + L + 1
    elseif( Hubb_m .or. Spinorbite ) then
      Lm0 = L + 1    
    else
      Lm0 = 1
    endif

    L_Lplus1 = L * ( L + 1 )
    Factorial_Lp2 = Factorial_Lp2 * ( L + 2 )

    br = - real( Numat, db ) / ( L_Lplus1 - Factorial_Lp2 )

    do m = -L,L  ! m of the state, not the orbital when spinorbite

      if( m /= 0 .and. .not. ( Spinorbite .or. Hubb_m .or. Full_pot ) ) cycle

      do iso_s = 1,nspino
 
        if( Hubb_nd .or. Full_pot ) then
          Lm_s = ( Lm0 + m - 1 ) * nspino + iso_s
        else
          Lm_s = 1
        endif                       
     
        iso = iso_s  ! it is the diagonal term which is not zero
        
        if( Spinorbite ) then
          J_plus = iso == 1 .or.  m == - L
          if( iso == 1 ) then
            s = 0.5_db
          else
            s = - 0.5_db
          endif
          J_z = m + s
          Two_J_z = nint( 2 * J_z )
        endif
      
        do isp = 1,nspinp
          isr = min( isp, nspin )
        
          if( Spinorbite ) then
            m_orb = m - iso + isp
            if( m_orb < - L .or. m_orb > L ) cycle
          else
            m_orb = m
          endif

          Lm_orb = Lm0 + m_orb

          if( Spinorbite .and. Relativiste ) then
            if( J_plus ) then
              p = sqrt( ( L + 1 )**2 - ( alfa_sf * numat )**2 )
            else
              p = sqrt( L**2 - ( alfa_sf * numat )**2 )
            endif
          elseif( Spinorbite ) then
            if( J_plus .and. abs( m_orb ) == L ) then
              p = L + 1._db
            elseif( J_plus ) then
              p = 0.5_db + 0.5_db * sqrt( 1._db + 4*(L**2) + 8*L )
            else
              if( L == 1 ) then
! There is no solution for L=1 with spin-orbit and not relativistic !
                p = L + 1._db
              else
                p = 0.5_db + 0.5_db * sqrt( -5._db + 4*(L**2) )
              endif
            endif
          elseif( Relativiste ) then
            p = sqrt( L**2 + L + 1 - ( alfa_sf * Numat )**2 )
          else
            p = L + 1._db
          endif

          if( Spinorbite ) then
            if( J_plus ) then
              fac = Fac_Spinor(L,Two_J_z,isp,1)
            else
              fac = Fac_Spinor(L,Two_J_z,isp,2)
              if( Relativiste ) then
        ! Multiplicative term (which does not matter) in order to have J+ and J- of the same order 
                q = sqrt( ( L + 1 )**2 - ( alfa_sf * Numat )**2 )
                fac = fac * r(1)**( q - p )
              endif    
            endif
          else
            fac = 1._db
          endif

          wr(1:2,Lm_orb,Lm_s,isp,iso) = fac * ( 1 + br * r(1:2) ) * r(1:2)**p

        end do
      end do
    end do
  end do   ! end of over L

  if( Spinorbite ) call Cal_Fac_up_dn( Fac_up_dn, Full_pot, Hubb_m, Li, Lf, nlm, nspino ) 

! Calculation over radius

  do ir = 2,nr-1
    im = ir - 1
    ip = ir + 1

    do L = Li,Lf

      Hubb_m = Hubb_a .and. L == L_hubbard( Numat )

      if( Full_pot ) then
        Lm0 = L**2 + L + 1
      elseif( Hubb_m .or. Spinorbite ) then
        Lm0 = L + 1    
      else
        Lm0 = 1
      endif

      L_Lplus1 = L * ( L + 1 )

! m is the index of the spinor when spinorbite
      do m = -L,L 
      
        if( m /= 0 .and. .not. ( Spinorbite .or. Hubb_m .or. Full_pot ) ) cycle
        
        Lm = Lm0 + m
        
        do iso = 1,nspino

          do isp = 1,nspinp
        
! m_orb is the m of the orbital
            if( Spinorbite ) then
              m_orb = m - iso + isp
              if( m_orb < - L .or. m_orb > L ) cycle
              if( isp == 1 ) then
                m_orb_p = m_orb + 1
                m_orb_s = m_orb 
              else
                m_orb_p = m_orb - 1
                m_orb_s = - m_orb 
              endif 
              Lm_orb_p = Lm0 + m_orb_p
            else
              m_orb = m
            endif

            Lm_orb = Lm0 + m_orb
            
            isr = min( isp, nspin )
            isq = 3 - isp

            td = g0(ir,isr) + L_Lplus1 * f2(ir)

            wr(ip,Lm_orb,:,isp,iso) = td * wr(ir,Lm_orb,:,isp,iso) + gm(ir,isr) * wr(im,Lm_orb,:,isp,iso)
            if( Radial_comp ) then
              wi(ip,Lm_orb,:,isp,iso) = td * wi(ir,Lm_orb,:,isp,iso) + gm(ir,isr) * wi(im,Lm_orb,:,isp,iso)
              if( Ecomp ) then 
                wr(ip,Lm_orb,:,isp,iso) = wr(ip,Lm_orb,:,isp,iso) + Eimag * wi(ir,Lm_orb,:,isp,iso)
                wi(ip,Lm_orb,:,isp,iso) = wi(ip,Lm_orb,:,isp,iso) - Eimag * wr(ir,Lm_orb,:,isp,iso)
              endif
            endif
            
            if( Spinorbite ) then
              wr(ip,Lm_orb,:,isp,iso) = wr(ip,Lm_orb,:,isp,iso) + m_orb_s * gso(ir,isp) * wr(ir,Lm_orb,:,isp,iso) 
              if( abs( m_orb_p ) <= L ) wr(ip,Lm_orb,:,isp,iso) = wr(ip,Lm_orb,:,isp,iso) &
                                                                + Fac_up_dn(Lm,iso) * gso(ir,isp) * wr(ir,Lm_orb_p,:,isq,iso)
                
              if( Radial_comp ) then
                wi(ip,Lm_orb,:,isp,iso) = wi(ip,Lm_orb,:,isp,iso) + m_orb_s * gso(ir,isp) * wi(ir,Lm_orb,:,isp,iso) 
                if( abs( m_orb_p ) <= L ) wi(ip,Lm_orb,:,isp,iso) = wi(ip,Lm_orb,:,isp,iso) &
                                                                  + Fac_up_dn(Lm,iso) * gso(ir,isp) * wi(ir,Lm_orb_p,:,isq,iso)
              endif
            endif

            if( Hubb_m ) then

              do mp = -L,L
                do iso_p = 1,nspino

                  if( Spinorbite ) then
                    m_orb_p = mp - iso_p + isp
                    if( abs( m_orb_p ) > L ) cycle
                  else
                    m_orb_p = mp
                  endif 
                  if( Hubb_d .and. ( m /= mp .or. iso_p /= iso ) ) cycle
                  if( Spinorbite ) then
                    V_h = V_hubb(m,iso,mp,iso_p)  
                  else
                    V_h = V_hubb(m,isp,mp,isp)
                  endif
                  Lm_orb_p = Lm_orb - m_orb + m_orb_p

                  if( Radial_comp ) then
                    wr(ip,Lm_orb,:,isp,iso) = wr(ip,Lm_orb,:,isp,iso) + real( V_h, db) * wr(ir,Lm_orb_p,:,isp,iso_p) &
                                                                  - aimag( V_h ) * wi(ir,Lm_orb_p,:,isp,iso_p)
                    wi(ip,Lm_orb,:,isp,iso) = wi(ip,Lm_orb,:,isp,iso) + real( V_h, db) * wi(ir,Lm_orb_p,:,isp,iso_p) &
                                                                  + aimag( V_h ) * wr(ir,Lm_orb_p,:,isp,iso_p)
                  else
                    wr(ip,Lm_orb,:,isp,iso) = wr(ip,Lm_orb,:,isp,iso) + real( V_h, db) * wr(ir,Lm_orb_p,:,isp,iso_p)
                  endif
                end do
              end do

            endif

            if( Full_pot ) then
              do Lm_orb_p = 1,nlm_V
                do iso_p = 1,nspino

                  if( Lm_orb_p == Lm_orb .and. iso_p == iso ) cycle

                  wr(ip,Lm_orb,:,isp,iso) = wr(ip,Lm_orb,:,isp,iso) &
                                          + real( V(ir,Lm_orb,Lm_orb_p,isr), db ) * wr(ir,Lm_orb_p,:,isp,iso_p)
                  
                  if( Radial_comp ) then
                    wr(ip,Lm_orb,:,isp,iso) = wr(ip,Lm_orb,:,isp,iso) &
                                            - aimag( V(ir,Lm_orb,Lm_orb_p,isr) ) * wi(ir,Lm_orb_p,:,isp,iso_p)
                    wi(ip,Lm_orb,:,isp,iso) = wi(ip,Lm_orb,:,isp,iso) &
                                            + real( V(ir,Lm_orb,Lm_orb_p,isr), db ) * wi(ir,Lm_orb_p,:,isp,iso_p)
                    wi(ip,Lm_orb,:,isp,iso) = wi(ip,Lm_orb,:,isp,iso) &
                                            + aimag( V(ir,Lm_orb,Lm_orb_p,isr) ) * wr(ir,Lm_orb_p,:,isp,iso_p)
                  endif
                  
                end do
              end do
            endif

            wr(ip,Lm_orb,:,isp,iso) = - wr(ip,Lm_orb,:,isp,iso) / gp(ir,isr)
            if( Radial_comp )  wi(ip,Lm_orb,:,isp,iso) = - wi(ip,Lm_orb,:,isp,iso) / gp(ir,isr)

          end do
        end do
      end do
    end do
  end do

! In non spherical cases with spin-orbit, the index on spinor becomes the one of the state
! resulting in a sum of both spinors of the wave functions
  if( Spinorbite .and. nlm_fp > 1 ) then  
    do L = Li,Lf
      Hubb_m = Hubb_a .and. L == L_hubbard( Numat )
      if( Full_pot ) then
        Lm0 = L**2 + L + 1
      elseif( Hubb_m ) then
        Lm0 = L + 1    
      else
        cycle ! we are never here
      endif
      do m = - L,L
        Lm = Lm0 + m
        do iso_s = 1,nspino
          Lm_s = ( Lm - 1 ) * nspino + iso_s
          ur(:,:,Lm,:,iso_s) = wr(:,:,Lm_s,:,1) + wr(:,:,Lm_s,:,2)  
          ui(:,:,Lm,:,iso_s) = wi(:,:,Lm_s,:,1) + wi(:,:,Lm_s,:,2)
        end do
      end do
    end do  
  else
    ur(:,:,:,:,:) =  wr(:,:,:,:,:)
    ui(:,:,:,:,:) =  wi(:,:,:,:,:)
  endif
  
  deallocate( wi, wr )
  
  if( icheck > 3 ) then
    call write_ur(Full_pot,li,lf,nlm,nlm_fp,nr,nspinp,nspino,Numat,r,Radial_comp,10000._db,ui,ur,1)
  elseif( icheck > 2 ) then 
    call write_ur(Full_pot,li,lf,nlm,nlm_fp,nr,nspinp,nspino,Numat,r,Radial_comp,Rmtg,ui,ur,1)
  endif

  do Lm_orb = 1,nlm
    do Lm_s = 1,nlm_fp
      do isp = 1,nspinp
        do iso = 1,nspino
          ur(:,Lm_orb,Lm_s,isp,iso) = ur(:,Lm_orb,Lm_s,isp,iso) / r(:)
          if( Radial_comp ) ui(:,Lm_orb,Lm_s,isp,iso) = ui(:,Lm_orb,Lm_s,isp,iso) / r(:)
        end do
      end do
    end do
  end do

  if( .not. Renorm ) return

  call Renormal(Radial_comp,Full_pot,icheck,konde,LL,Lmax,nlm,nlm_fp,Normal_tau,nr,nrmtg,nspin,nspino,nspinp,r,Rmtg, &
                Tau,ui,ur,Failed)

    if( Failed ) then
      Full_potential_loc = .false.
      Failed = .false.
    else
      exit
    endif

  end do ! back to the beginning

 ! if( icheck > 2 .or. Failed ) then
  if( icheck > 2 ) then
    do ir = 1,nr
      ur(ir,:,:,:,:) = ur(ir,:,:,:,:) * r(ir)
      if( Radial_comp ) ui(ir,:,:,:,:) = ui(ir,:,:,:,:) * r(ir)
    end do
    if( icheck > 3 ) then
      call write_ur(Full_pot,li,lf,nlm,nlm_fp,nr,nspinp,nspino,Numat,r,Radial_comp,10000._db,ui,ur,2)
    else 
      call write_ur(Full_pot,li,lf,nlm,nlm_fp,nr,nspinp,nspino,Numat,r,Radial_comp,Rmtg,ui,ur,2)
    endif
    do ir = 1,nr
      ur(ir,:,:,:,:) = ur(ir,:,:,:,:) / r(ir)
      if( Radial_comp ) ui(ir,:,:,:,:) = ui(ir,:,:,:,:) / r(ir)
    end do
  endif
  
  return
  100 format(/'    Radius    ',1000('Vr(',i2,',',i2,')',3x,'Vi(',i2,',',i2,')',2x))
  140 format(1p,1000(1x,2e11.3))
end

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

! Prefactor of the spinors

subroutine PreFac_Spinor( Fac_Spinor, Lmax ) 

  use declarations
  implicit none
  
  integer:: is, isp, L, Lmax, Two_J, Two_J_z, Two_L_p_1 
  
  real(kind=db):: J_z
  
  real(kind=db), dimension(0:Lmax,-2*Lmax-1:2*Lmax+1,2,2):: Fac_Spinor
 
  Fac_Spinor(:,:,:,:) = 0._db
   
  do L = 0, Lmax

    Two_L_p_1 = 2 * L + 1
      
  ! J+: is = 1, J-: is = -1
    do is = -1,1,2  
      Two_J = 2 * L + is
      do Two_J_z = - Two_J, Two_J, 2
        J_z = 0.5_db * Two_J_z
         
        do isp = 1,2
      
          if( is == - 1 ) then
      
            if( isp == 1 ) then
              Fac_Spinor(L,Two_J_z,isp,2) = - sqrt( ( L + 0.5_db - J_z ) / Two_L_p_1 )    
            else
              Fac_Spinor(L,Two_J_z,isp,2) = sqrt( ( L + 0.5_db + J_z ) / Two_L_p_1 )
            endif
      
          else
      
            if( isp == 1 .and. Two_J_z > - Two_J ) then
              Fac_Spinor(L,Two_J_z,isp,1) = sqrt( ( L + 0.5_db + J_z ) / Two_L_p_1 )
            elseif( isp == 2 .and. Two_J_z < Two_J ) then
              Fac_Spinor(L,Two_J_z,isp,1) = sqrt( ( L + 0.5_db - J_z ) / Two_L_p_1 )
            endif
      
          endif
      
        end do
      
      end do
    end do
  
  end do  

  return
end

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

! Factor up-dn of in spinorbit

subroutine Cal_Fac_up_dn( Fac_up_dn, Full_pot, Hubb_m, Li, Lf, nlm, nspino ) 

  use declarations
  implicit none
  
  integer:: iso, L, Li, Lf, Lm, Lm0, m, nlm, nspino, Two_J_z, Two_J_p 
  
  logical:: Full_pot, Hubb_m 
  
  real(kind=db):: J_z
  
  real(kind=db), dimension(nlm,nspino):: Fac_up_dn

  Fac_up_dn(:,:) = 0._db
  
  Lm = 0
  do L = Li,Lf
    if( Full_pot ) then
      Lm0 = L**2 + L + 1
    elseif( Hubb_m ) then
      Lm0 = L + 1    
    else
      Lm0 = 1
    endif
    Two_J_p = 2 * L + 1
    do m = -L,L
      Lm = Lm + 1
      do iso = 1,nspino
        if( iso == 1 ) then
          J_z = m + 0.5_db
          Two_J_z = 2 * m + 1
        else
          J_z = m - 0.5_db
          Two_J_z = 2 * m - 1
        endif
        if( Two_J_z > Two_J_p ) cycle 
        Fac_up_dn(Lm,iso) = sqrt( ( L - J_z + 0.5_db ) * ( L + J_z + 0.5_db ) )
      end do
    end do
  end do

  return
end

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

! Writing of the radial function

subroutine Write_ur(Full_pot,li,lf,nlm,nlm_fp,nr,nspinp,nspinpo,Numat,r,Radial_comp,Rmtg,ui,ur,icom)

  use declarations
  implicit none

  integer:: i, icom, ir, isp, isol, k, kmax, L, li, lf, Lp, m, nlm, nlm_fp, mp, n, np, nr, nspinp, nspinpo, Numat

  integer, dimension(nspinpo):: Two_J_z
  integer, dimension(nspinp,nspinpo):: m_orb
  
  Character(len=14):: mot, mot14
  Character(len=2), dimension(nspinpo):: Jp
  Character(len=14), dimension(196):: Label, Labeli

  logical:: Full_pot, Radial_comp

  real(kind=db):: Rmtg
  real(kind=db), dimension(nr):: r
  real(kind=db), dimension(nr,nlm,nlm_fp,nspinp,nspinpo):: ui, ur
  real(kind=db), dimension(nlm_fp,nspinp,nspinpo):: uui, uur

  if( nlm == 1 .and. nspinp == 1 ) then
    Label(1) = '     ur       '
    Labeli(1) = '     ui       '
    kmax = 1
  else
    k = 0
    do isol = 1,nspinpo
      np = 0
      do Lp = li,lf
        do mp = -Lp,Lp
            
          if( nlm_fp == 1 .and. mp /= 0 ) cycle
          do isp = 1,nspinp
            k = k + 1
            mot14 = ' ur(          '
            i = 5
            if( nspinp == 2 ) then
              if( isp == 1 ) then
                mot14(i:i) = 'u'
              else
                mot14(i:i) = 'd'
              endif
              i = i + 1
              if( nlm_fp > 1 ) then
                mot14(i:i) = ','
                i = i + 1
              endif
            endif
            if( nlm_fp > 1 ) then
              if( Full_pot ) then
                call ad_number(abs(Lp),mot14,14)
                i = i + 1
                mot14(i:i) = ','
                i = i + 1
              endif
              if( mp < 0 ) then
                mot14(i:i) = '-'
                i = i + 1
              endif
              call ad_number(abs(mp),mot14,14)
              i = i + 1
            endif
            if( nspinpo == 2 .and. nlm_fp == 1 ) then
              mot14(i:i) = ','
              i = i + 1
              if( isol == 1 ) then
                mot14(i:i) = 'u'
              else
                mot14(i:i) = 'd'
              endif
              i = i + 1
            endif
            mot14(i:i) = ')'
            label(k) = mot14
            if( Radial_comp ) then
              mot14(3:3) = 'i'
              labeli(k) = mot14
            endif
          end do
        end do
      end do
      if( nlm_fp > 1 ) exit
    end do
    kmax = k
    do k = 1,kmax
      mot = label(k)
      Call Center_word( mot, 14 )
      label(k) = mot
      if( Radial_comp ) then
        mot = labeli(k)
        Call Center_word( mot, 14 )
        labeli(k) = mot
      endif
   end do
  endif

  n = 0
  np = 0
  do L = li,lf

    if( nlm_fp == 1 ) then
      do m = -L,L ! the m of the basis
        if( nlm == 1 .and. m /= 0 ) cycle
        if( nlm == 1 ) then
          if( icom == 1 ) then
            write(3,110) Numat, L
          elseif( icom == 2 ) then
            write(3,120) Numat, L
          else
            write(3,130) Numat, L
          endif
        else
          if( icom == 1 ) then
            write(3,140) Numat, L, m
          elseif( icom == 2 ) then
            write(3,150) Numat, L, m
          else
            write(3,160) Numat, L, m
          endif
        endif
        if( nspinpo == 2 ) then
          do isol = 1,nspinpo
            do isp = 1,nspinp
            ! m_orb = m + s - sigma  : m of the orbital
            !       = m - isol + isp 
              m_orb(isp,isol) = m - isol + isp
              if( isol == 1 ) then
                ! s = 1/2
                Two_J_z(isol) = 2 * m + 1 
              else
                ! s = - 1/2
                Two_J_z(isol) = 2 * m - 1 
              endif
              if( m > - L .and. isol == 2 ) then
                Jp(isol) = 'J-'
              else
                Jp(isol) = 'J+'
              endif
            end do
          end do
          n = L + 1
        else
          n = n + 1
        endif
        
        if( nspinpo == 2 ) then
          if( Radial_comp ) then
            write(3,170)
            if( nspinpo == 2 ) write(3,175) ( Two_J_z(isol), Jp(isol), isol = 1,nspinpo )  
            if( nspinpo == 2 ) write(3,176) ( m_orb(:,isol), isol = 1,nspinpo )  
          else
            write(3,180)
            if( nspinpo == 2 ) write(3,185) ( Two_J_z(isol), Jp(isol), isol = 1,nspinpo )  
            if( nspinpo == 2 ) write(3,186) ( m_orb(:,isol), isol = 1,nspinpo )  
          endif
        endif
        if( Radial_comp ) then
          write(3,190) ( Label(k), Labeli(k), k = 1,kmax )
        else
          write(3,190) ( Label(k), k = 1,kmax )
        endif
        do ir = 1,nr
          do isol = 1,nspinpo
            do isp = 1,nspinp
              if( nspinpo == 1 ) then
                uur(:,isp,isol) = ur(ir,n,:,isp,isol)
                if( Radial_comp ) uui(:,isp,isol) =  ui(ir,n,:,isp,isol)
              elseif( abs( m_orb(isp,isol) ) > L ) then
                uur(:,isp,isol) = 0._db
                if( Radial_comp ) uui(:,isp,isol) = 0._db
              else
                uur(:,isp,isol) = ur(ir,n+m_orb(isp,isol),:,isp,isol)
                if( Radial_comp ) uui(:,isp,isol) = ui(ir,n+m_orb(isp,isol),:,isp,isol)
              endif
            end do
          end do
          if( Radial_comp ) then
            write(3,200) r(ir)*bohr, ( ( ( uur(np,isp,isol), uui(np,isp,isol), isp = 1,nspinp), np = 1,nlm_fp), &
                                             isol = 1,nspinpo )
          else
            write(3,200) r(ir)*bohr, ( ( ( uur(np,isp,isol), isp = 1,nspinp), np = 1,nlm_fp), isol = 1,nspinpo )
          endif
          
          if( r(ir) > Rmtg + eps10 ) exit
        end do
      end do

    else

      do mp = -L,L
        np = np + 1
        do isol = 1,nspinpo
          if( nspinpo == 1 ) then
            if( icom == 1 ) then
              write(3,140) Numat, L, mp
            elseif( icom == 2 ) then
              write(3,150) Numat, L, mp
            else
              write(3,160) Numat, L, mp
            endif
          else
            if( icom == 1 ) then
              write(3,210) Numat, L, mp, isol
            elseif( icom == 2 ) then
              write(3,220) Numat, L, mp, isol
            else
              write(3,230) Numat, L, mp, isol
            endif
          endif
          if( Radial_comp ) then
            write(3,190) ( Label(k), Labeli(k), k = 1,kmax )
            do ir = 1,nr
              write(3,200) r(ir)*bohr, ( ( ur(ir,n,np,isp,isol), ui(ir,n,np,isp,isol), isp = 1,nspinp), n = 1,nlm )
              if( r(ir) > Rmtg + eps10 ) exit
            end do
          else
            write(3,190) ( Label(k), k = 1,kmax )
            do ir = 1,nr
              write(3,200) r(ir)*bohr, ( ( ur(ir,n,np,isp,isol), isp = 1,nspinp), n = 1,nlm )
              if( r(ir) > Rmtg + eps10 ) exit
            end do
          endif
        end do
      end do
    endif
  end do

  return
  110 format(/' Radial regular wave function time r:  Z =',i3,', L =',i2,/)
  120 format(/' Radial regular wave function, time r, after normalization:', '  Z =',i3,', L =',i2,/)
  130 format(/' Radial irregular wave function time r:  Z =',i3,', L =',i2,/)
  140 format(/' Radial regular wave function time r:  Z =',i3,', L =',i2, ', m =',i2,/)
  150 format(/' Radial regular wave function, time r, after normalization:', '  Z =',i3,', L =',i2,', m =',i2,/)
  160 format(/' Radial irregular wave function time r:  Z =',i3,', L =',i2, ', m =',i2,/)
  170 format(35x,' Solution 1',43x,' Solution 2')
  175 format(10x,2(20x,' J_z =',i2,'/2, ',a2,21x))
  176 format(11x,4(11x,'m_orb =',i2,6x))
  180 format(22x,' Solution 1',16x,' Solution 2')
  185 format(10x,2(10x,' J_z =',i2,'/2, ',a2,3x))
  186 format(10x,4(5x,'m_orb =',i2))
  190 format('    Radius  ',392a14)
  200 format(f11.7,1p,491e14.6)
  210 format(/' Radial regular wave function time r:  Z =',i3,', L =',i2, ', m =',i2,', Solution',i2,/)
  220 format(/' Radial regular wave function, time r, after normalization:', '  Z =',i3,', L =',i2,', m =',i2,', Solution',i2,/)
  230 format(/' Radial irregular wave function time r:  Z =',i3,', L =',i2, ', m =',i2,', Solution',i2,/)
end

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

! Normalisation of radial functions using continuity at muffin-tin radius with solutions in vaccum
! Called by Sch_radial

subroutine Renormal(Radial_comp,Full_pot,icheck,konde,LL,Lmax,nlm,nlm_fp,Normal_tau,nr,nrmtg,nspin,nspino,nspinp,r, &
                  Rmtg,Tau,ui,ur,Failed)

  use declarations
  implicit none

  integer:: icheck, inr, ir, iso, iso_p, isp, isr, L, LL, Lm, Lm_s, Lmax, Lp, m, nlm, nlm_fp, mp, n, np, nr, nrmtg, nspin, nspino, &
            nspinp

  complex(kind=db):: z
  complex(kind=db), dimension(0:Lmax):: bess, d_hank, d_bess, hank
  complex(kind=db), dimension(nspin):: konde, s1, s2
  complex(kind=db), dimension(nlm,nlm_fp,nspinp,nspino):: Ampl
  complex(kind=db), dimension(nlm,nspinp,nlm,nspinp):: Ampl_fp, Tau
  complex(kind=db), dimension(nlm,nlm_fp,nspinp,nspino):: u1, u2, Wronske, Wronsks
  complex(kind=db), dimension(2,0:Lmax,nspin):: bs, hs

  logical:: Failed, Full_pot, Normal_tau, Radial_comp

  real(kind=db):: a, ai, b, bi, c, ci, d0, d01, d02, d1, d2, d12, Rmtg, Wronskout
  real(kind=db), dimension(nr):: r
  real(kind=db), dimension(nr,nlm,nlm_fp,nspinp,nspino):: ui, ur

  inr = min( nrmtg, nr )
  d12 = r(inr-1) - r(inr-2)
  d01 = r(inr) - r(inr-1)
  d02 = r(inr) - r(inr-2)
  d2 = 1 / ( d12 * d02 )
  d1 = 1 / ( d12 * d01 )
  d0 = 1 / ( d01 * d02 )

  Wronske(:,:,:,:) = (0._db, 0._db)
  Wronsks(:,:,:,:) = (0._db, 0._db)
  u1(:,:,:,:) = (0._db, 0._db)
  u2(:,:,:,:) = (0._db, 0._db)

! Hankel function and its derivative (versus r, not z) at Rmtg
  do isp = 1,nspin
    call Cal_Hankel(d_hank,hank,konde(isp),Lmax,Rmtg,.false.)
    hs(1,0:Lmax,isp) = hank(0:Lmax)
    hs(2,0:Lmax,isp) = d_hank(0:Lmax)
    call Cal_Bessel(d_bess,bess,konde(isp),Lmax,Rmtg)
    bs(1,0:Lmax,isp) = bess(0:Lmax)
    bs(2,0:Lmax,isp) = d_bess(0:Lmax)
  end do

  do isp = 1,nspinp
    do iso = 1,nspino
      do m = 1,nlm
        do mp = 1,nlm_fp

          a = ur(inr-2,m,mp,isp,iso) * d2 - ur(inr-1,m,mp,isp,iso) * d1 + ur(inr,m,mp,isp,iso) * d0
          b = ( ur(inr-1,m,mp,isp,iso) - ur(inr-2,m,mp,isp,iso)) / d12 - a * ( r(inr-1) + r(inr-2) )
          c = ur(inr,m,mp,isp,iso) - a * r(inr)**2 - b * r(inr)

          if( Radial_comp ) then
            ai = ui(inr-2,m,mp,isp,iso) * d2 - ui(inr-1,m,mp,isp,iso) * d1 + ui(inr,m,mp,isp,iso) * d0
            bi = (ui(inr-1,m,mp,isp,iso) - ui(inr-2,m,mp,isp,iso)) / d12  - ai * ( r(inr-1) + r(inr-2) )
            ci = ui(inr,m,mp,isp,iso) - ai * r(inr)**2 - bi *r(inr)
          endif
          
          if( Radial_comp ) then
            u1(m,mp,isp,iso) = cmplx( a * Rmtg**2 + b * Rmtg + c,  ai * Rmtg**2 + bi * Rmtg + ci, db )
            u2(m,mp,isp,iso) = cmplx( 2 * a * Rmtg + b, 2 * ai * Rmtg + bi, db )
          else
            u1(m,mp,isp,iso) = cmplx( a * Rmtg**2 + b * Rmtg + c, 0._db, db )
            u2(m,mp,isp,iso) = cmplx( 2 * a * Rmtg + b, 0._db, db )
          endif

        end do
      end do
    end do
  end do

! Wronskout = W(j,-ih)
! The following formula for Wronskout comes from normalisation by sqrt(k/pi) of Bessel and Hankel functions
  Wronskout = 1 / ( pi * Rmtg**2 )

  n = 0
  do L = 0,Lmax
    if( .not. Full_pot .and. L /= LL ) cycle
    s1(:) = - img * hs(1,L,:)
    s2(:) = - img * hs(2,L,:)
    do m = -L,L
      if( nlm_fp == 1 .and. m > -L ) exit
      n = n + 1
      do isp = 1,nspinp
        isr = min( isp, nspin )
        if( nlm_fp == 1 ) then
          Wronsks(:,1,isp,:) = u1(:,1,isp,:) * s2(isr) - u2(:,1,isp,:) * s1(isr)
          Wronske(:,1,isp,:) = u1(:,1,isp,:) * bs(2,L,isr) - u2(:,1,isp,:) * bs(1,L,isr)
        else
! Wronskian index are in the same order than "u", second index is thus the one defining the state, which must run in the product for normalisation
          Wronsks(n,:,isp,:) = u1(n,:,isp,:) * s2(isr) - u2(n,:,isp,:) * s1(isr)
          Wronske(n,:,isp,:) = u1(n,:,isp,:) * bs(2,L,isr) - u2(n,:,isp,:) * bs(1,L,isr)
        endif
      end do
    end do
  end do

  if( icheck > 2 ) then
    n = 0
    do L = 0,Lmax
      if( .not. Full_pot .and. L /= LL ) cycle
      write(3,110) L
      write(3,120) - img * hs(1,L,:)
      write(3,130) - img * hs(2,L,:)
      write(3,140) bs(1,L,:)
      write(3,150) bs(2,L,:)
      write(3,160) Wronskout
      if( nspino == 2 ) then
        write(3,162)
      elseif( nspinp == 2 ) then
        write(3,164)
      else
        write(3,166)
      endif
      do m = -L,L
        if( nlm == 1 .and. m /= 0 ) cycle
        n = n + 1
        np = 0
        do Lp = 0,Lmax
          if( .not. Full_pot .and. Lp /= LL ) cycle
          do mp = -Lp,Lp
            if( nlm_fp == 1 .and. mp /= 0 ) cycle
            np = np + 1
            write(3,170) L, m, Lp, mp, ' Wronsks   =', ( Wronsks(n,np,:,iso), iso = 1,nspino )
            write(3,170) L, m, Lp, mp, ' u1        =', ( u1(n,np,:,iso), iso = 1,nspino )
            write(3,170) L, m, Lp, mp, ' u2        =', ( u2(n,np,:,iso), iso = 1,nspino )
          end do
        end do
      end do
    end do
  endif

  call Cal_ampl( Ampl, Ampl_fp, Full_pot, icheck, LL, Lmax, nlm, nlm_fp, Normal_tau, nspino, nspinp, Tau, Wronske, Wronsks, &
                 Wronskout, Failed )

  if( Failed ) return

  do ir = 1,nr

    if( Radial_comp ) then
      u1(:,:,:,:) =  cmplx( ur(ir,:,:,:,:), ui(ir,:,:,:,:), db )
      ur(ir,:,:,:,:) = 0._db
      ui(ir,:,:,:,:) = 0._db
    else
      u1(:,:,:,:) =  cmplx( ur(ir,:,:,:,:), 0._db, db )
      ur(ir,:,:,:,:) = 0._db
    endif

    if( nlm_fp == 1 .and. nspino == 1 ) then

      do isp = 1,nspinp
        do n = 1,nlm
          z = Ampl(n,1,isp,1) * u1(n,1,isp,1)
          ur(ir,n,1,isp,1) = real( z, db )
          if( Radial_comp ) ui(ir,n,1,isp,1) = aimag( z )
        end do
      end do

    elseif( nlm_fp == 1 .and. nspino == 2 ) then

      do isp = 1,nspinp
        n = 0
        do m = -LL,LL
          n = n + 1
          do iso = 1,nspino ! the spin of the incoming wave becomes the solution index
 
            mp = m + iso - isp
            if( mp > LL .or. mp < -LL ) cycle
            np = n + iso - isp

            z = sum( Ampl(np,1,iso,:) * u1(n,1,isp,:) )

            ur(ir,n,1,isp,iso) = real( z, db )
            if( Radial_comp ) ui(ir,n,1,isp,iso) = aimag( z )

          end do
        end do
      end do

    elseif( nspino == 1 ) then

      do isp = 1,nspinp

        do Lm = 1,nlm
          do Lm_s = 1,nlm

            z = sum( Ampl_fp(Lm_s,isp,:,isp) * u1(Lm,:,isp,1) )
            ur(ir,Lm,Lm_s,isp,1) = real( z, db )
            if( Radial_comp )  ui(ir,Lm,Lm_s,isp,1) = aimag( z )

          end do
        end do

      end do

    else

      do Lm = 1,nlm
        do isp = 1,nspinp
          do Lm_s = 1,nlm
            do iso = 1,nspino ! Solution index is also the incoming spin

              z = ( 0._db, 0._db )
              do iso_p = 1,nspino
                z = z + sum( Ampl_fp(Lm_s,iso,:,iso_p) * u1(Lm,:,isp,iso_p) )
              end do
              ur(ir,Lm,Lm_s,isp,iso) = real( z, db )
              if( Radial_comp )  ui(ir,Lm,Lm_s,isp,iso) = aimag( z )

            end do
          end do
        end do
      end do

    endif

  end do

  return
  110 format(/' Renormalisation parameters, L =',i2)
  120 format(/' -i.hankel =',1p,8e11.3)
  130 format('     deriv =',1p,8e11.3)
  140 format('    bessel =',1p,8e11.3)
  150 format('     deriv =',1p,8e11.3)
  160 format(' Wronskout =',1p,8e11.3)
  162 format('  L  m Lp mp',21x,'up up',17x,'dn up',17x,'up dn',17x, 'dn dn')
  164 format('  L  m Lp mp',  23x,'up',19x,'dn')
  166 format('  L  m Lp mp')
  170 format(4i3,a12,1p,16e11.3)
end

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

! Calculation of the amplitudes of the radial functions

subroutine Cal_ampl( Ampl, Ampl_fp, Full_pot, icheck, LL, Lmax, nlm, nlm_fp, Normal_tau, nspino, nspinp, Tau, Wronske, Wronsks, &
                     Wronskout, Failed )

  use declarations
  implicit none

  integer, parameter:: Length_col = 27
  integer, parameter:: Length_n = 3
  
  integer:: i, icheck, ipr, iso, isp, ispp, j, L, LL, Lm, Lm_s, Lmax, m, nlm, nlm_fp, mq, n, n_dim, nd, ndim, np, &
            nspino, nspinp, nu

  character(len=Length_n):: Name 
  character(len=Length_name):: Matrix_info
  character(len=Length_col), dimension(:), allocatable:: Col_name 

  complex(kind=db):: Det
  complex(kind=db), dimension(nlm,nspinp,nlm,nspinp):: Ampl_fp, Tau
  complex(kind=db), dimension(nlm,nlm_fp,nspinp,nspino):: Amp, Ampl, Wronske, Wronsks

  complex(kind=db), dimension(:,:), allocatable:: Mat_A, Mat_e, Mat_s, Mat_T

  logical:: Failed, Full_pot, Normal_tau, Stop_job

  real(kind=db):: Wronskout

  Failed = .false.
  Stop_job = .true.

  Amp(:,:,:,:) = (0._db, 0._db)
  Ampl(:,:,:,:) = (0._db, 0._db)
  Tau(:,:,:,:) = (0._db, 0._db)

  if( nlm_fp == 1 ) then

    if( nspino == 1 ) then
      do isp = 1,nspinp
        do n = 1,nlm
          if( Normal_tau ) then
            Ampl(n,1,isp,1) = - Wronskout / Wronske(n,1,isp,1)
          else
            Ampl(n,1,isp,1) = Wronskout / Wronsks(n,1,isp,1)
          endif
          Tau(n,isp,n,isp) = - Wronske(n,1,isp,1) / Wronsks(n,1,isp,1)
        end do
      end do

    else

! Pour Ampl, isp est le spin d'attaque (donc l'indice de solution apres la renormalisation)
! Le m de Amp est m + 1/2 - is = m + iso - 1
      do m = -LL-1,LL
        if( m == -LL-1 ) then
          isp = 2
          iso = 2
          mq = m + isp - 1
          n = LL + 1 + mq
          if( Normal_tau ) then
            Ampl(n,1,isp,iso) = - Wronskout / Wronske(n,1,isp,iso)
          else
            Ampl(n,1,isp,iso) = Wronskout / Wronsks(n,1,isp,iso)
          endif
          Tau(n,isp,n,isp) = - Wronske(n,1,isp,iso) / Wronsks(n,1,isp,iso)
        elseif( m == LL ) then
          isp = 1
          iso = 1
          mq = m + isp - 1
          n = LL + 1 + mq
          if( Normal_tau ) then
            Ampl(n,1,isp,iso) = - Wronskout / Wronske(n,1,isp,iso)
          else
            Ampl(n,1,isp,iso) = Wronskout / Wronsks(n,1,isp,iso)
          endif
          Tau(n,isp,n,isp) = - Wronske(n,1,isp,iso) / Wronsks(n,1,isp,iso)
        else
          nu = LL + 1 + m
          nd = LL + 1 + m + 1
          Det = Wronsks(nu,1,1,1) * Wronsks(nd,1,2,2) - Wronsks(nd,1,2,1) * Wronsks(nu,1,1,2)
          Amp(nu,1,1,1) = Wronsks(nd,1,2,2) / Det
          Amp(nu,1,1,2) = - Wronsks(nd,1,2,1) / Det
          Amp(nd,1,2,1) = - Wronsks(nu,1,1,2) / Det
          Amp(nd,1,2,2) = Wronsks(nu,1,1,1) / Det

          do isp = 1,nspinp
            n = LL + 1 + m + isp - 1
            do ispp = 1,nspinp
              np = LL + 1 + m + ispp - 1
              Tau(n,isp,np,ispp) = (0._db,0._db)
              do iso = 1,nspino
                Tau(n,isp,np,ispp) = Tau(n,isp,np,ispp) - Amp(n,1,isp,iso) * Wronske(np,1,ispp,iso)
              end do
            end do
          end do

          if( Normal_tau ) then
            Det = Wronske(nu,1,1,1) * Wronske(nd,1,2,2) - Wronske(nd,1,2,1) * Wronske(nu,1,1,2)
            Ampl(nu,1,1,1) = - Wronskout * Wronske(nd,1,2,2) / Det
            Ampl(nu,1,1,2) = Wronskout * Wronske(nd,1,2,1) / Det
            Ampl(nd,1,2,1) = Wronskout * Wronske(nu,1,1,2) / Det
            Ampl(nd,1,2,2) = - Wronskout * Wronske(nu,1,1,1) / Det
          else
            call write_error
            do ipr = 6,9,3
              write(ipr,'(A)') ' No normalisation by Tau not possible with spin-orbit !'
            end do
            stop
          endif

        endif
      end do
    endif

  elseif( nspino == 1 .and. nlm == nlm_fp ) then

    ndim = nlm_fp
    allocate( Mat_e(ndim,ndim) )
    allocate( Mat_s(ndim,ndim) )
    allocate( Mat_A(ndim,ndim) )
    allocate( Mat_T(ndim,ndim) )

    Mat_e(:,:) = ( 0._db, 0._db )
    Mat_s(:,:) = ( 0._db, 0._db )
    Mat_A(:,:) = ( 0._db, 0._db )
    Mat_T(:,:) = ( 0._db, 0._db )

    do isp = 1,nspinp
   
      do Lm_s = 1,nlm_fp
        do Lm = 1,nlm
          Mat_e(Lm_s,Lm) = Wronske(Lm,Lm_s,isp,1)
          Mat_s(Lm_s,Lm) = Wronsks(Lm,Lm_s,isp,1)
        end do
      end do
      
      if( icheck > 3 ) then
        write(3,110) 'incoming'
        do i = 1,ndim
          write(3,130) i, Mat_e(i,:)
        end do
        write(3,110) 'outgoing'
        do i = 1,ndim
          write(3,130) i, Mat_s(i,:)
        end do
      endif

      Matrix_info = ' Wronsks matrix, nlm_fp > 1 case, from cal_ampl'
      call invcomp(Matrix_info,ndim,Mat_s,ndim,ndim,0,Stop_job)

! Mat_T is line Lm orb in, column Lm orb out 
      Mat_T = - matmul( Mat_s, Mat_e )

      if( Normal_tau ) then
        Matrix_info = ' Mat_e matrix, nlm_fp > 1 case, from cal_ampl'
        call invcomp(Matrix_info,ndim,Mat_e,ndim,ndim,0,Stop_job)
! because inverse, Mat_A line is Lm orbital and spin (that is Lm and spin attack which define the new states), column is state and iso 
        Mat_A = - Wronskout * Mat_e
      else
        Mat_A = - Wronskout * Mat_s
      endif

      Mat_A = Transpose( Mat_A ) 

      do Lm = 1,nlm
        do Lm_s = 1,nlm_fp
  ! Line is state, column is Lm orbital
          Ampl_fp(Lm_s,isp,Lm,isp) = Mat_A(Lm,Lm_s)
          Tau(Lm_s,isp,Lm,isp) = Mat_T(Lm,Lm_s)
        end do
      end do
    
    end do

    deallocate( Mat_A, Mat_e, Mat_s, Mat_T )
    
  elseif( nspino == nspinp .and. nlm == nlm_fp ) then

    ndim = nspino * nlm_fp
    allocate( Mat_e(ndim,ndim) )
    allocate( Mat_s(ndim,ndim) )
    allocate( Mat_A(ndim,ndim) )
    allocate( Mat_T(ndim,ndim) )

    Mat_e(:,:) = ( 0._db, 0._db )
    Mat_s(:,:) = ( 0._db, 0._db )
    Mat_A(:,:) = ( 0._db, 0._db )
    Mat_T(:,:) = ( 0._db, 0._db )

    i = 0
    do Lm_s = 1,nlm_fp
      do iso = 1,nspino
        i = i + 1
        j = 0
        do Lm = 1,nlm
          do isp = 1,nspinp
            j = j + 1
  ! Line is state and iso, column is Lm orbital and spin in
            Mat_e(i,j) = Wronske(Lm,Lm_s,isp,iso)
            Mat_s(i,j) = Wronsks(Lm,Lm_s,isp,iso)
          end do
        end do
      end do
    end do
      
    if( icheck > 3 ) then
      write(3,110) 'incoming'
      do i = 1,ndim
        write(3,130) i, Mat_e(i,:)
      end do
      write(3,110) 'outgoing'
      do i = 1,ndim
        write(3,130) i, Mat_s(i,:)
      end do
    endif

    Matrix_info = ' Wronsks matrix, nlm_fp > 1 case, from cal_ampl'
    call invcomp(Matrix_info,ndim,Mat_s,ndim,ndim,0,Stop_job)
! because inverse, in Mat_s line is Lm orbital and spin out, column is state and iso

! Mat_T is line Lm orb spin in, column Lm orb spin out ( in-out because for the "in-" here spin-out = spin-in because of the Kroenicker symbol )

    Mat_T = - matmul( Mat_s, Mat_e )

    if( Normal_tau ) then
      Matrix_info = ' Mat_e matrix, nlm_fp > 1 case, from cal_ampl'
      call invcomp(Matrix_info,ndim,Mat_e,ndim,ndim,0,Stop_job)
! because inverse, Mat_A line is Lm orbital and spin (that is Lm and spin attack which define the new states), column is state and iso 
      Mat_A = - Wronskout * Mat_e
    else
      Mat_A = - Wronskout * Mat_s
    endif

! Transpose to be line state iso, column Lm orbital and spin    
    Mat_A = Transpose( Mat_A ) 

    i = 0
    do Lm = 1,nlm
      do isp = 1,nspinp ! spin attack defining new state
        i = i + 1
        j = 0
        do Lm_s = 1,nlm_fp
          do iso = 1,nspino
            j = j + 1
  ! Line is state and iso, column is Lm orbital and spin
            Ampl_fp(Lm_s,iso,Lm,isp) = Mat_A(i,j)
  ! Line is state and iso, column is Lm orbital and spin out
            Tau(Lm_s,iso,Lm,isp) = Mat_T(i,j)
          end do
        end do
      end do
    end do

    deallocate( Mat_A, Mat_e, Mat_s, Mat_T )
    
  else

    call write_error
    do ipr = 6,9,3
      write(ipr,135) nspino, nspinp, nlm, nlm_fp
    end do
    stop
    
  endif

  if( icheck > 1 ) then
    if( nlm == 1 .and. nspinp == 1 ) then
      write(3,140)
    elseif( nlm == 1 ) then
      write(3,150)
    elseif( nlm_fp == 1 .and. nspino == 2 ) then
      write(3,155)
    else
      n_dim = nlm * nspinp  
      allocate( Col_name(n_dim) )
      Name = 'Amp'
      if( Full_pot .and. nspinp == 2 ) then
        call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
      elseif( Full_pot ) then
        call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
      elseif( nspinp == 2 ) then
        call Create_col_name(Col_name,LL,LL,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
      else
        call Create_col_name(Col_name,LL,LL,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
      endif
      if( nspinp == 1 ) then
        write(3,'(/a8,100a27)') '  L  m  ', Col_name(:)
      else
        write(3,'(/a10,100a27)') '  L  m isp', Col_name(:)
      endif
      deallocate( Col_name )
    endif

    do isp = 1,nspinp
      n = 0
      do L = 0,Lmax
        if( .not. Full_pot .and. L /= LL ) cycle
        do m = -L,L
          if( nlm == 1 .and. m /= 0 ) cycle
          n = n + 1
          if( nlm == 1 .and. nspinp == 1 ) then
            write(3,220) L, Ampl(n,1,isp,min(isp,nspino))
          elseif( nlm == 1 ) then
            write(3,230) L, isp, Ampl(n,1,isp,min(isp,nspino))
          elseif( nlm_fp == 1 .and. nspinp == 1 ) then
            write(3,230) L, m, Ampl(n,1,isp,:)
          elseif( nlm_fp == 1 ) then
            write(3,240) L, m, isp, Ampl(n,1,isp,:)
          elseif( nspinp == 1 ) then
            write(3,230) L, m, Ampl_fp(n,1,:,1)
          else
            write(3,240) L, m, isp, ( Ampl_fp(n,isp,:,iso), iso = 1,nspino )
          endif
        end do
        if( nlm_fp == 1 .and. nspino == 1 ) exit
      end do
    end do
  endif

  if( icheck > 1 ) then
    if( nlm == 1 .and. nspinp == 1 ) then
      write(3,180)
    elseif( nlm == 1 ) then
      write(3,190)
    else
      n_dim = nlm * nspinp 
      allocate( Col_name(n_dim) )
      Name = 'Tau'
      if( Full_pot .and. nspinp == 2 ) then
        call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
      elseif( Full_pot ) then
        call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
      elseif( nspinp == 2 ) then
        call Create_col_name(Col_name,LL,LL,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
      else
        call Create_col_name(Col_name,LL,LL,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
      endif
      if( nspinp == 1 ) then
        write(3,'(/a8,100a27)') '  L  m  ', Col_name(:)
      else
        write(3,'(/a10,100a27)') '  L  m isp', Col_name(:)
      endif
      deallocate( Col_name )
    endif
    do isp = 1,nspinp
      n = 0
      do L = 0,Lmax
        if( .not. Full_pot .and. L /= LL ) cycle
        do m = -L,L
          if( nlm == 1 .and. m /= 0 ) cycle
          n = n + 1
          if( nlm == 1 .and. nspinp == 1 ) then
            write(3,220) L, Tau(n,isp,n,isp)
          elseif( nlm == 1 ) then
            write(3,230) L, isp, Tau(n,isp,n,isp)
          elseif( nlm_fp == 1 .and. nspinp == 1 ) then
            write(3,230) L, m, Tau(n,isp,n,isp)
          elseif( nlm_fp == 1 .and. nspino == 1 ) then
            write(3,240) L, m, isp, Tau(n,isp,n,isp)
          elseif( nspinp == 1 ) then
            write(3,230) L, m, ( Tau(n,isp,:,ispp), ispp = 1,nspinp )
          else
            write(3,240) L, m, isp, ( Tau(n,isp,:,ispp), ispp = 1,nspinp )
          endif
        end do
        if( nlm_fp == 1 .and. nspino == 1 ) exit
      end do
    end do
  endif

! Test on the calculation
  if( Full_pot ) then
    do n = 1,nlm
      do np = n+1,nlm
        do isp = 1,nspinp
          if( ( abs( Tau(n,isp,np,isp) ) < abs( Tau(n,isp,n,isp) ) ) &
                         .or. ( abs( Tau(n,isp,np,isp) ) < abs( Tau(np,isp,np,isp) ) ) ) cycle
          if( icheck > 0 ) then
            if( .not. Failed ) then
              if( nspinp == 1 ) then
                write(3,250) n, np, Tau(n,isp,np,isp), Tau(n,isp,n,isp), Tau(np,isp,np,isp)
              else
                write(3,260) n, np, isp, Tau(n,isp,np,isp), Tau(n,isp,n,isp), Tau(np,isp,np,isp)
              endif 
            else
              if( nspinp == 1 ) then
                write(3,270) n, np, Tau(n,isp,np,isp), Tau(n,isp,n,isp), Tau(np,isp,np,isp)
              else
                write(3,280) n, np, isp, Tau(n,isp,np,isp), Tau(n,isp,n,isp), Tau(np,isp,np,isp)
              endif
            endif
          endif
          Failed = .true.
        end do
      end do
    end do
    if( Failed .and. icheck > 0 ) write(3,'(A)') ' Off-diagonal potential neglected !' 
  endif

  return
  110 format(/' Wronskian ',a8,' matrix')
  130 format(i3,1p,100(1x,2e13.5))
  135 format(' Error in cal_ampl:', / &
             ' npinp =',i2,' /= nspino =',i2, ' or', /&
             ' nlm =',i3,' /= nlm_fp =',i3,' !')
  140 format(/' Amplitude',/'  L',11x,'Ampl')
  150 format(/' Amplitude',/'  L isp',9x,'Ampl')
  155 format(/' Amplitude',/'  L  m isp',6x,'Ampl(Sol 1)',12x, 'Ampl(Sol 2)')
  180 format(/'  L',11x,'Tau')
  190 format(/'  L isp',10x,'Tau')
  220 format(i3,1p,16(1x,2e13.5))
  230 format(2i3,1p,16(1x,2e13.5))
  240 format(3i3,1p,16(1x,2e13.5))
  250 format(/' Off-digonal abs(Tau) higher than diagonal for Lm =',i3,', Lmp =',i3,1p, &
                                            ', Tau(Lm,Lmp) =',2e13.5,', Tau(Lm,Lm) =',2e13.5,', Tau(Lmp,Lmp) =',2e13.5)
  260 format(/' Off-digonal abs(Tau) higher than diagonal for Lm =',i3,', Lmp =',i3,', isp =',i2,1p, &
                                            ', Tau(Lm,Lmp) =',2e13.5,', Tau(Lm,Lm) =',2e13.5,', Tau(Lmp,Lmp) =',2e13.5)
  270 format(47x,'Lm =',i3,', Lmp =',i3,1p,', Tau(Lm,Lmp) =',2e13.5,', Tau(Lm,Lm) =',2e13.5,', Tau(Lmp,Lmp) =',2e13.5)
  280 format(47x,'Lm =',i3,', Lmp =',i3,', isp =',i2,1p,', Tau(Lm,Lmp) =',2e13.5,', Tau(Lm,Lm) =',2e13.5,', Tau(Lmp,Lmp) =',2e13.5)
  
end

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

! Calculation of basis functions on the FDM grid points 
! used in Mat_FDM

subroutine Cal_phiato( Full_pot, ia, iang, ibord, icheck, iopsymr, LL, Lmax, nlm, nlm_fp, natome, nbord, nbtm, &
             nbtm_fdm, nlmagm, nlmmax, nphiato, nphiato_c, npsom, nr, nspinp, nspino, Phiato, Phiato_c, Posi,r, &
             Radial_comp, Spinorbite, ui, ur, xyz, Ylm_comp, Ylmato )

  use declarations
  implicit none

  integer:: i, ia, iang, ib, icheck, iso, isp, isym, jsol, jsp, L, LL, Lm, Lm0, Lmax, Lmv, &
    Lp, m, mp, mpp, mv, n, natome, nbord, nbtm, nbtm_fdm, nlm, nlm_fp, nlmagm, nlmmax, np, &
    nphiato, nphiato_c, npsom, nr, nspinp, nspino

  integer, dimension(nopsm):: iopsymr
  integer, dimension(nbtm,natome):: ibord

  character(len=7):: mot7

  complex(kind=db):: phic, Yc
  complex(kind=db), dimension(nphiato_c,nlmagm,nspinp,nspino,natome):: Phiato_c

  logical:: Full_pot, Radial_comp, Spinorbite, Ylm_comp

  real(kind=db):: f_interp2, phi, phii, R_val, r0, rm, rp, u0, uc0, ucm, ucp, um, up
  real(kind=db), dimension(3):: ps, x, w
  real(kind=db), dimension(nbord):: rrel
  real(kind=db), dimension(nr):: r
  real(kind=db), dimension(3,natome):: posi
  real(kind=db), dimension(nr,nlm,nlm_fp,nspinp,nspino):: ui, ur
  real(kind=db), dimension(4,npsom):: xyz
  real(kind=db), dimension(nphiato,nlmagm,nspinp,nspino,natome):: Phiato
  real(kind=db), dimension(nbtm_fdm,nlmmax,natome):: Ylmato

  ps(1:3) = posi(1:3,ia)

  do ib = 1,nbord

    i = ibord(ib,ia)
    x(1:3) = xyz(1:3,i)

    call posrel(iopsymr,x,ps,w,rrel(ib),isym)
    
    R_val = rrel(ib)
    
    do i = 2,nr
      if( r(i) > R_val ) exit
    end do
      
    i = min(i,nr)   
    i = max(i,3)

    rm = r(i-2)
    r0 = r(i-1)
    rp = r(i)

    n = 0
    do L = 0,Lmax
      if( .not. Full_pot .and. L /= LL ) cycle
      Lm0 = L**2 + L + 1
      do m = -L,L
        if( nlm == 1 .and. m /= 0 ) cycle
        n = n + 1
        do isp = 1,nspinp
          if( iang == 1 ) then
            jsp = isp
          elseif( iang == - 1 ) then
            jsp = nspinp + 1 - isp
          endif

          np = 0
          do Lp = 0,Lmax
            if( .not. Full_pot .and. Lp /= L ) cycle
            do mp = -Lp,Lp
              if( nlm_fp == 1 .and. mp /= m ) cycle
              np = np + 1
              Loop_isol: do iso = 1,nspino
                if( iang == 1 ) then
                  jsol = iso
                elseif( iang == - 1 ) then
                  jsol = nspino + 1 - iso
                endif
                if( nlm_fp > 1 ) then
                  Lmv = Lp**2 + Lp + 1 + mp
                elseif( Spinorbite ) then
                  mv = m + iso - isp  ! mv is the one of the spinor
                  if( mv > L .or. mv < -L ) cycle
                  Lmv = Lm0 + mv
                else
                  Lmv = Lm0 + m
                endif
                mv = m

                if( iang == 0 ) then
                  if( nspino == 2 .and. isp /= iso ) cycle
                  um = 0.5_db * ( ur(i-2,n,np,1,1) + ur(i-2,n,np,min(2,nspinp),min(2,nspino)) )
                  u0 = 0.5_db * ( ur(i-1,n,np,1,1) + ur(i-1,n,np,min(2,nspinp),min(2,nspino)) )
                  up = 0.5_db * ( ur(i,n,np,1,1) + ur(i,n,np,min(2,nspinp),min(2,nspino)) )
                else
                  um = ur(i-2,n,np,jsp,jsol)
                  u0 = ur(i-1,n,np,jsp,jsol)
                  up = ur(i,n,np,jsp,jsol)
                endif
               
                if( Radial_comp ) then
                  if( iang == 0 ) then
                    if( nspino == 2 .and. isp /= iso ) cycle
                    ucm = 0.5_db * ( ui(i-2,n,np,1,1) + ui(i-2,n,np,min(2,nspinp),min(2,nspino)) )
                    uc0 = 0.5_db * ( ui(i-1,n,np,1,1) + ui(i-1,n,np,min(2,nspinp),min(2,nspino)) )
                    ucp = 0.5_db * ( ui(i,n,np,1,1) + ui(i,n,np,min(2,nspinp),min(2,nspino)) )
                  else
                    ucm = ui(i-2,n,np,jsp,jsol)
                    uc0 = ui(i-1,n,np,jsp,jsol)
                    ucp = ui(i,n,np,jsp,jsol)
                  endif
                endif
                               
                phi = f_interp2(R_val,rm,r0,rp,um,u0,up)
                if( Radial_comp ) then
                  phii = f_interp2(R_val,rm,r0,rp,ucm,uc0,ucp)
                else
                  phii = 0._db
                endif
                phic = cmplx( phi, phii, db )
             
                do mpp = -L,L
                  if( nlm /= 1 .and. mpp /= m ) cycle
                  Lm = Lm0 + mpp
                  if( nlm == 1 ) Lmv = Lm

                  if( nphiato > 0 ) then
                    Phiato(ib,Lmv,isp,iso,ia) = Phiato(ib,Lmv,isp,iso,ia) + phi * Ylmato(ib,Lm,ia)
                  elseif( Ylm_comp ) then
                    Phiato_c(ib,Lmv,isp,iso,ia) = Phiato_c(ib,Lmv,isp,iso,ia) &
                                                + phic * Yc(mpp,Ylmato(ib,Lm,ia),Ylmato(ib,Lm-2*mpp,ia))
                  else
                    Phiato_c(ib,Lmv,isp,iso,ia) = Phiato_c(ib,Lmv,isp,iso,ia) + phic * Ylmato(ib,Lm,ia)
                  endif
 
                end do

              end do Loop_isol
            end do
          end do

        end do
      end do
    end do
  end do
  
  if( icheck > 2 .and. ( Full_pot .or. LL == Lmax ) ) then  
    write(3,110) ia
    
    mot7 = ' Phiato'
    
    do L = 0,Lmax
      Lm0 = L**2 + L + 1
      do mp = -L,L
        if( nphiato > 0 ) then
          if( Spinorbite ) then
            write(3,120) mot7, mot7, mot7, mot7, L, mp
          elseif( nspinp == 2 ) then
            write(3,130) mot7, mot7, L, mp
          else
            write(3,140)  mot7, L, mp
          endif
        else
          if( Spinorbite ) then
            write(3,150) mot7, mot7, mot7, mot7, L, mp
          elseif( nspinp == 2 ) then
            write(3,160) mot7, mot7,L, mp
          else
            write(3,170) mot7, L, mp
          endif
        endif

        Lm = Lm0 + mp

        do ib = 1,nbord
          if( nphiato > 0 ) then
            write(3,210) ibord(ib,ia), rrel(ib)*bohr, ( Phiato(ib,Lm,:,iso,ia), iso = 1,nspino )
          else
            write(3,210) ibord(ib,ia), rrel(ib)*bohr, ( Phiato_c(ib,Lm,:,iso,ia), iso = 1,nspino )
          endif
        end do
          
      end do
    end do

  endif

  return
  100 format(/'    Radius',8x,'ur',10x,'ui',11x,'dur',10x,'dui',11x,'usr',10x,'usi',10x,'dusr',9x,'dusi,  Lm1 =',i2) 
  110 format(/' ia =',i3)
  120 format(/' ibord    rrel  ',a7,'(u,1) ',a7,'(d,1) ',a7,'(u,2) ',a7,'(d,2)   L =',i3,', m =',i3)
  130 format(/' ibord    rrel  ',a7,'(u)   ',a7,'(d)   L =',i3,', m =',i3)
  140 format(/' ibord    rrel  ',a7,'   L =',i3,', m =',i3)
  150 format(/' ibord    rrel   ',6x,a7,'(u,1)',14x,a7,'(d,1)',14x,a7,'(u,2)  ',14x,a7,'(d,2)   L =',i3,', m =',i3)
  160 format(/' ibord    rrel   ',7x,a7,'(u)',17x,a7,'(d)   L =',i3, ', m =',i3)
  170 format(/' ibord    rrel   ',9x,a7,13x,'  L =',i3, ', m =',i3)
  180 format(/' ibord    rrel   ',6x,a7,'(u,1)',14x,a7,'(d,1)',14x,a7,'(u,2)',14x,a7,'(d,2)',7x, &
              a7,'(u,1)_irreg',1x,a7,'(d,1)_irreg',8x,a7,'(u,2)_irreg',8x,a7,'(d,2)_irreg  L =',i3,', m =',i3)
  190 format(/' ibord    rrel   ',7x,a7,'(u)',16x,a7,'(d)',16x,a7,'(u)',16x,a7,'(d)',10x, &
              a7,'(u)_irreg',16x,a7,'(d)_irreg',16x,a7,'(u)_irreg',16x,a7,'(d)_irreg',11x,'L =',i3, ', m =',i3)
  200 format(/' ibord    rrel   ',9x,a7,16x,a7,'_irreg',11x,'  L =',i3, ', m =',i3)
  210 format(i5,f11.7,1p,16e13.4)
end

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

! used only with Spin_axis_free
! Spin_axis_free is not yet efficient

subroutine Rotate_phiato(iaprotoi,ibord,icheck,Lmaxat,n_atom_proto,natome,nbord,nbtm,nlmagm,nlmmax,nphiato_c, &
                               nspino,nspinp,Phiato_c,Rot_atom,Ylmato)

  use declarations
  implicit none

  integer:: ia, ib, icheck, iso, iso_p, isp, L, Lm, Lm0, Lm_p, Lmax, Lmv, Lmv_p, m, m_p, mv, mv_p, n_atom_proto, natome, &
    nbtm, nlmagm, nlmmax, nphiato_c, nspino, nspinp
 
  integer, dimension(0:n_atom_proto):: Lmaxat
  integer, dimension(natome):: iaprotoi, nbord
  integer, dimension(nbtm,natome):: ibord

  character(len=7):: mot7

  complex(kind=db):: Yc  
  complex(kind=db), dimension(nphiato_c,nlmagm,nspinp,nspino):: Phi
  complex(kind=db), dimension(nphiato_c,nlmagm,nspinp,nspino,natome):: Phiato_c

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

  logical:: Rotation
  
  real(kind=db), dimension(3,3):: Mat_rot
  real(kind=db), dimension(3,3,natome):: Rot_atom
  real(kind=db), dimension(nbtm,nlmmax,natome):: Ylmato

  do ia = 1,natome

    Lmax = Lmaxat( iaprotoi(ia) )
    Mat_rot(:,:) = Rot_atom(:,:,ia)

    Rotation = abs( Mat_rot(1,1) - 1._db ) > eps10 .or. abs( Mat_rot(2,2) - 1._db ) > eps10 &
                                                   .or. abs( Mat_rot(3,3) - 1._db ) > eps10
                                                       
    if( Rotation ) then
      allocate( Dlmsms(-Lmax:Lmax,2,-Lmax:Lmax,2,0:Lmax) )  
      call Dlmsms_half_integer(Dlmsms,icheck,.false.,Lmax,Mat_rot)
    endif
 
    Phi(:,:,:,:) = Phiato_c(:,:,:,:,ia)
    Phiato_c(:,:,:,:,ia) = ( 0._db, 0._db )

    do L = 0,Lmax
      Lm0 = L**2 + L + 1 
  
      do iso = 1,nspino
        do m = -L,L   ! m of the spinor
  
          do isp = 1,nspinp
          
            mv = m + isp - iso  !  m of the spherical harmonics 

  !!!!          if( mv > L .or. mv < -L ) cycle

  !!!!          Lmv = Lm0 + mv
            Lm = Lm0 + m
 
            if( Rotation ) then
                                  
              do iso_p = 1,nspino  
                do m_p = -L,L

                  mv_p = m_p + isp - iso_p

                  if( mv_p > L .or. mv_p < -L ) cycle
                
                  Lm_p = Lm0 + m_p
                  Lmv_p = Lm0 + mv_p
                
                  do ib = 1,nbord(ia)
 ! In the exit, the index Lm if of the spinor
                    Phiato_c(ib,Lm,isp,iso,ia) = Phiato_c(ib,Lm,isp,iso,ia) &
                                                  + Dlmsms(m,iso,m_p,iso_p,L) * Phi(ib,Lm_p,isp,iso_p) &
                                                  * Yc( mv_p, Ylmato(ib,Lmv_p,ia), Ylmato(ib,Lmv_p-2*mv_p,ia) )  
                  end do

                end do
              end do
            
            else

              if( mv > L .or. mv < -L ) cycle

              Lmv = Lm0 + mv

              do ib = 1,nbord(ia)
                Phiato_c(ib,Lm,isp,iso,ia) = Phi(ib,Lm,isp,iso) * Yc( mv, Ylmato(ib,Lmv,ia), Ylmato(ib,Lmv-2*mv,ia) )  
              end do
 
            endif
            
          end do
          
        end do
      end do
    end do
      
    if( Rotation ) deallocate( Dlmsms )
    
  end do
  
  if( icheck > 2 ) then
  
    Write(3,'(/A)') ' Phiato after rotation'
    do ia = 1,natome
      write(3,110) ia
    
      mot7 = ' Phiato'
      
      do L = 0,Lmax
        do m = -L,L
          write(3,120) mot7, mot7, mot7, mot7, L, m
          Lm = L**2 + L + 1 + m
          do ib = 1,nbord(ia)
            write(3,130) ibord(ib,ia), ( Phiato_c(ib,Lm,:,iso,ia), iso = 1,nspino )
          end do
        end do
      end do

    end do
    
  endif

  return
  110 format(/' ia =',i3)
  120 format(/' ibord',6x,a7,'(u,1)',14x,a7,'(d,1)',14x,a7,'(u,2)  ',14x,a7,'(d,2)   L =',i3,', m =',i3)
  130 format(i5,1p,16e13.4)
end

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

! Rotation of the spinor
! used only with "Spin_axis_free"
! Seems not efficient

subroutine Rotate_Ylms(iaprotoi,ibord,icheck,Lmaxat,n_atom_proto,natome,nbm_c,nbordf,nbtm,nlmmax, &
                               nspino,nspinp,Rot_atom,Ylmato,Ylms)

  use declarations
  implicit none

  integer:: ia, ib, icheck, iso, iso_p, isp, L, Lm, Lm0, Lmax, Lmv, Lmv_p, m, m_p, mv, mv_p, n_atom_proto, natome, nbm_c, nbtm, &
    nlmmax, nspino, nspinp
 
  integer, dimension(0:n_atom_proto):: Lmaxat
  integer, dimension(natome):: iaprotoi, nbordf
  integer, dimension(nbtm,natome):: ibord

  complex(kind=db):: Yc  
  complex(kind=db), dimension(nspinp):: Psi 
  complex(kind=db), dimension(nbm_c,nlmmax,nspinp,nspino,natome):: Ylms

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

  logical:: Jplus, Jplus_p, Rotation
  
  real(kind=db):: f, f_p, Jz, Jz_p, Prefac_spinor_bis
!  real(kind=db), dimension(2,2):: F
  real(kind=db), dimension(3,3):: Mat_rot
  real(kind=db), dimension(3,3,natome):: Rot_atom
  real(kind=db), dimension(nbtm,nlmmax,natome):: Ylmato
  
  do ia = 1,natome

    Lmax = Lmaxat( iaprotoi(ia) )
    Mat_rot(:,:) = Rot_atom(:,:,ia)

    Rotation = abs( Mat_rot(1,1) - 1._db ) > eps10 .or. abs( Mat_rot(2,2) - 1._db ) > eps10 &
                                                   .or. abs( Mat_rot(3,3) - 1._db ) > eps10

    if( Rotation ) then
      allocate( Dlmsms(-Lmax:Lmax,2,-Lmax:Lmax,2,0:Lmax) )  
      call Dlmsms_half_integer(Dlmsms,icheck,.false.,Lmax,Mat_rot)
    endif
 
    Ylms(:,:,:,:,ia) = ( 0._db, 0._db )

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

        do iso = 1,nspino
          
          do isp = 1,nspinp

            if( Rotation ) then
                                  
              do iso_p = 1,nspino  
                do m_p = -L,L

                  mv_p = m_p + isp - iso_p

                  if( mv_p > L .or. mv_p < -L ) cycle
                
                  Lmv_p = Lm0 + mv_p
     
                  f_p = Prefac_spinor_bis(iso_p,isp,L,m_p)
                  
                  do ib = 1,nbordf(ia)
                    Ylms(ib,Lm,isp,iso,ia) = Ylms(ib,Lm,isp,iso,ia) + f_p * Dlmsms(m,iso,m_p,iso_p,L) &
                                                                    * Yc( mv_p, Ylmato(ib,Lmv_p,ia), Ylmato(ib,Lmv_p-2*mv_p,ia) )  
                  end do

                end do
              end do
            
            else

              mv = m + isp - iso
              if( mv > L .or. mv < -L ) cycle
              Lmv = Lm0 + mv

              f = Prefac_spinor_bis(iso,isp,L,m)
              
              do ib = 1,nbordf(ia)
                Ylms(ib,Lm,isp,iso,ia) = f * Yc( mv, Ylmato(ib,Lmv,ia), Ylmato(ib,Lmv-2*mv,ia) )  
              end do
 
            endif
            
          end do
          
        end do
      end do
    end do
  
    if( Rotation ) deallocate( Dlmsms )
    
  end do
  
  if( icheck > 2 ) then
  
    Write(3,'(/A)') ' Ylms after rotation'
    do ia = 1,natome
      write(3,110) ia
    
      do L = 0,Lmax
        do m = -L,L
          write(3,120) L, m
          Lm = L**2 + L + 1 + m
          do ib = 1,nbordf(ia)
            write(3,130) ibord(ib,ia), ( Ylms(ib,Lm,:,iso,ia), iso = 1,nspinp )
          end do
        end do
      end do

      Write(3,'(/A)') '  L    m iso Jp  Jz    mp isop Jpp Jzp      Scalar product(up)         Scalar product(dn)              Total'
      do L = 0,Lmax
        do m = -L,L
          write(3,*)
          Lmv = L**2 + L + 1 + m
           
          do iso = 1,2
            Jplus = iso == 1 .or. m == - L
            Jz =  m + ( 3._db - 2._db * iso ) / 2._db
!            if( Jplus ) then
!              F(1,1) = sqrt( ( L + 0.5_db + Jz ) / ( 2*L + 1 ) )
!              F(1,2) = sqrt( ( L + 0.5_db - Jz ) / ( 2*L + 1 ) )
!            else
!              F(1,1) = - sqrt( ( L + 0.5_db - Jz ) / ( 2*L + 1 ) )
!              F(1,2) = sqrt( ( L + 0.5_db + Jz ) / ( 2*L + 1 ) )
!            endif
 
            do m_p = -L,L
              Lmv_p = L**2 + L + 1 + m_p
              do iso_p = 1,2
                Jplus_p = iso_p == 1 .or. m_p == - L
                Jz_p =  m_p + ( 3._db - 2._db * iso_p ) / 2._db
!                if( Jplus_p ) then
!                  F(2,1) = sqrt( ( L + 0.5_db + Jz_p ) / ( 2*L + 1 ) )
!                  F(2,2) = sqrt( ( L + 0.5_db - Jz_p ) / ( 2*L + 1 ) )
!                else
!                  F(1,1) = - sqrt( ( L + 0.5_db - Jz_p ) / ( 2*L + 1 ) )
!                  F(2,2) = sqrt( ( L + 0.5_db + Jz_p ) / ( 2*L + 1 ) )
!                endif
!                if( Jplus .neqv. Jplus_p ) cycle  
!                psi = F(1,1)*F(2,1)*sum( conjg( Ylms(1:nbordf(ia),Lmv,1,iso,ia) ) *  Ylms(1:nbordf(ia),Lmv_p,1,iso_p,ia) ) &
!                    + F(1,2)*F(2,2)*sum( conjg( Ylms(1:nbordf(ia),Lmv,2,iso,ia) ) *  Ylms(1:nbordf(ia),Lmv_p,2,iso_p,ia) )
                do isp = 1,nspinp
                  Psi(isp) = sum( conjg( Ylms(1:nbordf(ia),Lmv,isp,iso,ia) ) *  Ylms(1:nbordf(ia),Lmv_p,isp,iso_p,ia) )
                  Psi(isp) = Psi(isp) * 4 * pi / nbordf(ia)
                end do
                if( abs( sum( Psi(:) ) ) > eps10 ) write(3,140) L, m, iso, Jplus, Jz, m_p, iso_p, Jplus_p, Jz_p, Psi(:), sum(Psi(:))
              end do
            end do
          end do
        end do
      end do

    end do
    
  endif

  return
  110 format(/' ia =',i3)
  120 format(/' ibord',9x,'Ylms(u,1)',18x,'Ylms(d,1)',18x,'Ylms(u,2)',18x,'Ylms(d,2)       L =',i3,', m =',i3)
  130 format(i5,1p,4(1x,2e13.5))
  140 format(i3,2(2x,2i3,L4,f5.1),1p,3(1x,2e13.5))
end

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

function Prefac_spinor_bis(iso,isp,L,m)

  use declarations
  implicit none

  integer:: iso, isp, L, m
  
  real(kind=db):: f, One_over_two_L_plus_one, Prefac_spinor_bis
   
  One_over_two_L_plus_one = 1._db / ( 2._db * L + 1._db )  
  
  f = 0._db
  
  if( iso == 1 .or. m == - L ) then
    ! J+
    if( iso == 2 ) then  ! m = -L
      if( isp == 1 ) then
        f = 0._db
      else
        f = 1._db   ! only isp == 2   Jz = -L - 0.5
      endif
    elseif( isp == 1 ) then
      f = sqrt( ( L + m + 1._db ) * One_over_two_L_plus_one )   ! Jz = m + 0.5, L + m + 1 = L + Jz + 0.5
    else
      f = sqrt( ( L - m ) * One_over_two_L_plus_one )    ! Jz = m + 0.5, L - m = L - Jz + 0.5
    endif
  else 
  ! J-  Note that for J-, sign could be reverse
    if( isp == 1 ) then
      f = sqrt( ( L - m + 1._db ) * One_over_two_L_plus_one )  ! Jz = m - 0.5,  L - m + 1 = L - Jz + 0.5 
    else
      f = - sqrt( ( L + m ) * One_over_two_L_plus_one )   ! Jz = m - 0.5, L + m = L + Jz + 0.5
    endif
  endif

  Prefac_spinor_bis = f

  return
end

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

subroutine Rotate_TauLL(icheck,Lmaxa,natome,nlmagm,nspinp,Rot_atom,TauLL,Xtal_to_Atom)

  use declarations
  implicit none

  integer:: i, ia, icheck, iso, iso_p, j, L, Lm, Lm_p, Lm0, Lmax, m, m_p, natome, ndim, nlmagm, nspinp

  integer, dimension(natome):: Lmaxa

  complex(kind=db), dimension(nlmagm,nspinp,nlmagm,nspinp,natome):: TauLL 
  complex(kind=db), dimension(:,:,:,:,:), allocatable:: Dlmsms, Dlmsms_i 
  complex(kind=db), dimension(:,:), allocatable:: Mat_Dlms, Mat_Dlms_i, Mat_tau, Mat_tau_f 
  
  logical:: Xtal_to_Atom
  
  real(kind=db), dimension(3,3):: Mat_rot
  real(kind=db), dimension(3,3,natome):: Rot_atom
  
  do ia = 1,natome
  
    Mat_rot(:,:) = Rot_atom(:,:,ia)

    if( abs( Mat_rot(1,1) - 1._db ) < eps10 .and. abs( Mat_rot(2,2) - 1._db ) < eps10 &
                                            .and. abs( Mat_rot(3,3) - 1._db ) < eps10 ) cycle

    Lmax = Lmaxa(ia)

    if( icheck > 2 ) then
 
      write(3,'(/a56,i3)') '  Multiple scattering amplitude in cluster basis, ia =', ia 

      write(3,110)  ( ( ( L, m, iso_p, m = -L,L), L = 0,Lmax), iso_p = 1,nspinp) 
 
      do iso = 1,nspinp
        do L = 0,Lmax
          do m = - L,L
            Lm = L**2 + L + 1 + m
            write(3,'(3i3,1p,100(1x,2e13.5))') L, m, iso, ( TauLL(Lm,iso,:,iso_p,ia), iso_p = 1,nspinp) 
          end do
        end do
      end do
  
    endif

    allocate( Dlmsms(-Lmax:Lmax,2,-Lmax:Lmax,2,0:Lmax) ) 
    allocate( Dlmsms_i(-Lmax:Lmax,2,-Lmax:Lmax,2,0:Lmax) ) 

    call Dlmsms_half_integer(Dlmsms,icheck,.false.,Lmax,Mat_rot)
 ! Inverse
    call Dlmsms_half_integer(Dlmsms_i,icheck,.true.,Lmax,Mat_rot)
 
    do L = 1,Lmax
      Lm0 = L**2 + L + 1

      ndim = nspinp * ( 2 * L + 1 )
    
      allocate( Mat_tau(ndim,ndim) )
      allocate( Mat_tau_f(ndim,ndim) )
      allocate( Mat_Dlms(ndim,ndim) )
      allocate( Mat_Dlms_i(ndim,ndim) )
    
      i = 0
      do m = -L,L
        Lm = Lm0 + m
        do iso = 1,nspinp
          i = i + 1
          j = 0
          do m_p = -L,L
            Lm_p = Lm0 + m_p
            do iso_p = 1,nspinp
              j = j + 1
              Mat_tau(i,j) = TauLL(Lm,iso,Lm_p,iso_p,ia)       
              Mat_Dlms(i,j) = Dlmsms(m,iso,m_p,iso_p,L)
              Mat_Dlms_i(i,j) = Dlmsms_i(m,iso,m_p,iso_p,L)
            end do
          end do
        end do
      end do
      
      if( Xtal_to_Atom ) then
        Mat_tau_f = matmul( Mat_Dlms_i, matmul( Mat_tau, Mat_Dlms ) )
      else
        Mat_tau_f = matmul( Mat_Dlms, matmul( Mat_tau, Mat_Dlms_i ) )
      endif    

      i = 0
      do m = -L,L
        Lm = Lm0 + m
        do iso = 1,nspinp
          i = i + 1
          j = 0
          do m_p = -L,L
            Lm_p = Lm0 + m_p
            do iso_p = 1,nspinp
              j = j + 1
              TauLL(Lm,iso,Lm_p,iso_p,ia) = Mat_tau_f(i,j)       
            end do
          end do
        end do
      end do

      deallocate( Mat_tau,  Mat_tau_f, Mat_Dlms, Mat_Dlms_i )
    
    end do
    
    if( icheck > 2 ) then
  
      write(3,'(/a53,i3)') '  Multiple scattering amplitude in atom basis, ia =', ia 

      write(3,110)  ( ( ( L, m, iso_p, m = -L,L), L = 0,Lmax), iso_p = 1,nspinp) 
  
      do iso = 1,nspinp
        do L = 0,Lmax
          do m = - L,L
            Lm = L**2 + L + 1 + m
            write(3,'(3i3,1p,100(1x,2e13.5))') L, m, iso, ( TauLL(Lm,iso,:,iso_p,ia), iso_p = 1,nspinp) 
          end do
        end do
      end do
    
    endif
    
    deallocate( Dlmsms, Dlmsms_i )

  end do

  return
  110 format('  L  m is', 100(10x,'(',i1,',',i2,',',i1,')',9x) )
end

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

! Calculation of radial integrals and irregular solution
! Called by Tenseur_car and S_nrixs_cal

subroutine Radial_integral(Ecinetic,Eimag,Energ,Enervide,Eseuil,Final_tddft,Full_pot,Hubb_a,Hubb_d,icheck, &
         initlv,ip_max,ip0,Lmax,Lmax_pot,m_hubb,nb_test,nbseuil,ninit1,ninitv,nlm_pot,nlma,nlma2,nr,NRIXS,nrm,nspin,nspino, &
         nspinp,Numat,psii,r,r_or_bess,Relativiste,Renorm,Rmtg,Rmtsd,rof,Singul,Solsing,Spinorbite,Test_case,V_hubb,V_intmax, &
         V0bd,Vrato,Ylm_comp)

  use declarations
  implicit none

  integer:: i, icheck, initl, initlv, ip, ip_max, ip0, ip1, ip2, iseuil, isp, L, L_hubbard, L1, L2, lfin, Lm, lm1, &
    lm2, Lmax, Lmax_pot, Lmp, Lp, m, m1, m2, m_hubb, mp, nb_test, &
    nbseuil, ninit1, ninitv, nlm_V, nlm_pot, nlm, nlm_fp, nlma, nlma2, nr, nrm, &
    nrmtsd, nrmtg, nspin, nspino, nspinp, Numat

  character(len=2):: mot1, mot2
  character(len=104):: mot

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

  logical:: Ecomp, Final_tddft, Full_pot, Hubb_a, &
    Hubb_d, Hubb_m, NRIXS, Radial_comp, Relativiste, Renorm, Solsing, Spinorbite, Ylm_comp
  logical, dimension(nb_test):: Test_case

  real(kind=db):: Eimag, Energ, Enervide, Ephoton, Rmtg, Rmtsd, V_intmax
  real(kind=db), dimension(nspin):: Ecinetic, V0bd
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato

  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nbseuil):: Eseuil, Vecond
  real(kind=db), dimension(nr,nspin):: g0, gm, gp
  real(kind=db), dimension(nr,nspino):: gso
  real(kind=db), dimension(nrm,nbseuil):: psii
  real(kind=db), dimension(nr,ip0:ip_max):: r_or_bess

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

  konde(:) = sqrt( cmplx(Ecinetic(:), Eimag,db) )

  if( nbseuil == 2 ) then
    if( Final_tddft .and. nbseuil /= ninitv ) then
      ninit1 = ( ninitv - 2 ) / 2
      if( initlv <= ninit1 ) then
        iseuil = 1
      else
        iseuil = 2
      endif
    else ! not used in DFT (only for TDDFT)
      iseuil = initlv
    endif
  else
    iseuil = 1
  endif

  if( icheck > 1 ) then
    write(3,110) initlv, iseuil
    write(3,120) Energ*rydb
    write(3,130) Ecinetic(:)*rydb
    write(3,140) V0bd(:)*rydb
    write(3,150) konde(:)
  endif

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

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

  call mod_V(icheck,Lmax,Lmax_pot,nlm_V,nlm_pot,nr,nrmtg,nrmtsd,nspin,r,Rmtg,Rmtsd,V,V_intmax,V0bd,Vrato,Ylm_comp)

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

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

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

  do L = 0,lfin

    if( Hubb_a .and. L == L_hubbard( Numat ) )  then
      Hubb_m = .true.
    else
      Hubb_m = .false.
    endif
    Radial_comp = Ecomp .or. ( ( Hubb_a .or. Full_pot ) .and. Ylm_comp )

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

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

    call Sch_radial( Ecomp ,Eimag, f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, L, Lmax, m_hubb, &
         nlm, nlm_fp, nlm_V, nr, nrmtg, nspin, nspino, nspinp, Numat, r, Radial_comp, Relativiste, Renorm, Rmtg, &
         Spinorbite, Tau, ui, ur, V, V_hubb )

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

! Calculation of irregular solution
    if( Solsing ) call Cal_Solsing(Ecomp,Eimag,f2,Final_tddft,Full_pot,g0,gm,gp,gso,Hubb_a,Hubb_d, &
         icheck,initlv,ip_max,ip0,iseuil,konde,L,Lmax,m_hubb,nb_test,nbseuil,ninitv, &
         nlm_V,nlm,nlm_fp,nlma,nr,NRIXS,nrm,nrmtsd,nspin,nspino,nspinp, &
         Numat,psii,r,r_or_bess,Radial_comp,Rmtsd,Singul,Spinorbite,Tau,Test_case,ui,ur,V,V_hubb,Vecond)

    deallocate( Tau, ui, ur )

  end do   ! end of loop over L

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

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

      do ip = ip0,ip_max
        select case(ip)
          case(0)
            write(3,160) '  monopole'
          case(1)
            write(3,160) '    dipole'
          case(2)
            write(3,160) 'quadrupole'
          case(3)
            write(3,160) '  octupole'
        end select
        if( Full_pot .or. Hubb_a ) then
          write(3,170) '  L  m Lp mp', mot
        else
          write(3,175) '  L  m', mot
        endif
        Lm = 0
        do L = 0,Lmax
          do m = -L,L
            Lm = Lm + 1
            if( .not. ( Hubb_a .or. Full_pot .or. Spinorbite ) .and. m /= 0 ) cycle
            Lmp = 0
            do Lp = 0,Lmax
              if( .not. Full_pot .and. L /= Lp ) cycle
              do mp = -Lp,Lp
                if( .not. ( Hubb_a .or. Full_pot .or. m == mp ) ) cycle
                Lmp = Lp**2 + Lp + 1 + mp
                Lmp = min(nlma2,Lmp)
                if( Full_pot .or. Hubb_a ) then
                  if( Ecomp) then
                    write(3,180) L, m, Lp, mp, ( rof(Lm,Lmp,isp,:,ip,initl), isp = 1,nspinp)
                  else
                    write(3,180) L, m, Lp, mp, ( real(rof(Lm,Lmp,isp,:,ip,initl)), isp = 1,nspinp)
                  endif
                else
                  if( Ecomp) then
                    write(3,185) L, m, ( rof(Lm,Lmp,isp,:,ip,initl), isp = 1,nspinp )
                  else
                    write(3,185) L, m, ( real(rof(Lm,Lmp,isp,:,ip,initl)), isp = 1,nspinp )
                  endif
                endif
              end do
            end do
          end do
        end do
      end do

      if( .not. Solsing ) cycle

      do ip1 = ip0,ip_max
        select case(ip1)
          case(0)
            mot1 = 'M1'
          case(1)
            mot1 = 'E1'
          case(2)
            mot1 = 'E2'
          case(3)
            mot1 = 'E3'
        end select

        do ip2 = ip0,ip_max
          if( .not. Full_pot .and. mod(ip1+ip2,2) == 1 ) cycle

          select case(ip2)
            case(0)
              mot2 = 'M1'
            case(1)
              mot2 = 'E1'
            case(2)
              mot2 = 'E2'
            case(3)
              mot2 = 'E3'
          end select

          write(3,190) mot1, mot2
          if( Hubb_m .or. Full_pot .and. nspinp == 1 ) then 
            write(3,200) ' L1 m1 L2 m2','  Sing '
          elseif( Hubb_m .or. Full_pot .or. Spinorbite ) then 
            write(3,200) ' L1 m1 L2 m2','  up up','  up dn','  dn up','  dn dn'
          elseif( nspinp == 2 ) then
            write(3,210) '  L  m','   up  ','   dn  '
          else
            write(3,210) '  L  m','  Sing '
          endif

          lm1 = 0
          do L1 = 0,Lmax
            do m1 = -L1,L1
              lm1 = lm1 + 1
              lm2 = 0
              do L2 = 0,Lmax
                do m2 = -L2,L2
                  lm2 = lm2 + 1
                  if( Hubb_m .or. Full_pot .or. Spinorbite ) then
                    if( sum( abs( Singul(lm1,:,lm2,:,ip1,ip2,initl) ) ) < eps10 ) cycle
                    write(3,220) L1, m1, L2, m2, ( Singul(lm1,isp,lm2,:,ip1,ip2,initl), isp = 1,nspinp )
                  elseif( lm1 /= lm2 .or. m1 /= 0 ) then
                    cycle
                  else
                    write(3,230) L1, m1, ( Singul(lm1,isp,lm2,isp,ip1,ip2,initl), isp = 1,nspinp )
                  endif
                end do
              end do
            end do
          end do
        end do
      end do
    end do

  endif

  deallocate( V )

  return
  110 format(/' initl =',i2,', iseuil =',i2)
  120 format(' Energ    =',f10.3,' eV')
  130 format(' Ecinetic =',2f10.3)
  140 format(' V0bd     =',2f10.3)
  150 format(' konde    =',2f12.5)
  155 format(/' iseuil =',i2)
  160 format(/' Radial matrix, ',a10,1x,'term:')
  170 format(a12,a104)
  175 format(a6,a104)
  180 format(4i3,1p,8e13.5)
  185 format(2i3,1p,8e13.5)
  190 format(/' Radial integral of singular solution, ',a2,'-',a2, ' term:')
  200 format(a12,10x,a7,4(20x,a7))
  210 format(a6,10x,a7,2(20x,a7))
  220 format(4i3,1p,4(1x,2e13.5)) 
  230 format(2i3,1p,4(1x,2e13.5))
end

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

! Calculation of the radial integral in the (Fermi) Golden rule.
! psii, u and ur are wave functions time r.

subroutine Radial_matrix(Final_tddft,initlv,ip_max,ip0,iseuil,L,nlm,nlm_fp,nbseuil, &
           ninitv,nlma,nlma2,nr,NRIXS,nrm,nspino,nspinp,psii,r,r_or_bess,Radial_comp,Rmtsd,rof,ui,ur,Vecond)

  use declarations
  implicit none

  integer initlv, ip, ip_max, ip0, iseuil, is, isol, isp, iss, L, Lm, lm1, lm2, nlm, nlm_fp, n1, n2, nbseuil, &
    ninitv, nlma, nlma2, nr, nrm, ns1, ns2, nspino, nspinp

  complex(kind=db), dimension(nlma,nlma2,nspinp,nspino,ip0:ip_max,ninitv):: rof

  logical:: Final_tddft, NRIXS, Radial_comp

  real(kind=db):: f_integr3, fac, radlr, radli, Rmtsd
  real(kind=db), dimension(nbseuil):: Vecond
  real(kind=db), dimension(nr):: r
  real(kind=db), dimension(nrm,nbseuil):: psii
  real(kind=db), dimension(nr,ip0:ip_max):: r_or_bess
  real(kind=db), dimension(nr,nlm,nlm_fp,nspinp,nspino):: ui, ur

  real(kind=db), dimension(:), allocatable:: fct
  real(kind=db), dimension(:,:), allocatable:: psiir

  allocate( psiir(nr,nbseuil) )
  allocate( fct(nr) )
  
  if( Final_tddft ) then
    ns1 = initlv
    ns2 = initlv
  else
    ns1 = 1
    ns2 = nbseuil
  endif

  do is = 1,nbseuil
    psiir(1:nr,is) =  psii(1:nr,is) * r(1:nr) 
  end do

  lm1 = L**2
  lm2 = (L + 1)**2

  do ip = ip0,ip_max
  
    do is = ns1,ns2

      if( Final_tddft ) then
        iss = nbseuil   ! It is the second edge which is the energy origin
      else
        iss = is
        iseuil = is
      endif

      if( NRIXS ) then
        fac = 1._db
      else
        select case(ip)
          case(0)
            fac = 1._db
          case(1)
            fac = 1._db
          case(2)
            fac = 0.5_db * Vecond(iss)
          case(3)
            fac = - ( 1._db / 6 ) * Vecond(iss)**2
        end select
      endif

      do isp = 1,nspinp
        do n1 = 1,nlm
          do isol = 1,nspino
            do n2 = 1,nlm_fp

              fct(1:nr) = psiir(1:nr,iseuil) * ur(1:nr,n1,n2,isp,isol) * r_or_bess(1:nr,ip)
              radlr = fac * f_integr3(r,fct,1,nr,Rmtsd)
              if( Radial_comp ) then
                fct(1:nr) = psiir(1:nr,iseuil) * ui(1:nr,n1,n2,isp,isol) * r_or_bess(1:nr,ip)
                radli = fac * f_integr3(r,fct,1,nr,Rmtsd)
              else
                radli = 0._db
              endif

              if( nlm /= 1 .and. nlm_fp /= 1 ) then
                rof(lm1+n1,lm1+n2,isp,isol,ip,is) = cmplx( radlr, radli,db)
              elseif( nlm /= 1 .and. nlma2 /= 1 ) then
                rof(lm1+n1,lm1+n1,isp,isol,ip,is) = cmplx( radlr, radli,db)
              elseif( nlm /= 1 ) then
                rof(lm1+n1,n2,isp,isol,ip,is) = cmplx( radlr, radli,db)
              elseif( nlm == 1 .and. nlma2 /= 1 ) then
                do Lm = lm1+1,lm2
                  rof(Lm,Lm,isp,isol,ip,is) = cmplx(radlr, radli,db)
                end do
              else
                do Lm = lm1+1,lm2
                  rof(Lm,n2,isp,isol,ip,is) = cmplx(radlr, radli,db)
                end do
              endif

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

  deallocate( psiir, fct )

  return
end

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

! Radial matrix for the emission

subroutine Rad_matrix_Emis(nb_Emis,nbseuil,nrato_abs,nrm,Psi_Emis,Psii,RadMat_Emis,Rato_abs)

  use declarations
  implicit none
  
  integer:: i, j, nb_Emis, nbseuil, nrato_abs, nrm

  real(kind=db):: f_integr3

  real(kind=db), dimension(nrato_abs):: fct, Rato_abs
  real(kind=db), dimension(nrm,nbseuil):: Psii
  real(kind=db), dimension(nrm,nb_Emis):: Psi_Emis
  real(kind=db), dimension(nb_Emis,nbseuil):: RadMat_Emis

  do i = 1,nbseuil
    do j = 1,nb_emis
      fct(1:nrato_abs) = Psii(1:nrato_abs,i) * Psi_Emis(1:nrato_abs,j) * Rato_abs(1:nrato_abs)**2
      RadMat_Emis(j,i) = f_integr3(Rato_abs,fct,1,nrato_abs,Rato_abs(nrato_abs))
    end do
  end do

  return
end

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

! Calculation of the radial integral of the (Fermi) golden rule
! ui et ur are the wave functions times r.

subroutine radial_matrix_optic(ip_max,ip0,ne,nlm1g,nlm_fp,nr,nrmtsd,nspinp,nspino,r,Radial_comp,Rmtsd,roff_rr,ui,ur,Vecond)

  use declarations
  implicit none

  integer:: ip, ip_max, ip0, ipp, ir, isol, isoli, isolf, isp, ispi, ispf, nlm1g, nlm_fp, n1i, n1f, n2i, n2f, ne, &
    nr, nrmtsd, nspinp, nspino

  logical:: Radial_comp

  real(kind=db):: f_integr3, fac, Rmtsd, Vecond
  real(kind=db), dimension(nr):: r
  real(kind=db), dimension(nrmtsd):: rp, fct
  real(kind=db), dimension(nr,nlm1g,nlm_fp,nspinp,nspino,ne):: ui, ur
  real(kind=db), dimension(nlm1g,nlm1g,nlm_fp,nlm_fp,nspinp**2,nspino**2,ip0:ip_max):: roff_ii, roff_ir, roff_ri, roff_rr

  do ip = ip0,ip_max

    ipp = ip + 1

    rp(1:nrmtsd) = r(1:nrmtsd)**ipp

    select case(ip)
      case(0)
        fac = 1._db
      case(1)
        fac = 1._db
      case(2)
        fac = 0.5_db * Vecond
      case(3)
      fac = - ( 1._db / 6 ) * Vecond**2
    end select

    do ispi = 1,nspinp
      do n1i = 1,nlm1g
        do isoli = 1,nspino
          do n2i = 1,nlm_fp

            do ispf = 1,nspinp
              isp = ispf + ( ispi - 1 ) * nspinp
              do n1f = 1,nlm1g
                do isolf = 1,nspino
                  isol = isolf + ( isoli - 1 ) * nspino
                  do n2f = 1,nlm_fp

                    do ir = 1,nrmtsd
                      fct(ir) = ur(ir,n1i,n2i,ispi,isoli,1) * ur(ir,n1f,n2f,ispf,isolf,2) * rp(ir)
                    end do

                    roff_rr(n1i,n1f,n2i,n2f,isp,isol,ip) = fac * f_integr3(rp,fct,1,nrmtsd,Rmtsd)

                    if( Radial_comp ) then
                      do ir = 1,nrmtsd
                        fct(ir) = ur(ir,n1i,n2i,ispi,isoli,1) * ui(ir,n1f,n2f,ispf,isolf,2) * rp(ir)
                      end do

                      roff_ri(n1i,n1f,n2i,n2f,isp,isol,ip) = fac * f_integr3(rp,fct,1,nrmtsd,Rmtsd)

                      do ir = 1,nrmtsd
                        fct(ir) = ui(ir,n1i,n2i,ispi,isoli,1) * ur(ir,n1f,n2f,ispf,isolf,2) * rp(ir)
                      end do

                      roff_ir(n1i,n1f,n2i,n2f,isp,isol,ip) = fac * f_integr3(rp,fct,1,nrmtsd,Rmtsd)

                      do ir = 1,nrmtsd
                        fct(ir) = ui(ir,n1i,n2i,ispi,isoli,1) * ui(ir,n1f,n2f,ispf,isolf,2) * rp(ir)
                      end do

                      roff_ii(n1i,n1f,n2i,n2f,isp,isol,ip) = fac * f_integr3(rp,fct,1,nrmtsd,Rmtsd)

                    endif

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

  return
end

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

! Calculation of the singular term coming from the irregular solution for the absorption
! Called by Radial

Subroutine Cal_Solsing(Ecomp,Eimag,f2,Final_tddft,Full_pot,g0,gm,gp,gso,Hubb_a,Hubb_d, &
         icheck,initlv,ip_max,ip0,iseuil,konde,LL,Lmax,m_hubb,nb_test,nbseuil,ninitv, &
         nlm_V,nlm,nlm_fp,nlma,nr,NRIXS,nrm,nrmtsd,nspin,nspino,nspinp, &
         Numat,psii,r,r_or_bess,Radial_comp,Rmtsd,Singul,Spinorbite,Tau,Test_case,ui,ur,V,V_hubb,Vecond)

  use declarations
  implicit none

  integer:: icheck, initlv, ip_max, ip0, ip1, ip2, is, is1, is2, ise, iseuil, iso1, iso2, isp1, isp2, iss, L, L_hubbard, LL, Lm, &
    Lm1, Lm2, Lmax, Lmp1, Lmp2, m_hubb, m1, m2, ms1, ms2, mv, &
    n0, n1, n2, nb_test, nbseuil, ninitv, nlm, nlm_fp, nlm_V, nlma, np1, np2, nr, nrm, nrmax, nrmtsd, ns1, ns2, nspin, &
    nspino, nspinp, Numat

  complex(kind=db):: integr_sing, Sing, Sing_s, Sta_e, Sta_s
  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(nlma,nspinp,nlma,nspinp,ip0:ip_max,ip0:ip_max,ninitv):: Singul
  complex(kind=db), dimension(nrmtsd):: f_reg, f_irg
  complex(kind=db), dimension(nlm,nspinp,nlm,nspinp):: Tau
  complex(kind=db), dimension(nr,nlm_V,nlm_V,nspin):: V
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb

  logical:: Ecomp, Final_tddft, Full_pot, Hubb_a, Hubb_m, Hubb_d, NRIXS, Radial_comp, Spinorbite
  logical, dimension(nb_test):: Test_case

  real(kind=db):: Eimag, fac1, fac2, Rmtsd, Sta_i, Sta_r
  real(kind=db), dimension(nbseuil):: Vecond
  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nrmtsd):: rr, phi1, phi2
  real(kind=db), dimension(nrm,nbseuil):: psii
  real(kind=db), dimension(nr,nspin):: g0, gm, gp
  real(kind=db), dimension(nr,nspino):: gso
  real(kind=db), dimension(nr,nlm,nlm_fp,nspinp,nspino):: ui, ur
  real(kind=db), dimension(nr,ip0:ip_max):: r_or_bess

  real(kind=db), dimension(:,:,:,:,:), allocatable:: usi, usr

  rr(1:nrmtsd) = r(1:nrmtsd)

  if( Final_tddft ) then
    ns1 = initlv
    ns2 = initlv
  else
    ns1 = 1
    ns2 = nbseuil
  endif

  nrmax = nrmtsd+1 
  allocate( usi(nrmax,nlm,nlm_fp,nspinp,nspino) )
  allocate( usr(nrmax,nlm,nlm_fp,nspinp,nspino) )

  call Sch_radial_irreg( Ecomp, Eimag, f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, LL, &
       Lmax, m_hubb, nlm, nlm_fp, nlm_V, nr, nrmtsd, nrmax, nspin, nspino, nspinp, Numat, r, Radial_comp, Rmtsd, Spinorbite, &
       usi, usr, V, V_hubb )

  do is = ns1,ns2

    if( Final_tddft ) then
      iss = nbseuil   ! it is the second edge which is the origin (because at lower energy)
      ise = iseuil
    else
      iss = is
      ise = is
    endif

    do ip1 = ip0,ip_max  ! Loop on dipole, quadrupole, Octupole

      if( NRIXS ) then
        fac1 = 1._db
      else
        select case(ip1)
          case(0)
            fac1 = 1._db
          case(1)
            fac1 = 1._db
          case(2)
            fac1 = 0.5_db * Vecond(iss)
          case(3)
            fac1 = - ( 1._db / 6 ) * Vecond(iss)**2
        end select
      endif

      phi1(1:nrmtsd) = psii(1:nrmtsd,ise) * r_or_bess(1:nrmtsd,ip1)

      do ip2 = ip0,ip_max  ! loop over multipole

        if( NRIXS ) then
          fac2 = 1._db
        else
          select case(ip2)
            case(0)
              fac2 = 1._db
            case(1)
              fac2 = 1._db
            case(2)
              fac2 = 0.5_db * Vecond(iss)
            case(3)
              fac2 = - ( 1._db / 6 ) * Vecond(iss)**2
          end select
        endif

        phi2(1:nrmtsd) = psii(1:nrmtsd,ise) * r_or_bess(1:nrmtsd,ip2)

        n1 = 0
        do L = 0,Lmax
          if( .not. Full_pot .and. L /= LL ) cycle
          Hubb_m = Hubb_a .and. L == L_hubbard( Numat )

          n0 = L**2 + L + 1
          do m1 = -L,L
            if( nlm == 1 .and. m1 /= 0 ) cycle
            n1 = n1 + 1
            do m2 = -L,L
              if( nlm == 1 .and. m2 /= 0 ) cycle
!              if( .not. ( Full_pot .or. ( Hubb_m .and. .not. Hubb_d ) ) .and. abs(m2-m1) > 1 ) cycle
              n2 = n1 + m2 - m1
        
              do isp1 = 1,nspinp
                do isp2 = 1,nspinp
                  if( .not. spinorbite .and. isp1 /= isp2 ) cycle
                  if( nlm == 1 .and. isp1 /= isp2 ) cycle
!                  if( .not. ( Full_pot .or. ( Hubb_m .and. .not. Hubb_d ) ) .and. isp2 - isp1 /= m2 - m1 ) cycle
            
                  do np1 = 1,nlm_fp
            
                    do iso1 = 1,nspino
                      if( Spinorbite .and. nlm_fp == 1 ) then
                        ms1 = m1 + iso1 - isp1    ! ms1 is the "m" of the amplitude, not the one of the radial function 
                        if( ms1 > L .or. ms1 < -L ) cycle
                        is1 = iso1
                      else
                        ms1 = m1
                        is1 = isp1
                      endif

                      do np2 = 1,nlm_fp

                        do iso2 = 1,nspino
                          if( Spinorbite .and. nlm_fp == 1 ) then
                            ms2 = m2 + iso2 - isp2
                            if( ms2 > L .or. ms2 < -L ) cycle
                            is2 = iso2
                          else
                            ms2 = m2
                            is2 = isp2
                          endif
                      
                          if( nlm_fp > 1 ) then
                            Lmp1 = np1
                            Lmp2 = np2
                          elseif( nlm > 1 ) then
                            Lmp1 = L + 1 + ms1
                            Lmp2 = L + 1 + ms2
                          else
                            Lmp1 = 1
                            Lmp2 = 1
                          endif

                          if( icheck > 3 ) write(3,110) L, ip1, ip2
            
                          if( Radial_comp ) then
                            f_reg(1:nrmtsd) = r(1:nrmtsd) * cmplx( ur(1:nrmtsd,n1,np1,isp1,iso1), ui(1:nrmtsd,n1,np1,isp1,iso1), &
                                                                                                                               db )
                          else
                            f_reg(1:nrmtsd) = r(1:nrmtsd) * cmplx( ur(1:nrmtsd,n1,np1,isp1,iso1), 0._db, db )
                          endif
            
                          f_irg(1:nrmtsd) = cmplx( usr(1:nrmtsd,n2,np2,isp2,iso2), usi(1:nrmtsd,n2,np2,isp2,iso2), db)

                                      
                          Sing = fac1 * fac2 * integr_sing(nrmtsd,phi1,phi2,f_reg,f_irg,Rmtsd,rr,icheck)
               
                          if( Test_case(4) ) then
                            Sing_s = fac1 * fac2 * integr_sing(nrmtsd,phi1,phi2,f_irg,f_reg,Rmtsd,rr,icheck)
                          else
                       ! new: 2022/04/05
                            if( Radial_comp ) then
                              f_reg(1:nrmtsd) = r(1:nrmtsd) * cmplx( ur(1:nrmtsd,n2,np2,isp2,iso2), ui(1:nrmtsd,n2,np2,isp2,iso2), &
                                                                                                                               db )
                            else
                              f_reg(1:nrmtsd) = r(1:nrmtsd) * cmplx( ur(1:nrmtsd,n2,np2,isp2,iso2), 0._db, db )
                            endif
            
                            f_irg(1:nrmtsd) = cmplx( usr(1:nrmtsd,n1,np1,isp1,iso1), usi(1:nrmtsd,n1,np1,isp1,iso1), db)
                          
                            Sing_s = fac1 * fac2 * integr_sing(nrmtsd,phi1,phi2,f_irg,f_reg,Rmtsd,rr,icheck)
                          endif
            
                          if( nlm == 1 ) then
                            do mv = -L,L
                              Lm = n0 + mv
                              Singul(Lm,isp1,Lm,isp2,ip1,ip2,is) = Singul(Lm,isp1,Lm,isp2,ip1,ip2,is) &
                                   + 0.5_db * img * aimag( Sing * Tau(Lmp1,is1,Lmp2,is2) + Sing_s * Tau(Lmp2,is2,Lmp1,is1) )
                            end do
                          else
                            Lm1 = n0 + m1  ! it is the spherical harmonics "m"
                            Lm2 = n0 + m2
                            if( Test_case(4) ) then
                              Singul(Lm1,isp1,Lm2,isp2,ip1,ip2,is) = Singul(Lm1,isp1,Lm2,isp2,ip1,ip2,is) &
                                     + 0.5_db * img * aimag( Sing * Tau(Lmp1,is1,Lmp2,is2) + Sing_s * Tau(Lmp2,is2,Lmp1,is1) )
                            else
                         ! new: 2022/04/05
                              Sta_e = Sing * Tau(Lmp1,is1,Lmp2,is2) 
                              Sta_s = Sing_s * Tau(Lmp2,is2,Lmp1,is1) 
                              Sta_r = 0.5_db * real( Sta_e - Sta_s, db)
                              Sta_i = 0.5_db * aimag( Sta_e + Sta_s )
                              Singul(Lm1,isp1,Lm2,isp2,ip1,ip2,is) = Singul(Lm1,isp1,Lm2,isp2,ip1,ip2,is) &
                                                                   + cmplx( Sta_r, Sta_i, db )
                            endif


                          endif
                      
                        end do ! end of loop iso2            
                      end do  ! end of loop np2
                    end do  ! end of loop iso1
                  end do   ! end of loop np1         
                end do    ! end of loop isp2
              end do    ! end of loop isp1
            end do   ! end of loop m2
          end do   ! end of loop m1
        end do  ! end of loop L

      end do ! end of loop dipole, quadrupole
    end do ! end of loop dipole, quadrupole

  end do ! end of loop seuil

  deallocate( usi, usr )
  
  return
  110 format(/' L =',i2,', ip1 =',i2,', ip2 =',i2)
end

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

! Resolution of the radial Schrodinger equation for the irregular solution by inward integration
! At R, continuity is with - i * Hankel

subroutine Sch_radial_irreg( Ecomp, Eimag,f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, LL, &
          Lmax, m_hubb, nlm, nlm_fp, nlm_V, nr, nrmtsd, nrmax, nspin, nspino, nspinp, Numat, r, Radial_comp, Rmtsd, Spinorbite, &
          usi, usr, V, V_hubb )

  use declarations
  implicit none

  integer:: icheck, im, ip, ir, iso, iso_p, isp, isq, isr, L, L_hubbard, L_Lplus1, Li, LL, Lf, Lm, Lm_orb, Lm_orb_p, Lm_s, &
    Lm0, Lmax, m, m_hubb, m_orb, m_orb_p, m_orb_s, mp, n, nlm, nlm_fp, nlm_V, nr, nrmax, nrmtsd, nspin, nspino, nspinp, Numat

  logical:: Ecomp, Full_pot, Hubb_a, Hubb_d, Hubb_m, Hubb_nd, Radial_comp, Spinorbite

  complex(kind=db):: fnormc, V_h, z
  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(0:Lmax):: bess, neum
  complex(kind=db), dimension(nrmtsd:nrmax,0:Lmax,nspin):: Hankel
  complex(kind=db), dimension(nr,nlm_V,nlm_V,nspin):: V
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb
  complex(kind=db), dimension(:,:,:,:,:), allocatable:: us, ws

  real(kind=db):: Eimag, fnorm, konder, Rmtsd, td, zr
  
  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(0:Lmax):: bessr, neumr
  real(kind=db), dimension(nr,nspin):: g0, gm, gp
  real(kind=db), dimension(nr,nspino):: gso
  real(kind=db), dimension(:), allocatable:: rr
  real(kind=db), dimension(nlm,nspino):: Fac_up_dn

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

  real(kind=db), dimension(nrmax,nlm,nlm_fp,nspinp,nspino):: usi, usr
  
  allocate( us(nrmax,nlm,nspino*nlm_fp,nspinp,nspino)  )

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

  do ir = nrmtsd,nrmax
    do isp = 1,nspin
      if( Ecomp ) then
        fnormc = sqrt( konde(isp) / pi )
        z = konde(isp) * r(ir)
        call cbessneu(fnormc,z,Lmax,Lmax,bess,neum)
        Hankel(ir,0:Lmax,isp) = bess(0:Lmax) + img * neum(0:Lmax) 
      else
        konder = Real( konde(isp), db )
        fnorm = sqrt( konder / pi )
        zr = konder * r(ir)
        call cbessneur(fnorm,zr,Lmax,Lmax,bessr,neumr)
        Hankel(ir,0:Lmax,isp) =  bessr(0:Lmax) + img * neumr(0:Lmax)
      endif
    end do
  end do

! Development at the muffin-in radius  
  if( Full_pot ) then
    Li = 0
    Lf = Lmax
  else
    Li = LL
    Lf = LL
  endif

  do L = Li,Lf
  
    Hubb_m = Hubb_a .and. L == L_hubbard(Numat) 
    if( Full_pot ) then 
      Lm0 = L**2 + L + 1
    elseif( Hubb_m .or. Spinorbite ) then
      Lm0 = L + 1
    else
      Lm0 = 1
    endif
  
    do m = -L,L
      if( m /= 0 .and. .not. ( Spinorbite .or. Hubb_m .or. Full_pot ) ) cycle

      Lm = Lm0 + m

      do isp = 1,nspinp  ! real spin which here defines also the solution state
        isr = min( isp, nspin )
        iso = min( isp, nspino )

        if( Spinorbite ) then
          m_orb = m - iso + isp
          if( m_orb < - L .or. m_orb > L ) cycle
        else
          m_orb = m
        endif
        Lm_orb = Lm0 + m_orb

        if( nlm_fp == 1 ) then
          Lm_s = 1
        else
          Lm_s = ( Lm0 + m - 1 ) * nspino + iso
        endif
        
        do ir = nrmtsd,nrmax
          us(ir,Lm_orb,Lm_s,isp,iso) = - img * r(ir) * Hankel(ir,L,isr)
        end do

      end do

    end do
  end do

  if( Spinorbite ) call Cal_Fac_up_dn( Fac_up_dn, Full_pot, Hubb_m, Li, Lf, nlm, nspino ) 

  do ir = nrmtsd,2,-1
    ip = ir - 1      ! inverse par rapport a Sch_radial
    im = ir + 1

    do L = Li,Lf

      Hubb_m = Hubb_a .and. L == L_hubbard( Numat )
      Hubb_nd = Hubb_m .and. .not. Hubb_d

      if( Full_pot ) then
        Lm0 = L**2 + L + 1
      elseif( Hubb_m .or. Spinorbite ) then
        Lm0 = L + 1
      else
        Lm0 = 1
      endif
      
      L_Lplus1 = L * ( L + 1 )

! m is the index of the spinor when spinorbite
      do m = -L,L 
      
        if( m /= 0 .and. .not. ( Spinorbite .or. Hubb_m .or. Full_pot ) ) cycle
        
        Lm = Lm0 + m
        
        do iso = 1,nspino
        
          do isp = 1,nspinp
          
            isr = min( isp, nspin )
            isq = 3 - isp

! m_orb is the m of the orbital 
            if( Spinorbite ) then
              m_orb = m - iso + isp
              if( m_orb < - L .or. m_orb > L ) cycle
              if( isp == 1 ) then
                m_orb_p = m_orb + 1
                m_orb_s = m_orb 
              else
                m_orb_p = m_orb - 1
                m_orb_s = - m_orb 
              endif 
              Lm_orb_p = Lm0 + m_orb_p
            else
              m_orb = m
            endif

            Lm_orb = Lm0 + m_orb

            td = g0(ir,isr) + L_Lplus1 * f2(ir)

            us(ip,Lm_orb,:,isp,iso) = td * us(ir,Lm_orb,:,isp,iso) + gp(ir,isr) * us(im,Lm_orb,:,isp,iso)

            if( Ecomp ) us(ip,Lm_orb,:,isp,iso) = us(ip,Lm_orb,:,isp,iso) - img * Eimag * us(ir,Lm_orb,:,isp,iso)
 
            if( Spinorbite ) then
              us(ip,Lm_orb,:,isp,iso) = us(ip,Lm_orb,:,isp,iso) + m_orb_s * gso(ir,isp) * us(im,Lm_orb,:,isp,iso) 
              if( abs( m_orb_p ) <= L ) us(ip,Lm_orb,:,isp,iso) = us(ip,Lm_orb,:,isp,iso) &
                                                              + Fac_up_dn(Lm,iso) * gso(ir,isp) * us(ir,Lm_orb_p,:,isq,iso)
            endif
            
            if( Hubb_m ) then

              do mp = -L,L
                do iso_p = 1,nspino

                  if( Spinorbite ) then
                    m_orb_p = mp - iso_p + isp
                    if( abs( m_orb_p ) > L ) cycle
                  else
                    m_orb_p = mp
                  endif 
                  if( Hubb_d .and. ( m /= mp .or. iso_p /= iso ) ) cycle
                  if( Spinorbite ) then
                    V_h = V_hubb(m,iso,mp,iso_p)  
                  else
                    V_h = V_hubb(m,isp,mp,isp)
                  endif
                  Lm_orb_p = Lm_orb - m_orb + m_orb_p
                  
                  us(ip,Lm_orb,:,isp,iso) = us(ip,Lm_orb,:,isp,iso) + V_h * us(ir,Lm_orb_p,:,isp,iso_p)

                end do
              end do

            endif
                  
            if( Full_pot ) then
              do Lm_orb_p = 1,nlm_V
                do iso_p = 1,nspino

                  if( Lm_orb_p == Lm_orb .and. iso_p == iso ) cycle

                  us(ip,Lm_orb,:,isp,iso) = us(ip,Lm_orb,:,isp,iso) + V(ir,Lm_orb,Lm_orb_p,isr) * us(ir,Lm_orb_p,:,isp,iso_p)

                end do
              end do
            endif

            us(ip,Lm_orb,:,isp,iso) = - us(ip,Lm_orb,:,isp,iso) / gm(ir,isr)

          end do
        end do
      end do
    end do
  end do

! In non spherical cases with spin-orbit, the index on spinor becomes the one of the state
! resulting in a sum of both spinors of the wave functions
  if( Spinorbite .and. nlm_fp > 1 ) then  
    allocate( ws(nrmax,nlm,nspino*nlm_fp,nspinp,nspino) )
    ws(:,:,:,:,:) = us(:,:,:,:,:)

    deallocate( us )
    allocate( us(nrmax,nlm,nlm_fp,nspinp,nspino)  )
    us(:,:,:,:,:) = ( 0._db, 0._db )
     
    do L = Li,Lf
      Hubb_m = Hubb_a .and. L == L_hubbard( Numat )
      if( Full_pot ) then
        Lm0 = L**2 + L + 1
      elseif( Hubb_m ) then
        Lm0 = L + 1    
      else
        cycle ! we are never here
      endif
      do m = - L,L
        Lm = Lm0 + m
        do iso = 1,nspino
          Lm_s = ( Lm - 1 ) * nspino + iso
          us(:,:,Lm,:,iso) = ws(:,:,Lm_s,:,1) + ws(:,:,Lm_s,:,2)  
        end do
      end do
    end do  
  endif

  if( icheck > 2 ) then
    n = nrmax
    allocate( ui(n,nlm,nlm_fp,nspinp,nspino) )
    allocate( ur(n,nlm,nlm_fp,nspinp,nspino) )
    allocate( rr(n) )
    ur(1:n,:,:,:,:) = Real( us(1:n,:,:,:,:), db )
    ui(1:n,:,:,:,:) = aimag( us(1:n,:,:,:,:) )
    rr(1:n) = r(1:n)
    call write_ur( Full_pot, li, lf, nlm, nlm_fp, n, nspinp, nspino, Numat, rr, Radial_comp, Rmtsd, ui, ur, 3 )
    deallocate( rr, ui, ur )
  endif

  usr(:,:,:,:,:) = real( us(:,:,:,:,:), db )
  usi(:,:,:,:,:) = aimag( us(:,:,:,:,:) )
  
  deallocate( us )
  
  return
end

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

! Calculation of radial integrals in the optics case 
! called by Tenseur_car_opt

subroutine Radial_optic(Ecinetic_t,Eimag_t,Energ,Enervide,Full_pot,Hubb_a,Hubb_d,icheck,ief,ip_max,ip0, &
         Lmax,Lmax_pot,m_depend,m_hubb,n_ph,n_Ec,n_V,nlm_pot,nlm1g,nlm_fp,No_diag,nr,nr_zet,nspin,nspino,nspinp,Numat,r, &
         Relativiste,Renorm,Rmtg,Rmtsd,roff_rr,roff0,Solsing,Spinorbite,V_hubb,V_intmax,V0bd_t,Vrato_t,Ylm_comp,zet)

  use declarations
  implicit none

  integer:: i, icheck, ie, ie1, ie2, ief, ip, ip_max, ip0, iso1, iso2, isp, isp1, isp2, j, L, lf, L_hubbard, lfin, Lm, lmf, &
    lm1, lm2, Lmax, Lmax_pot, Lmp, lmpf, Lp, lpf, m, m_hubb, mf, mp, mpf, n_ph, nlm_V, nlm_pot, nlm, nlm1g, nlm_fp, nlm2, &
    n_Ec, n_V, nr, nr_zet, nrmax, nrmtsd, nrmtg, nspin, nspino, nspinp, Numat

  character(len=104):: mot

  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb
  complex(kind=db), dimension(:,:,:,:), allocatable:: Tau, V
  complex(kind=db), dimension(:,:,:,:,:), allocatable:: us
  complex(kind=db), dimension(:,:,:,:,:,:), allocatable:: us_t

  logical:: Ecomp, Diag, Full_pot, Hubb_a, Hubb_d, Hubb_m, m_depend, No_diag, Radial_comp, Relativiste, &
    Renorm, Solsing, Spinorbite, Ylm_comp

  real(kind=db):: Eimag, Rmtg, Rmtsd, V_intmax, Vecond
  real(kind=db), dimension(nspin):: Ecinetic, V0bd
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato
  real(kind=db), dimension(n_Ec):: Eimag_t, Enervide
  real(kind=db), dimension(nspin,n_Ec):: Ecinetic_t
  real(kind=db), dimension(n_ph):: Energ
  real(kind=db), dimension(nspin,n_V):: V0bd_t
  real(kind=db), dimension(nr,nlm_pot,nspin,n_V):: Vrato_t

  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nr,nspin):: g0, gm, gp
  real(kind=db), dimension(nr,nspino):: gso
  real(kind=db), dimension(nr_zet,nlm1g,nlm_fp,nspinp,nspino,n_Ec):: zet
  real(kind=db), dimension(nlm1g,nlm1g,nlm_fp,nlm_fp,nspinp**2,nspino**2,ip0:ip_max):: roff_rr
  real(kind=db), dimension(ief-1,ief:n_Ec,nlm1g,nlm1g,nspinp,nspinp,nspino**2):: roff0

  real(kind=db), dimension(:,:,:,:,:), allocatable:: ui, ur, usi, usr
  real(kind=db), dimension(:,:,:,:,:,:), allocatable:: ui_t, ui1, ur_t, ur1

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

! Multiplicative term for the quadrupolar transitions
! In S.I. vecond = k = E*alfa_sf*4*pi*epsilon0 / (e*e)
! In ua and rydb : k = 0.5_db * alfa_sf * E
  Vecond = 0.5_db * alfa_sf * Energ(1)

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

  Vrato(:,:,:) = Vrato_t(:,:,:,1)
  V0bd(:) = V0bd_t(:,1)

  call mod_V(icheck,Lmax,Lmax_pot,nlm_V,nlm_pot,nr,nrmtg,nrmtsd,nspin,r,Rmtg,Rmtsd,V,V_intmax,V0bd,Vrato,Ylm_comp)

  Ecomp = .false.
  if( abs(Eimag_t(1)) > eps10 ) then
    Ecomp = .true.
  else
    do isp = 1,nspin
      do ie = 1,n_Ec
        if( Ecinetic_t(isp,ie) > eps10 ) cycle
        Ecomp = .true.
        exit
      end do
    end do
  endif
  Radial_comp = Ecomp .or. ( ( Hubb_a .or. Full_pot ) .and. Ylm_comp )

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

  allocate( ur_t(nr,nlm1g,nlm_fp,nspinp,nspino,n_Ec) )
  allocate( ui_t(nr,nlm1g,nlm_fp,nspinp,nspino,n_Ec) )

  do L = 0,lfin

    if( Hubb_a .and. L == L_hubbard( Numat ) )  then
      Hubb_m = .true.
    else
      Hubb_m = .false.
    endif

    if( Full_pot ) then
      nlm = ( Lmax + 1 )**2
      nlm2 = nlm
    elseif( Hubb_m .and. .not. Hubb_d ) then
      nlm = 2*L + 1
      nlm2 = nlm
    elseif( Spinorbite .or. Hubb_m ) then
      nlm = 2*L + 1
      nlm2 = 1
    else
      nlm = 1
      nlm2 = 1
    endif

    nrmax = nrmtsd + 1 
    allocate( ui(nr,nlm,nlm2,nspinp,nspino) )
    allocate( ur(nr,nlm,nlm2,nspinp,nspino) )
    allocate( Tau(nlm,nspinp,nlm,nspinp) )
    allocate( us(nrmax,nlm,nlm2,nspinp,nspino) )
    allocate( usi(nrmax,nlm,nlm2,nspinp,nspino) )
    allocate( usr(nrmax,nlm,nlm2,nspinp,nspino) )

    if( L == 0 ) allocate( us_t(nrmax,nlm1g,nlm_fp,nspinp,nspino,n_Ec) )

    do ie = 1,n_Ec

      if( icheck > 1 ) write(3,110) ie, Enervide(ie)*rydb, Ecinetic_t(:,ie)*rydb 
      if( icheck > 1 .and. n_V <= 2 ) write(3,120) V0bd_t(1,:)*rydb 
     
      Ecinetic(:) = Ecinetic_t(:,ie)
      Eimag = Eimag_t(ie)
      konde(:) = sqrt( cmplx(Ecinetic(:), Eimag, db) )

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

      call Sch_radial( Ecomp ,Eimag, f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, L, Lmax, m_hubb, &
         nlm, nlm2, nlm_V, nr, nrmtg, nspin, nspino, nspinp, Numat, r, Radial_comp, Relativiste, Renorm, Rmtg, &
         Spinorbite, Tau, ui, ur, V, V_hubb )

! Calculation of irregular solution
      if( Solsing ) &
        call Sch_radial_irreg( Ecomp, Eimag, f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, L, &
           Lmax, m_hubb, nlm, nlm2, nlm_V, nr, nrmtsd, nrmax, nspin, nspino, nspinp, Numat, r, Radial_comp, Rmtsd, Spinorbite, &
           usi, usr, V, V_hubb )

      us(:,:,:,:,:) = cmplx( usr(:,:,:,:,:), usi(:,:,:,:,:), db )
      
      if( Radial_comp ) then
        if( Full_pot ) then
          ur_t(:,:,:,:,:,ie) = ur(:,:,:,:,:)
          ui_t(:,:,:,:,:,ie) = ui(:,:,:,:,:)
          us_t(:,:,:,:,:,ie) = us(:,:,:,:,:)
        elseif( Hubb_m .and. .not. Hubb_d ) then
          ur_t(:,L**2+1:L**2+nlm,L**2+1:L**2+nlm,:,:,ie) = ur(:,1:nlm,1:nlm,:,:)
          ui_t(:,L**2+1:L**2+nlm,L**2+1:L**2+nlm,:,:,ie) = ui(:,1:nlm,1:nlm,:,:)
          us_t(:,L**2+1:L**2+nlm,L**2+1:L**2+nlm,:,:,ie) = us(:,1:nlm,1:nlm,:,:)
        elseif( No_diag ) then
          do lm1 = L**2+1,(L+1)**2
            Lm = min( lm1 - L**2, nlm )
            ur_t(:,lm1,lm1,:,:,ie) = ur(:,Lm,1,:,:)
            ui_t(:,lm1,lm1,:,:,ie) = ui(:,Lm,1,:,:)
            us_t(:,lm1,lm1,:,:,ie) = us(:,Lm,1,:,:)
          end do
        elseif( Spinorbite .or. Hubb_m ) then
           do lm1 = L**2+1,(L+1)**2
             Lm = lm1 - L**2
             ur_t(:,lm1,1,:,:,ie) = ur(:,Lm,1,:,:)
             ui_t(:,lm1,1,:,:,ie) = ui(:,Lm,1,:,:)
             us_t(:,lm1,1,:,:,ie) = us(:,Lm,1,:,:)
           end do
        elseif( m_depend ) then
          do lm1 = L**2+1,(L+1)**2
            ur_t(:,lm1,1,:,:,ie) = ur(:,1,1,:,:)
            ui_t(:,lm1,1,:,:,ie) = ui(:,1,1,:,:)
            us_t(:,lm1,1,:,:,ie) = us(:,1,1,:,:)
          end do
        else
          ur_t(:,L,1,:,:,ie) = ur(:,1,1,:,:)
          ui_t(:,L,1,:,:,ie) = ui(:,1,1,:,:)
          us_t(:,L,1,:,:,ie) = us(:,1,1,:,:)
        endif
      else
        if( Full_pot ) then
          ur_t(:,:,:,:,:,ie) = ur(:,:,:,:,:)
        elseif( Hubb_m .and. .not. Hubb_d ) then
          ur_t(:,L**2+1:L**2+nlm,L**2+1:L**2+nlm,:,:,ie) = ur(:,1:nlm,1:nlm,:,:)
        elseif( No_diag ) then
          do lm1 = L**2+1,(L+1)**2
            Lm = min( lm1 - L**2, nlm )
            ur_t(:,lm1,lm1,:,:,ie) = ur(:,Lm,1,:,:)
          end do
        elseif( Spinorbite .or. Hubb_m ) then
           do lm1 = L**2+1,(L+1)**2
             Lm = lm1 - L**2
             ur_t(:,lm1,1,:,:,ie) = ur(:,Lm,1,:,:)
           end do
        elseif( m_depend ) then
          do lm1 = L**2+1,(L+1)**2
            ur_t(:,lm1,1,:,:,ie) = ur(:,1,1,:,:)
          end do
        else
          ur_t(:,L+1,1,:,:,ie) = ur(:,1,1,:,:)
        endif
      endif

    end do

    deallocate( Tau, ui, ur, us, usi, usr )

  end do   ! fin de La boucle sur L

  if( nr_zet > 0 ) zet(:,:,:,:,:,:) = ur_t(:,:,:,:,:,:) 

  allocate( ur1(nr,nlm1g,nlm_fp,nspinp,nspino,2) )
  allocate( ui1(nr,nlm1g,nlm_fp,nspinp,nspino,2) )

  do ie1 = 1,ief-1

    ur1(:,:,:,:,:,1) = ur_t(:,:,:,:,:,ie1)
    ui1(:,:,:,:,:,1) = ui_t(:,:,:,:,:,ie1)

    do ie2 = ief, n_Ec
    
      ur1(:,:,:,:,:,2) = ur_t(:,:,:,:,:,ie2)
      ui1(:,:,:,:,:,2) = ui_t(:,:,:,:,:,ie2)
     
      call radial_matrix_optic(ip_max,ip0,n_Ec,nlm1g,nlm_fp,nr,nrmtsd,nspinp,nspino,r,Radial_comp,Rmtsd,roff_rr,ui1,ur1,Vecond)

      if( ief > 1 .and. ip0 == 0 ) then
        i = 0
        do isp1 = 1,nspinp
          do isp2 = 1,nspinp
            i = i + 1
            j = 0
            do iso1 = 1,nspino
              do iso2 = 1,nspino
                j = j + 1
                if( nlm_fp == 1 ) then
                  roff0(ie1,ie2,:,:,isp1,isp2,j) = roff_rr(:,:,1,1,i,j,0)
                else
                  roff0(ie1,ie2,:,:,isp1,isp2,j) = ( 0._db, 0._db )
                  do lm1 = 1,nlm_fp
                    do lm2 = 1,nlm_fp
                      roff0(ie1,ie2,lm1,lm2,isp1,isp2,j) = sum( roff_rr(:,:,lm1,lm2,i,j,0) )
                    end do
                  end do 
                endif
              end do
            end do
          end do
        end do

      endif

    end do
  end do

  deallocate( ui_t, ui1, ur_t, ur1, us_t, V )

  if( icheck > 1 ) then

    Diag = .true.
    
    if( Diag ) then
      write(3,130) (((( Lm, isp, iso1, iso2, iso2 = 1,nspino), iso1 = 1,nspino), isp = 1,nspinp), Lm = 1,nlm1g)
      do ie1 = 1,ief-1
        do ie2 = ief, n_Ec
          write(3,140) Enervide(ie1)*rydb, Enervide(ie2)*rydb, (( roff0(ie1,ie2,Lm,Lm,isp,isp,:), isp = 1,nspinp), &
                                                                            Lm = 1,nlm1g )
        end do
      end do
    else
      write(3,145) (((((( lm1, lm2, isp1, isp2, iso1, iso2, iso2 = 1,nspino), iso1 = 1,nspino), isp2 = 1,nspinp), &
                                                            isp1 = 1,nspinp), lm2 = 1,nlm_fp), lm1 = 1,nlm1g )
      do ie1 = 1,ief-1
        do ie2 = ief, n_Ec
          write(3,140) Enervide(ie1)*rydb, Enervide(ie2)*rydb, (((( roff0(ie1,ie2,lm1,lm2,isp1,isp2,:), &
                                          isp2 = 1,nspinp), isp1 = 1,nspinp), lm2 = 1,nlm_fp), lm1 = 1,nlm1g )
        end do
      end do
    endif
    
    mot = ' '
    if( Ecomp .and. nspino == 2 ) then
      mot(11:17) = 'up sol1'
      mot(37:43) = 'up sol2'
      mot(63:69) = 'dn sol1'
      mot(89:95) = 'dn sol2'
    elseif( nspino == 2 ) then
      mot(5:50) = 'up sol1      up sol2      dn sol1      dn sol2'
    elseif( nspinp == 2 ) then
      mot = '      up           dn'
    else
      mot = ' '
    endif

    do ip = ip0,ip_max
      select case(ip)
        case(0)
          write(3,160) '  monopole'
        case(1)
          write(3,160) '    dipole'
        case(2)
          write(3,160) 'quadrupole'
        case(3)
          write(3,160) '  octupole'
      end select
      if( Full_pot .or. Hubb_a ) then
        write(3,170) ' L1 m1 Lp mp L2 m2 Lp mp', mot
      else
        write(3,175) ' L1 m1 L2 m2', mot
      endif

      do L = 0,Lmax
        do m = -L,L
          if( m_depend ) then
            Lm = L**2 + L + 1 + m
          else
            if( m /= 0 ) cycle
            Lm = L + 1
          endif
          do Lp = 0,Lmax
            if( .not. Full_pot .and. L /= Lp ) cycle
            do mp = -Lp,Lp
              if( .not. ( Hubb_a .or. Full_pot .or. m == mp ) ) cycle
              Lmp = min( Lp**2 + Lp + 1 + mp, nlm_fp )

              do lf = 0,Lmax
                do mf = -lf,lf
                  if( m_depend ) then
                    lmf = lf**2 + lf + 1 + mf
                  else
                    if( mf /= 0 ) cycle
                    lmf = lf + 1
                  endif
                  lmpf = 0
                  do lpf = 0,Lmax
                    if( .not. Full_pot .and. lf /= lpf ) cycle
                    do mpf = -lpf,lpf
                      if( .not. ( Hubb_a .or. Full_pot .or. mf == mpf ) ) cycle
                      lmpf = lpf**2 + lpf + 1 + mpf
                      lmpf = min( nlm_fp, lmpf )

                      if( Full_pot .or. Hubb_a ) then
                        write(3,180) L, m, Lp, mp, lf, mf, lpf, mpf, (roff_rr(Lm,lmf,Lmp,lmpf,isp,:,ip), isp = 1,nspinp**2)
                      else
                        write(3,185) L, m, lf, mf, (roff_rr(Lm,lmf,Lmp,lmpf,isp,:,ip), isp = 1,nspinp**2)
                      endif
                    end do
                  end do
                end do
              end do
            end do
          end do
        end do
      end do
    end do

  end if

  return
  110 format(/' Energy index =',i4,',  Enervide =',f10.3,',  Ecinetic =',2f10.3,' eV')
  120 format(22x,'V0bd     =',4f10.3)
  130 format(/' Roff0',/'   Enervide_1   Enervide_2', 1000(4x,i3,3i2) ) 
  140 format(2f13.5,1p,1000e13.5)
  145 format(/' Roff0',/'   Enervide_1   Enervide_2', 1000(3x,2i3,4i1) ) 
  160 format(/' Radial matrix (Roff_rr), ',a10,1x,'term:')
  170 format(a24,a104)
  175 format(a12,a104)
  180 format(8i3,1p,16e13.5)
  185 format(4i3,1p,16e13.5)
end

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

! Calculation of density of state
! Note that Harm_cubic is set as .false. during the SCF_step

subroutine Cal_dens(Cal_xanes,Density_comp,Density_sp,drho_self,Ecinetic,Eimag,Energ,Enervide,Full_atom, &
                Full_pot,Harm_cubic,Hubb,Hubb_diag,Hubb_diag_abs,iaabsi,iaprotoi,icheck,itypei,itypepr,lla2_state, &
                Lmax_pot,Lmaxat,m_hubb,mpinodes,mpirank,n_atom_0,n_atom_0_self,n_atom_ind,n_atom_ind_self, &
                n_atom_proto,natome,nb_test,nlmagm,nlm_pot, &
                nrato,nrm,nrm_self,nspin,nspino,nspinp,ntype,Numat,rato,Relativiste,Renorm,Rmtg,Rmtsd,Solsing,Solsing_only, &
                Spinorbite,State_all,Statedens,Statedens_i,Taull,Test_case,V_hubb,V_hubb_abs,V_intmax,V0bd,Vrato,Ylm_comp)

  use declarations
  implicit none

  integer ia, iaabsi, iapr, icheck, ipr, ir, isp, isp1, isp2, it, lla2_state, Lm, Lmax, Lmax_pot, &
    m_hubb, mpinodes, mpirank, n_atom_0, n_atom_0_self, n_atom_ind, n_atom_ind_self, &
    n_atom_proto, natome, nb_test, nlm_pot, nlma, nlmagm, nr, nrs, nrm, nrm_self, nspin, nspino, nspinp, ntype, Z

  complex(kind=db), dimension(nlmagm,nspinp,nlmagm,nspinp,natome):: Taull
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb_abs
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp,n_atom_0_self:n_atom_ind_self):: V_hubb
  complex(kind=db), dimension(:,:,:,:), allocatable:: V_hubb_t
  complex(kind=db), dimension(:,:,:,:), allocatable:: Taulla

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

  logical:: Absorbeur, Cal_xanes, Density_comp, Density_sp, Full_atom, Full_pot, Harm_cubic, Hubb_a, Hubb_d, &
    Hubb_diag_abs, Relativiste, Renorm, Self, Solsing, Solsing_only, Spinorbite, State_all, Ylm_comp, Comp_to_real
  logical, dimension(nb_test):: Test_case
  logical, dimension(0:ntype):: Hubb
  logical, dimension(n_atom_0:n_atom_ind):: iapr_done
  logical, dimension(n_atom_0_self:n_atom_ind_self):: Hubb_diag

  real(kind=db):: Eimag, Energ, Enervide, V_intmax
  real(kind=db), dimension(nspin):: Ecinetic, V0bd
  real(kind=db), dimension(0:n_atom_proto):: Rmtg, Rmtsd
  real(kind=db), dimension(lla2_state,nspinp,lla2_state,nspinp,n_atom_0:n_atom_ind,0:mpinodes-1):: Statedens, Statedens_i
  real(kind=db), dimension(0:nrm,0:ntype):: rato
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind) :: Vrato
  real(kind=db), dimension(nrm_self,nlm_pot,nspinp,n_atom_0_self:n_atom_ind_self,0:mpinodes-1):: drho_self
  real(kind=db), dimension(:), allocatable:: r
  real(kind=db), dimension(:,:,:), allocatable:: drho, Vrato_t
  real(kind=db), dimension(:,:,:,:), allocatable:: State, State_i

  Self = .not. Cal_xanes

  if( Self ) drho_self(:,:,:,:,mpirank) = 0._db

  Statedens(:,:,:,:,:,mpirank) = 0._db
  Statedens_i(:,:,:,:,:,mpirank) = 0._db

  iapr_done(:) = .false.

  boucle_ia: do ia = 1,natome

    Absorbeur = ( ia == iaabsi .and. Cal_xanes )
    if( Cal_xanes .and. .not. ( State_all .or. Absorbeur ) ) cycle

    ipr = iaprotoi(ia)
    it = itypepr(ipr)
    Hubb_a = Hubb(it)

    Z = Numat( it )
    if( Z < 19 ) then
      Lmax = min(2,Lmaxat(ipr))
    elseif( Z > 18 .and. Z < 55 ) then
      Lmax = min(3,Lmaxat(ipr))
    else
      Lmax = min(4,Lmaxat(ipr))
    endif
    nlma = (Lmax + 1)**2

    if( Full_atom ) then
      iapr = ia
    else
      iapr = ipr
      if( iapr_done(iapr) ) cycle
    endif
    it = itypei(ia)

    do ir = 1,nrato(it)
      if( rato(ir,it) > Rmtsd(ipr) + eps10 ) exit
    end do
    nr = ir + 1

    if( Self ) then
      nrs = nr
    else
      nrs = 0
    endif
    allocate( r(nr) )
    allocate( drho(nrs,nlm_pot,nspinp) )
    allocate( State(nlma,nspinp,nlma,nspinp))
    allocate( State_i(nlma,nspinp,nlma,nspinp))
    allocate( Vrato_t(nr,nlm_pot,nspin) )
    allocate( V_hubb_t(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp) )
    allocate( Taulla(nlma,nspinp,nlma,nspinp) )
    State(:,:,:,:) = 0._db
    State_i(:,:,:,:) = 0._db
    drho(:,:,:) = 0._db
    r(1:nr) = rato(1:nr,it)
    Vrato_t(1:nr,:,:) = Vrato(1:nr,:,:,iapr)
    if( Hubb(it) .and. ( iapr <= n_atom_ind_self .or. Absorbeur ) ) then 
   ! ".or. Absorber" is because in case of Extract, n_atom_ind_self == 0, and the test becomes false
      Hubb_a = .true.
      if( Absorbeur ) then
        V_Hubb_t(:,:,:,:) = V_Hubb_abs(:,:,:,:)
        Hubb_d = Hubb_diag_abs
      else
        V_Hubb_t(:,:,:,:) = V_Hubb(:,:,:,:,iapr)
        Hubb_d = Hubb_diag(iapr)
      endif
    else
      Hubb_a = .false.
      Hubb_d = .true.
    end if

! Comp_to_real = .true. corresponds to calculation with complex harmonics that we project to real harmonics
    if( ( Cal_xanes .and. Density_comp ) .or. .not. Cal_xanes ) then
      Comp_to_real = .false.
    else
      Comp_to_real = Ylm_comp
    endif

    do isp1 = 1,nspinp
      do Lm = 1,nlma
        do isp2 = 1,nspinp
          Taulla(1:nlma,isp1,Lm,isp2) = Taull(1:nlma,isp1,Lm,isp2,ia)
        end do
      end do
    end do

    call Radial_sd(Density_sp,drho,Ecinetic,Eimag,Energ,Enervide,Full_pot,Harm_cubic,Hubb_a,Hubb_d,ia,icheck,Lmax, &
         Lmax_pot,m_hubb,nb_test,nlm_pot,nlma,nr,nrs,nspin,nspino,nspinp,Z,r,Relativiste,Renorm,Rmtg(ipr),Rmtsd(ipr), &
         Self,Solsing,Solsing_only,Spinorbite,State,State_i,Taulla,Test_case,V_hubb_t,V_intmax,V0bd,Vrato_t,Ylm_comp,Comp_to_real)

    deallocate( r, Taulla, V_hubb_t, Vrato_t )

    do isp1 = 1,nspinp
      do Lm = 1,nlma
        do isp2 = 1,nspinp
          Statedens(1:nlma,isp1,Lm,isp2,iapr,mpirank) = State(1:nlma,isp1,Lm,isp2)
          Statedens_i(1:nlma,isp1,Lm,isp2,iapr,mpirank) = State_i(1:nlma,isp1,Lm,isp2)
        end do
      end do
    end do

    if( Self ) then
      do isp = 1,nspinp
        do Lm = 1,nlm_pot
          drho_self(1:nr,Lm,isp,iapr,mpirank) = drho(1:nr,Lm,isp)
          if( .not. Full_pot ) exit
        end do
      end do
    endif

    deallocate( State, State_i, drho )

    iapr_done(iapr) = .true.

  end do boucle_ia

  return
end

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

! Calculation of radial integrals and irregular solution for the density of states
! Comp_to_real = .true. corresponds to calculation with complex harmonics that we project to real harmonics
! Called by Cal_dens
! In the SCF_step, Comp_to_real and Harm_cubic are false

subroutine Radial_sd(Density_sp,drho,Ecinetic,Eimag,Energ,Enervide,Full_pot,Harm_cubic,Hubb_a,Hubb_d,ia,icheck,Lmax, &
         Lmax_pot,m_hubb,nb_test,nlm_pot,nlma,nr,nrs,nspin,nspino,nspinp,Numat,r,Relativiste,Renorm,Rmtg,Rmtsd, &
         Self,Solsing,Solsing_only,Spinorbite,State,State_i,Taull,Test_case,V_hubb,V_intmax,V0bd,Vrato,Ylm_comp,Comp_to_real)

  use declarations
  implicit none

  integer, parameter:: Length_col = 27
  integer, parameter:: Length_n = 5
  
  integer:: ia, icheck, L, L_hubbard, Lfin, Lmax, Lmax_pot, m_hubb, nb_test, nlm_V, nlm_pot, nlm, nlm_fp, nlma, &
    nr, nrs, nrmtg, nrmtsd, nspin, nspino, nspinp, Numat

  character(len=Length_n):: Name 

  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(nlma,nspinp,nlma,nspinp):: Taull, Taull_loc
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb, V_hubb_loc 
  complex(kind=db), dimension(nlma,nspinp,nlma,nspinp):: State_loc
  complex(kind=db), dimension(:,:,:,:), allocatable:: Tau, V

  logical:: Density_sp, Ecomp, Full_pot, Harm_cubic, Hubb_a, Hubb_d, Hubb_m, Radial_comp, Relativiste, Renorm, &
    Self, Solsing, Solsing_only, Spinorbite, Ylm_comp, Ylm_comp_loc, Comp_to_real, Comp_to_real_loc
  logical, dimension(nb_test):: Test_case

  real(kind=db):: Eimag, Energ, Enervide, Rmtg, Rmtsd, V_intmax
  real(kind=db), dimension(nspin):: Ecinetic, V0bd
  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nr,nspin):: g0, gm, gp
  real(kind=db), dimension(nr,nspino):: gso
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato
  real(kind=db), dimension(nrs,nlm_pot,nspinp):: drho
  real(kind=db), dimension(nlma,nspinp,nlma,nspinp):: State, State_i
  real(kind=db), dimension(:,:,:,:,:), allocatable:: ui, ur

  konde(:) = sqrt( cmplx(Ecinetic(:), Eimag,db) )

  if( icheck > 1 ) then
    write(3,110)
    write(3,120) ia, Numat, Rmtg*bohr, Rmtsd*bohr, Energ*rydb
    write(3,130) Ecinetic(:)*rydb
    write(3,140) V0bd(:)*rydb
    write(3,150) konde(:)
  endif

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

  call mod_V(icheck,Lmax,Lmax_pot,nlm_V,nlm_pot,nr,nrmtg,nrmtsd,nspin,r,Rmtg,Rmtsd,V,V_intmax,V0bd,Vrato,Ylm_comp)

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

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

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

  TauLL_loc(:,:,:,:) = Taull(:,:,:,:)
  V_hubb_loc(:,:,:,:) = V_hubb(:,:,:,:) 
       
  if( ( Full_pot .or. ( Hubb_a .and. .not. Hubb_d ) ) .and. Ylm_comp .and. .not. Spinorbite ) then
    Ylm_comp_loc = .false.
    Comp_to_real_loc = .false.
    Name = 'TauLL'
    call Trans_CompToReal_TauLL(.true.,icheck,Length_n,Lmax,Name,nlma,nspinp,Spinorbite,TauLL_loc)
    if( Hubb_a .and. .not. Hubb_d ) &
      call Trans_CompToReal_V_Hubb(icheck,m_hubb,nspinp,Spinorbite,V_hubb_loc)
  else
    Ylm_comp_loc = Ylm_comp
    Comp_to_real_loc = Comp_to_real
  endif
  
  do L = 0,lfin

    if( Hubb_a .and. L == L_hubbard( Numat ) )  then
      Hubb_m = .true.
    else
      Hubb_m = .false.
    endif

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

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

    call Sch_radial( Ecomp, Eimag, f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, L, Lmax, m_hubb, &
         nlm, nlm_fp, nlm_V, nr, nrmtg, nspin, nspino, nspinp, Numat, r, Radial_comp, Relativiste, Renorm, Rmtg, &
         Spinorbite, Tau, ui, ur, V, V_hubb_loc )

! Calculation of the radial integral
    if( .not. Solsing_only ) &
        call Radial_matrix_sd(Density_sp,drho,Full_pot,Harm_cubic,icheck,L,Lmax,nlm_pot,nlm,nlm_fp,nlma,nr,nrs,nrmtsd, &
           nspin,nspino,nspinp,r,Radial_comp,Rmtsd,Spinorbite,State,State_i,Self,Taull_loc,ui,ur,Ylm_comp_loc,Comp_to_real_loc)
    
! Calculation of the DOS due to the irregular solution 
    if( Solsing ) then
      if( Test_case(4) ) then
    ! before April 3rd, 2023
        call Cal_Solsing_sd(drho,Ecomp,Eimag,f2,Full_pot,g0,gm,gp,gso,Harm_cubic,Hubb_a,Hubb_d,icheck, &
          konde,L,Lmax,m_hubb,nlm_V,nlm_pot,nlm,nlm_fp,nlma,nr,nrmtsd,nrs,nspin,nspino,nspinp,Numat,r,Radial_comp,Rmtsd,Self, &
          Spinorbite,State,Tau,ui,ur,V,V_hubb_loc,Comp_to_real_loc)
      else
        call Cal_Solsing_sd_mod(Density_sp,drho,Ecomp,Eimag,f2,Full_pot,g0,gm,gp,gso,Harm_cubic,Hubb_a,Hubb_d,icheck, &
          konde,L,Lmax,m_hubb,nlm_V,nlm_pot,nlm,nlm_fp,nlma,nr,nrmtsd,nrs,nspin,nspino,nspinp,Numat,r,Radial_comp,Rmtsd,Self, &
          Spinorbite,State,State_i,Tau,ui,ur,V,V_hubb_loc,Ylm_comp_loc,Comp_to_real_loc)
      endif
    endif

    deallocate( Tau )
    deallocate( ui, ur )

  end do   ! end of loop over L

  deallocate( V )

  if( Ylm_comp .and. .not. Ylm_comp_loc .and. .not. Comp_to_real ) then
    State_loc(:,:,:,:) = cmplx( State(:,:,:,:), State_i(:,:,:,:), db )

    Name = 'State'
    call Trans_CompToReal_TauLL(.false.,icheck,Length_n,Lmax,Name,nlma,nspinp,Spinorbite,State_loc)
    
    State(:,:,:,:) = real( State_loc(:,:,:,:), db )
    State_i(:,:,:,:) = aimag( State_loc(:,:,:,:) )
  endif
  
  return
  110 format(/' ---- Radial_sd ----',100('-'))
  120 format(/'     Atom =',i3,/'        Z =',i3,/ '     Rmtg =',f10.5,' A,  Rmtsd =',f10.5,' A',/ &
              '    Energ =',f10.3,' eV')
  130 format(' Ecinetic =',2f10.3)
  140 format('    V0bd  =',2f10.3)
  150 format('    konde =',2f12.5)
  230 format(2i3,1p,16(1x,2e13.5))
  240 format(3i3,1p,16(1x,2e13.5))
end

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

! Transformation from complex to real basis of multiple scattering amplitudes (or reverse if "comp_to_real" = .false.)

subroutine Trans_CompToReal_TauLL(Comp_to_real,icheck,Length_n,Lmax,Name,nlma,nspinp,Spinorbite,TauLL_loc)

  use declarations
  implicit none

  integer, parameter:: Length_col = 27
  
  integer:: icheck, isp1, isp2, L, Length_n, Lm, Lmax, m, n_dim, nlma, nspinp
  
  character(len=Length_n):: Name 
  character(len=Length_col), dimension(:), allocatable:: Col_name 

  complex(kind=db), dimension(nlma,nspinp,nlma,nspinp):: Taull_loc
  
  logical:: Comp_to_real, Spinorbite
  
  if( icheck > 2 ) then
    n_dim = nlma * nspinp 
    allocate( Col_name(n_dim) )
    if( Comp_to_real ) then
      write(3,'(/A)' ) ' Complex harmonics basis'
    else
      write(3,'(/A)' ) ' Real harmonics basis'
    endif
    if( nspinp == 2 ) then
      call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
    else
      call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
    endif
    if( nspinp == 1 ) then
      write(3,'(/a8,100a27)') '  L  m  ', Col_name(:)
    else
      write(3,'(/a10,100a27)') '  L  m isp', Col_name(:)
    endif
    deallocate( Col_name )
    do L = 0,Lmax
      do isp1 = 1,nspinp
        do m = -L,L
          Lm = L**2 + L + 1 + m
          if( nspinp == 1 ) then
            write(3,230) L, m, ( TauLL_loc(Lm,isp1,:,isp2)*rydb, isp2 = 1,nspinp )
          else
            write(3,240) L, m, isp1, ( TauLL_loc(Lm,isp1,:,isp2)*rydb, isp2 = 1,nspinp )
          endif
        end do
      end do
    end do
  endif
  
  call Trans_Tau_ab(Comp_to_real,Lmax,Lmax,nspinp,Spinorbite,Taull_loc)

  if( icheck > 1 ) then
    if( Comp_to_real ) then
      write(3,'(/A)' ) ' Real harmonics basis'
    else
      write(3,'(/A)' ) ' Complex harmonics basis'
    endif
    n_dim = nlma * nspinp 
    allocate( Col_name(n_dim) )
    if( nspinp == 2 ) then
      call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
    else
      call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
    endif
    if( nspinp == 1 ) then
      write(3,'(/a8,100a27)') '  L  m  ', Col_name(:)
    else
      write(3,'(/a10,100a27)') '  L  m isp', Col_name(:)
    endif
    deallocate( Col_name )
    do L = 0,Lmax
      do isp1 = 1,nspinp
        do m = -L,L
          Lm = L**2 + L + 1 + m
          if( nspinp == 1 ) then
            write(3,230) L, m, ( TauLL_loc(Lm,isp1,:,isp2)*rydb, isp2 = 1,nspinp )
          else
            write(3,240) L, m, isp1, ( TauLL_loc(Lm,isp1,:,isp2)*rydb, isp2 = 1,nspinp )
          endif
        end do
      end do
    end do
  endif
  
  return
  230 format(2i3,1p,16(1x,2e13.5))
  240 format(3i3,1p,16(1x,2e13.5))
end

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

! Transformation from complex to real basis of Hubbard potentials

subroutine Trans_CompToReal_V_Hubb(icheck,m_hubb,nspinp,Spinorbite,V_hubb_loc)

  use declarations
  implicit none

  integer, parameter:: Length_col = 27
  integer, parameter:: Length_n = 6
  
  integer:: icheck, isp1, isp2, L, m, m_hubb, n_dim, nspinp
  
  character(len=Length_n):: Name 
  character(len=Length_col), dimension(:), allocatable:: Col_name 

  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb_loc 
  
  logical:: Spinorbite
  
  L = m_hubb

  if( icheck > 1 ) then
  
    n_dim = (2 * L + 1) * nspinp 
    allocate( Col_name(n_dim) )
    Name = 'V_hu_c'
    if( nspinp == 2 ) then
      call Create_col_name(Col_name,L,L,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
    else
      call Create_col_name(Col_name,L,L,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
    endif
    if( nspinp == 1 ) then
      write(3,'(/a8,100a27)') '  L  m  ', Col_name(:)
    else
      write(3,'(/a10,100a27)') '  L  m isp', Col_name(:)
    endif
    deallocate( Col_name )
    do isp1 = 1,nspinp
      do m = -L,L
        if( nspinp == 1 ) then
          write(3,230) L, m, ( V_hubb_loc(m,isp1,:,isp2)*rydb, isp2 = 1,nspinp )
        else
          write(3,240) L, m, isp1, ( V_hubb_loc(m,isp1,:,isp2)*rydb, isp2 = 1,nspinp )
        endif
      end do
    end do
  endif
  
  call Trans_Tau(.true.,L,L,nspinp,Spinorbite,V_hubb_loc)

  if( icheck > 1 ) then
  
    L = 2
    n_dim = (2 * L + 1) * nspinp 
    allocate( Col_name(n_dim) )
    Name = 'V_hu_r'
    if( nspinp == 2 ) then
      call Create_col_name(Col_name,L,L,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
    else
      call Create_col_name(Col_name,L,L,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
    endif
    if( nspinp == 1 ) then
      write(3,'(/a8,100a27)') '  L  m  ', Col_name(:)
    else
      write(3,'(/a10,100a27)') '  L  m isp', Col_name(:)
    endif
    deallocate( Col_name )
    do isp1 = 1,nspinp
      do m = -L,L
        if( nspinp == 1 ) then
          write(3,230) L, m, ( V_hubb_loc(m,isp1,:,isp2)*rydb, isp2 = 1,nspinp )
        else
          write(3,240) L, m, isp1, ( V_hubb_loc(m,isp1,:,isp2)*rydb, isp2 = 1,nspinp )
        endif
      end do
    end do
  endif
  
  return
  230 format(2i3,1p,16(1x,2e13.5))
  240 format(3i3,1p,16(1x,2e13.5))
end

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

subroutine Trans_HarmoC_to_R(L,Mat_c,Mat_r)

  use declarations
  implicit none

  integer:: is, L, m
  
  complex(kind=db), dimension(-L:L,-L:L):: Mat_c, Mat_r, Trans, Transi 
      
  Trans(:,:) = (0._db, 0._db)
  Transi(:,:) = (0._db, 0._db)

  do m = -L,L
    if( m > 0 ) then
      is = (-1)**m
      Trans(m,m) = cmplx( is * sqrt_1o2, 0._db, db)
      Trans(m,-m) = cmplx( 0._db, is * sqrt_1o2, db)
    elseif( m == 0 ) then
      Trans(0,0) = (1._db, 0._db)
    else
      Trans(m,-m) = cmplx(sqrt_1o2, 0._db, db)
      Trans(m,m) = cmplx(0._db, -sqrt_1o2, db)
    endif
  end do
  
  Transi = Conjg( Transpose( Trans ) )

  Mat_r = Matmul( Transi, Matmul( Mat_c, Trans ) )

  return
end

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

! Transformation of complex spherical harmonics to real spherical (or tesseral) harmonics

subroutine Trans_CtoR(c_harm,isg,m,m_r,Comp_to_real)
    
  use declarations
  implicit none

  integer:: isg, m, m_r

  logical:: Comp_to_real
  
  complex(kind=db):: c_harm 
  
  if( Comp_to_real ) then
    if( m_r < 0 ) then
      if( isg == 1 ) then
        c_harm = cmplx( 0._db, sqrt_1o2, db )
      else
        c_harm = cmplx( 0._db, - (-1)**m_r * sqrt_1o2, db )
      endif
    elseif( m_r == 0 ) then
      c_harm = ( 1._db, 0._db )
    else
      if( isg == 1 ) then
        c_harm = cmplx( (-1)**m_r * sqrt_1o2, 0._db, db )
      else
        c_harm = cmplx( sqrt_1o2, 0._db, db )
      endif
    endif
    m = isg * m_r
  else
    m = m_r
    c_harm = ( 1._db, 0._db )
  endif

  return
end

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

! Transformation of complex spherical harmonics to real spherical (or tesseral) harmonics

subroutine Trans_RtoC(c_harm,isg,m,m_r,Comp_to_real)
    
  use declarations
  implicit none

  integer:: isg, m, m_r

  logical:: Comp_to_real
  
  complex(kind=db):: c_harm 
  
  if( Comp_to_real ) then
    m = isg * m_r
!    if( m < 0 ) then
!      if( isg == 1 ) then
!        c_harm = cmplx( 0._db, - sqrt_1o2, db )
!      else
!        c_harm = cmplx( sqrt_1o2, 0._db, db )
!      endif
!    elseif( m_r == 0 ) then
!      c_harm = ( 1._db, 0._db )
!    else
!      if( isg == 1 ) then
!        c_harm = cmplx( (-1)**m_r * sqrt_1o2, 0._db, db )
!      else
!        c_harm = cmplx( 0._db, (-1)**m_r * sqrt_1o2, db )
!      endif
!    endif
!!!!!!!!!
    if( m_r < 0 ) then
      if( isg == 1 ) then
        c_harm = cmplx( 0._db, sqrt_1o2, db )
      else
        c_harm = cmplx( 0._db, -(-1)**m_r * sqrt_1o2, db )
      endif
    elseif( m_r == 0 ) then
      c_harm = ( 1._db, 0._db )
    else
      if( isg == 1 ) then
        c_harm = cmplx( (-1)**m_r * sqrt_1o2, 0._db, db )
      else
        c_harm = cmplx( sqrt_1o2, 0._db, db )
      endif
    endif

!!!!!!!
  else
    m = m_r
    c_harm = ( 1._db, 0._db )
  endif

  return
end

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

! Transformation harmo comp to Harmo real when Comp_to_real = true and reverse when false.

subroutine Trans_Tau(Comp_to_real,L1,L2,nspin,Spinorbite,TauLL)

  use declarations
  implicit none

  integer:: is, isp1, isp2, L, L1, L2, m, mp, nspin

  complex(kind=db), dimension(-max(L1,L2):max(L1,L2),-max(L1,L2):max(L1,L2)):: Trans, Trans_i
  complex(kind=db), dimension(-L1:L1,-L2:L2):: Tau
  complex(kind=db), dimension(-L1:L1,-L1:L1):: Trans_1
  complex(kind=db), dimension(-L2:L2,-L2:L2):: Trans_2
  complex(kind=db), dimension(-L1:L1,nspin,-L2:L2,nspin):: TauLL

  logical:: Comp_to_real, Spinorbite

  if( L1 == 0 .and. L2 == 0 ) return
  
  Trans(:,:) = (0._db, 0._db)
  Trans_i(:,:) = (0._db, 0._db)

  L = max( L1, L2 )
  
! Matrix real to complex  
  do m = -L,L
    if( m > 0 ) then
      is = (-1)**m
      Trans(m,m) = cmplx( is * sqrt_1o2, 0._db, db)
      Trans(m,-m) = cmplx( 0._db, is * sqrt_1o2, db)
    elseif( m == 0 ) then
      Trans(0,0) = (1._db, 0._db)
    else
      Trans(m,-m) = cmplx(sqrt_1o2, 0._db, db)
      Trans(m,m) = cmplx(0._db, -sqrt_1o2, db)
    endif
  end do
  
  if( .not. Comp_to_real ) Trans = Conjg( Transpose( Trans ) )

  Trans_i = Conjg( Transpose( Trans ) )

  Trans_1(-L1:L1,-L1:L1) = Trans_i(-L1:L1,-L1:L1)
  Trans_2(-L2:L2,-L2:L2) = Trans(-L2:L2,-L2:L2)
      
  do isp1 = 1,nspin
    do isp2 = 1,nspin
      if( .not. Spinorbite .and. isp1 /= isp2 ) cycle
      
      Tau(:,:) = TauLL(:,isp1,:,isp2)

      Tau = matmul( Trans_1, matmul( Tau, Trans_2 ) )
    
! in order it works, I do not understand why
      if( Comp_to_real ) then
        do m = -L1,L1
          do mp = -L2,L2
            if( ( m < 0 .and. mp >= 0 ) .or. ( mp < 0 .and. m >= 0 ) ) Tau(m,mp) = - Tau(m,mp)   
          end do
        end do
      elseif( L1 == L2 ) then
        Tau = Transpose( Tau )
      endif

      TauLL(:,isp1,:,isp2) = Tau(:,:)

    end do
  end do
  
  return
end

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

! Transformation harmo comp to Harmo real when Comp_to_real = .true.
!                                 and reverse when false.

subroutine Trans_Tau_ab(Comp_to_real,Lmaxa,Lmaxb,nspin,Spinorbite,Taull)

  use declarations
  implicit none

  integer:: L1, L2, Lmaxa, Lmaxb, nspin

  complex(kind=db), dimension(:,:,:,:), allocatable:: Tau_ab
  complex(kind=db), dimension((Lmaxa+1)**2,nspin,(Lmaxb+1)**2,nspin):: Taull

  logical:: Comp_to_real, Spinorbite

  do L1 = 0,Lmaxa
    do L2 = 0,Lmaxb

      allocate( Tau_ab(-L1:L1,nspin,-L2:L2,nspin) )

      Tau_ab(-L1:L1,:,-L2:L2,:) = Taull(L1**2+1:(L1+1)**2,:,L2**2+1:(L2+1)**2,:)

      call Trans_Tau(Comp_to_real,L1,L2,nspin,Spinorbite,Tau_ab)

      Taull(L1**2+1:(L1+1)**2,:,L2**2+1:(L2+1)**2,:) = Tau_ab(-L1:L1,:,-L2:L2,:) 

      deallocate( Tau_ab )
    
    end do  
  end do

  return
end

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

! Transformation real (or tesseral) harmonics basis to cubic harmonics basis

subroutine Trans_Tau_ZtoK(Lmaxa,Lmaxb,nspinp,Spinorbite,Taull)

  use declarations
  implicit none

  integer, parameter:: lmax_ZtoK = 4
   
  integer:: isp1, isp2, L, La, Lb, lm0a, lm0b, Lmax, Lmaxa, Lmaxb, nspinp

  complex(kind=db), dimension(:,:), allocatable:: Tau_ab
  complex(kind=db), dimension((Lmaxa+1)**2,nspinp,(Lmaxb+1)**2,nspinp):: Taull

  logical:: Spinorbite

  real(kind=db):: a, b, c, d, e, f
  real(kind=db), dimension(-lmax_ZtoK:lmax_ZtoK,-lmax_ZtoK:lmax_ZtoK,0:lmax_ZtoK):: ZtoK
  real(kind=db), dimension(:,:), allocatable:: Trans_a, Trans_b

  Lmax = max( Lmaxa, Lmaxb )
  Lmax = min( Lmax, lmax_ZtoK )

  ZtoK(:,:,:) = 0.0_db

  do L = 0,Lmax
    select case(L)
      case(0)
        ZtoK(0,0,0) = 1._db
      case(1)
        ZtoK(-1,1,L) = 1._db
        ZtoK(0,-1,L) = 1._db
        ZtoK(1,0,L)  = 1._db
      case(2)
        ZtoK(-2,2,L) = 1._db
        ZtoK(-1,0,L) = 1._db
        ZtoK(0,-1,L) = 1._db
        ZtoK(1,1,L) = 1._db
        ZtoK(2,-2,L) = 1._db
      case(3)
        a = - sqrt(3._db/8)
        b = sqrt(5._db/8)
        ZtoK(-3,-2,L) = 1._db
        ZtoK(-2,1,L) = a;       ZtoK(-2,3,L) = b 
        ZtoK(-2,1,L) = a;       ZtoK(-2,3,L) = b 
        ZtoK(-1,-3,L) = -b;     ZtoK(-1,-1,L) = a 
        ZtoK(0,0,L) = 1._db
        ZtoK(1,1,L) = -b;       ZtoK(1,3,L) = a 
        ZtoK(2,-3,L) = a;       ZtoK(2,-1,L) = b 
        ZtoK(3,2,L) = 1._db
      case(4)
        c = sqrt(7._db/12)
        d = sqrt(5._db/12)
        e = - sqrt(1._db/8)
        f = sqrt(7._db/8)
        ZtoK(-4,0,L) = c;     ZtoK(-4,4,L) = d
        ZtoK(-3,2,L) = 1._db
        ZtoK(-2,0,L) = -d;    ZtoK(-2,4,L) = c 
        ZtoK(-1,-3,L) = e;    ZtoK(-1,-1,L) = -f 
        ZtoK(0,1,L) = f;      ZtoK(0,3,L) = e 
        ZtoK(1,-4,L) = 1._db
        ZtoK(2,-3,L) = f;     ZtoK(2,-1,L) = e 
        ZtoK(3,1,L) = e;     ZtoK(3,3,L) = -f 
        ZtoK(4,-2,L) = 1._db
    end select
  end do  
  
  do La = 0,Lmaxa

    lm0a = La**2 + La + 1
    allocate( Trans_a(-La:La,-La:La) )
    Trans_a(-La:La,-La:La) = ZtoK(-La:La,-La:La,La)

    do Lb = 0,Lmaxb

      lm0b = Lb**2 + Lb + 1
      allocate( Trans_b(-Lb:Lb,-Lb:Lb) )
      Trans_b(-Lb:Lb,-Lb:Lb) = ZtoK(-Lb:Lb,-Lb:Lb,Lb)

      allocate( Tau_ab(-La:La,-Lb:Lb) )

      do isp1 = 1,nspinp
        do isp2 = 1,nspinp
          if( .not. Spinorbite .and. isp1 /= isp2 ) cycle

          Tau_ab(-La:La,-Lb:Lb) = Taull(lm0a-La:lm0a+La,isp1,lm0b-Lb:lm0b+Lb,isp2)

          Tau_ab = matmul( Trans_a, matmul( Tau_ab, Transpose( Trans_b ) ) )

          Taull(lm0a-La:lm0a+La,isp1,lm0b-Lb:lm0b+Lb,isp2) = Tau_ab(-La:La,-Lb:Lb) 

        end do
      end do

      deallocate( Tau_ab, Trans_b )
    
    end do  

    deallocate( Trans_a )

  end do

  return
end

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

! Calculation of the radial integral for the density of state
! Comp_to_real = .true. corresponds to the calculation with complex harmo that we project to real harmo 

subroutine Radial_matrix_sd(Density_sp,drho,Full_pot,Harm_cubic,icheck,L,Lmax,nlm_pot,nlm,nlm_fp,nlma,nr,nrs,nrmtsd, &
           nspin,nspino,nspinp,r,Radial_comp,Rmtsd,Spinorbite,State,State_i,Self,Taull,ui,ur,Ylm_comp,Comp_to_real)

  use declarations
  implicit none

  integer, parameter:: Length_col = 27
  integer, parameter:: Length_n = 3

  real(kind=db), parameter:: sqrt_4pi = sqrt( 4*pi )
  real(kind=db), parameter:: One_on_sqrt_2 = 1 / sqrt( 1._db )
  
  integer:: i_k1, i_k2, icheck, ir, is, is1, is2, isg1, isg2, iso, iso1, iso2, isp, isp1, isp2, L, L1, L2, l3, Lm, Lm0, &
    lm1, lm2, Lmax, Lmax_pot, Lmn, Lmp, Lmp1, Lmp2, Lp1, Lp2, m, m1, m2, m3, m_k1, m_k2, mp1, mp2, m_r1, m_r2, mv1, mv2, &
    n_dim, n_rk1, n_rk2, n1, n2, nlm_pot, nlm, nlm_fp, nlma, np1, np2, nr, nrmtsd, nrs, nspin, nspino, nspinp
     
! The volatile statetement prevent for some compilation optimization
! On linux, at times without it, one gets segmentation fault error message during the running with magnetic system (YJ 2018/01/25)
  integer, volatile:: n_k1, n_k2
!  integer:: n_k1, n_k2

  character(len=Length_n):: Name 
  character(len=Length_col), dimension(:), allocatable:: Col_name 
  
  complex(kind=db):: c_harm, c_harm1, c_harm2, rof_sd, Sta_e, Sta_s
  complex(kind=db), dimension(nspinp):: rof_sd_l
  complex(kind=db), dimension(nrmtsd):: fc
  complex(kind=db), dimension(nrmtsd,nspinp):: fc_l
  complex(kind=db), dimension(nlma,nspinp,nlma,nspinp):: Taull
  complex(kind=db), dimension(:,:,:,:), allocatable:: Tau_ab

  logical:: Density_sp, Full_pot, Harm_cubic, Radial_comp, Self, Spinorbite, Ylm_comp, Comp_to_real

  real(kind=db):: c_cubic1, c_cubic2, f_integr3, g, Gaunt_r, gauntcp, radlr, radli, Rmtsd, Sta_i, Sta_r
  real(kind=db), dimension(nr):: r
  real(kind=db), dimension(nrmtsd):: r2, rr, fcr, fci, ri2
  real(kind=db), dimension(nspinp):: drho_mn, drho_mn_i, drho_mp, drho_mp_i
  real(kind=db), dimension(nrs,nlm_pot,nspinp):: drho, drho_i
  real(kind=db), dimension(nlma,nspinp,nlma,nspinp):: State, State_i
  real(kind=db), dimension(nr,nlm,nlm_fp,nspinp,nspino):: ui, ur

  if( Full_pot ) then
    Lm0 = 0
  else
    Lm0 = L**2
  endif
  
  drho_i(:,:,:) = 0._db

  rr(1:nrmtsd) = r(1:nrmtsd)
  r2(1:nrmtsd) = r(1:nrmtsd)**2
  ri2(1:nrmtsd) = 1 / ( quatre_pi * r2(1:nrmtsd) )

  if( nlm == 1 ) then
    do isp = 1,nspinp
      iso = min( isp, nspino )
      if( Radial_comp ) then
        fcr(1:nrmtsd) = r2(1:nrmtsd) * ( ur(1:nrmtsd,1,1,isp,iso) * ur(1:nrmtsd,1,1,isp,iso) &
                                       - ui(1:nrmtsd,1,1,isp,iso) * ui(1:nrmtsd,1,1,isp,iso) )
        radlr = f_integr3(rr,fcr,1,nrmtsd,Rmtsd)
        fci(1:nrmtsd) = r2(1:nrmtsd) * ( ur(1:nrmtsd,1,1,isp,iso) * ui(1:nrmtsd,1,1,isp,iso) &
                                       + ui(1:nrmtsd,1,1,isp,iso) * ur(1:nrmtsd,1,1,isp,iso) )
        radli = f_integr3(rr,fci,1,nrmtsd,Rmtsd)
      else
        fcr(1:nrmtsd) = r2(1:nrmtsd) * ur(1:nrmtsd,1,1,isp,iso) * ur(1:nrmtsd,1,1,isp,iso)
        radlr = f_integr3(rr,fcr,1,nrmtsd,Rmtsd)
        fci(:) = 0._db
        radli = 0._db
      endif
      rof_sd_l(isp) = cmplx( radlr, radli, db )
      if( Self ) fc_l(1:nrmtsd,isp) = ri2(1:nrmtsd) * cmplx( fcr(1:nrmtsd), fci(1:nrmtsd), db )

    end do
  endif

  if( icheck > 2 ) then
    write(3,'(/A)') ' Radial integral for the density of state:'
    if( nlm_fp > 1 ) then
      write(3,110)
    elseif( Spinorbite ) then
      write(3,120)
    else
      write(3,130)
    endif
  endif

  n_k1 = 0
  do L1 = 0,Lmax
    if( .not. Full_pot .and. L /= L1 ) cycle
    do m_k1 = -L1,L1
      n_k1 = n_k1 + 1
      lm1 = Lm0 + n_k1

      if( .not. Harm_cubic .or. L1 /= 3 .or. ( m_k1 == -3 .or. m_k1 == 0 .or. m_k1 == 3 ) ) then
        n_rk1 = 1
      else
        n_rk1 = 2
      endif

      do isp1 = 1,nspinp
      
        n_k2 = 0
        do L2 = 0,Lmax
          if( .not. Full_pot .and. L /= L2 ) cycle
          do m_k2 = -L2,L2
            n_k2 = n_k2 + 1
            lm2 = Lm0 + n_k2

            if( .not. Harm_cubic .or. L2 /= 3 .or. ( m_k2 == -3 .or. m_k2 == 0 .or. m_k2 == 3 ) ) then
              n_rk2 = 1
            else
              n_rk2 = 2
            endif
        
            do isp2 = 1,nspinp
  !            if( isp1 /= isp2 ) cycle ! in a scalar product there is no spin-crossing (but there is solution crossing)
              if( .not. Spinorbite .and. isp1 /= isp2 ) cycle
        
              do i_k1 = 1,n_rk1

                call Trans_TtoK(c_cubic1,Harm_cubic,i_k1,L1,m_k1,m_r1)

                do isg1 = -1,1,2
 
                  if( ( .not. Comp_to_real .or. m_r1 == 0 ) .and. isg1 == -1 ) cycle
       
                  call Trans_RtoC(c_harm1,isg1,m1,m_r1,Comp_to_real)

                  if( Full_pot ) then
                    n1 = L1**2 + L1 + 1 + m1
                  elseif( nlm == 1 ) then
                    n1 = 1
                  else
                    n1 = L1 + 1 + m1 
                  endif

                  np1 = 0
                  do Lp1 = 0,Lmax
                    if( .not. Full_pot .and. Lp1 /= L1 ) cycle

                    do mp1 = -Lp1, Lp1
                      if( nlm_fp == 1 .and. mp1 /= m1 ) cycle
                      np1 = np1 + 1

                      do iso1 = 1,nspino
  
                        if( Spinorbite ) then
                          is1 = iso1
                        else
                          is1 = isp1
                        endif

                        if( Spinorbite .and. nlm_fp == 1 ) then
                          mv1 = mp1 + iso1 - isp1
                          if( mv1 > L1 .or. mv1 < - L1 ) cycle
                        else
                          mv1 = mp1
                        endif                  

                        Lmp1 = Lp1**2 + Lp1 + 1 + mv1

                        do i_k2 = 1,n_rk2
        
                          call Trans_TtoK(c_cubic2,Harm_cubic,i_k2,L2,m_k2,m_r2)
        
                          do isg2 = -1,1,2
        
                            if( ( .not. Comp_to_real .or. m_r2 == 0 ) .and. isg2 == -1 ) cycle
                   
                            call Trans_CtoR(c_harm2,isg2,m2,m_r2,Comp_to_real)

                            if( Full_pot ) then
                              n2 = L2**2 + L2 + 1 + m2
                            elseif( nlm == 1 ) then
                              n2 = 1
                            else
                              n2 = L2 + 1 + m2 
                            endif
        
                            c_harm = c_harm1 * c_cubic1 * conjg( c_harm2 ) * c_cubic2
        
                            np2 = 0
                            do Lp2 = 0,Lmax
                              if( .not. Full_pot .and. Lp2 /= L2 ) cycle
                              if( .not. Full_pot .and. Lp2 /= Lp1 ) cycle
        
                              do mp2 = -Lp2,Lp2
                                if( nlm_fp == 1 .and. mp2 /= m2 ) cycle
                                np2 = np2 + 1

                                do iso2 = 1,nspino
 
                                  if( Spinorbite ) then
                                    is2 = iso2
                                  else
                                    is2 = isp2
                                  endif

                                  if( Spinorbite .and. nlm_fp == 1 ) then
                                    mv2 = mp2 + iso2 - isp2
                                    if( mv2 > L2 .or. mv2 < - L2 ) cycle
                                  else
                                    mv2 = mp2
                                  endif                  
                                  
                                  Lmp2 = Lp2**2 + Lp2 + 1 + mv2

                                  if( nlm == 1 ) then
        
                                    rof_sd = rof_sd_l(isp1)
                                    
                                    if( Self .and. isp1 == isp2 .and. lm1 == lm2 ) fc(:) = fc_l(:,isp1)
        
                                  else
                                    
                                    if( Radial_comp ) then
                                      fcr(1:nrmtsd) = r2(1:nrmtsd) &
                                                    * ( ur(1:nrmtsd,n1,np1,isp1,iso1) * ur(1:nrmtsd,n2,np2,isp2,iso2) &
                                                      - ui(1:nrmtsd,n1,np1,isp1,iso1) * ui(1:nrmtsd,n2,np2,isp2,iso2) )
                                      radlr = f_integr3(rr,fcr,1,nrmtsd,Rmtsd)
                                      fci(1:nrmtsd) = r2(1:nrmtsd) &
                                                    * ( ur(1:nrmtsd,n1,np1,isp1,iso1) * ui(1:nrmtsd,n2,np2,isp2,iso2) &
                                                      + ui(1:nrmtsd,n1,np1,isp1,iso1) * ur(1:nrmtsd,n2,np2,isp2,iso2) )
                                      radli = f_integr3(rr,fci,1,nrmtsd,Rmtsd)
                                    else
                                      fcr(1:nrmtsd) = r2(1:nrmtsd) * ur(1:nrmtsd,n1,np1,isp1,iso1) &
                                                                   * ur(1:nrmtsd,n2,np2,isp2,iso2)
                                      radlr = f_integr3(rr,fcr,1,nrmtsd,Rmtsd)
                                      fci(:) = 0._db
                                      radli = 0._db
                                    endif
        
                                    rof_sd = cmplx( radlr, radli, db)
        
                                    if( Self .and. isp1 == isp2 ) &
                                      fc(1:nrmtsd) = cmplx( fcr(1:nrmtsd),fci(1:nrmtsd),db) * ri2(1:nrmtsd )

                                  endif

                                  Sta_e = c_harm * rof_sd * Taull(Lmp1,is1,Lmp2,is2)
                                  Sta_s = conjg( c_harm ) * rof_sd * Taull(Lmp2,is2,Lmp1,is1)
                           
                                  Sta_r = 0.5_db * real( Sta_e - Sta_s, db)
                                  Sta_i = 0.5_db * aimag( Sta_e + Sta_s )
                                  
                                  if( Density_sp ) then
                                    State(lm1+mv1-m1,is1,lm2+mv2-m2,is2) = State(lm1+mv1-m1,is1,lm2+mv2-m2,is2) - Sta_i
                                    State_i(lm1+mv1-m1,is1,lm2+mv2-m2,is2) = State_i(lm1+mv1-m1,is1,lm2+mv2-m2,is2) + Sta_r
                                  else
                                    State(lm1,isp1,lm2,isp2) = State(lm1,isp1,lm2,isp2) - Sta_i
                                    State_i(lm1,isp1,lm2,isp2) = State_i(lm1,isp1,lm2,isp2) + Sta_r
                                  endif

                                  if( Self .and. isp1 == isp2 ) then

                                    Lm = 0
                                    boucle_L3: do L3 = 0,Lmax
                                      if( .not. Full_pot .and. L3 > 0 ) cycle                                  

                                      do m3 = -L3,L3
                                        Lm = Lm + 1
                                        if( Lm > nlm_pot ) exit
              ! not 4.pi,  the real V_L should then be multiplied again by sqrt_4pi                                        
                                        if( Lm == 1 ) then
                                          if( Ylm_comp ) then
                                            g = sqrt_4pi * gauntcp(L1,m1,L2,m2,L3,m3)
                                          else
                                            g = sqrt_4pi * Gaunt_r(L1,m1,L2,m2,L3,m3)
                                          endif
                                        else
                                          if( Ylm_comp ) then
                                            g = 4 * pi * gauntcp(L1,m1,L2,m2,L3,m3)
                                          else
                                            g = 4 * pi * Gaunt_r(L1,m1,L2,m2,L3,m3)
                                          endif
                                        endif

                                        if( abs( g ) < eps10 ) cycle 
                                      
                                        do ir = 1,nrmtsd
                                          Sta_e = c_harm * fc(ir) * Taull(Lmp1,is1,Lmp2,is2)
                                          Sta_s = conjg(c_harm) * fc(ir) * Taull(Lmp2,is2,Lmp1,is1)
                                          Sta_r = 0.5_db * real( Sta_e - Sta_s, db)
                                          Sta_i = 0.5_db * aimag( Sta_e + Sta_s )
                                          drho(ir,Lm,isp1) = drho(ir,Lm,isp1) - g * Sta_i        
                                          drho_i(ir,Lm,isp1) = drho_i(ir,Lm,isp1) + g * Sta_r        
                                        end do
                                      
                                      end do
        
                                    end do boucle_L3

                                  endif
        
                                  if( icheck > 2 .and. ( abs( Sta_e ) > eps10 .or. abs( Sta_s ) > eps10 ) ) then
                                    if( nlm_fp > 1 ) then
                                      write(3,140) L1, m_k1, m_r1, m1, isp1, L2, m_k2, m_r2, m2, isp2, Lp1, mp1, &
                                        iso1, Lp2, mp2, iso2, Lm1, Lm2, Lmp1, Lmp2, &
                                        State(Lm1,isp1,Lm2,isp2), State_i(Lm1,isp1,Lm2,isp2), & 
                                       -Sta_i, Sta_r, rof_sd, Taull(Lmp1,is1,Lmp2,is2), Taull(Lmp2,is2,Lmp1,is1)
                                        
                                    elseif( Spinorbite ) then
                                      write(3,150) lm1, isp1, lm2, isp2, Lmp1, is1, Lmp2, is2, L1, m_k1, m_r1, m1, L2, m_k2, &
                                         m_r2, m2, iso1, iso2, State(lm1,isp1,lm2,isp2), State_i(lm1,isp1,lm2,isp2), &
                                         -Sta_i, Sta_r, rof_sd, Taull(Lmp1,is1,Lmp2,is2), Taull(Lmp2,is2,Lmp1,is1) 
                                    else
                                      write(3,160) L1, m_k1, m_r1, m1, isp1, L2, m_k2, m_r2, m2, isp2, &
                                        State(lm1,isp1,lm2,isp2), State_i(lm1,isp1,lm2,isp2), -Sta_i, Sta_r, rof_sd, &
                                        Taull(Lmp1,is1,Lmp2,is2) 
                                    endif
                                  endif
        
                                end do  ! boucle iso2
                              end do  ! boucle mp2
                            end do  ! boucle Lp2
                          end do  ! boucle isg2
                        end do  ! boucle ik_2

                      end do  ! boucle i_k1
                    end do  ! boucle iso1
                  end do  ! boucle mp1
                end do  ! boucle isg1
              end do  ! boucle i_k1

            end do  ! boucle isp2
          end do  ! boucle m_k2
        end do  ! boucle L2

      end do  ! boucle isp1
    end do  ! boucle m_k1
  end do  ! boucle L1
  
  if( Self .and. Ylm_comp .and. Full_pot ) then
    Lmax_pot = nint( sqrt( real( nlm_pot ) ) ) - 1
    
    do L = 1,Lmax_pot
      do m = 1,L
        Lmp = L**2 + L + 1 + m
        Lmn = L**2 + L + 1 - m
        is = (-1)**m
        do ir = 1,nrmtsd
          drho_mp(:) = drho(ir,Lmp,:)
          drho_mp_i(:) = drho_i(ir,Lmp,:)
          drho_mn(:) = drho(ir,Lmn,:)
          drho_mn_i(:) = drho_i(ir,Lmn,:)
          drho(ir,Lmp,:) = One_on_sqrt_2 * ( is * drho_mp(:) + drho_mn(:) )  
          drho(ir,Lmn,:) = One_on_sqrt_2 * ( drho_mn_i(:) - is * drho_mp_i(:) )  
        end do
      end do
    end do
    
  endif

  if( icheck > 1 ) then
    n_dim = nlma * nspinp  
    allocate( Col_name(n_dim) )
    Name = 'Tau'
    if( Full_pot .and. nspinp == 2 ) then
      call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
    elseif( Full_pot ) then
      call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
    elseif( nspinp == 2 ) then
      call Create_col_name(Col_name,L,L,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
    else
      call Create_col_name(Col_name,L,L,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
    endif
    write(3,'(/A)') ' Multiple scattering amplitude:'

    if( nspinp == 1 ) then
      write(3,165) Col_name(:)
    else
      write(3,170) Col_name(:)
    endif
    deallocate( Col_name )

    do isp1 = 1,nspinp
      n1 = 0
      do L1 = 0,Lmax
        if( .not. Full_pot .and. L1 /= L ) cycle
        do m1 = -L1,L1
          n1 = n1 + 1
          lm1 = Lm0 + n1
          if( Full_pot .and. nspinp == 2 ) then
            write(3,180) L1, m1, isp1, (( Taull(lm1,isp1,lm2,isp2), lm2 = 1,nlma), isp2 = 1,nspinp )
          elseif( Full_pot ) then
            write(3,185) L1, m1, (( Taull(lm1,isp1,lm2,isp2), lm2 = 1,nlma), isp2 = 1,nspinp )
          elseif( nspinp == 2 ) then
            write(3,180) L1, m1, isp1, ((Taull(lm1,isp1,lm2,isp2), lm2 = Lm0+1,Lm0+2*L1+1), isp2 = 1,nspinp )
          else
            write(3,185) L1, m1, ((Taull(lm1,isp1,lm2,isp2), lm2 = Lm0+1,Lm0+2*L1+1), isp2 = 1,nspinp )
          endif
        end do
      end do
    end do
      
    if( nlm > 1 .and. Ylm_comp .and. icheck > 3 ) then

      allocate( Tau_ab(-L:L,nspinp,-L:L,nspinp) )
      
      Tau_ab(-L:L,:,-L:L,:) = Taull(L**2+1:(L+1)**2,:,L**2+1:(L+1)**2,:)

      call Trans_Tau(.true.,L,L,nspinp,Spinorbite,Tau_ab)

      allocate( Col_name(n_dim) )
      Name = 'Tau'
      call Create_col_name(Col_name,L,L,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
      write(3,'(/A)') ' Multiple scattering amplitude, real harmonics basis:'
      write(3,165) Col_name(:)
      deallocate( Col_name )
 
      do isp1 = 1,nspinp
        do m1 = -L,L
          if( nspinp == 1 ) then
            write(3,185) L, m1, ( ( Tau_ab(m1,isp1,m2,isp2), m2 = -L,L ), isp2 = 1,nspinp)
          else
            write(3,185) L, m1, isp1, ( ( Tau_ab(m1,isp1,m2,isp2), m2 = -L,L ), isp2 = 1,nspinp)
          endif
        end do
      end do

      deallocate( Tau_ab )
    endif

    allocate( Col_name(n_dim) )
    Name = 'DOS'
    if( Full_pot .and. nspinp == 2 ) then
      call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
    elseif( Full_pot ) then
      call Create_col_name(Col_name,0,Lmax,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
    elseif( nspinp == 2 ) then
      call Create_col_name(Col_name,L,L,1,0,Length_col,Length_n,Name,3,n_dim,nspinp)
    else
      call Create_col_name(Col_name,L,L,1,0,Length_col,Length_n,Name,2,n_dim,nspinp)
    endif
    write(3,'(/A)') ' Radial integral for the density of state before singul:'
    if( nspinp == 1 ) then
      write(3,165) Col_name(:)
    else
      write(3,170) Col_name(:)
    endif
    deallocate( Col_name )

    do isp1 = 1,nspinp
      n1 = 0
      do L1 = 0,Lmax
        if( .not. Full_pot .and. L1 /= L ) cycle
        do m1 = -L1,L1
          n1 = n1 + 1
          lm1 = Lm0 + n1
          if( nspinp == 2 .and. Full_pot ) then
            write(3,180) L1, m1, isp1, (( State(lm1,isp1,lm2,isp2), State_i(lm1,isp1,lm2,isp2), lm2 = 1,nlma), isp2 = 1,nspinp )
          elseif( Full_pot ) then 
            write(3,185) L1, m1, (( State(lm1,isp1,lm2,isp2), State_i(lm1,isp1,lm2,isp2), lm2 = 1,nlma), isp2 = 1,nspinp )
          elseif( nspinp == 2 ) then
            write(3,180) L1, m1, isp1, (( State(lm1,isp1,lm2,isp2), State_i(lm1,isp1,lm2,isp2), lm2 = Lm0+1,Lm0+2*L1+1), &
                                                                                                isp2 = 1,nspinp )
          else
            write(3,185) L1, m1, (( State(lm1,isp1,lm2,isp2), State_i(lm1,isp1,lm2,isp2), lm2 = Lm0+1,Lm0+2*L1+1), &
                                                                                                isp2 = 1,nspinp )
          endif 
        end do
      end do
    end do
  endif

  if( icheck > 2 .and. Self ) then
    if( nspin == 1 ) then
      write(3,190) ( Lm, Lm = 1,nlm_pot )
    else
      write(3,200) ( Lm, Lm, Lm = 1,nlm_pot )
    endif
    do ir = 1,nrmtsd
      write(3,210) r(ir)*bohr, ( drho(ir,Lm,:), Lm = 1,nlm_pot )
    end do
  endif

  return
  110 format(' L1 mk1 mr1 m1 isp1 L2 mk2 mr2 m2 isp2 Lp1 mp1 iso1 Lp2 mp2 iso2 Lm1 Lm2 Lmp1 Lmp2',11x,'State',22x,'dState',21x, &
             'rof_sd',20x,'Taull_e',20x,'Taull_s')
  120 format(' Lm1 isp1 Lm2 isp2 Lmp1 is1 Lmp2 is2 L1 mk1 mr1 m1 L2 mk2 mr2 m2 iso1 iso2',11x,'State',22x,'dState',21x, &
             'rof_sd',20x,'Taull_e',20x,'Taull_s')
  130 format(' L1 mk1 mr1 m1 isp1 L2 mk2, mr2 m2 isp2',11x,'State',22x,'dState',21x,'rof_sd',21x,'Taull')
  140 format(2(2i3,3i4,1x),2(i3,i4,i5,1x),i3,i4,2i5,1x,1p,6(1x,2e13.5))
  150 format(i3,i5,i4,2i5,i4,i5,i4,2(i4,i3,3i4),1x,1p,5(1x,2e13.5))
  160 format(2(2i3,3i4,1x),1p,4(1x,2e13.5))
  165 format('  L  m ',100a27)
  170 format('  L  m isp',100a27)
  180 format(3i3,1p,28(1x,2e13.5))
  185 format(2i3,1p,28(1x,2e13.5))
  190 format(/' drho before singul', /'   Radius   ',100(6x,i2,5x))
  200 format(/' drho before singul', /'   Radius   ',100(3x,i2,' up',8x,i2,' dn',5x))
  210 format(1p,300e13.5)
end

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

! Transformation of real (or tesseral) spherical harmonics to cubic spherical harmonics

subroutine Trans_TtoK(c_cubic,Harm_cubic,i_k,L,m_k,m_r)
    
  use declarations
  implicit none

  integer:: i_k, L, m_k, m_r

  logical:: Harm_cubic
  
  real(kind=db):: c_cubic 
  
  if( Harm_cubic .and. L >= 1 .and. L <= 3 ) then

    Select case(L)
      Case(1)

        select case(m_k)
          case(-1)
            m_r = 1; c_cubic = 1._db
          case(0)
            m_r = -1; c_cubic = 1._db
          case(1)
            m_r = 0; c_cubic = 1._db
        end select
  
      Case(2)

        select case(m_k)
          case(-2)
            m_r = 2; c_cubic = 1._db
          case(-1)
            m_r = 0; c_cubic = 1._db
          case(0)
            m_r = -1; c_cubic = 1._db
          case(1)
            m_r = 1; c_cubic = 1._db
          case(2)
            m_r = -2; c_cubic = 1._db
        end select
      
      Case(3)
      
        select case(m_k)
          case(-3)
            m_r = -2; c_cubic = 1._db
          case(-2)
            if( i_k == 1 ) then
              m_r = 1; c_cubic = - sqrt( 3._db / 8 )
            else
              m_r = 3; c_cubic = sqrt( 5._db / 8 )
            endif
          case(-1)
            if( i_k == 1 ) then
              m_r = -3; c_cubic = - sqrt( 5._db / 8 )
            else
              m_r = -1; c_cubic = - sqrt( 3._db / 8 )
            endif
          case(0)
            m_r = 0; c_cubic = 1._db
          case(1)
            if( i_k == 1 ) then
              m_r = 1; c_cubic = - sqrt( 5._db / 8 )
            else
              m_r = 3; c_cubic = - sqrt( 3._db / 8 )
            endif
          case(2)
            if( i_k == 1 ) then
              m_r = -3; c_cubic = - sqrt( 3._db / 8 )
            else
              m_r = -1; c_cubic = sqrt( 5._db / 8 )
            endif
          case(3)
            m_r = 2; c_cubic = 1._db
        end select
  
    end select 

  else
  
    c_cubic = 1._db
    m_r = m_k
  
  endif

  return
end

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

! Calculation of the DOS related to the irregular solution

Subroutine Cal_Solsing_sd(drho,Ecomp,Eimag,f2,Full_pot,g0,gm,gp,gso,Harm_cubic,Hubb_a,Hubb_d,icheck, &
          konde,LL,Lmax,m_hubb,nlm_V,nlm_pot,nlm,nlm_fp,nlma,nr,nrmtsd,nrs,nspin,nspino,nspinp,Numat,r,Radial_comp,Rmtsd,Self, &
          Spinorbite,State,Tau,ui,ur,V,V_hubb,Comp_to_real)

  use declarations
  implicit none

  integer:: i_k, icheck, ir, is1, is2, isg1, isg2, iso1, iso2, isp, L, LL, Lm, Lmax, Lmp1, Lmp2, Lp1, Lp2, m, m_hubb, m_k, m_r, &
    m1, m2, mp1, mp2,  ms1, ms2, n_k, n_rk, nlm_V, &
    nlm_pot, nlm, nlm_fp, n1, n2, n_r, n0, nlma, np1, np2,  nr, nrmax, nrmtsd, nrs, nspin, nspino, nspinp, Numat

  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(nlm,nspinp,nlm,nspinp):: Tau
  complex(kind=db), dimension(nr,nlm_V,nlm_V,nspin):: V
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb

  logical:: Ecomp, Full_pot, Harm_cubic, Hubb_a, Hubb_d, Radial_comp, Self, Spinorbite, Comp_to_real

  real(kind=db):: c_cubic, c_harm, Eimag, f_integr3, fac, Rmtsd, Sing
  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nrmtsd):: fctt, ri2, rr
  real(kind=db), dimension(nrmtsd,nspinp):: fct
  real(kind=db), dimension(nr,nspin):: g0, gm, gp
  real(kind=db), dimension(nr,nspino):: gso
  real(kind=db), dimension(nr,nlm,nlm_fp,nspinp,nspino):: ui, ur
  real(kind=db), dimension(nrs,nlm_pot,nspinp):: drho
  real(kind=db), dimension(nlma,nspinp,nlma,nspinp):: State
  
  real(kind=db), dimension(:,:,:,:,:), allocatable:: usi, usr

  rr(1:nrmtsd) = r(1:nrmtsd)

  nrmax = nrmtsd + 1
  allocate( usi(nrmax,nlm,nlm_fp,nspinp,nspino) )
  allocate( usr(nrmax,nlm,nlm_fp,nspinp,nspino) )

  call Sch_radial_irreg( Ecomp, Eimag, f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, LL, &
       Lmax, m_hubb, nlm, nlm_fp, nlm_V, nr, nrmtsd, nrmax, nspin, nspino, nspinp, Numat, r, Radial_comp, Rmtsd, Spinorbite, &
       usi, usr, V, V_hubb )

  if( icheck == 2 ) write(3,110)

  ri2(1:nrmtsd) = 1 / ( quatre_pi * r(1:nrmtsd)**2 )

! Here one takes r = r', because one calculates the trace of G(r,r')
! One calculates only the imaginary part
  n_k = 0
  do L = 0,Lmax
    if( .not. Full_pot .and. L /= LL ) cycle

    do m_k = -L,L
      if( nlm == 1 .and. m_k /= 0 ) cycle
      n_k = n_k + 1

! When nlm_V = 1, all radial wave function of same L are equal and the basis change for harm cubic is not useful
      if( nlm_V == 1 .or. .not. Harm_cubic .or. L /= 3 .or. ( m_k == -3 .or. m_k == 0 .or. m_k == 3 ) ) then
        n_rk = 1
      else
        n_rk = 2
      endif

      fct(:,:) = 0._db

      do isp = 1,nspinp

        do i_k = 1,n_rk

          if( nlm == 1 ) then
            m_r = m_k
            c_cubic = 1._db
          else
            call Trans_TtoK(c_cubic,Harm_cubic,i_k,L,m_k,m_r)
          endif
          
          n_r = n_k + m_r - m_k
          
          do isg1 = -1,1,2

            if( ( .not. Comp_to_real .or. m_r == 0 ) .and. isg1 == -1 ) cycle
       
            if( Comp_to_real .and. m_r /= 0 ) then
              c_harm = 0.5_db
              m1 = isg1 * m_r
              if( isg1 == 1 ) then
                n1 = n_r
              else
                n1 = n_r - 2 * m_r
              endif
            else
              c_harm = 1._db
              m1 = m_r
              n1 = n_r
            endif

            c_harm = c_harm * c_cubic**2                 

            do isg2 = -1,1,2

              if( ( .not. Comp_to_real .or. m_r == 0 ) .and. isg2 == -1 ) cycle
       
              if( Comp_to_real .and. m_r /= 0 ) then
                m2 = isg2 * m_r
                if( isg2 == 1 ) then
                  n2 = n_r
                else
                  n2 = n_r - 2 * m_r
                endif
              else
                m2 = m_r
                n2 = n_r
              endif

              np1 = 0
              do Lp1 = 0,Lmax
                if( .not. Full_pot .and. Lp1 /= L ) cycle
                do mp1 = -Lp1,Lp1
                  if( nlm_fp == 1 .and. mp1 /= m1 ) cycle
                  np1 = np1 + 1

                  do iso1 = 1,nspino
                    if( Spinorbite .and. nlm_fp == 1 ) then
                      ms1 = mp1 + iso1 - isp
                      if( ms1 > L .or. ms1 < -L ) cycle
                    else
                      ms1 = mp1
                    endif

                    if( nlm_fp > 1 ) then
                      Lmp1 = np1
                    elseif( nlm > 1 ) then
                      Lmp1 = Lp1 + 1 + ms1
                    else
                      Lmp1 = 1
                    endif

                    np2 = 0
                    do Lp2 = 0,Lmax
                      if( .not. Full_pot .and. Lp2 /= L ) cycle
                      do mp2 = -Lp2,Lp2
                        if( nlm_fp == 1 .and. mp2 /= m2 ) cycle
                        np2 = np2 + 1
           
                        do iso2 = 1,nspino
                          if( Spinorbite .and. nlm_fp == 1 ) then
                            ms2 = mp2 + iso2 - isp
                            if( ms2 > L .or. ms2 < -L ) cycle
                          else
                            ms2 = mp2
                          endif
           
                          if( nlm_fp > 1 ) then
                            Lmp2 = np2
                          elseif( nlm > 1 ) then
                            Lmp2 = Lp2 + 1 + ms2
                          else
                            Lmp2 = 1
                          endif
                          
                          if( Spinorbite ) then
                            is1 = iso1
                            is2 = iso2
                          else
                            is1 = isp
                            is2 = isp
                          endif

! Sign minus because usi is multiplied by TauLL wich is such that its imaginary part is minus the DOS ( and not plus like in formulae )                      
                          do ir = 1,nrmtsd
                            fac = 0.5_db * aimag( cmplx( ur(ir,n1,np1,isp,iso1), ui(ir,n1,np1,isp,iso1), db ) &
                                 * cmplx( usr(ir,n2,np2,isp,iso2), usi(ir,n2,np2,isp,iso2), db ) &
                                 * ( Tau(Lmp1,is1,Lmp2,is2) + Tau(Lmp2,is2,Lmp1,is1) ) ) 
                            fct(ir,isp) = fct(ir,isp) - c_harm * r(ir) * fac
                         end do

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

        end do

      end do

      do isp = 1,nspinp

        fctt(:) = fct(:,isp)
               
        if( icheck > 2 .and. Self ) then
          write(3,115) L, m_k, isp
          do ir = 1,nrmtsd
            write(3,180) r(ir)*bohr, fctt(ir)
          end do
        endif
        
        Sing = f_integr3(rr,fctt,1,nrmtsd,Rmtsd)
        if( Self ) fctt(1:nrmtsd) = fctt(1:nrmtsd) * ri2(1:nrmtsd)

        n0 = L**2 + L + 1
        if( nlm == 1 ) then
          do m = -L,L
            Lm = n0 + m
            State(Lm,isp,Lm,isp) = State(Lm,isp,Lm,isp) + Sing
            if( Self ) drho(1:nrmtsd,1,isp) = drho(1:nrmtsd,1,isp) + fctt(1:nrmtsd)
            if( icheck > 2 ) write(3,110)
            if( icheck > 1 ) write(3,120) L, m, isp, Sing, State(Lm,isp,Lm,isp)
          end do
        else
          Lm = n0 + m_k
          State(Lm,isp,Lm,isp) = State(Lm,isp,Lm,isp) + Sing
          if( Self ) drho(1:nrmtsd,1,isp) = drho(1:nrmtsd,1,isp) + fctt(1:nrmtsd)
          if( icheck > 2 ) write(3,110)
          if( icheck > 1 ) write(3,120) L, m_k, isp, Sing, State(Lm,isp,Lm,isp)
        endif

      end do
    end do
  end do

  deallocate( usi, usr )
 
  if( icheck > 2 .and. Self ) then
    write(3,170)
    do ir = 1,nrmtsd
      write(3,180) r(ir)*bohr, drho(ir,1,:)
    end do
  endif

  return
  110 format(/' Radial integral of singular solution for the density of state:',/'  L  m isp      Sing         State')
  115 format(/' Singular radial function for the density of state, L, m, isp =',3i3)
  120 format(3i3,1p,1x,e13.5,2x,2e13.5)
  170 format(/' drho after singul', /'   Radius         up           dn')
  180 format(1p,3e13.5)
end

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

! Calculation of the DOS related to the irregular solution

Subroutine Cal_Solsing_sd_mod(Density_sp,drho,Ecomp,Eimag,f2,Full_pot,g0,gm,gp,gso,Harm_cubic,Hubb_a,Hubb_d,icheck, &
          konde,LL,Lmax,m_hubb,nlm_V,nlm_pot,nlm,nlm_fp,nlma,nr,nrmtsd,nrs,nspin,nspino,nspinp,Numat,r,Radial_comp,Rmtsd,Self, &
          Spinorbite,State,State_i,Tau,ui,ur,V,V_hubb,Ylm_comp,Comp_to_real)

  use declarations
  implicit none

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

  integer:: i_k1, i_k2, icheck, ir, is, is1, is2, isg1, isg2, iso1, iso2, isp, L, L1, L2, L3, LL, Lm, Lm1, Lm2, Lmax, Lmax_pot, &
    Lmn, Lmp, Lmp1, &
    Lmp2, Lp1, Lp2, m, m_hubb, m_k1, m_k2, m_r1, m_r2, m1, m2, m3, mp1, mp2,  ms1, ms2, n_rk1, n_rk2, nlm_V, &
    nlm_pot, nlm, nlm_fp, n1, n2, n_r1, n_r2, n0, nlma, np1, np2, nr, nrmax, nrmtsd, nrs, nspin, nspino, nspinp, Numat

! The volatile statetement prevent for some compilation optimization
! On linux, at times without it, one gets segmentation fault error message (YJ 2023/04/05)
  integer, volatile:: n_k1, n_k2
!  integer:: n_k1, n_k2

  complex(kind=db):: c_harm, c_harm1, c_harm2, sta_e, sta_s
  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(nrmtsd,nspinp,nspinp,nspinp):: cfct
  complex(kind=db), dimension(nlm,nspinp,nlm,nspinp):: Tau
  complex(kind=db), dimension(nr,nlm_V,nlm_V,nspin):: V
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb

  logical:: Comp_to_real, Density_sp, Ecomp, Full_pot, Harm_cubic, Hubb_a, Hubb_d, Radial_comp, Self, Spinorbite, Ylm_comp

  real(kind=db):: c_cubic1, c_cubic2, Eimag, f_integr3, g, Gaunt_r, gauntcp, Rmtsd, Sing_i, Sing_r, Sta_i, Sta_r
  real(kind=db), dimension(nspinp):: drho_mn, drho_mn_i, drho_mp, drho_mp_i
  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nrmtsd):: fct_i, fct_r, ri2, rr
  real(kind=db), dimension(nr,nspin):: g0, gm, gp
  real(kind=db), dimension(nr,nspino):: gso
  real(kind=db), dimension(nrmtsd,nlm_pot,nspinp):: drho_i, drho_r
  real(kind=db), dimension(nr,nlm,nlm_fp,nspinp,nspino):: ui, ur
  real(kind=db), dimension(nrs,nlm_pot,nspinp):: drho
  real(kind=db), dimension(nlma,nspinp,nlma,nspinp):: State, State_i
  
  real(kind=db), dimension(:,:,:,:,:), allocatable:: usi, usr
  
  drho_i(:,:,:) = 0._db
  drho_r(:,:,:) = 0._db

  rr(1:nrmtsd) = r(1:nrmtsd)

  nrmax = nrmtsd + 1
  allocate( usi(nrmax,nlm,nlm_fp,nspinp,nspino) )
  allocate( usr(nrmax,nlm,nlm_fp,nspinp,nspino) )

  call Sch_radial_irreg( Ecomp, Eimag, f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, LL, &
       Lmax, m_hubb, nlm, nlm_fp, nlm_V, nr, nrmtsd, nrmax, nspin, nspino, nspinp, Numat, r, Radial_comp, Rmtsd, Spinorbite, &
       usi, usr, V, V_hubb )

  if( icheck == 2 ) then
    write(3,110)
    if( nlm == 1 ) then
      write(3,120)
    else
      write(3,130)
    endif
  endif

  ri2(1:nrmtsd) = 1 / ( quatre_pi * r(1:nrmtsd)**2 )

! Here one takes r = r', because one calculates the trace of G(r,r')
  n_k1 = 0
  do L1 = 0,Lmax
    if( .not. Full_pot .and. L1 /= LL ) cycle

    do m_k1 = -L1,L1
      if( nlm == 1 .and. m_k1 /= 0 ) cycle
      n_k1 = n_k1 + 1

! When nlm_V = 1, all radial wave function of same L are equal and the basis change for harm cubic is not useful
      if( nlm_V == 1 .or. .not. Harm_cubic .or. L1 /= 3 .or. ( m_k1 == -3 .or. m_k1 == 0 .or. m_k1 == 3 ) ) then
        n_rk1 = 1
      else
        n_rk1 = 2
      endif

      n_k2 = 0
      do L2 = 0,Lmax
        if( .not. Full_pot .and. L2 /= LL ) cycle

        do m_k2 = -L2,L2
          if( nlm == 1 .and. m_k2 /= 0 ) cycle
          n_k2 = n_k2 + 1

          if( nlm_V == 1 .or. .not. Harm_cubic .or. L2 /= 3 .or. ( m_k2 == -3 .or. m_k2 == 0 .or. m_k2 == 3 ) ) then
            n_rk2 = 1
          else
            n_rk2 = 2
          endif

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

          do isp = 1,nspinp

            do i_k1 = 1,n_rk1

              if( nlm == 1 ) then
                m_r1 = m_k1
                c_cubic1 = 1._db
              else
                call Trans_TtoK(c_cubic1,Harm_cubic,i_k1,L1,m_k1,m_r1)
              endif
              n_r1 = n_k1 + m_r1 - m_k1       
          
              do isg1 = -1,1,2

                if( ( .not. Comp_to_real .or. m_r1 == 0 ) .and. isg1 == -1 ) cycle
       
                if( Comp_to_real .and. m_r1 /= 0 ) then
                  call Trans_RtoC(c_harm1,isg1,m1,m_r1,Comp_to_real)
                  if( isg1 == 1 ) then
                    n1 = n_r1       
                  else
                    n1 = n_r1 - 2 * m_r1       
                  endif
                else
                  c_harm1 = 1._db
                  m1 = m_r1
                  n1 = n_r1       
                endif

                do i_k2 = 1,n_rk2

                  if( nlm == 1 ) then
                    m_r2 = m_k2
                    c_cubic2 = 1._db
                  else
                    call Trans_TtoK(c_cubic2,Harm_cubic,i_k2,L2,m_k2,m_r2)
                  endif
          
                  n_r2 = n_k2 + m_r2 - m_k2
          
                  do isg2 = -1,1,2

                    if( ( .not. Comp_to_real .or. m_r2 == 0 ) .and. isg2 == -1 ) cycle
       
                    if( Comp_to_real .and. m_r2 /= 0 ) then
                      call Trans_RtoC(c_harm2,isg2,m2,m_r2,Comp_to_real)
                      if( isg2 == 1 ) then
                        n2 = n_r2
                      else
                        n2 = n_r2 - 2 * m_r2
                      endif
                    else
                      c_harm2 = 1._db
                      m2 = m_r2
                      n2 = n_r2
                    endif

                    c_harm = c_harm1 * conjg( c_harm2 ) * c_cubic1 * c_cubic2                 

                    np1 = 0
                    do Lp1 = 0,Lmax
                      if( .not. Full_pot .and. Lp1 /= L1 ) cycle
                      do mp1 = -Lp1,Lp1
                        if( nlm_fp == 1 .and. mp1 /= m1 ) cycle
                        np1 = np1 + 1
            
                        do iso1 = 1,nspino
                          if( Spinorbite .and. nlm_fp == 1 ) then
                            ms1 = mp1 + iso1 - isp
                            if( ms1 > L1 .or. ms1 < -L1 ) cycle
                          else
                            ms1 = mp1
                          endif
            
                          if( nlm_fp > 1 ) then
                            Lmp1 = np1
                          elseif( nlm > 1 ) then
                            Lmp1 = Lp1 + 1 + ms1
                          else
                            Lmp1 = 1
                          endif
            
                          np2 = 0
                          do Lp2 = 0,Lmax
                            if( .not. Full_pot .and. Lp2 /= L2 ) cycle
                            do mp2 = -Lp2,Lp2
                              if( nlm_fp == 1 .and. mp2 /= m2 ) cycle
                              np2 = np2 + 1
            
                              do iso2 = 1,nspino
                                if( Spinorbite .and. nlm_fp == 1 ) then
                                  ms2 = mp2 + iso2 - isp
                                  if( ms2 > L2 .or. ms2 < -L2 ) cycle
                                else
                                  ms2 = mp2
                                endif
            
                                if( nlm_fp > 1 ) then
                                  Lmp2 = np2
                                elseif( nlm > 1 ) then
                                  Lmp2 = Lp2 + 1 + ms2
                                else
                                  Lmp2 = 1
                                endif
                                
                                if( Spinorbite ) then
                                  is1 = iso1
                                  is2 = iso2
                                else
                                  is1 = isp
                                  is2 = isp
                                endif
            
! Sign minus because usi is multiplied by TauLL wich is such that its imaginary part is minus the DOS ( and not plus like in formulae )                      
                                do ir = 1,nrmtsd
!                                  fac = 0.5_db * aimag( cmplx( ur(ir,n1,np1,isp,iso1), ui(ir,n1,np1,isp,iso1), db ) &
!                                      * cmplx( usr(ir,n2,np2,isp,iso2), usi(ir,n2,np2,isp,iso2), db ) &
!                                      * ( Tau(Lmp1,is1,Lmp2,is2) + Tau(Lmp2,is2,Lmp1,is1) ) ) 

!                                  cfac = 0.5_db * ( &
!                                                  cmplx( ur(ir,n1,np1,isp,iso1), ui(ir,n1,np1,isp,iso1), db ) &
!                                                * cmplx( usr(ir,n2,np2,isp,iso2), usi(ir,n2,np2,isp,iso2), db ) &
!                                                * Tau(Lmp1,is1,Lmp2,is2) &
!                                             - conjg( & 
!                                                  cmplx( ur(ir,n2,np2,isp,iso2), ui(ir,n2,np2,isp,iso2), db ) &
!                                                * cmplx( usr(ir,n1,np1,isp,iso1), usi(ir,n1,np1,isp,iso1), db ) &
!                                                * Tau(Lmp2,is2,Lmp1,is1) ) )                    

                                  Sta_e = c_harm * cmplx( ur(ir,n1,np1,isp,iso1), ui(ir,n1,np1,isp,iso1), db ) &
                                                * Tau(Lmp1,is1,Lmp2,is2) & 
                                                * cmplx( usr(ir,n2,np2,isp,iso2), usi(ir,n2,np2,isp,iso2), db )

                                  Sta_s = conjg( c_harm ) * cmplx( ur(ir,n2,np2,isp,iso2), ui(ir,n2,np2,isp,iso2), db ) &
                                                * Tau(Lmp2,is2,Lmp1,is1) & 
                                                * cmplx( usr(ir,n1,np1,isp,iso1), usi(ir,n1,np1,isp,iso1), db )

                                  Sta_r = 0.5_db * real( Sta_e - Sta_s, db)
                                  Sta_i = 0.5_db * aimag( Sta_e + Sta_s )
                                  
                                  if( Density_sp .and. .not. nlm == 1 ) then
                                    cfct(ir,is1,is2,isp) = cfct(ir,is1,is2,isp) + r(ir) * cmplx( Sta_r, Sta_i, db )
                                  else
                                    cfct(ir,isp,isp,isp) = cfct(ir,isp,isp,isp) + r(ir) * cmplx( Sta_r, Sta_i, db )
                                  endif
                                end do

                              end do
                            end do
                          end do
                        end do   ! Loop iso1
                      end do   ! Loop mp1
                    end do     ! Loop Lp1
                  end do  ! Loop isg2
                end do  ! Loop i_k2
              end do  ! Loop isg1
            end do  ! Loop i_k1
          end do  ! Loop isp

          if( icheck > 2 .and. Self ) then
            if( Density_sp ) then
              write(3,140) L1, m_k1, L2, m_k2
            else 
              write(3,140) L1, m_k1, L2, m_k2
            endif
            do ir = 1,nrmtsd
              if( Density_sp ) then
                write(3,'(1p,10e13.5)') r(ir)*bohr, cfct(ir,:,:,:)
              else
                write(3,'(1p,5e13.5)') r(ir)*bohr, ( cfct(ir,isp,isp,isp), isp = 1,nspinp )
              endif
            end do
          endif  

          do isp = 1,nspinp
            do is1 = 1,nspinp
              if( ( .not. Density_sp .or. nlm == 1 ) .and. is1 /= isp ) cycle
              do is2 = 1,nspinp
                if( ( .not. Density_sp .or. nlm == 1 ) .and. is1 /= is2 ) cycle
    
                fct_i(:) = aimag( cfct(:,is1,is2,isp) )
                   
                Sing_i = f_integr3(rr,fct_i,1,nrmtsd,Rmtsd)
                if( Self ) fct_i(1:nrmtsd) = fct_i(1:nrmtsd) * ri2(1:nrmtsd)
    
                if( nlm == 1 ) then
              
                  n0 = L1**2 + L1 + 1
                  do m = -L1,L1
                    Lm = n0 + m
                    State(Lm,isp,Lm,isp) = State(Lm,isp,Lm,isp) - Sing_i
                    if( Self ) drho_r(1:nrmtsd,1,isp) = drho_r(1:nrmtsd,1,isp) - fct_i(1:nrmtsd)
                    if( icheck > 2 ) then
                      write(3,110)
                      write(3,120)
                    endif
                    if( icheck > 1 ) write(3,150) L1, m, L1, m, isp, - Sing_i, State(Lm,isp,Lm,isp)
                  end do
                  
                else
    
                  m1 = m_k1 + is1 - isp ! corresponds to the spinor if Density_sp
                  m2 = m_k2 + is2 - isp 
                  if( m1 > L1 .or. m1 < -L1 .or. m2 > L2 .or. m2 < -L2 ) cycle 
                  Lm1 = L1**2 + L1 + 1 + m1
                  Lm2 = L2**2 + L2 + 1 + m2
                  
                  State(Lm1,is1,Lm2,is2) = State(Lm1,is1,Lm2,is2) - Sing_i
    
                  fct_r(:) = real( cfct(:,isp,isp,isp), db )
                  Sing_r = f_integr3(rr,fct_r,1,nrmtsd,Rmtsd)
                  State_i(Lm1,is1,Lm2,is2) = State_i(Lm1,is1,Lm2,is2) + Sing_r
                
                  if( Self ) then
                    fct_r(1:nrmtsd) = fct_r(1:nrmtsd) * ri2(1:nrmtsd)
                    Lm = 0
                    do L3 = 0,Lmax
                      if( .not. Full_pot .and. L3 > 0 ) cycle
                      do m3 = -L3,L3
                        Lm = Lm + 1
                        if( Lm > nlm_pot ) exit
                ! not 4.pi,  the real V_L should then be multiplied again by sqrt_4pi                                        
                        if( Lm == 1 ) then
                          if( Ylm_comp ) then
                            g = sqrt_4pi * gauntcp(L1,m_k1,L2,m_k2,L3,m3)
                          else
                            g = sqrt_4pi * Gaunt_r(L1,m_k1,L2,m_k2,L3,m3)
                          endif
                        else
                          if( Ylm_comp ) then
                            g = 4 * pi * gauntcp(L1,m_k1,L2,m_k2,L3,m3)
                          else
                            g = 4 * pi * Gaunt_r(L1,m_k1,L2,m_k2,L3,m3)
                          endif
                        endif
    
                        if( abs( g ) < eps10 ) cycle 
                      
                        do ir = 1,nrmtsd
                          drho_r(ir,Lm,isp) = drho_r(ir,Lm,isp) - g * fct_i(ir)        
                          drho_i(ir,Lm,isp) = drho_i(ir,Lm,isp) + g * fct_r(ir)        
                        end do
    
                      end do
                    end do
                  
                  endif
                  if( icheck > 2 ) then
                    write(3,110)
                    write(3,130)
                  endif
                  if( icheck > 1 ) &
                      write(3,150) L1, m_k1, L2, m_k2, isp, - Sing_i, Sing_r, State(Lm1,is1,Lm2,isp), &
                                                                                         State_i(Lm1,is1,Lm2,is2)
                endif
    
              end do
            end do
          end do
            
        end do ! Loop m_k2
      end do   ! Loop L2
    end do  ! Loop m_k1
  end do    ! Loop L1

  deallocate( usi, usr )

  if( Self ) then
  
    if( Ylm_comp .and. nlm_pot > 1 ) then
      do L = 1,Lmax_pot
        do m = 1,L
          Lmp = L**2 + L + 1 + m
          Lmn = L**2 + L + 1 - m
          is = (-1)**m
          do ir = 1,nrmtsd
            drho_mp(:) = drho_r(ir,Lmp,:)
            drho_mp_i(:) = drho_i(ir,Lmp,:)
            drho_mn(:) = drho_r(ir,Lmn,:)
            drho_mn_i(:) = drho_i(ir,Lmn,:)
            drho_r(ir,Lmp,:) = One_on_sqrt_2 * ( is * drho_mp(:) + drho_mn(:) )  
            drho_r(ir,Lmn,:) = One_on_sqrt_2 * ( drho_mn_i(:) - is * drho_mp_i(:) )  
          end do
        end do
      end do
    endif
    
    drho(1:nrmtsd,:,:) = drho(1:nrmtsd,:,:) + drho_r(1:nrmtsd,:,:)    
  
    if( icheck > 2 ) then
      write(3,'(/A)') ' drho after singular solution'
      if( Full_pot ) then
        write(3,'(/A)') '   Radius     drho( up, dn ), Lm = 1,nlm_pot'
      else
        write(3,'(/A)') '   Radius         up           dn'
      endif
      do ir = 1,nrmtsd
        write(3,'(1p,30e13.5)') r(ir)*bohr, ( drho(ir,Lm,:), Lm = 1,nlm_pot )
      end do
    endif
  endif

  return
  110 format(/' Radial integral of singular solution for the density of state:')
  120 format(' L1 m1 L2 m2 isp    -Sing_i        State')
  130 format(' L1 m1 L2 m2 isp    -Sing_i         Sing        State       State_i')
  140 format(/' Singular radial function for the density of state, L1, m1, L2, m2 =',4i3)
  150 format(5i3,1p,1x,e13.5,2x,4e13.5)
end

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

! Calculation of the Crystal Orbital Overlap Population

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

  use declarations
  implicit none

  integer:: i, i_rad, i_tr, ia, iaabsi, iab, iapr, iapra, iaprb, ib, icheck, ie, ipr, ipra, iprabs, iprb, isa, isb, &
    it, j, La, Lb, Lm, Lma, Lmax, Lmax_DOSout, Lmax_print, Lmaxa, Lmaxb, Lmaxm, Lmax_pot, &
    Lmb, Lmm, Lmp, m_hubb, ma, mb, mpa, mpb, mpinodee, mpirank, &
    n, n_angle, n_atom_0, n_atom_0_self, n_atom_coop, n_atom_ind, n_atom_ind_self, n_atom_proto, n_pt_integr, &
    n_rad, n_rad_m, nab_coop, natome, nlm_pot, nlmagm, nlmc, nlmr, nr, nrm, nspin, nspino, nspinp, &
    ntype, Z, Z_nospinorbite, Za, Zb

  integer, dimension(n_atom_coop):: ia_coop
  integer, dimension(natome):: iaprotoi
  integer, dimension(n_atom_0:n_atom_ind):: n_radius
  integer, dimension(0:ntype):: nrato, Numat
  integer, dimension(0:n_atom_proto):: itypepr, Lmaxat
  integer, dimension(2,nab_coop):: index_coop
  integer, dimension(:), allocatable:: index_r_a, index_r_b

  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp,n_atom_0_self:n_atom_ind_self):: V_hubb
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb_abs
  complex(kind=db), dimension(nlmagm,nspinp,nlmagm,nspinp,nspino):: Tau_coop_r
  complex(kind=db), dimension(nlmagm,nspinp,nlmagm,nspinp,nab_coop,nspino):: Tau_coop
  complex(kind=db), dimension(:), allocatable:: Ylmc
  complex(kind=db), dimension(:,:,:), allocatable:: Dlmm_ia, Dlmm_ib
  complex(kind=db), dimension(:,:,:,:), allocatable:: Taull, V_hubb_t
  complex(kind=db), dimension(:,:,:,:,:), allocatable:: um
  
  logical:: Absorbeur, Comp_to_real, Comp_to_real_out, Coop_z_along_bond, Density_comp_ext, Density_comp, &
            Density_real, &
            Full_atom, Full_potential, Harm_cubic, Harm_cubic_ext, Hubb_a, Hubb_d, Hubb_diag_abs, &
            Relativiste, Renorm, Spino, Rotation_bound, Spinorbite, Ylm_comp, Ylm_comp_out 
  logical, dimension(0:ntype):: Hubb
  logical, dimension(n_atom_0_self:n_atom_ind_self):: Hubb_diag

  real(kind=db):: Angle, Dist, Eimag, Energ, Enervide, R_circle, Rad_max, Radius_coop, Step, Step_rad, &
                  V_intmax, Vol
  real(kind=db), dimension(2):: Dist_coop
  real(kind=db), dimension(3):: V, Vx, Vy, Vz, Wx, Wy, Wz
  real(kind=db), dimension(nspin):: Ecinetic, V0bd
  real(kind=db), dimension(0:n_atom_proto):: Rmtg, Rmtg0, Rmtsd
  real(kind=db), dimension(3,3):: Mat_rot, Rot_a, Rot_b
  real(kind=db), dimension(3,3,natome):: rot_atom
  real(kind=db), dimension(3,natome):: Posi
  real(kind=db), dimension(0:nrm,0:ntype):: rato
  real(kind=db), dimension(0:nrm,nlm_pot,nspin,n_atom_0:n_atom_ind):: Vrato 
  real(kind=db), dimension(16,16,nspinp,nab_coop,0:mpinodee-1):: Coverlap
  real(kind=db), dimension(16,16,nspinp):: State

  real(kind=db), dimension(:), allocatable:: r, Ylmr
  real(kind=db), dimension(:,:), allocatable:: Radius_urm, Ylm_a, Ylm_b 
  real(kind=db), dimension(:,:,:), allocatable:: Vrato_e

  n_rad = 1
  Rad_max = 0.20_db
  Step_rad = Rad_max / max( n_rad, 1 )
  n_angle = 8
  Step = 2 * pi / max( n_angle, 1 )
 
! The following is because the real coop does not work when spinorbit...  
  if( Spinorbite ) then
    Density_comp = .true.
    Harm_cubic = .false.
  else
    Harm_cubic = Harm_cubic_ext
    Density_comp = Density_comp_ext
  endif

! Calculation of the radius where the radial functions must be calculated
  do i = 1,2
  
    n_radius(:) = 0
    
    do ia = 1,natome

     ipra = iaprotoi( ia )
      if( Full_atom ) then
        iapra = ia
      else
        iapra = ipra
      endif

      do ib = ia+1,natome

        if( n_atom_coop > 0 ) then
          do j = 1,n_atom_coop
            if( ia_coop(j) == 0 ) cycle
            if( ia == ia_coop(j) .or. ib == ia_coop(j) ) exit
          end do
          if( j > n_atom_coop ) cycle
        endif

        iprb = iaprotoi( ib )
        if( Full_atom ) then
          iaprb = ib
        else
          iaprb = iprb
        endif

        Dist = sqrt( sum( ( Posi(:,ia) - Posi(:,ib) )**2 ) )
        if( Dist < Dist_coop(1) - eps10 ) cycle
        if( Dist_coop(2) > eps10 ) then
          if( Dist > Dist_coop(2) + eps10 ) cycle
        else
          if( Dist > Rmtg( ipra ) + Rmtg( iprb ) ) cycle
        endif

        Radius_coop = ( Rmtg0( ipra ) + Rmtg0( iprb ) ) / 2 

        do i_rad = 0,n_rad
          n_radius(iapra) = n_radius(iapra) + 1
          n_radius(iaprb) = n_radius(iaprb) + 1
          if( i == 2 ) then
            if( i_rad == 0 ) then 
              Radius_urm(n_radius(iapra),iapra) = Rmtg0(ipra) 
              Radius_urm(n_radius(iaprb),iaprb) = Rmtg0(iprb)
            else 
              Radius_urm(n_radius(iapra),iapra) = sqrt( Rmtg0(ipra)**2 + ( i_rad * Step_rad * Radius_coop )**2 ) 
              Radius_urm(n_radius(iaprb),iaprb) = sqrt( Rmtg0(iprb)**2 + ( i_rad * Step_rad * Radius_coop )**2 )
            endif
          endif
        end do 
      end do
    end do
   
    if( i == 2 ) exit
    
    n_rad_m = 0
    do iapr = n_atom_0,n_atom_ind
      n_rad_m = max( n_rad_m, n_radius(iapr) )
    end do
    allocate( Radius_urm(n_rad_m,n_atom_0:n_atom_ind) )
    
  end do
  
  Lmaxm = 0
  do ipr = 1,n_atom_proto
    Z = Numat( itypepr(ipr) )
    Lmm = Lmax_print(Z)   ! in tab_data.f90
    Lmm = max( Lmm, Lmax_DOSout ) 
    Lmm = min( Lmm, Lmaxat(ipr) )  
    Lmaxm = max( Lmaxm, Lmm )
  end do
  Lmm = (Lmaxm + 1)**2

  allocate( um(n_rad_m,Lmm,nspinp,nspino,n_atom_0:n_atom_ind) )
  um(:,:,:,:,:) = (0._db, 0._db)
    
! Loop over non equivalent absorbing atoms

  do iapr = n_atom_0,n_atom_ind

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

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

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

    Lmax = Lmax_print(Z)   ! in tab_data.f90
    Lmax = max( Lmax, Lmax_DOSout ) 
    Lmax = min( Lmax, Lmaxat(ipr) )  

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

! In the following routine, when Hubbard, only the diagonal radial function is kept.
    call Cal_urm(Ecinetic,Eimag,Energ,Enervide, &
            Full_potential,Hubb_a,Hubb_d,iapr,icheck,Lmax,Lmax_pot,Lmm,m_hubb,n_atom_0,n_atom_ind,n_rad_m,n_radius,nlm_pot, &
            nr,nspin,nspino,nspinp,r,Radius_urm,Relativiste,Renorm,Rmtg(ipr),Rmtsd(ipr),Spinorbite,um,V_hubb, &
            V_intmax,V0bd,Vrato_e,Ylm_comp,Z)

    deallocate( r )
    deallocate( Vrato_e, V_hubb_t )

  end do

  COverlap(:,:,:,:,:) = 0._db
  
  iab = 0
  n_radius(:) = 0

  Density_real = .not. Density_comp
  Comp_to_real = Ylm_comp .and. Density_real 

  do ia = 1,natome

    ipra = iaprotoi( ia )
    Za = Numat( itypepr(ipra) )
    if( Full_atom ) then
      iapra = ia
    else
      iapra = ipra
    endif

    Lmaxa = Lmax_print(Za)   ! in tab_data.f90
    Lmaxa = max( Lmaxa, Lmax_DOSout ) 
    Lmaxa = min( Lmaxa, Lmaxat(ipra) )  

    allocate( Dlmm_ia(-Lmaxa:Lmaxa,-Lmaxa:Lmaxa,0:Lmaxa) )

    do ib = ia+1,natome

      if( n_atom_coop > 0 ) then
        do j = 1,n_atom_coop
          if( ia_coop(j) == 0 ) cycle
          if( ia == ia_coop(j) .or. ib == ia_coop(j) ) exit
        end do
        if( j > n_atom_coop ) cycle
      endif

      iprb = iaprotoi( ib )
      if( Full_atom ) then
        iaprb = ib
      else
        iaprb = iprb
      endif

      Dist = sqrt( sum( ( Posi(:,ia) - Posi(:,ib) )**2 ) )
      if( Dist < Dist_coop(1) - eps10 ) cycle
      if( Dist_coop(2) > eps10 ) then
        if( Dist > Dist_coop(2) + eps10 ) cycle
      else
        if( Dist > Rmtg( ipra ) + Rmtg( iprb ) ) cycle
      endif

      iab = iab + 1

      Zb = Numat( itypepr(iprb) )

      Lmaxb = Lmax_print(Zb)   
      Lmaxb = max( Lmaxb, Lmax_DOSout ) 
      Lmaxb = min( Lmaxb, Lmaxat(iprb) )  

      allocate( Dlmm_ib(-Lmaxb:Lmaxb,-Lmaxb:Lmaxb,0:Lmaxb) )

      index_coop(1,iab) = ia
      index_coop(2,iab) = ib

      Radius_coop = ( Rmtg0( ipra ) + Rmtg0( iprb ) ) / 2 
      Vol = ( 4 * pi / 3._db ) * Radius_coop**3
     
      Rot_a(:,:) = rot_atom(:,:,ia)
      Rot_b(:,:) = rot_atom(:,:,ib)
      Rot_a = Transpose( Rot_a )
      Rot_b = Transpose( Rot_b )
      
! Local basis with z axis along the bond direction
      Vz(:) = Posi(:,ib) - Posi(:,ia)
      Vz(:) = Vz(:) / sqrt( sum( Vz(:)**2 ) )
            
      if( abs( abs( Vz(3) ) - 1._db ) > eps10 ) then

        Vy(1) = - Vz(2) / sqrt( Vz(1)**2 + Vz(2)**2 ) 
        Vy(2) = Vz(1) / sqrt( Vz(1)**2 + Vz(2)**2 )
        Vy(3) = 0._db
              
        call prodvec( Vx, Vy, Vz )
        Vx(:) = Vx(:) / sqrt( sum( Vx(:)**2 ) )

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

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

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

! It is the inverse rotation because it is the Ylm wich moves, not the space.
        Mat_rot = Transpose( Mat_rot )
        
        Rot_a = Matmul( Mat_rot, Rot_a )
        Rot_b = Matmul( Mat_rot, Rot_b )
        
      endif

      if( icheck > 1 .and. ie == 1 ) then
        write(3,'(/3(a6,i3),a7,f10.5,a4)') ' iab =',iab,', ia =',ia,', ib =', ib,', Vol =', Vol*bohr**3, ' A^3'
        write(3,'(/a44,3(/17x,3f10.5))') ' Local basis:     Vx        Vy        Vz', ( Vx(i), Vy(i), Vz(i), i = 1,3 )
        do i_tr = 1,nspino
          do isa = 1,nspinp
            do isb = 1,nspinp
              if( nspinp == 1 ) then
                write(3,110) iab, i_tr
              else
                write(3,120) iab, isa, isb, i_tr
              endif
              write(3,'(6x,30(10x,2i3,10x))') (( Lb, mb, mb = -Lb,Lb), Lb = 0,Lmaxb )
              Lma = 0 
              do La = 0,Lmaxa
                do ma = -La,La
                  Lma = Lma + 1 
                  write(3,'(2i3,1p,100e13.5)') La, ma, (Tau_coop(Lma,isa,Lmb,isb,iab,i_tr), Lmb = 1,(Lmaxb + 1)**2)
                end do
              end do
            end do
          end do
        end do
      endif

      if( Lmaxa == 10000 ) then   ! not used
!      if( Comp_to_real .and. .not. Spinorbite ) then
        Lma = (Lmaxa + 1)**2 
        Lmb = (Lmaxb + 1)**2 
        allocate( Taull(Lma,nspinp,Lmb,nspinp) )
        do i_tr = 1,nspino
          Taull(1:Lma,:,1:Lmb,:) = Tau_coop(1:Lma,:,1:Lmb,:,iab,i_tr)
          call Trans_Tau_ab(Comp_to_real,Lmaxa,Lmaxb,nspinp,Spinorbite,Taull)
          Tau_coop(1:Lma,:,1:Lmb,:,iab,i_tr) = Taull(1:Lma,:,1:Lmb,:)
          deallocate( Taull )
          if( icheck > 1 .and. ie == 1 ) then
            do isa = 1,nspinp
              do isb = 1,nspinp
                if( Comp_to_real ) then
                  write(3,'(/A)') ' Tau_coop in real Ylm basis'
                else
                  write(3,'(/A)') ' Tau_coop in complex Ylm basis'
                endif 
                Lma = 0 
                do La = 0,Lmaxa
                  do ma = -La,La
                    Lma = Lma + 1 
                    write(3,'(2i3,1p,100e13.5)') La, ma, (Tau_coop(Lma,isa,Lmb,isb,iab,i_tr), Lmb = 1,(Lmaxb + 1)**2)
                  end do
                end do
              end do
            end do  
          endif
        end do
        Comp_to_real_out = .false.
        Ylm_comp_out = .false.
      else
        Comp_to_real_out = Comp_to_real
        Ylm_comp_out = Ylm_comp
      endif
      
      Tau_coop_r(:,:,:,:,:) = (0._db, 0._db)

      Rotation_bound = &
            abs( Rot_a(1,1) - 1._db ) > eps10 .or. abs( Rot_a(2,2) - 1._db ) > eps10 .or. abs( Rot_a(3,3) - 1._db ) > eps10 &
       .or. abs( Rot_b(1,1) - 1._db ) > eps10 .or. abs( Rot_b(2,2) - 1._db ) > eps10 .or. abs( Rot_b(3,3) - 1._db ) > eps10
        
      if( Rotation_bound ) then

        call Dlmm_COOP(Dlmm_ia,icheck,Lmaxa,Rot_a,Ylm_comp)
        call Dlmm_COOP(Dlmm_ib,icheck,Lmaxb,Rot_b,Ylm_comp)

        do i_tr = 1,nspino
          do isa = 1,nspinp
            do isb = 1,nspinp
              if( .not. Spinorbite .and. isa /= isb ) cycle
              Lma = 0
              do La = 0,Lmaxa
                do ma = -La,La
                  Lma = Lma + 1
                  Lmb = 0
                  do Lb = 0,Lmaxb
                    do mb = -Lb,Lb
                      Lmb = Lmb + 1
                      do mpa = -La,La
                        Lm = La**2 + La + 1 + mpa
                        do mpb = -Lb,Lb
                          Lmp = Lb**2 + Lb + 1 + mpb
                          if( i_tr == 1 ) then 
                            Tau_coop_r(Lma,isa,Lmb,isb,i_tr) = Tau_coop_r(Lma,isa,Lmb,isb,i_tr) + Dlmm_ia(ma,mpa,La) &
                                                           * Tau_coop(Lm,isa,Lmp,isb,iab,i_tr) * conjg( Dlmm_ib(mb,mpb,Lb) )
                          else  ! rotation with spinorbit does not work
                            Tau_coop_r(Lma,isa,Lmb,isb,i_tr) = Tau_coop_r(Lma,isa,Lmb,isb,i_tr) + Dlmm_ia(ma,mpa,La) &
                                                           * Tau_coop(Lm,isa,Lmp,isb,iab,i_tr) * conjg( Dlmm_ib(mb,mpb,Lb) )
                          endif  
                        end do
                      end do
                    end do  
                  end do 
                end do
              end do
            end do
          end do
        end do
        
      else
      
        Tau_coop_r(:,:,:,:,:) = Tau_coop(:,:,:,:,iab,:)
      
      endif
      
      deallocate( Dlmm_ib )        

      if( Rotation_bound .and. icheck > 1 .and. ie == 1 ) then
        do i_tr = 1,nspino
          do isa = 1,nspinp
            do isb = 1,nspinp
              if( nspinp == 1 ) then
                write(3,130) iab, i_tr
              else
                write(3,140) iab, isa, isb, i_tr
              endif 
              write(3,'(6x,30(10x,2i3,10x))') (( Lb, mb, mb = -Lb,Lb), Lb = 0,Lmaxb )
              Lma = 0 
              do La = 0,Lmaxa
                do ma = -La,La
                  Lma = Lma + 1 
                  write(3,'(2i3,1p,100e13.5)') La, ma, (Tau_coop_r(Lma,isa,Lmb,isb,i_tr), Lmb = 1,(Lmaxb + 1)**2)
                end do
              end do
            end do
          end do
        end do
      endif
      
      if( Coop_z_along_bond ) then
! Points are in the rotated local basis
        Wx(1) = 1._db; Wx(2) = 0._db; Wx(3) = 0._db 
        Wy(1) = 0._db; Wy(2) = 1._db; Wy(3) = 0._db
        Wz(1) = 0._db; Wz(2) = 0._db; Wz(3) = 1._db
      else
! Points are in the cluster original basis
        Wx(:) = Vx(:)
        Wy(:) = Vy(:)
        Wz(:) = Vz(:)
      endif

      n = 1
      do i_rad = 1,n_rad
        n = n + i_rad * n_angle  
      end do
      Vol = Vol / n

      n_pt_integr = n

      nlmr = ( Lmaxm + 1 )**2
      nlmc = ( ( Lmaxm + 1 ) * ( Lmaxm + 2 ) ) / 2      
      allocate( Ylm_a(nlmr,n_pt_integr) )
      allocate( Ylm_b(nlmr,n_pt_integr) )
      allocate( Ylmc(nlmc) )
      allocate( Ylmr(nlmr) )
      allocate( index_r_a(n_pt_integr) )
      allocate( index_r_b(n_pt_integr) )
      
      j = 0
      do i_rad = 0,n_rad
        n_radius(iapra) = n_radius(iapra) + 1
        n_radius(iaprb) = n_radius(iaprb) + 1

        R_circle = i_rad * Step_rad * Radius_coop
         
! One makes the average over i_rad * n_angle      
        do i = 1,max( i_rad * n_angle, 1 )
          j = j + 1
          index_r_a(j) = n_radius(iapra) 
          index_r_b(j) = n_radius(iaprb) 

          if( i_rad == 0 ) then
            V(:) = Rmtg0( ipra ) * Wz(:)          
          else
            Angle = i * Step / i_rad       
            V(:) = Rmtg0( ipra ) * Wz(:) + R_circle * ( cos( Angle ) * Wx(:) + sin( Angle ) * Wy(:) )
          endif
              
          Dist = sqrt( sum( V(:)**2 ) )
          call cYlm(Lmaxm,V,Dist,Ylmc,nlmc)
          call Ylmcr(Lmaxm,nlmc,nlmr,Ylmc,Ylmr)
          Ylm_a(1:nlmr,j) = Ylmr(1:nlmr)

          if( i_rad == 0 ) then
            V(:) = - Rmtg0( iprb ) * Wz(:)
          else  
            V(:) = - Rmtg0( iprb ) * Wz(:) + R_circle * ( cos( Angle ) * Wx(:) + sin( Angle ) * Wy(:) ) 
          endif
 
          Dist = sqrt( sum( V(:)**2 ) )
          call cYlm(Lmaxm,V,Dist,Ylmc,nlmc)
          call Ylmcr(Lmaxm,nlmc,nlmr,Ylmc,Ylmr)
          Ylm_b(1:nlmr,j) = Ylmr(1:nlmr)

        end do ! end of loop over n_angle
      end do ! end of loop over n_rad

      call Cal_COOP_state(Comp_to_real_out,Full_potential,Harm_cubic,iapra,iaprb,icheck,index_r_a,index_r_b,Lmaxa,Lmaxb,Lmm, &
                          nlmagm,nlmr,n_atom_0,n_atom_ind,n_pt_integr,n_rad_m,nspino,nspinp,Spinorbite,State, &
                          Tau_coop_r,um,Vol,Ylm_a,Ylm_b,Ylm_comp_out)  

      Coverlap(:,:,:,iab,mpirank) = State(:,:,:)
  
      deallocate( index_r_a, index_r_b, Ylm_a, Ylm_b, Ylmc, Ylmr )
          
    end do ! end of loop over atoms ib

    deallocate( Dlmm_ia )

  end do ! end of loop over atoms ia 
  
  deallocate( Radius_urm, um )

  return
 110 format(/' Tau_coop, iab =',i3,', i_trans =',i2)
 120 format(/' Tau_coop, iab =',i3,', isa, isb =',2i2,', i_trans =',i2)
 130 format(/' Tau_coop rotated, iab =',i3,', i_trans =',i2)
 140 format(/' Tau_coop rotated, iab =',i3,', isa, isb =',2i2,', i_trans =',i2)

end

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

! Spin rotation matrix
! R = cos(Gamma/2).I + i sin(Gamma/2) Sigma.Axe
! I: Identity matrix
! Sigma: Pauli matrices.

subroutine Cal_rot_spin(Gamma_rot,icheck,Mat_rot_spin,Axe)

  use declarations
  implicit none

  integer:: icheck, isp
  complex(kind=db), dimension(2,2):: Mat_rot_spin

  real(kind=db):: Gamma_rot, sin_g, cos_g
  real(kind=db), dimension(3):: Axe

  cos_g = cos( Gamma_rot / 2 )
  sin_g = sin( Gamma_rot / 2 )
  
  Mat_rot_spin(1,1) = cos_g + img * sin_g * Axe(3)
  Mat_rot_spin(1,2) = sin_g * ( img * Axe(1) + Axe(2) )   
  Mat_rot_spin(2,1) = sin_g * ( img * Axe(1) - Axe(2) )   
  Mat_rot_spin(2,2) = cos_g - img * sin_g * Axe(3)

  if( icheck > 1 ) then
    write(3,110) Gamma_rot*180/pi, Axe(:)
    Write(3,'(/A)') ' Spin rotation matrix ='  
    do isp = 1,2 
      write(3,120) Mat_rot_spin(isp,:)
    end do 
  endif

 110 format(/' Spin projection angle =',f9.3, / &
             ' Rotation axe =',3f9.5)
 120 format(3x,2(1x,2f9.5))  
  return
end

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

subroutine Cal_COOP_state(Comp_to_real,Full_potential,Harm_cubic,iapra,iaprb,icheck,index_r_a,index_r_b,Lmaxa,Lmaxb,Lmm, &
                          nlmagm,nlmr,n_atom_0,n_atom_ind,n_pt_integr,n_rad_m,nspino,nspinp,Spinorbite,State, &
                          Taull,um,Vol,Ylm_a,Ylm_b,Ylm_comp)

  use declarations
  implicit none

  integer:: i, icheck, iapra, iaprb, ira, irb, is, is1, is2, iso1, iso2, isp, &
    L1, L2, lm01, lm02, lm1, lm2, Lmax, Lmaxa, Lmaxb, Lmm, lmv1, lmv2, Lp1, Lp2, m, m1, m2, mp1, mp2, mv1, mv2, &
    n_atom_0, n_atom_ind, n_pt_integr, n_rad_m, nlma, nlmagm, nlmb, nlmr, nspino, nspinp

  integer, dimension(n_pt_integr):: index_r_a, index_r_b
  
  complex(kind=db):: dCoop, rof_sd, Tau_e, Tau_s, YaYb, Yc, Ycompa, Ycompb
  complex(kind=db), dimension(16,16,nspinp):: Coop
  complex(kind=db), dimension(n_rad_m,Lmm,nspinp,nspino,n_atom_0:n_atom_ind):: um
  complex(kind=db), dimension(n_rad_m,Lmm,nspinp,nspino,2):: ump
  complex(kind=db), dimension(nlmagm,nspinp,nlmagm,nspinp,nspino):: Taull
  complex(kind=db), dimension(:,:), allocatable:: Mat, Trans, Trans_a, Trans_b, Trans_i
  complex(kind=db), dimension(:,:,:,:), allocatable:: Tau
  
  logical:: Comp_to_real, Ylm_comp, Full_potential, Harm_cubic, New_title, Radial_comp, Spinorbite

  real(kind=db):: Vol
  real(kind=db), dimension(16,16,nspinp):: State, State_i
  real(kind=db), dimension(nlmr,n_pt_integr):: Ylm_a, Ylm_b

  nlma = ( Lmaxa + 1 )**2
  nlmb = ( Lmaxb + 1 )**2

  ump(:,:,:,:,1) = um(:,:,:,:,iapra)
  ump(:,:,:,:,2) = um(:,:,:,:,iaprb)

  Radial_comp = abs( aimag( ump(1,1,1,1,1) ) ) > eps10 .or. abs( aimag( ump(1,1,1,1,2) ) ) > eps10
    
  Coop(:,:,:) = 0._db
  State(:,:,:) = 0._db
  State_i(:,:,:) = 0._db
  
  if( icheck > 1 ) write(3,110) iapra, iaprb

  if( Comp_to_real ) then
! Matrix real to complex  
    Lmax = max( Lmaxa, Lmaxb )
  
    allocate( Trans(-Lmax:Lmax,-Lmax:Lmax) )
    allocate( Trans_i(-Lmax:Lmax,-Lmax:Lmax) )
    Trans(:,:) = (0._db, 0._db)
    Trans_i(:,:) = (0._db, 0._db)

    do m = -Lmax,Lmax
      if( m > 0 ) then
        is = (-1)**m
        Trans(m,m) = cmplx( is * sqrt_1o2, 0._db, db)
        Trans(m,-m) = cmplx( 0._db, is * sqrt_1o2, db)
      elseif( m == 0 ) then
        Trans(0,0) = (1._db, 0._db)
      else
        Trans(m,-m) = cmplx(sqrt_1o2, 0._db, db)
        Trans(m,m) = cmplx(0._db, -sqrt_1o2, db)
      endif
    end do
     
    Trans_i = Conjg( Transpose( Trans ) )

  endif
  
  do L1 = 0,Lmaxa
    lm01 = L1**2 + L1 + 1

    if( Comp_to_real ) then
      allocate( Trans_a(-L1:L1,-L1:L1) )
      Trans_a(-L1:L1,-L1:L1) = Trans_i(-L1:L1,-L1:L1)
    endif

    do L2 = 0,Lmaxb
      lm02 = L2**2 + L2 + 1

      if( Comp_to_real ) then
        allocate( Trans_b(-L2:L2,-L2:L2) )
        Trans_b(-L2:L2,-L2:L2) = Trans(-L2:L2,-L2:L2)
      endif

      allocate( Mat(-L1:L1,-L2:L2) )          

      do isp = 1,nspinp
        do iso1 = 1,nspino
          if( Spinorbite ) then
            is1 = iso1
          else
            is1 = isp
          endif
          do iso2 = 1,nspino
            if( Spinorbite ) then
              is2 = iso2
            else
              is2 = isp
            endif

            do i = 1,n_pt_integr
                                      
              ira = index_r_a(i)
              irb = index_r_b(i)

              New_title = .true.
              Mat(:,:) = (0._db, 0._db )
              
              do m1 = -L1,L1

                do Lp1 = 0,Lmaxa     ! The Lp1, mp1, Lp2, mp2 loops are not active yet
                  if( .not. Full_potential .and. Lp1 /= L1 ) cycle
                  if( Lp1 /= L1 ) cycle  ! Full_potential not acive
                  do mp1 = -Lp1, Lp1
                    if( mp1 /= m1 ) cycle
            
                    if( Spinorbite ) then
                      mv1 = m1 + iso1 - isp
                      if( mv1 < -L1 .or. mv1 > L1 ) cycle
                    else
                      mv1 = m1
                    endif
                
                    lmv1 = lm01 + mv1
                    lm1 = lm01 + m1
                
                    do m2 = -L2,L2
                
                      do Lp2 = 0,Lmaxb
                        if( .not. Full_potential .and. Lp2 /= L2 ) cycle
                        if( Lp2 /= L2 ) cycle  ! Full_potential not acive
                        do mp2 = -Lp2, Lp2
                          if( mp2 /= m2 ) cycle
                
                          if( Spinorbite ) then
                            mv2 = m2 + iso2 - isp
                            if( mv2 < -L2 .or. mv2 > L2 ) cycle
                          else
                            mv2 = m2
                          endif
                      
                          lmv2 = lm02 + mv2
                          lm2 = lm02 + m2
                      
                          rof_sd = ump(ira,lm1,isp,iso1,1) * ump(irb,lm2,isp,iso2,2)
                      
                          Tau_e = Taull(lmv1,is1,lmv2,is2,1)
                          if( Spinorbite ) then
                            Tau_s = Taull(lmv2,is2,lmv1,is1,2)
                          elseif( Ylm_comp ) then
                            Tau_s = (-1)**(mv1-mv2) * Taull(lmv1-2*mv1,is1,lmv2-2*mv2,is2,1)
                          else
                            Tau_s = Tau_e
                          endif
                      
                          Mat(m1,m2) = Mat(m1,m2) + 0.5_db * ( rof_sd * Tau_e - conjg( rof_sd * Tau_s ) ) 
 
                        end do
                      end do
               
                    end do
                  end do

                end do
              end do

              if( Comp_to_real ) then
              
                Mat = matmul( Trans_a, matmul( Mat, Trans_b ) )

! in order it works, I do not understand why
                do m1 = -L1,L1
                  do m2 = -L2,L2
                    if( ( m1 < 0 .and. m2 >= 0 ) .or. ( m2 < 0 .and. m1 >= 0 ) ) Mat(m1,m2) = - Mat(m1,m2)   
                  end do
                end do
                
              endif

              do m1 = -L1,L1
                if( Spinorbite ) then
                  mv1 = m1 + iso1 - isp
                  if( mv1 < -L1 .or. mv1 > L1 ) cycle
                else
                  mv1 = m1
                endif
                lmv1 = lm01 + mv1
                lm1 = lm01 + m1

                do m2 = -L2,L2
                  if( Spinorbite ) then
                    mv2 = m2 + iso2 - isp
                    if( mv2 < -L2 .or. mv2 > L2 ) cycle
                  else
                    mv2 = m2
                  endif
                  lmv2 = lm02 + mv2
                  lm2 = lm02 + m2

                  if( Ylm_comp .and. m1 /= 0 .and. .not. Comp_to_real ) then
                    Ycompa = Yc(m1,Ylm_a(lm1,i),Ylm_a(lm1-2*m1,i))
                  else
                    Ycompa = cmplx( Ylm_a(lm1,i), 0._db, db )
                  endif
                  if( Ylm_comp .and. m2 /= 0 .and. .not. Comp_to_real ) then
                    Ycompb = Yc(m2,Ylm_b(lm2,i),Ylm_b(lm2-2*m2,i))
                  else
                    Ycompb = cmplx( Ylm_b(lm2,i), 0._db, db )
                  endif
                  YaYb = conjg( Ycompa ) * Ycompb

! In order it works, I do not understand why:                 
                  if( Ylm_comp .and. .not. Comp_to_real ) YaYb = img**(m1-m2) * YaYb

                  dCoop = YaYb * Mat(m1,m2) * Vol

                  Coop(lm1,lm2,isp) = Coop(lm1,lm2,isp) + dCoop

                  if( icheck > 1 .and. abs( dCoop ) > 1.e-15_db ) then
                    if( New_title ) then
                      write(3,120)
                      New_title = .false.
                    endif

                    write(3,130) lm1, lm2, isp, L1, m1, mv1, iso1, L2, m2, mv2, iso2, i, &
                        img*Coop(lm1,lm2,isp), img*dCoop, Ycompa, Ycompb, YaYb, Mat(m1,m2) 
                  endif

                end do  ! end of loop over m2
              end do ! end of loop over m1
          
            end do ! end of loop over points i

          end do  ! iso2
        end do  ! iso1
      
      end do  ! end of loop over isp
      
      deallocate( Mat )
      if( Comp_to_real ) deallocate( Trans_b )
      
    end do   ! end of loop over L2
    
    if( Comp_to_real ) deallocate( Trans_a )

  end do  ! end of loop over L1

  if( Comp_to_real ) deallocate( Trans, Trans_i )
    
  if( Harm_cubic ) then
    allocate( Tau(nlma,nspinp,nlmb,nspinp) )
    do isp = 1,nspinp
      do lm2 = 1,nlmb
        Tau(1:nlma,isp,lm2,isp) = Coop(1:nlma,lm2,isp) 
      end do
    end do
    call Trans_Tau_ZtoK(Lmaxa,Lmaxb,nspinp,Spinorbite,Tau)
    do isp = 1,nspinp
      do lm2 = 1,nlmb
        Coop(1:nlma,lm2,isp) = Tau(1:nlma,isp,lm2,isp) 
      end do
    end do
    deallocate( Tau )
  endif

  if( icheck > 1 ) then
    write(3,'(/A)') ' Integral for the COOP:' 

    do isp = 1,nspinp
      if( nspinp == 2 ) write(3,200) isp
      write(3,215) (( L2, m2, m2 = -L2,L2), L2 = 0,Lmaxb)
      lm1 = 0
      do L1 = 0,Lmaxa
        do m1 = -L1,L1
          lm1 = lm1 + 1
          write(3,230) L1, m1, ( img * Coop(lm1,lm2,isp), lm2 = 1,(1+Lmaxb)**2 )
        end do
      end do
    end do
  endif

  State(:,:,:) = - aimag( Coop(:,:,:) )
  State_i(:,:,:) = real( Coop(:,:,:), db )
  
  return
  110 format(/' ia =',i3,', ib =',i3,/)
  120 format(/' lm1 lm2 isp  L1  m1 mv1 is1  L2  m2 mv2 is2   i',5x,'Coop_r',7x,'Coop_i',7x,'dCoop_r',6x,'dCoop_i',15x,'Ylm_a', &
              22x,'Ylm_b',24x,'Yab',24x,'Mat')
  130 format(12i4,6(1x,2e13.5))
  200 format(/' isp =',i2)
  215 format(/' L1 m1  ',100(9x,2i3,12x))
  220 format(2i3,1p,28e13.5)
  230 format(2i3,1p,28(1x,2e13.5))

end

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

! Writing of the COOP

subroutine Write_coop(Coverlap,Density_comp,Energ,Harm_cubic,iaprotoi,ie,ie_computer,index_coop,itypepr, &
                      Lmax_DOSout,mpinodee,n_atom_proto,nab_coop,natome,nomfich_s,nspin,nspinp,ntype,Numat)

  use declarations
  implicit none
 
  integer:: ia, iab, ib, ie, ie_computer, index, isp, it, L, La, lam, Lb, lbm, Lma, Lmax_DOSout, Lmax_print, Lmb, M, ma, mb, &
            mpinodee, n_atom_proto, nab_coop, natome, nspin, nspinp, ntype

  integer, dimension(natome):: iaprotoi
  integer, dimension(0:ntype):: Numat
  integer, dimension(0:n_atom_proto):: itypepr
  integer, dimension(2,nab_coop):: index_coop

  character(len=9):: mot9
  character(len=15):: mot15
  character(len=Length_name):: nomfich_coop, nomfich_s
  character(len=2), dimension(2):: Sp
  character(len=1), dimension(0:4):: Orb_L
  character(len=9), dimension(16):: Orb_Lm, Orb_Lm_D, Orb_Lm_K, Orb_Lm_Z
  character(len=15), dimension((256+16)*nspinp):: Col_name
  
  logical:: Density_comp, Harm_cubic, Spin_out

  real(kind=db):: COverlap_T, Energ
  real(kind=db), dimension(16,16,nspinp,nab_coop,0:mpinodee-1):: Coverlap
  real(kind=db), dimension(:,:,:), allocatable:: COverlap_l

  data Orb_L/'s','p','d','f','g'/
  data Orb_Lm_K/'s','px','py','pz','dx2-y2','dz2','dyz','dxz','dxy','fxyz','fx3','fy3','fz3','fx(y2-z2)','fy(z2-x2)','fz(x2-y2)'/
  data Orb_Lm_Z/'s','py','pz','px','dxy','dyz','dz2','dxz','dx2-y2','(3,-3)','fxyz','(3,-1)','fz3','(3,1)','fz(x2-y2)','(3,3)'/
  data Orb_Lm_D/'(0,0)','(1,-1)','(1,0)','(1,1)','(2,-2)','(2,-1)','(2,0)','(2,1)','(2,2)','(3,-3)','(3,-2)','(3,-1)','(3,0)', &
                '(3,1)','(3,2)','(3,3)'/
  data Sp/'up','dn'/

  Spin_out = nspin == 2 .or. ( nspinp == 2 .and. Density_comp )
  
  if( Density_comp) then
    Orb_Lm(:) = Orb_Lm_D
  elseif( Harm_cubic ) then
    Orb_Lm(:) = Orb_Lm_K
  else
    Orb_Lm(:) = Orb_Lm_Z
  endif
                        
 ! Writing
  do iab = 1,nab_coop

    ia = index_coop(1,iab)
    ib = index_coop(2,iab)

    nomfich_coop = nomfich_s
    L = len_trim(nomfich_coop)
    nomfich_coop(L+1:L+5) = '_coop'
    L = len_trim(nomfich_coop)
    nomfich_coop(L+1:L+1) = '_'
    call ad_number(ia,nomfich_coop,Length_name)
    L = len_trim(nomfich_coop)
    nomfich_coop(L+1:L+1) = '_'
    call ad_number(ib,nomfich_coop,Length_name)
    L = len_trim(nomfich_coop)
    nomfich_coop(L+1:L+4) = '.txt'
 
    it = itypepr( iaprotoi(ia) ) 
    Lam = Lmax_print( Numat( it ) )   
    Lam = max( Lam, Lmax_DOSout ) 

    it = itypepr( iaprotoi(ib) ) 
    Lbm = Lmax_print( Numat( it ) )   
    Lbm = max( Lbm, Lmax_DOSout ) 

    allocate( COverlap_l(0:lam,0:lbm,nspinp) )
    COverlap_l(:,:,:) = 0._db
    COverlap_T = 0._db
     
    do isp = 1,nspinp
      Lma = 0
      do La = 0,lam
        do ma = -La,La
          Lma = Lma + 1
          Lmb = 0
          do Lb = 0,lbm
            do mb = -Lb,Lb
              Lmb = Lmb + 1
              COverlap_l(La,Lb,isp) = COverlap_l(La,Lb,isp) + COverlap(Lma,Lmb,isp,iab,ie_computer) 
              COverlap_T = COverlap_T + COverlap(Lma,Lmb,isp,iab,ie_computer)
            end do
          end do
        end do
      end do
    end do
              
    if( ie == 1 ) then
      open(4, file = nomfich_coop )

      mot15 = 'Tot_COOP_'
      call ad_number(ia,mot15,15)
      L = len_trim(mot15) + 1
      if( L < 15 ) mot15(L:L) = '_' 
      call ad_number(ib,mot15,15)
      call Center_word(mot15,15)
      index = 1
      Col_name(index) = mot15 
           
      if( Spin_out ) then
        do isp = 1,nspinp
          do La = 0,lam
            do Lb = 0,lbm
              mot15 = Orb_L(La) // ':' // Orb_L(Lb) // '_' // Sp(isp)
              call Center_word(mot15,15)
              index = index + 1
              Col_name(index) = mot15 
            end do
          end do
        end do
      else
        do La = 0,lam
          do Lb = 0,lbm
            mot15 = Orb_L(La) // ':' // Orb_L(Lb)
            call Center_word(mot15,15)
            index = index + 1
            Col_name(index) = mot15 
          end do
        end do
      endif

      if( Spin_out ) then
        do isp = 1,nspinp
          Lma = 0        
          do La = 0,lam
            do ma = -La,La
              Lma = Lma + 1
              Lmb = 0
              do Lb = 0,lbm
                do mb = -Lb,Lb
                  Lmb = Lmb + 1
                  mot15 = Orb_Lm(Lma)
                  L = len_trim(mot15) + 1
                  mot15(L:L) = ':'
                  mot9 = Orb_Lm(Lmb)
                  M = min( 14 - L, len_trim(mot9) ) 
                  mot15(L+1:L+M) = mot9(1:M)
                  L = L + M + 1 
                  if( L < 13 ) then
                    mot15(L:L) = '_'
                    L = L + 1
                  endif
                  if( L < 14 ) mot15(L:L+1) = Sp(isp)
                  call Center_word(mot15,15)
                  index = index + 1
                  Col_name(index) = mot15 
                end do
              end do
            end do
          end do
        end do                    
      else
        Lma = 0
        do La = 0,lam
          do ma = -La,La
            Lma = Lma + 1
            Lmb = 0
            do Lb = 0,lbm
              do mb = -Lb,Lb
                Lmb = Lmb + 1
                mot15 = Orb_Lm(Lma)
                L = len_trim(mot15) + 1
                mot15(L:L) = ':'
                mot9 = Orb_Lm(Lmb)
                M = min( 14 - L, len_trim(mot9) ) 
                mot15(L+1:L+M) = mot9(1:M) 
                call Center_word(mot15,15)
                index = index + 1
                Col_name(index) = mot15 
              end do
            end do
          end do
        end do
      endif
          
      write(4,110) Col_name(1:index)
    else
      open(4, file = nomfich_coop, position='append')
    endif
    if( Spin_out ) then
      write(4,130) Energ*rydb, COverlap_T, & 
                     ((( COverlap_l(La,Lb,isp), Lb = 0,lbm), La = 0,lam), isp = 1,nspinp), & 
                     ((( COverlap(Lma,Lmb,isp,iab,ie_computer), &
                     Lmb = 1,( 1 + lbm )**2), Lma = 1,( 1 + lam )**2), isp = 1,nspinp)
    else
      write(4,130) Energ*rydb, 2*COverlap_T, & 
                     (( 2*COverlap_l(La,Lb,1), Lb = 0,lbm), La = 0,lam), & 
                     (( 2*COverlap(Lma,Lmb,1,iab,ie_computer), Lmb = 1,( 1 + lbm )**2), Lma = 1,( 1 + lam )**2)
    endif
     
    Close(4)
    
    deallocate( COverlap_l )
  end do
  
  return
  110 format('   Energy ',1000a15)
  130 format(f10.5,1p,1000e15.7)
end

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

! Calculation of the radial wave function on the points  between the atoms
! One neglects the non spherical potential
! Called by Cal_coop

subroutine Cal_urm(Ecinetic,Eimag,Energ,Enervide, &
            Full_pot,Hubb_a,Hubb_d,iapr,icheck,Lmax,Lmax_pot,Lmm,m_hubb,n_atom_0,n_atom_ind,n_rad_m,n_radius,nlm_pot, &
            nr,nspin,nspino,nspinp,r,Radius_urm,Relativiste,Renorm,Rmtg,Rmtsd,Spinorbite,um,V_hubb,V_intmax,V0bd,&
            Vrato,Ylm_comp,Z)

  use declarations
  implicit none

  integer:: i, iapr, icheck, ir, iso, isp, L, L_hubbard, lfin, Lm, Lm0, Lmax, Lmax_pot, Lmm, m, m_hubb, mp, n, n_atom_0, &
    n_atom_ind, n_rad_m, nlm_V, nlm_pot, nlm, nlm_fp, np, nr, nrmtg, nrmtsd, nspin, nspino, nspinp, Z

  integer, dimension(n_atom_0:n_atom_ind):: n_radius
  integer, dimension(n_rad_m):: index_r

  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(n_rad_m,Lmm,nspinp,nspino,n_atom_0:n_atom_ind):: um
  complex(kind=db), dimension(:,:,:,:), allocatable:: Tau, V
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb

  logical:: Ecomp, Full_pot, Hubb_a, Hubb_d, Hubb_m, Radial_comp, Relativiste, Renorm, &
    Spinorbite, Ylm_comp

  real(kind=db):: Eimag, Energ, Enervide, Rmtg, Rmtsd, V_intmax
  real(kind=db), dimension(n_rad_m):: p
  real(kind=db), dimension(n_rad_m,n_atom_0:n_atom_ind):: Radius_urm
  real(kind=db), dimension(nspin):: Ecinetic, V0bd
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato

  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nr,nspin):: g0, gm, gp
  real(kind=db), dimension(nr,nspino):: gso

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

  konde(:) = sqrt( cmplx(Ecinetic(:), Eimag, db) )

  if( icheck > 1 ) write(3,110) iapr, Z, Lmax
  if( icheck > 1 ) write(3,120) Energ*rydb, Enervide*rydb
  if( icheck > 2 ) then
    write(3,130) Ecinetic(:)*rydb
    write(3,140) V0bd(:)*rydb
    write(3,150) konde(:)
  endif

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

  call mod_V(icheck,Lmax,Lmax_pot,nlm_V,nlm_pot,nr,nrmtg,nrmtsd,nspin,r,Rmtg,Rmtsd,V,V_intmax,V0bd,Vrato,Ylm_comp)

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

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

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

  do i = 1,n_radius(iapr)
    do ir = 2,nr - 1
      if( r(ir) > Radius_urm(i,iapr) ) exit
    end do
    index_r(i) = ir
    p(i) = ( Radius_urm(i,iapr) - r(ir-1) ) / ( r(ir) - r(ir-1) )
  end do
    
  do L = 0,lfin

    if( Hubb_a .and. L == L_hubbard( Z ) )  then
      Hubb_m = .true.
    else
      Hubb_m = .false.
    endif

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

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

    call Sch_radial( Ecomp ,Eimag, f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, L, Lmax, m_hubb, &
         nlm, nlm_fp, nlm_V, nr, nrmtg, nspin, nspino, nspinp, Z, r, Radial_comp, Relativiste, Renorm, Rmtg, &
         Spinorbite, Tau, ui, ur, V, V_hubb )

    do i = 1,n_radius(iapr)

      ir = index_r(i)
      if( Radial_comp ) then
        if( Full_pot ) then
          do Lm = 1,nlm
            um(i,Lm,:,:,iapr) = cmplx( p(i) * ur(ir,Lm,Lm,:,:) + (1 - p(i)) * ur(ir-1,Lm,Lm,:,:), &
                                       p(i) * ui(ir,Lm,Lm,:,:) + (1 - p(i)) * ui(ir-1,Lm,Lm,:,:), db )
          end do
        else
          Lm0 = L**2 + L + 1
          do m = -L,L
            if( nlm == 1 ) then
              n = 1
            else
              n = L + 1 + m
            endif
            do mp = -L,L
!              if( nlm_fp == 1 .and. mp /= m ) cycle
              if( mp /= m ) cycle
              np = min(L + m + 1, nlm_fp )
              um(i,Lm0+m,:,:,iapr) = cmplx( p(i) * ur(ir,n,np,:,:) + (1 - p(i)) * ur(ir-1,n,np,:,:), &
                                            p(i) * ui(ir,n,np,:,:) + (1 - p(i)) * ui(ir-1,n,np,:,:), db )
            end do
          end do
        endif
      else
        if( Full_pot ) then
          do Lm = 1,nlm
            um(i,Lm,:,:,iapr) = cmplx( p(i) * ur(ir,Lm,Lm,:,:) + (1 - p(i)) * ur(ir-1,Lm,Lm,:,:), 0._db, db )
          end do
        else
          Lm0 = L**2 + L + 1
          do m = -L,L
            if( nlm == 1 ) then
              n = 1
            else
              n = L + 1 + m
            endif
            do mp = -L,L
!              if( nlm_fp == 1 .and. mp /= m ) cycle
              if( mp /= m ) cycle
              np = min(L + m + 1, nlm_fp )
              um(i,Lm0+m,:,:,iapr) = cmplx( p(i) * ur(ir,n,np,:,:) + (1 - p(i)) * ur(ir-1,n,np,:,:), 0._db, db )
            end do
          end do
        endif
      endif
    
    end do
    
    deallocate( Tau, ui, ur )

  end do   ! end of loop over L

  if( icheck > 1 ) then
    write(3,155) iapr
    write(3,160) ( Radius_urm(i,iapr)*bohr, i = 1,n_radius(iapr) )
    Lm = 0
    do L = 0,Lmax
      do m = -L,L
        Lm = Lm + 1
        do isp = 1, nspinp
          do iso = 1,nspino 
            write(3,170) L, m, isp, iso, ( um(i,Lm,isp,iso,iapr), i = 1,n_radius(iapr) )
          end do
        end do
      end do
    end do 
  endif
  
  deallocate( V )

  return
  110 format(/' iapr =',i3,', Z =',i3,', Lmax =',i2)
  120 format(' Energ =',f10.3,' eV,  Enervide =',f10.3,' eV')
  130 format(' Ecinetic =',2f10.3)
  140 format(' V0bd  =',2f10.3)
  150 format(' konde =',2f12.5)
  155 format(/' Radial wave function for the coop versus radius, iapr =',i3)
  160 format('  L  m is io',10(10x,f9.5,8x))
  170 format(4i3,1p,20(1x,2e13.5))
end

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

! Calculation of Dlmm for the COOP
! The other routine doing that (in mat.f90) seems not working 
! 6th January 2019

subroutine Dlmm_COOP(Dlmm,icheck,Lmax,Mat_rot,Ylm_comp)

  use declarations
  implicit none

  integer:: icheck, is, L, Lmax, m, mp, s
  
  integer, dimension(0:2*Lmax):: Fact

  logical:: Ylm_comp
  
  complex(kind=db), dimension(-Lmax:Lmax,-Lmax:Lmax):: Mat, Trans, Transi
  complex(kind=db), dimension(-Lmax:Lmax,-Lmax:Lmax,0:Lmax):: Dlmm

  real(kind=db):: a, alfa, b, beta, c, cos_b, f, gamma, sin_b
  real(kind=db), dimension(-Lmax:Lmax,-Lmax:Lmax,0:Lmax):: R
  real(kind=db), dimension(3,3):: Mat_rot

  Dlmm(:,:,:) = (0._db, 0._db)
  
  call Euler_mat(icheck,Mat_rot,alfa,beta,gamma)

  Fact(0) = 1
  do L = 1,2*Lmax
    Fact(L) = L * Fact(L-1)
  end do

  if( icheck > 2 ) write(3,100) alfa*180/pi, beta*180/pi, gamma*180/pi

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

  cos_b = cos(beta/2)
  sin_b = sin(beta/2)
  
  do L = 0,Lmax
    do m = -L,L
      do mp = -L,L
        f = sqrt( real( Fact(L+m) * Fact(L-m) * Fact(L+mp) * Fact(L-mp), db ) )
        
        do s = 0,2*L
          if( (L+mp-s) < 0 .or. (m-mp+s) < 0 .or. (L-m-s) < 0 ) cycle
          
          a = real( (-1)**(m-mp+s), db) / ( Fact(L+mp-s) * Fact(s) * Fact(m-mp+s) * Fact(L-m-s) )
          b = cos_b**(2*L+mp-m-2*s)
          c = Sin_b**(m-mp+2*s)
  
          R(m,mp,L) = R(m,mp,L) + f * a * b * c   

          if( icheck > 3 ) write(3,'(a14,4i3,f10.5)') ' L,m,mp,s,R =', L, m, mp, s, R(m,mp,L)     
        end do

      end do
    end do
  end do
  
  do L = 0,Lmax
    do m = -L,L
      do mp = -L,L
        Dlmm(m,mp,L) = exp( -img * ( m*alfa + mp*gamma) ) * R(m,mp,L)
      end do
    end do
  end do

 ! Case of real harmonics:
  if( .not. Ylm_comp ) then
 
    Trans(:,:) = (0._db, 0._db)
    Transi(:,:) = (0._db, 0._db)
    do m = -Lmax,Lmax
      if( m > 0 ) then
        is = (-1)**m
        Trans(m,m) = cmplx( is * sqrt_1o2, 0._db, db)
        Trans(m,-m) = cmplx( 0._db, is * sqrt_1o2, db)
      elseif( m == 0 ) then
        Trans(0,0) = (1._db, 0._db)
      else
        Trans(m,-m) = cmplx( sqrt_1o2, 0._db, db)
        Trans(m,m) = cmplx(0._db, -sqrt_1o2, db)
      endif
    end do
    
    Transi = Conjg( Transpose( Trans ) )
      
    do L = 0,Lmax

! I do not really understand the conjg
      do m = -L,L
        do mp = -L,L
          Mat(m,mp) = sum( conjg( Dlmm(m,-L:L,L) ) * Trans(-L:L,mp) )
        end do
      end do

      do m = -L,L
        do mp = -L,L
          Dlmm(m,mp,L) = sum( Transi(m,-L:L) * Mat(-L:L,mp) )
        end do
      end do

    end do
  
  endif
  
  if( icheck > 2 ) then
  
    do L = 0,Lmax
      write(3,110) '    R, L =',L
      do m = -L,L
        Write(3,120) m, ( R(m,mp,L), mp = -L,L )
      end do

      write(3,110) ' Dlmm, L =',L
      do m = -L,L
        Write(3,130) m, ( Dlmm(m,mp,L), mp = -L,L )
      end do
    end do

  endif
  
  return
 100 format(/' alfa, beta, gamma =',3f10.3)
 110 format(/a10,i2)
 120 format(i3,5f9.5)
 130 format(i3,5(1x,2f8.5))
end

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

! Called by main_tddft

subroutine Radial_wave(Ecinetic,Eimag,Energ,Enervide,Full_pot,Hubb_a,Hubb_d,icheck,initl,Lmax,Lmax_pot, &
            m_hubb,nbseuil,ninit1,ninitt,nlm_pot,nlmam,nlmam2,nr,nrm,nspin,nspino,nspinp,Numat,psii,r,Radial_comp, &
            Relativiste,Renorm,Rmtg,Rmtsd,rof_ph,Spinorbite,V_hubb,V_intmax,V0bd,Vrato,Ylm_comp,zet)

  use declarations
  implicit none

  integer:: icheck, initl, iseuil, iso, isp, L, L_hubbard, lfin, Lm, Lm0, Lmax, Lmax_pot, Lmp, m, m_hubb, mp, &
    n, nbseuil, ninit1, ninitt, nlm_V, nlm_pot, nlm, nlm_fp, nlmam, nlmam2, np, nr, nrm, nrmtg, nrmtsd, nspin, &
    nspino, nspinp, Numat

  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(-m_hubb:m_hubb,-m_hubb:m_hubb,nspinp,nspinp):: V_hubb
  complex(kind=db), dimension(nlmam,nlmam2,nspinp,nspino,0:0,1):: rof
  complex(kind=db), dimension(nlmam,nspinp,nspino,ninitt):: rof_ph
  complex(kind=db), dimension(:,:,:,:), allocatable:: Tau, V

  logical:: Ecomp, Full_pot, Hubb_a, Hubb_d, Hubb_m, NRIXS, Radial_comp, Relativiste, Renorm, Spinorbite, Ylm_comp

  real(kind=db):: Eimag, Energ, Enervide, Rmtg, Rmtsd, V_intmax
  real(kind=db), dimension(nspin):: Ecinetic, V0bd
  real(kind=db), dimension(nbseuil):: Vecond
  real(kind=db), dimension(nrm,nbseuil):: psii
  real(kind=db), dimension(nr,nlm_pot,nspin):: Vrato

  real(kind=db), dimension(nr):: f2, r
  real(kind=db), dimension(nr,nspin):: g0 , gm, gp
  real(kind=db), dimension(nr,nspino):: gso
  real(kind=db), dimension(nr,0:0):: r_or_bess
  real(kind=db), dimension(nr,nlmam,nlmam2,nspinp,nspino,ninitt):: zet

  real(kind=db), dimension(:,:,:,:,:), allocatable:: ui, ur
  
  rof(:,:,:,:,:,:) = ( 0._db, 0._db )
  
  NRIXS = .false.
  konde(:) = sqrt( cmplx(Ecinetic(:), Eimag,db) )

  if( nbseuil == 2 ) then
    if( nbseuil /= ninitt ) then
      ninit1 = ( ninitt - 2 ) / 2
      if( initl <= ninit1 ) then
        iseuil = 1
      else
        iseuil = 2
      endif
    else 
      iseuil = initl
    endif
  else
    iseuil = 1
  endif
 ! Fake value not used because only monopole calculated
  Vecond(:) = 0._db 

  r_or_bess(:,:) = 1._db
  
  if( icheck > 1 ) then
    write(3,110)
    write(3,120) Energ*rydb, Enervide*rydb
    write(3,130) Ecinetic(:)*rydb
    write(3,140) V0bd(:)*rydb
    write(3,150) konde(:)
  endif

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

  call mod_V(icheck,Lmax,Lmax_pot,nlm_V,nlm_pot,nr,nrmtg,nrmtsd,nspin,r,Rmtg,Rmtsd,V,V_intmax,V0bd,Vrato,Ylm_comp)

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

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

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

  do L = 0,lfin

    if( Hubb_a .and. L == L_hubbard( Numat ) )  then
      Hubb_m = .true.
    else
      Hubb_m = .false.
    endif

    if( Full_pot ) then
      nlm = ( Lmax + 1 )**2
      nlm_fp = nlm
    elseif( Hubb_m .and. .not. Hubb_d ) then
      nlm = 2*L + 1
      nlm_fp = nlm
    elseif( Spinorbite .or. Hubb_m ) then
      nlm = 2*L + 1
      nlm_fp = 1
    else
      nlm = 1
      nlm_fp = 1
    endif

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

    call Sch_radial( Ecomp, Eimag, f2, Full_pot, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, L, Lmax, m_hubb, &
         nlm, nlm_fp, nlm_V, nr, nrmtg, nspin, nspino, nspinp, Numat, r, Radial_comp, Relativiste, Renorm, Rmtg, &
         Spinorbite, Tau, ui, ur, V, V_hubb )

! Integrale radiale pour La regle d'or de Fermi
    call radial_matrix(.true.,1,0,0,iseuil,L,nlm,nlm_fp,nbseuil, &
           1,nlmam,nlmam2,nr,NRIXS,nrm,nspino,nspinp,psii,r,r_or_bess,Radial_comp,Rmtsd,rof,ui,ur,Vecond)

! Recopie
    if( Full_pot ) then
      zet(1:nr,1:nlm,1:nlm_fp,:,:,initl) = ur(1:nr,1:nlm,1:nlm_fp,:,:)
    else
      Lm0 = L**2 + L + 1
      do m = -L,L
        if( nlm == 1 ) then
          n = 1
        else
          n = L + 1 + m
        endif
        do mp = -L,L
          if( nlm_fp == 1 .and. mp /= m ) cycle
          np = min(L + m + 1, nlm_fp )
          Lmp = min(Lm0 + mp, nlmam2 )
          zet(1:nr,Lm0+m,Lmp,:,:,initl) = ur(1:nr,n,np,:,:)
        end do
      end do
    endif

    deallocate( Tau )

    deallocate( ui, ur )

  end do   ! fin de La boucle sur L

  if( nlm_fp == 1 ) then
    rof_ph(:,:,:,initl) = rof(:,1,:,:,0,1)
  else
    do iso = 1,nspino
      do isp = 1,nspinp
        do Lm = 1,nlmam2
          rof_ph(Lm,isp,iso,initl) =  sum( rof(1:nlmam,Lm,isp,iso,0,1) )
        end do
      end do
    end do
  endif        

  deallocate( V )

  return
  110 format(/' ---- Radial_wave --',100('-'))
  120 format(/' Energ =',f10.3,' eV,  Enervide =',f10.3,' eV')
  130 format(' Ecinetic =',2f10.3)
  140 format(' V0bd  =',2f10.3)
  150 format(' konde =',2f12.5)
end

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

! Calcul de Integrale_sur_r_et_r' de
! conj(phi(r) * f_reg( min(r,r') ) * f_irg( max(r,r') ) * phi(r') * dr * dr' )
! = Integrale_sur_r ( phi(r) * f_irg(r) * Integrale_sur_r'_de_0_a_r ( f_reg(r') * phi(r') * dr' )
!                   + phi(r) * f_reg(r) * Integrale_sur_r'_de_r_a_Rmax ( f_irg(r') * phi(r') * dr' ) * dr
!
! f_reg = r * solution reguliere
! f_irg = r * solution irreguliere
! phi = r * fonction initiale * r^p    ou   r * solution reguliere

function integr_sing(n,phi1,phi2,f_reg,f_irg,Rmtsd,r,icheck)

  use declarations
  implicit none

  integer:: icheck, ir, n

  complex(kind=db):: integr_sing

  complex(kind=db), dimension(n):: f_irg, f_reg, fct, phi_irg, phi_reg, s_phi_irg, s_phi_reg

  real(kind=db):: fi, fr, f_integr3, Rmtsd
   
  real(kind=db), dimension(n):: fct_r, phi1, phi2,  r

  phi_reg(:) = phi1(:) * f_reg(:)
  call ffintegr2(s_phi_reg,phi_reg,r,n,1,Rmtsd)

  phi_irg(:) = phi2(:) * f_irg(:)
  call ffintegr2(s_phi_irg,phi_irg,r,n,-1,Rmtsd)

  fct(:) = phi_irg(:) * s_phi_reg(:) + phi_reg(:) * s_phi_irg(:)

  fct_r(:) = real( fct(:),db )
  fr = f_integr3(r,fct_r,1,n,Rmtsd)

  fct_r(:) = aimag( fct(:) )
  fi = f_integr3(r,fct_r,1,n,Rmtsd)

!  integr_sing = - cmplx(fr,fi,db)
  integr_sing = cmplx(fr,fi,db)

  if( icheck > 3 .and. abs( integr_sing ) > eps10 ) then
    write(3,110)
    do ir = 1,n
      write(3,120) r(ir)*bohr, f_reg(ir), phi_reg(ir),s_phi_reg(ir), f_irg(ir), phi_irg(ir), s_phi_irg(ir), fct(ir)
      if( r(ir) > Rmtsd ) exit
    end do
    write(3,130) integr_sing
  endif

  return
  110 format(/5x,'Radius',15x,'f_reg',23x,'phi_reg',19x,'s_phi_reg',19x,'f_irg',23x,'phi_irg',21x,'s_phi_irg',22x,'fct')
  120 format(1p,15e14.6)
  130 format(/' Integr_sing =',1p,2e14.6)
end

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

! Calcul L'integrale de 0 a r (is=1) ou r a Rmtsd (is=-1) de fct
! Cas complexe

subroutine ffintegr2(fint,fct,r,n,is,Rmtsd)

  use declarations
  implicit none

  integer:: i, i1, i2, is, n  

  complex(kind=db):: a, a_tiers, b, b_demi, c, f0, fm, fp
  complex(kind=db), dimension(2):: dintegr
  complex(kind=db), dimension(n):: fct, fint

  real(kind=db):: r0, rm, rp, Rmtsd, Tiers, x0, xm, xp
  
  real(kind=db), dimension(n):: r

  Tiers = 1._db / 3._db

  if( is == 1 ) then
    i1 = 1
    i2 = n - 1
  else
    i1 = n - 1
    i2 = 1
    fint(n) = (0._db, 0._db)
  endif

  do i = i1,i2,is
    if( i == 1 ) then
      rm = r(i)
      r0 = r(i+1)
      rp = r(i+2)
      fm = fct(i)
      f0 = fct(i+1)
      fp = fct(i+2)
      xm = 0._db
      x0 = rm
      xp = 0.5_db * ( rm + r0 )
    else
      rm = r(i-1)
      r0 = r(i)
      rp = r(i+1)
      fm = fct(i-1)
      f0 = fct(i)
      fp = fct(i+1)
      xm = 0.5_db * ( rm + r0 )
      x0 = r0
      xp = 0.5_db * ( r0 + rp )
      if( r(i) > Rmtsd ) then
        rm = r(i-2); r0 = r(i-1); rp = r(i)
        fm = fct(i-2); f0 = fct(i-1); fp = fct(i)
      endif
   endif

    if( is == 1 .and. r0 > Rmtsd ) then
      if( r(i-1) > Rmtsd ) then
        fint(i) = fint(i-1)
        cycle
      elseif( rm > Rmtsd ) then
        fint(i) = fint(i-1) + dintegr(2)
        cycle
      else
        x0 = Rmtsd
      endif
    endif
    if( is == - 1 .and. r0 > Rmtsd ) then
      fint(i) = (0._db, 0._db)
      cycle
    endif
    if( xp > Rmtsd ) xp = Rmtsd

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

    a_tiers = a * tiers
    b_demi = b * 0.5_db

    if( is == 1 ) then
      dintegr(1) = ( a_tiers * ( xm**2 + xm * x0  + x0**2 ) + b_demi * ( xm + x0 ) + c ) * ( x0 - xm )
    else
      dintegr(1) = ( a_tiers * ( x0**2 + x0 * xp  + xp**2 ) + b_demi * ( x0 + xp ) + c ) * ( xp - x0 )
    endif

    if( i == i1 ) then
      fint(i) = dintegr(1)
    else
      fint(i) = fint(i-is) + sum( dintegr(:) )
    endif

    if( is == 1 ) then
      dintegr(2) = ( a_tiers * ( x0**2 + x0 * xp  + xp**2 ) + b_demi * ( x0 + xp ) + c ) * ( xp - x0 )
    else
      dintegr(2) = ( a_tiers * ( xm**2 + xm * x0  + x0**2 ) + b_demi * ( xm + x0 ) + c ) * ( x0 - xm )
    endif

  end do

  if( is == 1 ) fint(n) = fint(n-1)

  return
end

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

! Calculation of the integral from 0 to r (is=1) or from r to Rmtsd (is=-1) of fct

subroutine ffintegr2_r(fint,fct,r,n,is,Rmtsd)

  use declarations
  implicit none
  
  integer:: i, i1, i2, is, n

  real(kind=db):: a, a_tiers, b, b_demi, c, f0, fm, fp, r0, rm, rp, Rmtsd, Tiers, x0, xm, xp

  real(kind=db), dimension(2):: dintegr
  real(kind=db), dimension(n):: fct, fint

  real(kind=db), dimension(n):: r

  Tiers = 1._db / 3._db

  dintegr(:) = 0._db

  if( is == 1 ) then
    i1 = 1
    i2 = n - 1
  else
    i1 = n - 1
    i2 = 1
    fint(n) = 0._db
  endif

  do i = i1,i2,is
    if( i == 1 ) then
      rm = r(i)
      r0 = r(i+1)
      rp = r(i+2)
      fm = fct(i)
      f0 = fct(i+1)
      fp = fct(i+2)
      xm = 0._db
      x0 = rm
      xp = 0.5_db * ( rm + r0 )
    else
      rm = r(i-1)
      r0 = r(i)
      rp = r(i+1)
      fm = fct(i-1)
      f0 = fct(i)
      fp = fct(i+1)
      xm = 0.5_db * ( rm + r0 )
      x0 = r0
      xp = 0.5_db * ( r0 + rp )
    endif

    if( is == 1 .and. r0 > Rmtsd ) then
      if( r(i-1) > Rmtsd ) then
        fint(i) = fint(i-1)
        cycle
      elseif( rm > Rmtsd ) then
        fint(i) = fint(i-1) + dintegr(2)
        cycle
      else
        x0 = Rmtsd
      endif
    endif
    if( is == - 1 .and. r0 > Rmtsd ) then
      fint(i) = 0._db
      cycle
    endif
    if( xp > Rmtsd ) xp = Rmtsd

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

    a_tiers = a * tiers
    b_demi = b * 0.5_db

    if( is == 1 ) then
      dintegr(1) = ( a_tiers * ( xm**2 + xm * x0  + x0**2 ) + b_demi * ( xm + x0 ) + c ) * ( x0 - xm )
    else
      dintegr(1) = ( a_tiers * ( x0**2 + x0 * xp  + xp**2 ) + b_demi * ( x0 + xp ) + c ) * ( xp - x0 )
    endif

    if( i == i1 ) then
      fint(i) = dintegr(1)
    else
      fint(i) = fint(i-is) + sum( dintegr(:) )
    endif

    if( is == 1 ) then
      dintegr(2) = ( a_tiers * ( x0**2 + x0 * xp  + xp**2 ) + b_demi * ( x0 + xp ) + c ) * ( xp - x0 )
    else
      dintegr(2) = ( a_tiers * ( xm**2 + xm * x0  + x0**2 ) + b_demi * ( xm + x0 ) + c ) * ( x0 - xm )
    endif

  end do

  if( is == 1 ) fint(n) = fint(n-1)

  return
end

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

! Calculation and writing of the atomic electron density

! Similar to the first part of Cal_state

subroutine Write_Density(Energ,Density_comp,Full_atom,Harm_cubic,iaabsi,iaprotoi,icheck,ie,ie_computer,Int_statedens, &
                itypei,itypepr,lla_state,lla2_state,Lmax_DOSout,Lmaxat,mpinodes,n_atom_0,n_atom_ind,n_atom_proto,natome,nenerg, &
                nomfich_s,nonexc_g,nrato,nrm,nspin,nspinp,ntype,Numat,Rato,Rmtsd,State_all,Statedens)

  use declarations
  implicit none

  integer:: i_self, ia, iaabsi, iapr, icheck, ie, ie_computer, ipr, iprabs, ir, isp, it, L, &
    La, LL, lla_state, lla2_state, Lm, lm1, lm2, Lma, Lmax_DOSout, Lmax_pDOS, Lmax_print, m, Long, mpinodes, &
    n_atom_0, n_atom_ind, n_atom_proto, natome, nenerg, nr, nrm, nspin, nspinp, ntype, Z

  character(len=Length_name) nomfich_s, nomficht
  character(len=28) mot28

  integer, dimension(0:ntype):: nrato, Numat
  integer, dimension(0:n_atom_proto):: itypepr, la_ipr, ll_ipr, Lmaxat
  integer, dimension(natome):: iaprotoi, itypei

  logical:: Abs_exc, Density_comp, First, Full_atom, Harm_cubic, nonexc_g, Open_file, State_all
  logical, dimension(0:n_atom_proto):: proto_done

  real(kind=db):: de

  real(kind=db), dimension(nenerg):: Energ
  real(kind=db), dimension(0:n_atom_proto):: Rmtsd
  real(kind=db), dimension(lla2_state,nspinp,n_atom_0:n_atom_ind):: Int_Statedens
  real(kind=db), dimension(lla2_state,nspinp,lla2_state,nspinp,n_atom_0:n_atom_ind,0:mpinodes-1):: Statedens
  real(kind=db), dimension(0:lla_state,nspinp,n_atom_0:n_atom_ind):: Int_Statedens_l
  real(kind=db), dimension(0:lla_state,nspinp):: Statedens_l
  real(kind=db), dimension(nspinp,n_atom_0:n_atom_ind):: Int_Statedens_t
  real(kind=db), dimension(0:nrm,0:ntype):: rato

  if( icheck > 2 )  then
    write(3,110)
    write(3,120) Energ(ie)*rydb
  endif

  proto_done(:) = .false.

  if( nenerg == 1 ) then
    de = 1._db
  elseif( ie == 1 ) then
    de = Energ(2) - Energ(1)
  elseif( ie == nenerg ) then
    de = Energ(ie) - Energ(ie-1)
  else
    de = 0.5_db * ( Energ(ie+1) -  Energ(ie-1) )
  endif

  do ipr = 0,n_atom_proto
    Z = Numat( itypepr(ipr) )
    La = Lmax_print(Z)   ! in tab_data.f90
    La = max( La, Lmax_DOSout ) 
    La = min( La, Lmaxat(ipr) )  
    LL = Lmax_pDOS(Z)    ! in tab_data.f90
    LL = min( LL, Lmaxat(ipr) )
    la_ipr(ipr) = La    ! max number of harmoniques for the writing of the DOS
    ll_ipr(ipr) = LL    
  end do

  First = .true.
  boucle_ia: do ia = 1,natome

    ipr = iaprotoi(ia)
    La = la_ipr(ipr)
    LL = ll_ipr(ipr)

    if( ia == iaabsi ) iprabs = ipr

    if( Full_atom ) then
      iapr = ia
    else
      iapr = ipr
    endif

    it = itypei(ia)
    Z = Numat(it)
    if( proto_done(ipr) .and. .not. Full_atom ) cycle boucle_ia
    if( .not. ( ia == iaabsi .or. State_all ) ) cycle
     
! Calculation of the DOS integrated up to the Rmstd ratomic radius

    do ir = 1,nrato(it)
      if( rato(ir,it) > Rmtsd(ipr) + eps10 ) exit
    end do
    nr = ir

    Lma = (LL + 1)**2

    Statedens_l(:,:) = 0._db
    do L = 0,La
      lm1 = L**2 + 1
      lm2 = ( L + 1 )**2
      do isp = 1,nspinp
        do Lm = lm1,lm2
          Statedens_l(L,isp) = Statedens_l(L,isp) + Statedens(Lm,isp,Lm,isp,iapr,ie_computer)
        end do
      end do
    end do
    if( nspinp == 1 ) Statedens_l(0:La,1) = 2 * Statedens_l(0:La,1)

! Integral of the DOS
    do isp = 1,nspinp
      do Lm = 1,Lma
        Int_Statedens(Lm,isp,iapr) = Int_Statedens(Lm,isp,iapr) + de * Statedens(Lm,isp,Lm,isp,iapr,ie_computer)
      end do
    end do

    do L = 0,LL
      lm1 = L**2 + 1
      lm2 = ( L + 1 )**2
      do isp = 1,nspinp
        Int_Statedens_l(L,isp,iapr) = sum(Int_Statedens(lm1:lm2,isp,iapr))
      end do
      if( nspinp == 1 ) Int_Statedens_l(L,1,iapr) = 2 * Int_Statedens_l(L,1,iapr)
    end do

    Int_statedens_t(:,iapr) = 0._db
    do isp = 1,nspinp
      Int_Statedens_t(isp,iapr) = Int_Statedens_t(isp,iapr) + sum( Int_Statedens_l(0:La,isp,iapr) )
    end do

    if( icheck > 1 ) then
      write(3,180) iapr
      Lm = 0
      do L = 0,LL
        do m = -L,L
          Lm = Lm + 1
          do isp = 1,nspinp
            write(3,190) L, m, isp, Statedens(Lm,isp,Lm,isp,iapr,ie_computer), Int_Statedens(Lm,isp,iapr)
          end do
        end do
      end do
      write(3,200)
      do L = 0,La
        write(3,210) L, Int_Statedens_l(L,1:nspinp,iapr)
      end do
      write(3,220) Int_Statedens_t(1:nspinp,iapr)
    endif

    Open_file = ie == 1
    Abs_exc = Full_atom .and. ( ia == iaabsi )  .and. .not. nonexc_g

    if( Open_file .and. icheck > 0 ) then
      if( First ) then
        write(3,230)
        write(3,'(/A)') ' Output file name for the projected density of state:'
        write(3,240) 
      endif
      nomficht = ' '
      Long = len_trim(nomfich_s)
      do L = Long,1,-1
        if( nomfich_s(L:L) == '/' .or. nomfich_s(L:L) == '\' ) exit
      end do
      L = L + 1 
      nomficht(1:Long-L+1) = nomfich_s(L:Long+1)
      Long = len_trim(nomficht)
      nomficht(Long+1:Long+3) = '_sd'

      if( Abs_exc ) then
        call ad_number(0,nomficht,Length_name)
      else
        call ad_number(iapr,nomficht,Length_name)
      endif
      if( Abs_exc ) then
        mot28 = '     Excited absorbing atom:'
      elseif( ia == iaabsi ) then
        mot28 = ' Non-excited absorbing atom:'
      else
        mot28 = '                       Atom:'
      endif
      write(3,250) mot28, Z, ia, ipr, nomficht
    endif
    
  ! Writing file common with cal_state in SCF.f90
    call Write_stdens(Abs_exc,.true.,Density_comp,Energ(ie),Harm_cubic,i_self,iapr,ie_computer,La, &
           Int_Statedens_l,lla_state,lla2_state,mpinodes,n_atom_0,n_atom_ind,nomfich_s,nspin,nspinp, &
           Open_file,Statedens,Statedens_l,.false.)

    proto_done(ipr) = .true.
    First = .false.

  end do boucle_ia

  return
  110 format(/' ---- Write_density --------',100('-'))
  120 format(15x,' Energy =',f10.3,' eV')
  180 format(/'  L  m is  Density of states   Integral    ia =',i3)
  190 format(3i3,3f15.7)
  200 format(/'    L   sum_m(Integral)')
  210 format(i5,2f15.7)
  220 format(' Total =',f12.7,f15.7)
  230 format(/120('-'))
  240 format(/' See above, under "Atom_selec", index "ia" : the position of the atom in the symmetrized cluster',/ &
              '            under "Symsite",    index "ipr": the position of the equivalent atom site for the space group',/ )
  250 format(a28,' Z =',i3,', ia =',i3,', ipr =',i3,': ',A) 
end

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

! Calculation of Bessel and neuman functions.

subroutine cbess(fnorm,z,Lmax,Lmaxm,bessel)

  use declarations
  implicit none
  
  integer:: L, L1, Lmax, Lmaxm

  complex(kind=db):: bessel(0:Lmaxm), fnorm, z

  if( abs( z ) < eps10 ) then
    bessel(0) = fnorm
  else
    bessel(0) = fnorm * sin(z) / z
  endif

  if( Lmax == 0 ) return

  if( abs( z ) < eps10 ) then

    bessel(1:Lmax) = (0._db, 0._db)

  else

    bessel(1) = bessel(0) / z - fnorm * cos(z) / z

    do L = 2,Lmax
      L1 = 2*L - 1
      bessel(L) = L1 * bessel(L-1) / z - bessel(L-2)
    end do

  endif

  return
end

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

! Calcul des fonctions de bessel et neuman (en fait, divisees par z )

subroutine cbessneu(fnorm,z,Lmax,Lmaxm,bessel,neuman)

  use declarations
  implicit none
  
  integer:: L, L1, Lmax, Lmaxm

  complex(kind=db):: bessel(0:Lmaxm), fnorm, neuman(0:Lmaxm), z

  neuman(0) = - fnorm * cos(z) / z
  bessel(0) = fnorm * sin(z) / z

  if( Lmax == 0 ) return

  neuman(1) = neuman(0) / z - bessel(0)
  bessel(1) = bessel(0) / z + neuman(0)

  do L = 2,Lmax
    L1 = 2*L - 1
    neuman(L) = L1 * neuman(L-1) / z - neuman(L-2)
    bessel(L) = L1 * bessel(L-1) / z - bessel(L-2)
  end do

  return
end

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

! Calculation of spherical Hankel function of first or second kind ( or Riccati-Hankel(+) or (-) function, divided by z )
! and its derivative versus r, not z

subroutine Cal_Hankel(d_Hankel,Hankel,konde,Lmax,r,Second_kind)

  use declarations
  implicit none

  integer:: L, Lmax

  complex(kind=db):: cfac, fnorm, konde, z
  complex(kind=db), dimension(0:Lmax):: d_hankel, hankel
  complex(kind=db), dimension(0:Lmax+1):: hankel_t

  logical:: Second_kind
  
  real(kind=db):: r

  z = konde * r

  if( Second_kind ) then
    hankel_t(0) = img
  else
    hankel_t(0) = - img
  endif

  if( Second_kind ) then
    hankel_t(1) = - 1._db + img / z
  else
    hankel_t(1) = - 1._db - img / z
  endif

  do L = 2,Lmax+1
    hankel_t(L) = (2*L - 1) * hankel_t(L-1) / z - hankel_t(L-2)
  end do

  do L = 0,Lmax
    d_hankel(L) = L * hankel_t(L) / z - hankel_t(L+1)
  end do

! For normalization by the squrare root of the density of state in vacuum
  fnorm = sqrt( konde / pi )
  if( Second_kind ) then
    cfac = fnorm * exp( - img * z ) / z
  else
    cfac = fnorm * exp( img * z ) / z
  endif

  hankel(0:Lmax) = cfac * hankel_t(0:Lmax)

! Multiplication by konde, because it is the derivative versus r, not z
  d_hankel(0:Lmax) = cfac * konde * d_hankel(0:Lmax)

  return
end

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

! Calculation of spherical Bessel function ( or Riccati-Bessel function, divided by z )
! and its derivative versus r, not z

subroutine Cal_Bessel(d_Bessel,Bessel,konde,Lmax,r)

  use declarations
  implicit none

  integer:: L, Lmax

  complex(kind=db):: cfac, fnorm, konde, z
  complex(kind=db), dimension(0:Lmax):: d_Bessel, Bessel
  complex(kind=db), dimension(0:Lmax+1):: Bessel_t

  real(kind=db):: r

  z = konde * r

  Bessel_t(0) = sin( z )

  Bessel_t(1) = - cos( z ) + Bessel_t(0) / z

  do L = 2,Lmax+1
    Bessel_t(L) = (2*L - 1) * Bessel_t(L-1) / z - Bessel_t(L-2)
  end do

  do L = 0,Lmax
    d_Bessel(L) = L * Bessel_t(L) / z - Bessel_t(L+1)
  end do

! For normalization by the squrare root of the density of state in vacuum
  fnorm = sqrt( konde / pi )
  cfac = fnorm / z

  Bessel(0:Lmax) = cfac * Bessel_t(0:Lmax)

! Multiplication by konde, because it is the derivative versus r, not z
  d_Bessel(0:Lmax) = cfac * konde * d_Bessel(0:Lmax)

  return
end

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

! Calcul des fonctions de bessel et neuman ( disisees par z )

subroutine cbessneur(fnorm,z,Lmax,Lmaxm,bessel,neuman)

  use declarations
  implicit none
  
  integer:: L, L1, Lmax, Lmaxm
  
  real(kind=db):: fnorm

  real(kind=db):: bessel(0:Lmaxm), neuman(0:Lmaxm), z

  neuman(0) = - fnorm * cos(z) / z
  bessel(0) = fnorm * sin(z) / z

  if( Lmax == 0 ) return
  
  neuman(1) = neuman(0) / z - bessel(0)
  bessel(1) = bessel(0) / z + neuman(0)

  do L = 2,Lmax
    L1 = 2*L - 1
    neuman(L) = L1 * neuman(L-1) / z - neuman(L-2)
    bessel(L) = L1 * bessel(L-1) / z - bessel(L-2)
  end do

  return
end

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

! Calculation of Bessel function ( Riccati-Bessel / z )
! When Bessel < 10^(-7), one takes the origin limit: j_l = z^L / (2*L+1)!!
! because of unstability of the recursive formula.

subroutine cbessel(bess,ip0,Lmax,nr,q,r)

  use declarations
  implicit none

  integer:: i, ip0, j, k, L, L1, Lmax, nr

  real(kind=db):: fac, q, z_lim
  real(kind=db), dimension(nr):: r, z
  real(kind=db), dimension(nr,0:Lmax):: bessel
  real(kind=db), dimension(nr,ip0:Lmax):: bess

  z(:) = q * r(:)

  do L = 0,Lmax

    select case(L)

      case(0)

        do i = 1,nr
          if( z(i) < 1.e-7_db ) then
            bessel(i,L) = 1._db - z(i)**2 / 6._db
          else
            bessel(i,L) = sin( z(i) ) / z(i)
          endif
        end do

      case(1)

        fac = 1._db / 3
        z_lim = 3.e-7_db  ! = ( 1.e-7_db / fac )**( 1._db / L )
        do i = 1,nr
          if( z(i) < z_lim ) then
            bessel(i,L) = fac * z(i)
          else
            bessel(i,L) = ( bessel(i,0) - cos( z(i) ) ) / z(i)
          endif
        end do

      case default

        k = 1
        do j = 3,2*L+1,2
          k = k * j
        end do
        fac = 1._db / k
        z_lim = ( 1.e-7_db / fac )**( 1._db / L )
        L1 = 2*L - 1
 ! L = 2, fac = 1/15, z_lim = 0.00122
 ! L = 3, fac = 1/105, z_lim = 0.0219
 ! L = 4, fac = 1/945, z_lim = 0.0986
 ! L = 5, fac = 1/10395, z_lim = 0.253

        do i = 1,nr
          if( z(i) < z_lim ) then
            bessel(i,L) = fac * z(i)**L
          else
            bessel(i,L) = L1 * bessel(i,L-1) / z(i) - bessel(i,L-2)
          endif
        end do

    end select

  end do

  do L = ip0,Lmax
    bess(:,L) = bessel(:,L)
  end do

  return
end


