! FDMNES subroutines

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

! Looking for equivalent atoms in the unit cell and search of the relative symmetry

subroutine Symsite(Absauto,angxyz,angxyz_int,angxyz_sur,Atom_with_axe,Atom_nsph_e,Axe_atom_gr, &
        axyz,axyz_int,axyz_sur,Base_ortho_int,Base_ortho_sur,Bulk,Center_s,Centre, &
        Doping,E_moment_axis,Extract,Flapw,iabsm,icheck,igr_i,igr_is,igr_proto,itequ,itype,Magnetic,Matper, &
        Memory_save,n_atom_int,n_atom_per,n_atom_proto,n_atom_proto_int,n_atom_sur,n_atom_uc,n_multi_run_e,n_Z_abs,neqm, &
        ngroup,ngroup_m,ngroup_taux,nlat,nlatm,Noncentre,nspin,ntype,Numat,numat_abs,popats,posn,Space_Group_P1,Sym_2D,Taux_oc)

  use declarations
  implicit none

  integer:: i, ia, ia_b, ib, ib_b, icheck, igr, igr_1, igr_2, igr_b, igra, igrb, io, irev, is, isp, it, ita, itb, jgr, jgr_b, &
     js, kgr, ks, long, n_atom_int, n_atom_per, n_atom_proto, n_atom_proto_int, n_atom_sur, n_atom_uc, n_multi_run_e, n_Z_abs, na, &
     nabs, nb, nla, nlb, neq, neqm, ngroup, ngroup_m, ngroup_taux, nlatm, nspin, ntype, numat_it, numat_jgr

  character(len=5):: struct
  character(len=9):: nomsym
  character(len=11):: nomt

  integer, dimension(nopsm):: Ordering_search
  integer, dimension(0:ntype):: itequ, nlat, Numat
  integer, dimension(ngroup):: igr_i, igr_is, igr_proto, itype
  integer, dimension(n_multi_run_e):: iabsm
  integer, dimension(ngroup):: igreq
  integer, dimension(n_atom_uc):: itypegen, Ordering
  integer, dimension(n_Z_abs):: numat_abs
  integer, dimension(:), allocatable:: iabsmm, isymq

  logical:: Absauto, Base_ortho, Base_ortho_int, Base_ortho_sur, Bulk, Center_s, Doping, E_moment_sym, &
            Extract, Flapw, Magnetic, Matper, Memory_save, mspinor, Noncentre, Space_Group_P1, Sym_2D
  logical, dimension(ngroup):: Atom_nsph_e, ok
  logical, dimension(0:ngroup_m):: Atom_with_axe
  logical, dimension(n_atom_uc):: Far_atom

  real(kind=db):: dist, distm_neq, dpop, pp1, pp2, Vnorme, z_max

  real(kind=db), dimension(3):: angxyz, angxyz_int, angxyz_sur, Axe_atom_c, axyz, axyz_int, axyz_sur, Centre, dcosxyz, &
                                dcosxyz_int, dcosxyz_sur, E_moment_axis, ps, spini, vspin, wspin
  real(kind=db), dimension(3,3):: Cubmat, Cubmat_int, Cubmat_sur, Cubmati, Cubmati_int, Cubmati_sur, matopsym
  real(kind=db), dimension(ngroup_taux):: Taux_oc
  real(kind=db), dimension(3,n_atom_uc):: pos, posg, posn, poss
  real(kind=db), dimension(3,ngroup_m):: Axe_atom_gr, Axe_atom_s
  real(kind=db), dimension(ngroup,nlatm,nspin):: popats

  data Ordering_search/ 1,25,18,21,24,28,31,40,41,42,45,48,49,50,51,52,53,54,55,56, &
                        2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17, &
                       19,20,22,23,26,27,29,30, &
                       32,33,34,35,36,37,38,39,43,44,46,47, &
                       57,58,59,60,61,62,63,64/

  call Cal_Cubmat(angxyz,Cubmat,Struct)
  call invermat(Cubmat,Cubmati)
  dcosxyz(:) = 2 * cos( angxyz(:) )
  if( sum( abs( dcosxyz(:) ) ) < eps10 ) then
    Base_ortho = .true.
  else
    Base_ortho = .false.
  endif

  if( .not. Bulk .and. n_atom_int /= 0 ) then
    call Cal_Cubmat(angxyz_int,Cubmat_int,Struct)
    call invermat(Cubmat_int,Cubmati_int)
    dcosxyz_int(:) = 2 * cos( angxyz_int(:) )
    if( sum( abs( dcosxyz_int(:) ) ) < eps10 ) then
      Base_ortho_int = .true.
    else
      Base_ortho_int = .false.
    endif
  endif

  if( .not. Bulk .and. n_atom_sur /= 0 ) then
    call Cal_Cubmat(angxyz_sur,Cubmat_sur,Struct)
    call invermat(Cubmat_sur,Cubmati_sur)
    dcosxyz_sur(:) = 2 * cos( angxyz_sur(:) )
    if( sum( abs( dcosxyz_sur(:) ) ) < eps10 ) then
      Base_ortho_sur = .true.
    else
      Base_ortho_sur = .false.
    endif
  endif

  if( Bulk ) then
! In this case, n_atom_uc is in fact n_atom_bulk
    igr_1 = ngroup - n_atom_uc + 1
    igr_2 = ngroup
  else
    igr_1 = 1
    igr_2 = n_atom_uc
  endif

  ok(:) = .false.

  do it = 0,ntype
    itequ(it) = it
  end do

  do ita = 1,ntype
    na = Numat(ita)
    nla = nlat(ita)
    do igra = igr_1,igr_2
      if( abs(itype(igra)) == ita ) exit
    end do
    if( igra > igr_2 ) cycle

    do itb = ita+1,ntype

      if( itequ(itb) /= itb ) cycle
      if( FLAPW .and. .not. Extract ) cycle

      nb = Numat(itb)
      if( nb /= na ) cycle
      nlb = nlat(itb)
      if( nlb /= nla ) cycle
      do igrb = igr_1,igr_2
        if( abs(itype(igrb)) == itb ) exit
      end do
      if( igrb > igr_2 ) cycle

      dpop = 0._db
      do io = 1,nlb
        do isp = 1,nspin
          dpop = dpop + abs( popats(igra,io,isp) - popats(igrb,io,isp) )
        end do
      end do
      if( dpop < eps6 ) then
        itequ(itb) = ita
      elseif( nspin > 1 ) then
        dpop = 0._db
        do io = 1,nlb
          do isp = 1,nspin
            dpop = dpop + abs( popats(igra,io,isp) - popats(igrb,io,nspin-isp+1) )
          end do
        end do
        if( dpop < eps6 ) itequ(itb) = -ita
      endif

    end do
  end do

  do igr = 1,n_atom_uc
    if( Bulk ) then
      jgr = ngroup - n_atom_uc + igr
      it = abs( itype(jgr) )
    else
      it = abs( itype(igr) )
    endif
    itypegen(igr) = itequ(it)
  end do

  Atom_with_axe(1:ngroup_m) = .false.
  if( Magnetic ) then
    if( Flapw ) then
      Atom_with_axe(:) = .true.
    else
      do igr = igr_1,igr_2
        it = abs( itype(igr) )
        if( nlat(it) > 0 ) then
          dpop = sum( abs( popats(igr,1:nlat(it),nspin) - popats(igr,1:nlat(it),1) ) )
          if( dpop > eps6 ) Atom_with_axe(igr) = .true.
        endif
      end do
    endif
  endif

! List of absorbing atoms
  if( Absauto ) then
    nabs = 0
    do i = 1,n_Z_abs
      do igr = igr_1,igr_2
        if( Numat( abs( itype(igr) ) ) == numat_abs(i) ) nabs = nabs+1
      end do
    end do
    allocate( iabsmm(nabs) )
    ia = 0
    do i = 1,n_Z_abs
      do igr = igr_1,igr_2
        if( Numat( abs( itype(igr) ) ) /= numat_abs(i) ) cycle
        ia = ia + 1
        iabsmm(ia) = igr
      end do
    end do
  else
    nabs = n_multi_run_e
    allocate( iabsmm(n_multi_run_e) )
    iabsmm(:) = iabsm(:)
  endif

! When Memory_save is true, the number of non-equivalent (non-absorbing) atoms is reduced
  if( Memory_save ) then

    distm_neq = 1.0_db / bohr

    do igr = 1,n_atom_uc

      Far_atom(igr) = .true.
      do ia = 1,nabs
        ps(:) = posn(:,iabsmm(ia)) - posn(:,igr)
        if( Sym_2D .or. ( iabsmm(ia) > n_atom_per  .or. igr > n_atom_per ) ) then
          do i = 1,2
            if( ps(i) > 0.5_db ) ps(i) = ps(i) - 1._db
            if( ps(i)  < -0.5_db ) ps(i) = ps(i) + 1._db
          end do
        elseif( Matper ) then
          where( ps > 0.5_db ) ps = ps - 1._db
          where( ps < -0.5_db ) ps = ps + 1._db
        endif
        if( igr <= n_atom_per ) then
          ps(:) = ps(:) * axyz(:)
          dist = Vnorme(Base_ortho,dcosxyz,ps)
        elseif( igr <= n_atom_per+n_atom_int ) then
          ps(:) = ps(:) * axyz_int(:)
          dist = Vnorme(Base_ortho_int,dcosxyz_int,ps)
        else
          ps(:) = ps(:) * axyz_sur(:)
          dist = Vnorme(Base_ortho_sur,dcosxyz_sur,ps)
        endif
        if( dist <= distm_neq ) then
          Far_atom(igr) =  .false.
          exit
        endif
      end do

    end do

  else

    Far_atom(:) = .false.

  endif

  if( Bulk .and. Center_s ) then
    z_max = -10000._db
    do ia = 1,n_atom_uc
      if( Posn(3,ia) < z_max + eps10 ) cycle
      ib = ia
      z_max = Posn(3,ia)
    end do
    Ordering(1) = ib
    i = 1
    do ia = 1,n_atom_uc
      if( ia == ib ) cycle
      i = i + 1
      Ordering(i) = ia
    end do

  else
    call Search_ordering(Absauto,axyz,axyz_int,axyz_sur,Base_ortho,Base_ortho_int,Base_ortho_sur,Center_s,Centre,dcosxyz, &
                       dcosxyz_int,dcosxyz_sur,Matper,n_atom_per,n_atom_sur,n_atom_uc,Noncentre,Ordering,posn,Sym_2D)
  endif

  allocate( isymq(n_atom_uc) )

  boucle_jgr: do kgr = 1,n_atom_uc

    jgr = Ordering(kgr)

    if( Bulk ) then
      jgr_b = ngroup - n_atom_uc + jgr
    else
      jgr_b = jgr
    endif

    if( ok(jgr) .or. Far_atom(jgr) ) cycle

    numat_jgr = Numat( abs( itype(jgr_b) ) )

    n_atom_proto = n_atom_proto + 1
    if( jgr <= n_atom_int .and. .not. Bulk ) n_atom_proto_int = n_atom_proto_int + 1

    ps(:) = posn(:,jgr)
    do ia = 1,n_atom_uc
      posg(:,ia) = posn(:,ia) - ps(:)
    end do

    if( Matper ) call inmesh(posg,n_atom_per,n_atom_uc,Sym_2D)

    neq = 1
    isymq(1) = 1
    igreq(1) = jgr_b
    ok(jgr) = .true.

    boucle_igr: do igr = 1,n_atom_uc

      if( .not. Bulk .and. Space_group_P1 ) cycle boucle_igr

      if( ( jgr <= n_atom_per .and. igr > n_atom_per ) .or. ( igr <= n_atom_per .and. jgr > n_atom_per ) &
        .or. ( jgr <= n_atom_per+n_atom_int .and. igr > n_atom_per+n_atom_int ) &
        .or. ( igr <= n_atom_per+n_atom_int .and. jgr > n_atom_per+n_atom_int ) ) cycle

      if( ok(igr) .or. Far_atom(igr) ) cycle boucle_igr

      if( abs(itypegen(igr)) /= abs(itypegen(jgr))) cycle boucle_igr

      if( .not. Bulk .and. ngroup_taux > 0 ) then
        if( abs( Taux_oc(igr) - Taux_oc(jgr) ) > eps6 ) cycle boucle_igr
      endif

      do ia = 1,n_atom_uc
        pos(:,ia) = posn(:,ia) - Posn(:,igr)
      end do
      if( Matper ) call inmesh(pos,n_atom_per,n_atom_uc,Sym_2D)

! Search of symmetries making the atoms equivalent
      boucle_is: do ks = 1,nopsm
        is = Ordering_search(ks)

! For 2D diffraction, one only keeps 2D symmetries
        if( ( Sym_2D .or. igr > n_atom_per ) &
                      .and. .not. ( is == 1 .or. is == 18 .or. is == 21 .or. is == 24 .or. is == 40 .or. is == 41 .or. is == 45 &
                             .or. ( is >= 48 .and. is <= 52 ) .or. is == 57 .or. is == 59 .or. is == 61 .or. is == 63 ) ) cycle

! Electric moment
        if( .not. E_moment_sym( is, E_moment_axis ) ) cycle boucle_is

        call opsym(is,matopsym)
        if( struct /= 'cubic' ) then
          matopsym = matmul(matopsym,cubmat)
          matopsym = matmul(cubmati,matopsym)
        endif

        do ia = 1,n_atom_uc
          ps(:) = posg(:,ia) * axyz(:)
          ps = matmul( matopsym, ps )
          poss(:,ia) = ps(:) / axyz(:)
        end do
        if( Matper ) call inmesh(poss,n_atom_per,n_atom_uc,Sym_2D)

        if( Magnetic ) then
          call opsym(is,matopsym)
          do ia = 1,n_atom_uc
            if( Bulk ) then
              ia_b = ngroup - n_atom_uc + ia
            else
              ia_b = ia
            endif

            Axe_atom_c(:) = Axe_atom_gr(:,ia_b)
   ! Spin vector is a pseudo vector and the symmetry operation must be performed
   ! on the 2 orthogonal vectors whose the cross product is the spin direcction
            if( abs( Axe_atom_c(1) ) < eps6 ) then
              wspin(1) = 1._db;  wspin(2:3) = 0._db
            else
              wspin(3) = 1._db;  wspin(1:2) = 0._db
            endif
            call prodvec( vspin, Axe_atom_c, wspin )
            vspin(:) = vspin(:) / sum( vspin(:)**2 )
            call prodvec( wspin, Axe_atom_c, vspin )
            wspin(:) = wspin(:) / sum( wspin(:)**2 )

            vspin = matmul( matopsym, vspin )
            wspin = matmul( matopsym, wspin )
            call prodvec(spini,vspin,wspin)

            Axe_atom_s(:,ia_b) = spini(:)
         end do
        endif

        boucle_irev: do irev = 1,nspin    ! 1 identity, 2 time reversal

          boucle_ia: do ia = 1,n_atom_uc
            if( ( ia <= n_atom_per .and. igr > n_atom_per ) .or. ( ia > n_atom_per .and. igr <= n_atom_per ) &
             .or. ( ia <= n_atom_per+n_atom_int .and. igr > n_atom_per+n_atom_int ) &
             .or. ( ia > n_atom_per+n_atom_int .and. igr <= n_atom_per+n_atom_int ) ) cycle
            if( Bulk ) then
              ia_b = ngroup - n_atom_uc + ia
            else
              ia_b = ia
            endif

            boucle_ib: do ib = 1,n_atom_uc
              if( ( ib <= n_atom_per .and. igr > n_atom_per ) .or. ( ib > n_atom_per .and. igr <= n_atom_per ) &
               .or. ( ib <= n_atom_per+n_atom_int .and. igr > n_atom_per+n_atom_int ) &
               .or. ( ib > n_atom_per+n_atom_int .and. igr <= n_atom_per+n_atom_int )) cycle
              if( Bulk ) then
                ib_b = ngroup - n_atom_uc + ib
              else
                ib_b = ib
              endif

              if( abs( pos(1,ia) - poss(1,ib) ) > epspos .or. abs( pos(2,ia) - poss(2,ib) ) > epspos .or. &
                  abs( pos(3,ia) - poss(3,ib) ) > epspos ) cycle boucle_ib

              if( abs(itypegen(ia)) /= abs(itypegen(ib)) ) cycle boucle_ib

              if( .not. Magnetic ) cycle boucle_ia

              if( .not. ( Atom_with_axe(ia_b) .or. Atom_with_axe(ib_b))) cycle boucle_ia

              if( ( Atom_with_axe(ia_b) .and. .not. Atom_with_axe(ib_b)) .or. &
                ( .not. Atom_with_axe(ia_b) .and. Atom_with_axe(ib_b) )) cycle boucle_is
!!!!!!
!write(6,'(a3,6i3)') ' p1', jgr, igr, is, irev, ia, ib
              mspinor = itypegen(ia) == itypegen(ib)
!write(6,'(3L3)') Atom_with_axe(ia_b), mspinor, ( irev == 1 .and. mspinor ) .or. ( irev == 2 .and. .not. mspinor )
!write(6,'(i3,3f15.12)') ia_b, Axe_atom_gr(:,ia_b)
!write(6,'(i3,3f15.12)') ib_b, Axe_atom_gr(:,ib_b)
!read(5,*)
              if( Atom_with_axe(ia_b) ) then

                if( ( irev == 1 .and. mspinor ) .or. ( irev == 2 .and. .not. mspinor ) ) then
                  if(     abs( Axe_atom_gr(1,ia_b) - Axe_atom_s(1,ib_b) ) > epspos  &
                     .or. abs( Axe_atom_gr(2,ia_b) - Axe_atom_s(2,ib_b) ) > epspos  &
                     .or. abs( Axe_atom_gr(3,ia_b) - Axe_atom_s(3,ib_b) ) > epspos ) cycle boucle_irev
                else
                  if(     abs( Axe_atom_gr(1,ia_b) + Axe_atom_s(1,ib_b) ) > epspos  &
                     .or. abs( Axe_atom_gr(2,ia_b) + Axe_atom_s(2,ib_b) ) > epspos  &
                     .or. abs( Axe_atom_gr(3,ia_b) + Axe_atom_s(3,ib_b) ) > epspos ) cycle boucle_irev
                endif

              else

                 pp1 = sum( abs( Axe_atom_gr(:,ia_b) - Axe_atom_s(:,ib_b) ) )
                 pp2 = sum( abs( Axe_atom_gr(:,ia_b) + Axe_atom_s(:,ib_b) ) )
                 if( pp1 > epspos .and. pp2 > epspos ) cycle boucle_irev
              endif
!!!!!!!
!write(6,'(a3,6i3)') ' p2', jgr, igr, is, irev, ia, ib
!read(5,*)

              js = ia

              cycle boucle_ia

            end do boucle_ib

            cycle boucle_is

          end do boucle_ia

! This symmetry is the good one
          if( irev == 2 ) then
            js = - is
          else
            js = is
          endif

          neq = neq + 1
          ok(igr) = .true.
          if( Bulk ) then
! Here, n_atom_uc is in fact n_atom_bulk
            igreq(neq) = ngroup - n_atom_uc + igr
          else
            igreq(neq) = igr
          endif
          isymq(neq) = js

          exit boucle_is

        end do boucle_irev

      end do boucle_is

    end do boucle_igr

! One takes the spin axis of the first atom of the group as reference
!    if( Magnetic ) then

!      do i = 2,neq

!        is = abs( isymq(i) )
!        call opsym(is,matopsym)

!        Axe_atom_c(:) = axyz(:) * Axe_atom_gr(:,igreq(1))
!        Axe_atom_c =  matmul( cubmat, Axe_atom_c )
!        if( abs(Axe_atom_c(1)) < eps6 ) then
!          wspin(1) = 1._db;  wspin(2:3) = 0._db
!        else
!          wspin(3) = 1._db;  wspin(1:2) = 0._db
!        endif
!        call prodvec( vspin, Axe_atom_c, wspin )
!        vspin(:) = vspin(:) / sum( vspin(:)**2 )
!        call prodvec( wspin, Axe_atom_c, vspin )
!        wspin(:) = wspin(:) / sum( wspin(:)**2 )
!        vspin = matmul( matopsym, vspin )
!        wspin = matmul( matopsym, wspin )
!        call prodvec(spini,vspin,wspin)
!        spini =  matmul( cubmati, spini )
!        spini(:) = spini(:) / axyz(:)

!        ia = igreq(i)
!        Axe_atom_gr(:,ia) = (isymq(i) / is ) * spini(:)

!      end do

!    endif

    neqm = max(neqm,neq)
    do i = 1,neq
      igr_proto(igreq(i)) = n_atom_proto
      igr_i(igreq(i)) = i
      igr_is(igreq(i)) = isymq(i)
    end do

    if( icheck > 0 ) then
      if( n_atom_proto == 1 ) write(3,110)
      if( Bulk ) then
        write(3,120) n_atom_proto, numat_jgr, neq
      elseif( igreq(1) <= n_atom_sur ) then
        write(3,123) n_atom_proto, numat_jgr, neq
      elseif( igreq(1) <= n_atom_int + n_atom_sur ) then
        write(3,125) n_atom_proto, numat_jgr, neq
      else
        write(3,130) n_atom_proto, numat_jgr, neq
      endif
      do ia = 1,neq
        nomt = '         '
        nomt(3:11) = nomsym( abs(isymq(ia)) )
        if(isymq(ia) < 0 ) then
          long = len_trim( adjustl( nomsym(abs(isymq(ia))) ) )
          nomt(10-long:11-long) = 'T.'
        endif
        if( Bulk ) then
          igra = igreq(ia) - ngroup + n_atom_uc
        else
          igra = igreq(ia)
        endif
        write(3,140) igreq(ia), posn(:,igra), nomt, isymq(ia)
      end do
    endif

  end do boucle_jgr

  deallocate( isymq )

  if( Memory_save ) then

    do jgr = 1,n_atom_uc

      if( Bulk ) then
        jgr_b = ngroup - n_atom_uc + jgr
      else
        jgr_b = jgr
      endif

      if( ok(jgr) ) cycle

      ok(jgr) = .true.
      n_atom_proto = n_atom_proto + 1
      if( jgr <= n_atom_int .and. .not. Bulk ) n_atom_proto_int = n_atom_proto_int + 1

      neq = 1

      igr_proto(jgr_b) = n_atom_proto
      igreq(1) = jgr_b
      igr_i(jgr_b) = neq
      igr_is(jgr_b) = 1

      do igr = 1,n_atom_uc
        if( ( jgr <= n_atom_per .and. igr > n_atom_per ) .or. ( jgr > n_atom_per .and. igr <= n_atom_per ) ) cycle

        if( ok(igr ) .or. itypegen(igr) /= itypegen(jgr) ) cycle
        if( Bulk ) then
          igr_b = ngroup - n_atom_uc + igr
        else
          igr_b = igr
        endif

        ok(igr) = .true.
        neq = neq + 1

        igreq(neq) = igr_b
        igr_proto(igr_b) = n_atom_proto
        igr_i(igr_b) = neq
        igr_is(igr_b) = 1
      end do
      neqm = max(neqm,neq)

      if( icheck > 0 ) then
        numat_it = Numat( abs( itype(jgr) ) )
        if( Bulk ) then
          write(3,150) n_atom_proto, numat_it, neq
        elseif( jgr <= n_atom_sur ) then
          write(3,160) n_atom_proto, numat_it, neq
        elseif( jgr <= n_atom_sur + n_atom_int ) then
          write(3,170) n_atom_proto, numat_it, neq
        else
          write(3,180) n_atom_proto, numat_it, neq
        endif
        write(3,'(20i6)') igreq(1:neq)
      endif

    end do

  endif

  if( Doping )  igr_proto(n_atom_uc+1) = n_atom_proto + 1

  deallocate( iabsmm )

  return
  110 format(/' ---- Symsite ------',100('-'))
  120 format(/3x,'ipr =',i5,', Z =',i3,', natomsym =',i6,'      - Bulk -',//, &
             '  igr         posx          posy          posz            sym    code')
  123 format(/3x,'ipr =',i5,', Z =',i3,', natomsym =',i6,'   - Surface -',//, &
             '  igr         posx          posy          posz            sym    code')
  125 format(/3x,'ipr =',i5,', Z =',i3,', natomsym =',i6,' - Interface -',//, &
             '  igr         posx          posy          posz            sym    code')
  130 format(/3x,'ipr =',i5,', Z =',i3,', natomsym =',i6//, &
             '  igr         posx          posy          posz            sym    code')
  140 format(i5,2x,3f14.8,2x,a11,3x,129i3)
  150 format(/3x,'ipr =',i5,', Z =',i3,', natomsym =',i6,'      - Bulk -',//,'  igr...')
  160 format(/3x,'ipr =',i5,', Z =',i3,', natomsym =',i6,'   - Surface -',//,'  igr...')
  170 format(/3x,'ipr =',i5,', Z =',i3,', natomsym =',i6,' - Interface -',//,'  igr...')
  180 format(/3x,'ipr =',i5,', Z =',i3,', natomsym =',i6//,'  igr...')
end

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

subroutine Search_ordering(Absauto,axyz,axyz_int,axyz_sur,Base_ortho,Base_ortho_int,Base_ortho_sur,Center_s,Centre,dcosxyz, &
                       dcosxyz_int,dcosxyz_sur,Matper,n_atom_per,n_atom_sur,n_atom_uc,Noncentre,Ordering,posn,Sym_2D)

  use declarations
  implicit none

  integer:: i, igr, jgr, n, n_atom_per, n_atom_sur, n_atom_uc

  integer, dimension(n_atom_uc):: Ordering

  logical:: Absauto, Base_ortho, Base_ortho_int, Base_ortho_sur, Center_s, Closer, Matper, Noncentre, Positive, Same_distance, &
            Sym_2D

  real(kind=db):: dist12, Vnorme
  real(kind=db), dimension(3):: axyz, axyz_int, axyz_sur, Centre, dcosxyz, dcosxyz_int, dcosxyz_sur, ps
  real(kind=db), dimension(n_atom_uc):: dist
  real(kind=db), dimension(3,n_atom_uc):: pos, posn

  do igr = 1,n_atom_uc
    if( Noncentre ) then
      pos(:,igr) = posn(:,igr) - Centre(:)
    elseif( Center_s ) then
      pos(1:2,igr) = posn(1:2,igr) - Centre(1:2)
      pos(3,igr) = posn(3,igr)
    else
      pos(:,igr) = posn(:,igr)
    endif
  end do

  if( Matper) call inmesh(pos,n_atom_per,n_atom_uc,Sym_2D)
  if( Sym_2D ) then
    do igr = 1,n_atom_uc
      do i = 1,2
        if( pos(i,igr) > 0.5_db + eps10 ) pos(i,igr) = pos(i,igr) - 1._db
        if( pos(i,igr) < -0.5_db + eps10 ) pos(i,igr) = pos(i,igr) + 1._db
      end do
    end do
  elseif( Matper ) then
    where( pos > 0.5_db + eps10 ) pos = pos - 1._db
    where( pos < -0.5_db + eps10 ) pos = pos + 1._db
  endif

  do igr = 1,n_atom_uc
    if( igr <= n_atom_per ) then
      ps(:) = pos(:,igr) * axyz(:)
      dist(igr) = Vnorme(Base_ortho,dcosxyz,ps)
    elseif( igr <= n_atom_per+n_atom_sur ) then
      ps(:) = pos(:,igr) * axyz_sur(:)
      dist(igr) = Vnorme(Base_ortho_sur,dcosxyz_sur,ps)
    else
      ps(:) = pos(:,igr) * axyz_int(:)
      dist(igr) = Vnorme(Base_ortho_int,dcosxyz_int,ps)
    endif
    pos(:,igr) = ps(:)
  end do

  do igr = 1,n_atom_uc
    Ordering(igr) = igr
  end do

! When Absorber keyword is used, there is a risk that the ordering make the chosen aborbing atom not first in the list
  if( Absauto ) then

    do igr = 1,n_atom_uc
      do jgr = igr+1,n_atom_uc
        if( igr <= n_atom_per .and. jgr > n_atom_per ) cycle
        if( igr > n_atom_per .and. igr <= n_atom_per + n_atom_sur .and. jgr > n_atom_per + n_atom_sur ) cycle
        if( dist(jgr) > dist(igr) + eps10 ) cycle
        Same_distance = abs( dist(igr) - dist(jgr) ) < eps10
 ! When at the same distance, one puts first the atom in the positive direction versus the origin
        ps(:) = pos(:,jgr) - pos(:,igr)
        if( Sym_2D ) then
          if( abs( pos(3,jgr) - pos(3,igr) ) > eps10 ) cycle
          Positive = Same_distance .and. ( sum( ps(1:2) ) > eps10 .or. ps(1) > eps10 )
          Closer = ( Noncentre .or. Center_s ) .and. dist(jgr) < dist(igr) - eps10
        else
          Positive = Same_distance .and. &
                    ( sum( ps(:) ) > eps10 .or. ps(1) > eps10 .or. ( abs( ps(1) ) < eps10 .and. ps(2) > eps10 ) )
          Closer = ( Noncentre .or. Center_s ) .and. dist(jgr) < dist(igr) - eps10
        endif
        if( Positive .or. Closer ) then
          dist12 = dist(igr)
          dist(igr) = dist(jgr)
          dist(jgr) = dist12
          i = Ordering(igr)
          Ordering(igr) = Ordering(jgr)
          Ordering(jgr) = i
          ps(:) = pos(:,igr)
          pos(:,igr) = pos(:,jgr)
          pos(:,jgr) = ps(:)
          endif
      end do
    end do

  endif

! For self-consistency, the atom must be calculated from the bulk up to surface,
! because the self-consistent potential of deeper atoms is conserved when top more layers are calculated

  if( n_atom_uc - n_atom_per > 0 ) then

    n = n_atom_per + n_atom_sur

    do igr = n_atom_per + 1, n_atom_uc
      do jgr = igr + 1, n_atom_uc
        if( pos(3,igr) > pos(3,jgr) - eps10 .or. ( igr <= n .and. jgr > n ) ) cycle
        i = Ordering(igr)
        Ordering(igr) = Ordering(jgr)
        Ordering(jgr) = i
        ps(:) = pos(:,igr)
        pos(:,igr) = pos(:,jgr)
        pos(:,jgr) = ps(:)
      end do
    end do

  endif

  return
end

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

! For the operation symmetry is, return if compatible or not with the direction of the Electric moment

function E_moment_sym( is, E_moment_axis )

  use declarations
  implicit none

  logical:: E_moment_sym

  integer:: is

  logical, dimension(3):: E_moment_axis_NonZero

  real(kind=db), dimension(3):: E_moment_axis

  E_moment_axis_NonZero(:) = abs( E_moment_axis(:) ) > eps10

  E_moment_sym = .true.

  if( .not. ( E_moment_axis_NonZero(1) .or. E_moment_axis_NonZero(2) .or. E_moment_axis_NonZero(3) ) ) return

  select case(is)
    case(2,3)
      if( abs( E_moment_axis(1) - E_moment_axis(2) ) > eps10 &
                                 .or. abs( E_moment_axis(1) - E_moment_axis(3) ) > eps10 ) E_moment_sym = .false.
    case(4,5)
      if( abs( E_moment_axis(1) + E_moment_axis(2) ) > eps10 &
                                 .or. abs( E_moment_axis(1) - E_moment_axis(3) ) > eps10 ) E_moment_sym = .false.
    case(6,7)
      if( abs( E_moment_axis(1) + E_moment_axis(2) ) > eps10 &
                                 .or. abs( E_moment_axis(1) + E_moment_axis(3) ) > eps10 ) E_moment_sym = .false.
    case(8,9)
      if( abs( E_moment_axis(1) - E_moment_axis(2) ) > eps10 &
                                   .or. abs( E_moment_axis(1) + E_moment_axis(3) ) > eps10 ) E_moment_sym = .false.
    case(10)
      if( abs( E_moment_axis(1) - E_moment_axis(2) ) > eps10 .or. E_moment_axis_NonZero(3) ) E_moment_sym = .false.
    case(11)
      if( abs( E_moment_axis(1) + E_moment_axis(2) ) > eps10 .or. E_moment_axis_NonZero(3) ) E_moment_sym = .false.
    case(12)
      if( abs( E_moment_axis(1) - E_moment_axis(3) ) > eps10 .or. E_moment_axis_NonZero(2) ) E_moment_sym = .false.
    case(13)
      if( abs( E_moment_axis(1) + E_moment_axis(3) ) > eps10 .or. E_moment_axis_NonZero(2) ) E_moment_sym = .false.
    case(14)
      if( abs( E_moment_axis(2) - E_moment_axis(1) ) > eps10 .or. E_moment_axis_NonZero(2) ) E_moment_sym = .false.
    case(15)
      if( abs( E_moment_axis(3) + E_moment_axis(1) ) > eps10 .or. E_moment_axis_NonZero(2) ) E_moment_sym = .false.
    case(16,19,22)
      if( E_moment_axis_NonZero(2) .or. E_moment_axis_NonZero(3) ) E_moment_sym = .false.
    case(17,20,23)
      if( E_moment_axis_NonZero(1) .or. E_moment_axis_NonZero(3) ) E_moment_sym = .false.
    case(18,21,24,49,50,51,52)
      if( E_moment_axis_NonZero(1) .or. E_moment_axis_NonZero(2) ) E_moment_sym = .false.
    case(25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,53,54,55,56)
      if( E_moment_axis_NonZero(1) .or. E_moment_axis_NonZero(2) .or. E_moment_axis_NonZero(3) ) E_moment_sym = .false.
    case(40)
      if( E_moment_axis_NonZero(1) ) E_moment_sym = .false.
    case(41)
      if( E_moment_axis_NonZero(2) ) E_moment_sym = .false.
    case(42)
      if( E_moment_axis_NonZero(3) ) E_moment_sym = .false.
   case(43)
      if( abs( E_moment_axis(2) - E_moment_axis(3) ) > eps10 .or. E_moment_axis_NonZero(1) ) E_moment_sym = .false.
    case(44)
      if( abs( E_moment_axis(1) - E_moment_axis(3) ) > eps10 .or. E_moment_axis_NonZero(2) ) E_moment_sym = .false.
    case(45)
      if( abs( E_moment_axis(1) - E_moment_axis(2) ) > eps10 .or. E_moment_axis_NonZero(3) ) E_moment_sym = .false.
    case(46)
      if( abs( E_moment_axis(2) + E_moment_axis(3) ) > eps10 .or. E_moment_axis_NonZero(1) ) E_moment_sym = .false.
    case(47)
      if( abs( E_moment_axis(1) + E_moment_axis(3) ) > eps10 .or. E_moment_axis_NonZero(2) ) E_moment_sym = .false.
    case(48)
      if( abs( E_moment_axis(1) + E_moment_axis(2) ) > eps10 .or. E_moment_axis_NonZero(3) ) E_moment_sym = .false.
    case(57)
      if( abs( 2*E_moment_axis(1) - E_moment_axis(2) ) > eps10 ) E_moment_sym = .false.
    case(58)
      if( abs( 2*E_moment_axis(1) - E_moment_axis(2) ) > eps10 .or. E_moment_axis_NonZero(3) ) E_moment_sym = .false.
    case(59)
      if( abs( E_moment_axis(1) - E_moment_axis(2) ) > eps10 ) E_moment_sym = .false.
    case(60)
      if( abs( E_moment_axis(1) - E_moment_axis(2) ) > eps10 .or. E_moment_axis_NonZero(3) ) E_moment_sym = .false.
    case(61)
      if( abs( E_moment_axis(1) - 2*E_moment_axis(2) ) > eps10 ) E_moment_sym = .false.
    case(62)
      if( abs( E_moment_axis(1) - 2*E_moment_axis(2) ) > eps10 .or. E_moment_axis_NonZero(3) ) E_moment_sym = .false.
    case(63)
      if( abs( E_moment_axis(1) + 2*E_moment_axis(2) ) > eps10 ) E_moment_sym = .false.
    case(64)
      if( abs( E_moment_axis(1) + 2*E_moment_axis(2) ) > eps10 .or. E_moment_axis_NonZero(3) ) E_moment_sym = .false.
  end select

  return
end

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

subroutine inmesh(pos,n_atom_per,n_atom_uc,Sym_2D)

  use declarations
  implicit none

  integer:: igr, k, m, n_atom_per, n_atom_uc

  logical:: Sym_2D

  real(kind=db), dimension(3,n_atom_uc):: pos

  do igr = 1,n_atom_uc
    do k = 1,3
      if( ( Sym_2D .or. igr > n_atom_per ) .and. k == 3 ) exit
      if( pos(k,igr) > 1._db - eps10 ) then
        m = int( pos(k,igr) + eps10 )
        pos(k,igr) = pos(k,igr) - m
      elseif( pos(k,igr) < - eps10 ) then
        m = 1 - int( pos(k,igr) + eps10 )
        pos(k,igr) = pos(k,igr) + m
      endif
    end do
  end do

  return
end

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

! number of layer with absorbing atoms and center of eachs ones taken as the barycenter of the absorbing prototypical atoms

subroutine Find_layer_center(axyz,angxyz,Center_abs_s,Delta_plane_max,i,iabsm,iabsorig,icheck,igr_layer,igreq,isymqa,itype, &
                      n_atom_proto,n_atom_proto_bulk,n_atom_uc,n_layer_abs,n_multi_run,n_proto_layer,n_proto_layer_max,n_Z_abs, &
                      natomsym_max,neqm,ngreq,ngroup,ntype,Numat,numat_abs,Posn)

  use declarations
  implicit none

  integer, parameter:: n_proto_max = 8

  integer:: i, i_eq, i_layer, i_magnet, ia, icheck, igr, index, ipr, isym, ix, iy, j, j_eq, j_layer, Long, multi_run, n, &
    n_atom_proto, n_atom_proto_bulk, n_atom_proto_s, n_atom_uc, n_layer_abs, n_multi_run, n_proto_layer_max, n_Z_abs, &
    natomsym_max, neqm, ngroup, ntype

  integer, dimension(ngroup):: itype
  integer, dimension(n_multi_run):: iabsm, iabsorig
  integer, dimension(0:ntype):: Numat
  integer, dimension(n_Z_abs):: numat_abs
  integer, dimension(0:n_atom_proto):: ngreq
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(0:n_atom_proto,natomsym_max):: isymqa
  integer, dimension(n_layer_abs):: n_proto_layer
  integer, dimension(n_proto_max):: ia_p, na
  integer, dimension(9*neqm,n_proto_layer_max):: igr_val
  integer, dimension(3,9*neqm,n_proto_layer_max):: indice_val
  integer, dimension(n_proto_layer_max,n_layer_abs):: igr_layer
  integer, dimension(n_atom_proto-n_atom_proto_bulk,n_layer_abs):: ipr_layer
  integer, dimension(3,n_proto_layer_max,n_layer_abs):: index_layer

  character(len=5):: Struct
  character(len=9):: nomsym
  character(len=11):: Sym_name_1, Sym_name_2

  logical:: First

  real(kind=db):: Delta_p_max, Delta_plane_max, Dist_min, z_layer

  real(kind=db), dimension(3):: angxyz, axyz, p, v
  real(kind=db), dimension(n_atom_proto-n_atom_proto_bulk):: z_layer_found
  real(kind=db), dimension(3,3):: Cubmat, Cubmat_i
  real(kind=db), dimension(3,n_layer_abs):: Center_abs_s
  real(kind=db), dimension(3,n_atom_uc):: Posn
  real(kind=db), dimension(3,9*neqm,n_proto_layer_max):: P_val

  z_layer_found(:) = -1000._db
  n_layer_abs = 0

  Delta_p_max = Delta_plane_max / axyz(3) + eps10

  n_atom_proto_s = n_atom_proto - n_atom_proto_bulk

  do ipr = 1,n_atom_proto_s
    igr = igreq(ipr,1)
    do j = 1,n_z_abs
      if( Numat( abs( itype(igr) ) ) == numat_abs(j) ) exit
    end do
    if( j > n_z_abs ) cycle

    z_layer = Posn(3, igr )

    do i_layer = 1,n_layer_abs
      if( abs( z_layer - z_layer_found(i_layer) ) < Delta_p_max ) then
        z_layer_found(i_layer) = 0.5_db * ( z_layer + z_layer_found(i_layer) )
        exit
      endif
    end do
    if( i_layer > n_layer_abs ) then
      n_layer_abs = n_layer_abs + 1
      z_layer_found(n_layer_abs) = z_layer
    endif
  end do

  if( i == 1 ) return

! Ordering of the layer

  do i_layer = 1,n_layer_abs
    do j_layer = i_layer+1,n_layer_abs
      if( z_layer_found(j_layer) > z_layer_found(i_layer) + eps10 ) then
        z_layer = z_layer_found(j_layer)
        z_layer_found(j_layer) = z_layer_found(i_layer)
        z_layer_found(i_layer) = z_layer
      endif
    end do
  end do

  igr_layer(:,:) = 0
  ipr_layer(:,:) = 0
  indice_val(:,:,:) = 0
  Center_abs_s(:,:) = 0._db

  call Cal_Cubmat(angxyz,Cubmat,Struct)

  n_proto_layer_max = 0
  n_proto_layer(:) = 0
  ipr_layer(:,:) = 0

! Evaluation of the number of absorbing prototypical atoms in the layers
  do i_layer = 1,n_layer_abs

    index = 0

    do ipr = 1,n_atom_proto_s
      igr = igreq(ipr,1)
      do j = 1,n_z_abs
        if( Numat( abs( itype(igr) ) ) == numat_abs(j) ) exit
      end do
      if( j > n_z_abs ) cycle
      z_layer = Posn(3, igr )

      if( abs( z_layer - z_layer_found(i_layer) ) > Delta_p_max ) cycle

      index = index + 1
      ipr_layer(index,i_layer) = ipr
    end do

    n_proto_layer(i_layer) = index

    n_proto_layer_max = max( n_proto_layer_max, n_proto_layer(i_layer) )

    if( n_proto_layer(i_layer) < 3 .or. Delta_p_max < 2*eps10 ) cycle

    z_layer = 0._db
    do index = 1,n_proto_layer(i_layer)
      ipr = ipr_layer(index,i_layer)
      igr = igreq(ipr,1)
      z_layer = z_layer + Posn(3, igr )
    end do
    z_layer_found(i_layer) = z_layer / n_proto_layer(i_layer)

  end do

  if( n_proto_layer_max > n_proto_max ) then
    call write_error
    do ipr = 6,9,3
      write(ipr,'(/A)') '  There are too much non equivalent atoms in one of the surface layer'
      write(ipr,'(/a25,i3)') '    The maximum number is =', n_proto_max
      write(ipr,'(/A)') '   z_layer  number of non equivalent atoms'
      do i_layer = 1,n_layer_abs
        write(ipr,'(f11.7,i7)') z_layer_found(i_layer), n_proto_layer(i_layer)
      end do
    end do
    stop
  endif

  if( i == 2 ) return

  igr_layer(:,:) = 0

  do i_layer = 1,n_layer_abs
    n = n_proto_layer(i_layer)

    if( n == 1 ) then
      ipr = ipr_layer(1,i_layer)
      igr_layer(1,i_layer) = igreq(ipr,1)
      index_layer(:,1,i_layer) = 0
      Center_abs_s(:,i_layer) = Posn(:, igr_layer(1,i_layer) )
      cycle
    endif

    do index = 1,n

      ipr = ipr_layer(index,i_layer)

      ia = 0
      do i_eq = 1,ngreq(ipr)
        igr = igreq(ipr,i_eq)
        p(:) = Posn(:,igr)

        ia = ia + 1
        v(:) = p(:)
        if( Struct /= 'cubic' ) v = matmul( Cubmat, v )
        v(:) = v(:) * axyz(:)
        igr_val(ia,index) = igr
        indice_val(1,ia,index) = 0
        indice_val(2,ia,index) = 0
        P_val(:,ia,index) = v(:)

        do ix = -1,1
          p(1) = p(1) + ix
          do iy = -1,1
            if( ix == 0 .and. iy == 0 ) cycle
            p(2) = p(2) + iy
            ia = ia + 1
            v(:) = p(:)
            if( Struct /= 'cubic' ) v = matmul( Cubmat, v )
            v(:) = v(:) * axyz(:)
            igr_val(ia,index) = igr
            indice_val(1,ia,index) = ix
            indice_val(2,ia,index) = iy
            P_val(:,ia,index) = v(:)
          end do
        end do
      end do
      na(index) = ia

    end do

    dist_min = 1000000._db

    ia_p(1) = 0
    do
      ia_p(1) = ia_p(1) + 1

      ia_p(2) = 0
      do
        ia_p(2) = ia_p(2) + 1

        if( n == 2 ) then
          call Layer_min_dist(Center_abs_s,dist_min,i_layer,ia_p,igr_layer,igr_val,index_layer,indice_val,n, &
                              n_layer_abs,n_proto_layer_max,n_proto_max,neqm,P_val)
          if( ia_p(2) == na(2) ) exit
          cycle
        endif

        ia_p(3) = 0
        do
          ia_p(3) = ia_p(3) + 1

          if( n == 3 ) then
            call Layer_min_dist(Center_abs_s,dist_min,i_layer,ia_p,igr_layer,igr_val,index_layer,indice_val,n, &
                                n_layer_abs,n_proto_layer_max,n_proto_max,neqm,P_val)
            if( ia_p(3) == na(3) ) exit
            cycle
          endif

          ia_p(4) = 0
          do
            ia_p(4) = ia_p(4) + 1

            if( n == 4 ) then
              call Layer_min_dist(Center_abs_s,dist_min,i_layer,ia_p,igr_layer,igr_val,index_layer,indice_val,n, &
                                  n_layer_abs,n_proto_layer_max,n_proto_max,neqm,P_val)
              if( ia_p(4) == na(4) ) exit
              cycle
            endif

            ia_p(5) = 0
            do
              ia_p(5) = ia_p(5) + 1

              if( n == 5 ) then
                call Layer_min_dist(Center_abs_s,dist_min,i_layer,ia_p,igr_layer,igr_val,index_layer,indice_val,n, &
                                    n_layer_abs,n_proto_layer_max,n_proto_max,neqm,P_val)
                if( ia_p(5) == na(5) ) exit
                cycle
              endif

              ia_p(6) = 0
              do
                ia_p(6) = ia_p(6) + 1

                if( n == 6 ) then
                  call Layer_min_dist(Center_abs_s,dist_min,i_layer,ia_p,igr_layer,igr_val,index_layer,indice_val,n, &
                                      n_layer_abs,n_proto_layer_max,n_proto_max,neqm,P_val)
                  if( ia_p(6) == na(6) ) exit
                  cycle
                endif

                ia_p(7) = 0
                do
                  ia_p(7) = ia_p(7) + 1

                  if( n == 7 ) then
                    call Layer_min_dist(Center_abs_s,dist_min,i_layer,ia_p,igr_layer,igr_val,index_layer,indice_val,n, &
                                        n_layer_abs,n_proto_layer_max,n_proto_max,neqm,P_val)
                    if( ia_p(7) == na(7) ) exit
                    cycle
                  endif

                  ia_p(8) = 0
                  do
                    ia_p(8) = ia_p(8) + 1

                    if( n == 8 ) then
                      call Layer_min_dist(Center_abs_s,dist_min,i_layer,ia_p,igr_layer,igr_val,index_layer,indice_val,n, &
                                          n_layer_abs,n_proto_layer_max,n_proto_max,neqm,P_val)
                      if( ia_p(8) == na(8) ) exit
                      cycle
                    endif

                    if( ia_p(8) == na(8) ) exit
                  end do
                  if( ia_p(7) == na(7) ) exit
                end do
                if( ia_p(6) == na(6) ) exit
              end do
              if( ia_p(5) == na(5) ) exit
            end do
            if( ia_p(4) == na(4) ) exit
          end do
          if( ia_p(3) == na(3) ) exit
        end do
        if( ia_p(2) == na(2) ) exit
      end do
      if( ia_p(1) == na(1) ) exit
    end do

  end do ! end of loop over layers

  if( Struct /= 'cubic' ) call invermat(Cubmat,Cubmat_i)

  do i_layer = 1,n_layer_abs
    if( n_proto_layer(i_layer) == 1 ) cycle
    v(:) = Center_abs_s(:,i_layer) / axyz(:)
    if( Struct /= 'cubic' ) v = matmul( Cubmat_i, v )
    Center_abs_s(:,i_layer) = v(:)
  end do

  if( icheck > 0 ) then
    write(3,'(/A)') ' Layer              Centre_abs_s           index of the prototypical atoms (ipr, igr, shift_x, shift_y)'
    do i_layer = 1,n_layer_abs
      write(3,'(i5,2x,3f12.8,3x,20(3x,4i3))') i_layer, Center_abs_s(:,i_layer), ( ipr_layer(ipr,i_layer), igr_layer(ipr,i_layer), &
                                                                   index_layer(1:2,ipr,i_layer), ipr = 1,n_proto_layer(i_layer) )
    end do
  endif

! Modification of the representative of the equivalent atoms
  First = .true.
  do i_layer = 1,n_layer_abs
    do index = 1,n_proto_layer(i_layer)
      ipr = ipr_layer(index,i_layer)
      if( igr_layer(index,i_layer) /= igreq(ipr,1) ) then
! Substitution in the list of equivalent atoms
        do i_eq = 2,ngreq(ipr)
          if( igreq(ipr,i_eq) == igr_layer(index,i_layer) ) exit
        end do
        igreq(ipr,i_eq) = igreq(ipr,1)
        igreq(ipr,1) = igr_layer(index,i_layer)

        isym = isymqa(ipr,i_eq)
        isymqa(ipr,i_eq) = isymqa(ipr,1)
        isymqa(ipr,1) = isym

! For the magnetic case the refecence (first atom) changing, the others atom must be time reversed
! The remaining atom symmetry modification is done in coabs subroutine
        i_magnet = ( isymqa(ipr,i_eq) / abs( isymqa(ipr,i_eq) ) ) * ( isymqa(ipr,1) / abs( isymqa(ipr,1) ) )
        if( i_magnet == - 1 ) then
          do j_eq = 2,ngreq(ipr)
            if( j_eq == i_eq ) cycle
            isymqa(ipr,j_eq) = - isymqa(ipr,j_eq)
          end do
        endif

        if( icheck > 0 ) then
          Sym_name_1 = ' '
          Sym_name_1(3:11) = nomsym( abs( isymqa(ipr,1) ) )
          if( isymqa(ipr,1) < 0 ) then
            Long = len_trim( adjustl( nomsym(abs( isymqa(ipr,1) )) ) )
            Sym_name_1(10-Long:11-Long) = 'T.'
          endif
          call center_word(Sym_name_1,11)

          Sym_name_2 = ' '
          Sym_name_2(3:11) = nomsym( abs( isymqa(ipr,i_eq) ) )
          if( isymqa(ipr,i_eq) < 0 ) then
            Long = len_trim( adjustl( nomsym(abs( isymqa(ipr,i_eq) )) ) )
            Sym_name_2(10-Long:11-Long) = 'T.'
          endif
          call center_word(Sym_name_2,11)

          if( First ) write(3,*)
          write(3,110) i_layer, igreq(ipr,1), igreq(ipr,i_eq), Sym_name_1, Sym_name_2
          First = .false.
        endif
      endif
    end do
  end do

  multi_run = 0
  do i_layer = 1,n_layer_abs
    do index = 1,n_proto_layer(i_layer)
      multi_run = multi_run + 1
      iabsm(multi_run) = igr_layer(index,i_layer)
      ipr = ipr_layer(index,i_layer)
      iabsorig(multi_run) = ipr
    end do
  end do

  return
  110 format(' Layer',i2,' atoms',i3,' and',i3,' with symmetry',a11,' and',a11,' have been inverted')
end

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

subroutine Layer_min_dist(Center_abs_s,dist_min,i_layer,ia_p,igr_layer,igr_val,index_layer,indice_val,n, &
                          n_layer_abs,n_proto_layer_max,n_proto_max,neqm,P_val)

  use declarations
  implicit none

  integer:: i_layer, index, n, n_layer_abs, n_proto_layer_max, n_proto_max, neqm

  integer, dimension(n_proto_max):: ia_p
  integer, dimension(n_proto_layer_max,n_layer_abs):: igr_layer
  integer, dimension(3,n_proto_layer_max,n_layer_abs):: index_layer
  integer, dimension(9*neqm,n_proto_layer_max):: igr_val
  integer, dimension(3,9*neqm,n_proto_layer_max):: indice_val

  real(kind=db):: dist, dist_max, dist_min
  real(kind=db), dimension(3):: Centre
  real(kind=db), dimension(3):: Center_abs_s(3,n_layer_abs)
  real(kind=db), dimension(3,9*neqm,n_proto_layer_max):: P_val

  Centre(:) = 0._db
  do index = 1, n
    Centre(:) = Centre(:) + P_val(:,ia_p(index),index)
  end do
  Centre(:) = Centre(:) / n

  dist_max = 0._db
  do index = 1, n
    dist = sum( ( Centre(:) - P_val(:,ia_p(index),index) )**2 )
    dist_max = max( dist_max, dist )
  end do

  if( dist_max < dist_min - eps10 ) then
    dist_min = dist_max
    Center_abs_s(:,i_layer) = Centre(:)
    do index = 1,n
      igr_layer(index,i_layer) = igr_val(ia_p(index),index)
      index_layer(:,index,i_layer) = indice_val(:,ia_p(index),index)
    end do
  endif

  return
end

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

! Give the dimmension of the initial (core) states
! ninit : total number of inital states
! ninit1 : number of initial state of the first edge (in double edges such as L23, M45...)

subroutine dim_init(Jseuil,Lseuil,nbseuil,ninit1,ninit)

  use declarations
  implicit none

  integer,intent(in):: Jseuil, Lseuil, nbseuil
  integer,intent(out):: ninit, ninit1

  if( nbseuil == 1 ) then

    select case( Jseuil )
      case( 1 )           ! edges K, L1, M1 ...
        ninit1 = 2
      case( 2 )           ! edges L2, M2
        ninit1 = 2
      case( 3 )           ! edges L3, M3
        ninit1 = 4
      case( 4 )           !       M4, N4
        ninit1 = 4
      case( 5 )           !       M5
        ninit1 = 6
      case( 6 )           !       N6
        ninit1 = 6
      case( 7 )           !       N7
        ninit1 = 8
    end select
    ninit = ninit1

  else

    select case( Lseuil )
      case( 0 )           ! K or L1
        ninit1 = 2
        ninit = 2
      case( 1 )           ! L23, M23
        ninit1 = 2
        ninit = 6
      case( 2 )           ! M45
        ninit1 = 4
        ninit = 10
      case( 3 )           ! N67
        ninit1 = 6
        ninit = 14
    end select

  end if

  return
end

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

! Calculation of m and of coefficients multiplying the Ylm for any state |j,mj>

subroutine coef_init(coef_g,is_g,ninit,Jseuil,Lseuil,m_g,nbseuil)

  use declarations
  implicit none

  integer,intent(in):: ninit, Jseuil, Lseuil, nbseuil
  integer,dimension(ninit),intent(out):: is_g
  integer,dimension(ninit,2),intent(out):: m_g

  integer i, init, is_init, iseuil, is, isp, li, mi, ni

  real(kind=db) Ci2, J_init, Jz, spin
  real(kind=db), dimension(ninit,2), intent(out):: coef_g

! there is a redondancy bewtween the locale ninit and the external ninit
  m_g(:,:) = 1000
  coef_g(:,:) = 0._db

  init = 0

  select case(Jseuil)
    case(1,3,5,7)
      is_init = 1
    case default
      is_init = -1
  end select

  do iseuil = 1, nbseuil

    if( iseuil == 2 ) is_init = - is_init
    li = Lseuil
    J_init = li + 0.5_db * is_init
    ni = nint( 2*J_init  + 1 )

! Loop of core states |j,mj>, with multiplicity 2*j+1

    do i = 1,ni

      init = init + 1
      Jz = - J_init + i - 1
      is_g(init) = is_init

      do isp = 1,2

        if( isp == 1 ) then
          spin = 0.5_db
          is = is_init
        else
          spin = -0.5_db
          is = 1
        endif

        mi = nint( Jz - spin )
        if( abs(mi) > li ) cycle

        Ci2 = ( li + 0.5_db + 2*spin*is_init*Jz ) / ( 2*li + 1 )
        if( Ci2 < eps6 ) cycle

        coef_g(init,isp) = is * sqrt( Ci2 )
        m_g(init,isp) = mi

      end do

    end do

  end do

  return
end

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

! Elaboration of the energy grid for the xanes calculation step

subroutine grille_xanes(eeient,eimag,eimagent,Egamme,energ,icheck,lin_gam,ngamme,neimagent,nenerg)

  use declarations
  implicit none

  integer:: icheck, i, ie, igc, lin_gam, ngamme, neimagent, nenerg, ngc

  real(kind=db):: de, def, p1, r
  real(kind=db), dimension(neimagent) :: eeient, eimagent
  real(kind=db), dimension(nenerg) :: energ, eimag
  real(kind=db), dimension(ngamme) :: Egamme

! Energy grid elaboration
  energ(1) = Egamme(1)

  if( lin_gam == 1 ) then            ! 'rangel'
    def = 10._db / rydb
    do ie = 2,nenerg
      r = 1 + energ(ie-1) / def
      r = max( r, 0.25_db )
      de = sqrt( r ) * Egamme(2)
      energ(ie) = energ(ie-1) + de
    end do
  else
    ngc = 2
    do ie = 2,nenerg
      energ(ie) = energ(ie-1) + Egamme(ngc)
      do igc = ngc, ngamme - 1, 2
        if( energ(ie) >= Egamme(igc+1) - eps10 ) then
          ngc = ngc + 2
          energ(ie) = min( Egamme(ngc-1), energ(ie) )
        else
          exit
        endif
      end do
    end do
    Energ(nenerg) = min( Energ(nenerg), Egamme(ngamme) )
  endif

  eimag(1:nenerg) = 0._db
  if( neimagent > 0 ) then
    do ie = 1,nenerg
      if( energ(ie) >= eeient(neimagent) ) then
        eimag(ie) = eimagent(neimagent)
      elseif( energ(ie) <= eeient(1) ) then
        eimag(ie) = eimagent(1)
      else
        do i = 2,neimagent
          if( eeient(i) >= energ(ie) ) exit
        end do
        p1 = ( energ(ie) - eeient(i-1) ) / ( eeient(i) - eeient(i-1) )
        eimag(ie) = p1 * eimagent(i) + (1 - p1) * eimagent(i-1)
      endif
    end do
  endif

  if( icheck > 1 .and. neimagent > 0 ) then
    write(3,110)
    write(3,120)
    do ie = 1,nenerg
      write(3,130) energ(ie)*rydb, eimag(ie)*rydb
    end do
  endif

  return
  110 format(/' ---- Grille_xanes -',100('-'))
  120 format(/'   energie    eimag      en eV')
  130 format(4f9.3)
end

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

subroutine init_run(Bulk_step,cdil,Chargat,Charge_free,Chargm,Chargm_SCF,Clementi,Com,Counter_ato,Counter_ion,Doping,Ecrantage, &
      Flapw,Force_ecr,Hubb,iabsorbeur,iabsorig,icheck,icom,igreq,iprabs,iprabs_nonexc, &
      itabs,itdil,itype,itype_dop,itypepr,Jseuil,Lcoeur,Ldil,Lecrantage,Lseuil,Lvval,mpinodes0,mpirank0, &
      n_atom_bulk,n_atom_proto,n_counter_ato,n_counter_ion,n_multi_run,n_orbexc,nb_Emis,nbseuil,ncoeur, &
      necrantage,neqm,ngreq,ngroup,nlat,nlatm,nnlm,nomfich_s,Nonexc,norbdil,nrato,nrato_dirac,nrato_lapw,nrm,nseuil,nspin,ntype, &
      Numat,numat_abs,nvval,P_Emis,Pop_open_val,popatm,Popats,popatv,popval,Psi_Emis,Psi_coeur,Psii,psi_open_val,Psival,r0_lapw, &
      Rato,Ray_max_dirac,Rchimp,Relativiste,rho_coeur,rhoit,Rionic_imp,rlapw,Rmt,Rmtimp,Self_nonexc,V_hubbard,nompsii)

  use declarations
  implicit none
  include 'mpif.h'

  integer:: i, iabsorig, iabsorbeur, icheck, igr, ipr, iprabs, iprabs_nonexc, it, itabs, itype_dop, Jseuil, L, Lecrantage, Lseuil, &
      mpinodes0, mpirank0, n_atom_bulk, n_atom_proto, n_counter_ato, n_counter_ion, n_multi_run, n_orbexc, nb_Emis, nbseuil, &
      necrantage, neqm, ngroup, nlatm, nnlm, norbdil, nrato_dirac, nr, nrm, nseuil, nspin, ntype, numat_abs

  character(len=Length_name):: nomfich_s, nompsii
  character(len=35), dimension(0:ntype):: com

  integer, dimension(4):: P_emis
  integer, dimension(norbdil):: itdil, Ldil
  integer, dimension(ngroup):: itype
  integer, dimension(nnlm):: Lqnexc, nqnexc
  integer, dimension(0:n_atom_proto):: itypepr, ngreq
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(0:ntype):: icom, nlat, nrato, nrato_lapw, Numat
  integer, dimension(2,0:ntype):: Lcoeur, ncoeur
  integer, dimension(0:ntype,nlatm):: Lvval, nvval

  logical:: Bulk_step, Charge_free, Clementi, Doping, Flapw, Force_ecr, Nonexc, Relativiste, Self_nonexc
  logical, dimension(0:ntype):: hubb

  real(kind=db):: Chargm, Chargm_SCF, Ray_max_dirac
  real(kind=db), dimension(norbdil):: cdil
  real(kind=db), dimension(0:n_atom_proto):: chargat
  real(kind=db), dimension(ngroup):: chargatg
  real(kind=db), dimension(0:ntype):: popatc, r0_lapw, rchimp, Rionic_imp, rlapw, rmt, rmtimp, V_hubbard
  real(kind=db), dimension(nspin):: ecrantage
  real(kind=db), dimension(nnlm,nspin):: popexc
  real(kind=db), dimension(0:n_atom_proto,nlatm,nspin):: popatm
  real(kind=db), dimension(0:ntype,nlatm):: popatv
  real(kind=db), dimension(ngroup,nlatm,nspin):: popats
  real(kind=db), dimension(0:ntype,nlatm,nspin):: popval
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion
  real(kind=db), dimension(nrm,nb_Emis):: Psi_Emis
  real(kind=db), dimension(nrm,nbseuil):: psii
  real(kind=db), dimension(0:nrm):: r
  real(kind=db), dimension(0:nrm,0:ntype):: rato, rhoit, rho_coeur
  real(kind=db), dimension(0:nrm,nlatm,0:ntype):: psival
  real(kind=db), dimension(nrm,2):: psi_open_val
  real(kind=db), dimension(2):: pop_open_val
  real(kind=db), dimension(0:nrm,2,0:ntype):: psi_coeur

  if( n_multi_run > 1 .and. mpirank0 == 0 ) then
    L = len_trim(nomfich_s)
    nomfich_s(L+1:L+1) = '_'
    call ad_number(iabsorig,nomfich_s,Length_name)
    L = len_trim(nomfich_s)
    write(6,'(/3x,A)') nomfich_s(1:L)
  endif

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

  boucle_1: do iprabs_nonexc = 1,n_atom_proto
    do i = 1,ngreq(iprabs_nonexc)
      if( abs(igreq(iprabs_nonexc,i)) == iabsorbeur ) exit boucle_1
    end do
  end do boucle_1
  if( Nonexc ) then
    iprabs = iprabs_nonexc
  else
    iprabs = 0
  endif

! Atomic electron density
  call atom(Clementi,com,icheck,icom,itype,Jseuil,Lcoeur,Lseuil,Lvval,mpirank0,nbseuil,ncoeur,ngroup,nlat, &
        nlatm,nnlm,Nonexc,nrato,nrato_dirac,nrato_lapw,nrm,nseuil,nspin,ntype,Numat,nvval,popatc,popats, &
        popatv,popexc,popval,psi_coeur,psii,psival,r0_lapw,rato,Ray_max_dirac,Relativiste,rho_coeur,rhoit,rlapw)

  call pop_group(Bulk_step,Chargatg,Charge_free,Chargm,Counter_ato,Counter_ion,Flapw,icheck,itype,mpirank0,n_atom_bulk, &
                 n_counter_ato,n_counter_ion,ngroup,nlat,nlatm,nspin,ntype,Numat,popatc,popats)

  do ipr = 1,n_atom_proto
    igr = igreq(ipr,1)
    Chargat(ipr) = Chargatg(igr)
    do L = 1,nlat(abs(itype(igr)))
      popatm(ipr,L,1:nspin) = popats(igr,L,1:nspin)
    end do
  end do

! Absorbing atom electron density
  call Type_work(Com,Doping,Ecrantage,force_ecr,hubb,iabsorbeur,icheck,icom,itabs,itype,itype_dop,Jseuil,Lcoeur,Lecrantage, &
        Lqnexc,Lseuil,Lvval,mpinodes0,mpirank0,n_orbexc,nb_Emis,nbseuil,ncoeur,necrantage,ngroup,nlat,nlatm,nnlm,nompsii,Nonexc, &
        nqnexc,nrato,nrato_dirac,nrm,nseuil,nspin,ntype,Numat,nvval,P_emis,pop_open_val,popatc,popats,popatv,popexc,popval, &
        Psi_coeur,Psi_emis,psii,psi_open_val,psival,Rato,Ray_max_dirac,rchimp,Relativiste,rho_coeur,rhoit,Rionic_imp,rmt,rmtimp, &
        V_hubbard)

  if( norbdil /= 0 ) then
    do it = min(itabs,1),ntype
      nr = nrato(it)
      r(:) = rato(:,it)
      call dilatorb(cdil,icheck,it,itdil,Ldil,nlatm,norbdil,nr,nrm,ntype,popatv,psival,r,rhoit)
    end do
  endif

  call Pop_mod(Chargat,Chargm,Chargm_SCF,Doping,Flapw,iabsorbeur,icheck,igreq,itabs,iprabs_nonexc,itype,itype_dop,itypepr,Lqnexc, &
        Lvval,n_atom_proto,n_orbexc,neqm,ngreq,ngroup,nlat,nlatm,nnlm,Nonexc,nqnexc,nspin,ntype,numat_abs,nvval,popatm,popexc, &
        Self_nonexc)

  return
  110 format(/' ---- Init_run ------',100('-'))
end

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

subroutine atom(Clementi,Com,icheck,icom,itype,Jseuil,Lcoeur,Lseuil,Lvval,mpirank0,nbseuil,ncoeur,ngroup,nlat, &
        nlatm,nnlm,Nonexc,nrato,nrato_dirac,nrato_lapw,nrm,nseuil,nspin,ntype,Numat,nvval,popatc,popats, &
        popatv,popexc,popval,psi_coeur,psii,psival,r0_lapw,rato,Ray_max_dirac,Relativiste,rho_coeur,rhoit,rlapw)

  use declarations
  implicit none
  include 'mpif.h'

  integer:: icheck, igr, ipr, it, j, Jseuil, k, L, Lseuil, mpirank0, n, n_orbexc, nb_Emis, &
    nbseuil, ngroup, nlatm, nnlm, nr, nrato_dirac, nrm, nseuil, nspin, ntype

  real(kind=db):: dr, drmax, dx, Ray_max_dirac, Rmax

  character(len=35), dimension(0:ntype) :: com

  integer, dimension(4):: P_Emis
  integer, dimension(nnlm):: Lqnexc, nqnexc
  integer, dimension(ngroup):: itype
  integer, dimension(0:ntype):: icom, nlat, nrato, nrato_lapw, Numat
  integer, dimension(2,0:ntype):: Lcoeur, ncoeur
  integer, dimension(0:ntype,nlatm):: Lvval, nvval

  logical:: Clementi, Nonexc, Relativiste

  real(kind=db), dimension(0:ntype):: popatc, r0_lapw, rlapw
  real(kind=db), dimension(nrm):: ra
  real(kind=db), dimension(nrm,nbseuil):: psii
  real(kind=db), dimension(ngroup,nlatm,nspin):: popats
  real(kind=db), dimension(nnlm,nspin):: popexc
  real(kind=db), dimension(0:ntype,nlatm) :: popatv
  real(kind=db), dimension(0:ntype,nlatm,nspin):: popval
  real(kind=db), dimension(0:nrm,0:ntype):: rato, rhoit, rho_coeur
  real(kind=db), dimension(0:nrm,nlatm,0:ntype):: psival
  real(kind=db), dimension(nrm,2):: psi_open_val
  real(kind=db), dimension(2):: pop_open_val
  real(kind=db), dimension(0:nrm,2,0:ntype):: psi_coeur

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

  if( clementi ) then
    do it = 1,ntype
      if( icom(it) == 1 .and. Numat(it) < 55 ) then
        com(it) = ' Clementi and Roetti'
        icom(it) = 2
      endif
    end do
  endif

  do it = 1,ntype
    if( Numat(it) == 0 ) cycle
    select case( icom(it) )

      case(1)

! Value for the excited atom not yet used
        Lqnexc(:) = 0
        nqnexc(:) = 0
        nb_Emis = 0
        P_Emis(:) = 0
        allocate( Psi_Emis(nrm,nb_Emis) )

        call dirgen(icheck,it,0,Jseuil,Lcoeur,Lqnexc,Lseuil,Lvval,mpirank0,n_orbexc,nb_Emis,nbseuil,ncoeur,nlat,nlatm, &
          nnlm,nonexc,nqnexc,nr,nrato_dirac,nrm,nseuil,nspin,ntype,nvval,P_Emis,pop_open_val,popatc,popatv, &
          popexc,popval,psi_coeur,Psi_emis,psii,psi_open_val,psival,ra,Ray_max_dirac,rho_coeur,rhoit,Numat(it),Relativiste)

        deallocate( Psi_Emis )

        nrato(it) = nr
        rato(1:nr,it) = ra(1:nr)
        rato(0,it) = 0._db

        do igr = 1,ngroup
          if( abs( itype(igr) ) /= it ) cycle
          do L = 1,nlat(it)
            popats(igr,L,1:nspin) = popval(it,L,1:nspin)
          end do
        end do

      case(2)

        call clem(icheck,it,0,Lseuil,Lvval,mpirank0,nbseuil,nlat,nlatm,nonexc,nr,nrm,nseuil,ntype,nvval,popatc, &
               popatv,psii,psival,ra,rhoit,Numat(it))
        nrato(it) = nr
        rato(1:nr,it) = ra(1:nr)
        rato(0,it) = 0._db

      case(3)

        nrato(it) = nrato_lapw(it)
        if( nrato(it) > nrm .and. mpirank0 == 0 ) then
          call write_error
          do ipr = 3,9,3
            if( ipr == 3 .and. icheck == 0 ) cycle
            write(ipr,110) nrato(it), nrm
          end do
          stop
        endif
        dx = log( rlapw(it) / r0_lapw(it) ) / ( nrato_lapw(it) - 1 )
        do j = 1,nrato_lapw(it)
          rato(j,it) = r0_lapw(it) * exp( ( j - 1 ) * dx )
        enddo
        rato(0,it) = 0._db
! extrapolation
        rmax = 2.5_db / bohr
        drmax = 0.1_db / bohr

        boucle_r: do j = nrato_lapw(it)+1,nrm
          rato(j,it) = r0_lapw(it) * exp( ( j - 1 ) * dx )
          if( rato(j,it) > rmax ) then
            nrato(it) = j
            exit boucle_r
          endif
          dr = rato(j,it) - rato(j-1,it)
          if( dr > drmax ) then
            do k = j,nrm
              rato(k,it) = rato(k-1,it) + drmax
              if( rato(k,it) > rmax ) then
                nrato(it) = k
                exit boucle_r
              endif
            end do
          endif
        end do boucle_r

        if( rato(nrato(it),it) < 2.5_db/bohr ) then
          n = 1 + Int( ( rmax - rato(nrato(it),it) ) / drmax )
          call write_error
          do ipr = 3,9,3
            if( ipr == 3 .and. icheck == 0 ) cycle
            write(ipr,120) nrm + n, nrm
          end do
          stop
        endif

    end select

  end do     ! end of loop over chemical species

  return
  110 format(/' nrato =',i6,' > nrm =',i6,' !', /' Increase the value of nrm using keyword nrato')
  120 format(/' The number of radius needs to be increased',/ ' nrato =',i6,' > nrm =',i6,' after extrapolation !', &
         /' Increase the value of nrm using keyword nrato')
end

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

! Atom calculation following Clementi and Roetti

!  References :
!   HS  F. Herman and S. Skillman "Atomic Structure Calculations"
!       Prentice Hall 1963
!   CR  E. Clementi and C. Roetti "Atomic Data and Nuclear Data Tables"
!       Vol.14,(3-4) [1974] p.177-478

!   NPRIN Principal quantum number
!   NAZIM Azimuthal quantum number
!   NCONF Number of electrons occupying this orbital
!   NTERM Number of radial basis functions
!   NEXP  Ni for the basis functions (See Clementi Roetti book)
!   ESP   Exponential constant for the basis function
!   CON   Coefficient which multiplies the basis function
!
subroutine clem(icheck,it,itabs,Lseuil,Lvval,mpirank0,nbseuil,nlat,nlatm,Nonexc,nrato,nrm,nseuil,ntype,nvval,popatc, &
              popatv,psii,psival,rato,rhoit,Z)

  use declarations
  implicit none

  integer, parameter:: norbm = 11
  integer, parameter:: ntrm = 11

  integer:: i, icalc, icheck, io, io0, ipr, ir, it, itabs, iv, j, Lseuil, mpirank0, nbseuil, ncalc, nlatm, norb, norb0, nr, &
    nrato, nrm, nseuil, ntype, Z, Zp

  integer, dimension(norbm):: nazim, nazim0, nconf, nconf0, nprin, nprin0, nterm, nterm0
  integer, dimension(norbm,ntrm) :: nexp, nexp0
  integer, dimension(0:ntype):: nlat
  integer, dimension(0:ntype,nlatm):: Lvval, nvval

  logical:: Nonexc

  real(kind=db):: alfa, arg, ch, delta, f, phi, r0, rmax, ra

  real(kind=db), dimension(6):: nfact
  real(kind=db), dimension(nrm):: rato
  real(kind=db), dimension(nrm,nbseuil):: psii
  real(kind=db), dimension(norbm,ntrm):: esp, esp0, con, con0, onor
  real(kind=db), dimension(0:ntype):: popatc
  real(kind=db), dimension(0:ntype,nlatm):: popatv
  real(kind=db), dimension(0:nrm,0:ntype):: rhoit
  real(kind=db), dimension(0:nrm,nlatm,0:ntype):: psival

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

! Radius
  r0 = 0.00005_db / bohr
  rmax = 10._db / bohr
  delta = 1.02_db
  rato(1) = r0
  ra = r0
  f = log( delta )
  do ir = 2,1000000
   ra = ra + r0 * exp( ( ir - 1) * f )
   if( ir > nrm ) cycle
   rato(ir) = ra
   if( rato(ir) > rmax ) exit
  end do
  nrato = ir
  nr = nrato
  if( nr > nrm .and. mpirank0 == 0 ) then
    call write_error
    do ipr = 3,9,3
      if( ipr == 3 .and. icheck == 0 ) cycle
      write(ipr,105) nr, nrm
    end do
    stop
  endif

! Factorials
  Nfact(1) = sqrt_2
  do i = 2,6
    Nfact(i) = Nfact(i-1) * sqrt( 2._db * i * ( 2 * i - 1 ) )
  end do

! For the absorbing atom one calculates both excited and not excited atoms
  if( it == itabs .and. .not. nonexc ) then
    ncalc = 2
  else
    ncalc = 1
  endif

  do icalc = 1,ncalc

    Zp = Z + icalc - 1 ! Approximation Z + 1

    if( Zp < 30 ) then
      call clempar1(Zp,norb,nprin,nazim,nconf,nterm,nexp,esp,con)
    elseif( Z < 50 ) then
      call clempar2(Zp,norb,nprin,nazim,nconf,nterm,nexp,esp,con)
    else
      call clempar3(Zp,norb,nprin,nazim,nconf,nterm,nexp,esp,con)
    endif

    if( it == itabs .and. icalc == 1 ) then
      if( nseuil == 0 ) then
        psii(:,:) = 0._db
      else
        ch = 0._db
        do io = 1,norb
          if( nprin(io) == nseuil .and. nazim(io) == Lseuil ) exit
        end do
        do i = 1,Nterm(io)
          alfa =  ( 2 * esp(io,i) )**( nexp(io,i) + 0.5_db )
          onor(io,i) =  alfa / Nfact(nexp(io,i))
        end do
        do ir = 1,nr
          phi = 0._db
          do j = 1,nterm(io)
            arg = esp(io,j) * rato(ir)
            if( arg > 100._db ) cycle
            phi = phi + onor(io,j) * con(io,j) * rato(ir)**nexp(io,j) * exp( - arg )
          end do
          psii(ir,1) = phi
          psii(ir,nbseuil) = phi
          ch = ch + phi**2 * ( rato(ir+1) - rato(ir) )
        end do
        if( icheck > 1 ) write(3,120) io, nprin(io), nazim(io), nconf(io), ch
      endif
    endif

    if( it == itabs .and. .not. nonexc ) then
      if( icalc == 1 ) then
        norb0 = norb
        nprin0(1:norb) = nprin(1:norb)
        nazim0(1:norb) = nazim(1:norb)
        nconf0(1:norb) = nconf(1:norb)
        nterm0(1:norb) = nterm(1:norb)
        nexp0(1:norb,:) = nexp(1:norb,:)
        esp0(1:norb,:) = esp(1:norb,:)
        con0(1:norb,:) = con(1:norb,:)
      else
        do io = 1,norb
          if( nprin(io) == nseuil .and. nazim(io) == Lseuil ) nconf(io) = nconf(io) - 1
          if( nprin(io) > nseuil .or. ( nprin(io) == nseuil .and. nazim(io) >= Lseuil ) ) cycle
          do io0 = 1,norb0
            if( nprin0(io0) /= nprin(io) .or. nazim0(io0) /= nazim(io) ) cycle
            nconf(io) = nconf0(io0)
            nterm(io) = nterm0(io0)
            nexp(io,:) = nexp0(io0,:)
            esp(io,:) = esp0(io0,:)
            con(io,:) = con0(io0,:)
            exit
          end do
        end do
      endif
    endif

  end do

  do io = 1,nlat(it)
    do i = 1,norb
      if( nprin(i) == nvval(it,io) .and. nazim(i) == Lvval(it,io)) exit
    end do
    if( i == norb+1 .and. mpirank0 == 0 ) then
      call write_error
      do ipr = 3,9,3
        if( ipr == 3 .and. icheck == 0 ) cycle
        write(ipr,110) it, nvval(it,io), Lvval(it,io)
      end do
      stop
    endif
    popatv(it,io) = 1._db * nconf(i)
  end do

  popatc(it) = 1._db * sum( nconf(1:norb) )
  do io = 1,nlat(it)
    popatc(it) = popatc(it) - popatv(it,io)
  end do

!  Calculate normalization coefficients
!  (see CR p.180, equation (6))

  do io = 1,norb
    do i = 1,Nterm(io)
      alfa =  ( 2 * esp(io,i) )**( nexp(io,i) + 0.5_db )
      onor(io,i) =  alfa / Nfact(nexp(io,i))
    end do
  end do

  rhoit(:,it) = 0._db
  do io = 1,norb
    do iv = 1,nlat(it)
      if( nprin(io) == nvval(it,iv) .and. nazim(io) == Lvval(it,iv) ) exit
    end do
    if( iv == nlat(it)+1 ) iv = 0
    ch = 0._db
    do ir = 1,nr
      phi = 0._db
      do j = 1,nterm(io)
        arg = esp(io,j) * rato(ir)
        if( arg > 100._db ) cycle
        phi = phi + onor(io,j) * con(io,j) * rato(ir)**nexp(io,j) * exp( - arg )
      end do
      if( iv > 0 ) psival(ir,iv,it) = phi
      rhoit(ir,it) = rhoit(ir,it) + nconf(io) * ( phi / rato(ir) )**2
      ch = ch + phi**2 * ( rato(ir+1) - rato(ir) )
    end do
    if( icheck > 1 ) write(3,120) io, nprin(io), nazim(io), nconf(io), ch
  end do
  rhoit(1:nr,it) = rhoit(1:nr,it) / quatre_pi

  return
  100 format(/' it =',i2,'  Z =',i4)
  105 format(/' Number of radius =',i6,' > nrm =',i6,// ' Increase nrm using keyword nrato !'/)
  110 format(///' Orbital not found in the Clementi and Roetti bases :',/'   it =',i2,',  n =',i2,'  L =',i2)
  120 format(' io, nprin, nazim, nconf =',4i3,' ch =',f10.7)
end

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

! Charge and occupancy of the atoms in the unit cell or cluster

subroutine pop_group(Bulk_step,chargatg,Charge_free,Chargm,Counter_ato,Counter_ion,Flapw,icheck,itype,mpirank0,n_atom_bulk, &
                     n_counter_ato,n_counter_ion,ngroup,nlat,nlatm,nspin,ntype,Numat,popatc,popats)

  use declarations
  implicit none

  integer:: icheck, igr, ipr, it, L, mpirank0, n_atom_bulk, n_counter_ato, n_counter_ion, ngroup, nlatm, nspin, ntype

  integer, dimension(0:ntype) :: nlat, Numat
  integer, dimension(ngroup):: itype

  logical:: Bulk_step, Charge_free, Flapw

  real(kind=db):: Chargm
  real(kind=db), dimension(ngroup):: chargatg
  real(kind=db), dimension(0:ntype):: popatc
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion
  real(kind=db), dimension(ngroup,nlatm,nspin):: popats

  if( Flapw ) then
    chargatg(:) = 0
    return
  endif

  do igr = 1,ngroup
    it = abs( itype(igr) )
    if( nlat(it) > 0 ) then
      chargatg(igr) = Numat(it) - popatc(it) - sum( popats(igr,1:nlat(it),1:nspin) )
    else
      chargatg(igr) = Numat(it) - popatc(it)
    endif
  end do

  if( icheck > 1 ) then
    write(3,110)
    if( nspin == 1 ) then
      write(3,120)
    else
      write(3,130)
    endif
    if( Bulk_step ) then
      do igr = ngroup - n_atom_bulk + 1, ngroup
        it = abs( itype(igr) )
        write(3,140) igr, chargatg(igr), ( popats(igr,L,1:nspin), L = 1,nlat(it) )
      end do
    else
      do igr = 1,ngroup - n_atom_bulk
        it = abs( itype(igr) )
        write(3,140) igr, chargatg(igr), ( popats(igr,L,1:nspin), L = 1,nlat(it) )
      end do
    endif
  endif

! Test on neutrality of the unit cell or the cluster
  if( Bulk_step ) then
    Chargm = sum( chargatg(ngroup-n_atom_bulk+1:ngroup ) )
  else
    Chargm = sum( chargatg(1:ngroup-n_atom_bulk) )
    if( n_counter_ion > 0 ) Chargm = Chargm + sum( Counter_ion(4,:) )
    if( n_counter_ato > 0 ) Chargm = Chargm + sum( Counter_ato(7,:) * Counter_ato(8,:) )
  endif
  if( abs(Chargm) > 0.0001_db .and. mpirank0 == 0 ) then
    if( Charge_free ) then
      if( icheck > 0 ) write(3,150) Chargm
      write(6,150) Chargm
    else
      call write_error
      do ipr = 3,9,3
        if( ipr == 3 .and. icheck == 0 ) cycle
        write(ipr,150) Chargm
        write(ipr,160)
      end do
      stop
    endif
  endif

  return
  110 format(/' ---- Pop_group ----',100('-'))
  120 format(/'  igr    charge   popats(1)  popats(2)')
  130 format(/'  igr    charge   popats(1,up)  popats(1,dn) ...')
  140 format(i4,11f11.5)
  150 format(/' Unit cell or molecule charge =',f8.4)
  160 format(//' By default the code does not accept non-neutral molecule or unit-cell,'/, &
               ' because often it is a mistake in the use of "Atom" or "Atom_conf" keywords.',// &
               ' If it is not a mistake, what is possible specially when working with molecule,'/, &
               ' use the keyword: "Chfree".',/ &
               ' The code will not stop anymore.',// &
               ' Remark: avoid electronic configuration coresponding to the formal charges.'/, &
               ' They are usually "too much", specially for the s and p orbitals.')
end

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

subroutine Type_work(Com,Doping,Ecrantage,force_ecr,hubb,iabsorbeur,icheck,icom,itabs,itype,itype_dop,Jseuil,Lcoeur,Lecrantage, &
        Lqnexc,Lseuil,Lvval,mpinodes0,mpirank0,n_orbexc,nb_Emis,nbseuil,ncoeur,necrantage,ngroup,nlat,nlatm,nnlm,nompsii,nonexc, &
        nqnexc,nrato,nrato_dirac,nrm,nseuil,nspin,ntype,Numat,nvval,P_emis,pop_open_val,popatc,popats,popatv,popexc,popval, &
        Psi_coeur,Psi_emis,psii,psi_open_val,psival,Rato,Ray_max_dirac,rchimp,Relativiste,rho_coeur,rhoit,Rionic_imp,rmt,rmtimp, &
        V_hubbard)

  use declarations
  implicit none
  include 'mpif.h'

  integer:: iabsorbeur, icheck, igr, ipr, ir, irt, istat, it, itabs, itabs_t, itype_dop, Jseuil, L, Lecrantage, Lseuil, &
     mpinodes0, mpirank0, mpierr, n_orbexc, nb_emis, nbseuil, necrantage, ngroup, nlatm, nnlm, nr, nrato_dirac, nrm, nseuil, &
     nspin, ntype

  character(len=35), dimension(0:ntype) :: com
  character(len=Length_name):: nompsii

  integer, dimension(4):: P_emis
  integer, dimension(ngroup):: itype
  integer, dimension(nnlm):: Lqnexc, nqnexc
  integer, dimension(0:ntype):: icom, nlat, nrato, Numat
  integer, dimension(0:ntype,nlatm):: Lvval, nvval
  integer, dimension(2,0:ntype):: Lcoeur, ncoeur
  logical, dimension(0:ntype):: hubb

  logical:: Doping, Force_ecr, nonexc, Relativiste

  real(kind=db):: p1, p2, Ray_max_dirac

  real(kind=db), dimension(0:ntype):: popatc, rchimp, Rionic_imp, rmt, rmtimp, V_hubbard
  real(kind=db), dimension(nspin):: Ecrantage
  real(kind=db), dimension(nrm):: rr
  real(kind=db), dimension(nrm,nbseuil):: psii, psiit
  real(kind=db), dimension(nrm,nb_emis):: Psi_Emis, Psi_Emist
  real(kind=db), dimension(ngroup,nlatm,nspin):: popats
  real(kind=db), dimension(nnlm,nspin):: popexc
  real(kind=db), dimension(0:ntype,nlatm):: popatv
  real(kind=db), dimension(0:ntype,nlatm,nspin):: popval
  real(kind=db), dimension(0:nrm,0:ntype):: rato, rhoit, rho_coeur
  real(kind=db), dimension(0:nrm,nlatm,0:ntype):: psival
  real(kind=db), dimension(nrm,2):: psi_open_val
  real(kind=db), dimension(2):: pop_open_val
  real(kind=db), dimension(0:nrm,2,0:ntype):: psi_coeur

  if( Doping ) then
    itabs = itype_dop
  else
    itabs = abs( itype(iabsorbeur) )
  endif

  if( Numat(itabs) == 0 .and. mpirank0 == 0 ) then
    call write_error
    do ipr = 3,9,3
      if( ipr == 3 .and. icheck == 0 ) cycle
      write(ipr,110) iabsorbeur
    end do
    stop
  endif

  itabs_t = itabs

  rmt(0) = rmt(itabs)
  Numat(0) = Numat( itabs )
  nlat(0) = nlat( itabs )
  nvval(0,:) = nvval(itabs,:)
  ncoeur(:,0) = ncoeur(:,itabs)
  Lcoeur(:,0) = Lcoeur(:,itabs)
  Lvval(0,:) = Lvval(itabs,:)
  popval(0,:,:) = popval(itabs,:,:)
  com(0) = com(itabs)
  icom(0) = icom(itabs)
  rchimp(0) = rchimp(itabs)
  Rionic_imp(0) = Rionic_imp(itabs)
  rmtimp(0) = rmtimp(itabs)
  Hubb(0) = Hubb(itabs)
  V_hubbard(0) = V_hubbard(itabs)

  call Screendef(Ecrantage,Force_ecr,icheck,Lecrantage,Lqnexc,Lseuil,Lvval,mpirank0,n_orbexc,necrantage, &
        nlat,nlatm,nnlm,nqnexc,nseuil,nspin,ntype,nvval,popexc,popval,Numat(itabs))

! itabs est remis a la valeur initiale a la fin de la routine si on est en nonexc
  itabs = 0

! Il faut recalculer cette partie meme en nonexc pour avoir psii.
  psii(:,:) = 0._db

  if( icom(itabs) == 2 .or. nompsii == 'clementi' ) then

    call clem(icheck,itabs,itabs,Lseuil,Lvval,mpirank0,nbseuil,nlat,nlatm,nonexc,nr,nrm,nseuil,ntype,nvval,popatc, &
          popatv,psii,psival,rr,rhoit,Numat(itabs))

    if( nb_Emis > 0 ) then
      call write_error
      do ipr = 6,9,3
        write(ipr,'(//A)') '  Emission not possible using Clementi Basis'
      end do
      stop
    endif

  elseif( icom(itabs) == 1 .or. nompsii == 'dirac' ) then

    call Dirgen(icheck,itabs,itabs,Jseuil,Lcoeur,Lqnexc,Lseuil,Lvval,mpirank0,n_orbexc,nb_Emis,nbseuil,ncoeur,nlat,nlatm, &
         nnlm,nonexc,nqnexc,nr,nrato_dirac,nrm,nseuil,nspin,ntype,nvval,P_Emis,pop_open_val,popatc,popatv, &
         popexc,popval,psi_coeur,Psi_emis,psii,psi_open_val,psival,rr,Ray_max_dirac,rho_coeur,rhoit,Numat(itabs),Relativiste)

! popats pour l'absorbeur
    do igr = 1,ngroup
      if( abs( itype(igr) ) /= itabs ) cycle
      do L = 1,nlat(itabs)
        popats(igr,L,1:nspin) = popval(itabs,L,1:nspin)
      end do
    end do

  elseif( icom(itabs) == 3 .and. nompsii /= 'clementi' .and. nompsii /= 'dirac' ) then
    if( mpirank0 == 0 ) then
      open(8, file = nompsii, status='old', iostat=istat)
      if( istat /= 0 ) call write_open_error(nompsii,istat,1)
      read(8,*) nr
      do ir = 1,nr
        read(8,*) rr(ir), psii(ir,1)
      end do
      if( nbseuil == 2 ) psii(:,nbseuil) = psii(:,1)
      close(8)
    endif
    if( mpinodes0 > 1 ) then
      call MPI_Bcast(nr,1,MPI_INTEGER,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(rr,nrm,MPI_REAL8,0,MPI_COMM_WORLD,mpierr)
      call MPI_Bcast(psii,nrm*nbseuil,MPI_REAL8,0,MPI_COMM_WORLD, mpierr)

    endif
  endif

! ici on fait les atributions pour L'absorbeur rato(:,0)

  if( icom(itabs) /= 3 ) then
    nrato(itabs) = nr
    rato(0,itabs) = 0._db
    rato(1:nr,itabs) = rr(1:nr)
  endif

  if( icom(itabs) == 3 .and. ( nompsii == 'clementi' .or. nompsii == 'dirac' ) ) then
    psiit(1:nr,:) = psii(1:nr,:)
    if( nb_Emis > 0 ) Psi_Emist(1:nr,:) = Psi_Emis(1:nr,:)

! Interpolation pour avoir la fct d'onde initiale de coeur dans les rayons FLAPW
    psii(:,:) = 0._db
    if( nb_Emis > 0 ) Psi_Emis(1:nr,:) = 0._db
    do ir = 1,nrato(itabs_t)
      do irt = 2,nr
        if( rr(irt) > rato(ir,itabs_t) ) exit
      end do
      if( irt > nr ) exit
      p1 = ( rato(ir,itabs_t) -  rr(irt-1) ) / (rr(irt) - rr(irt-1))
      p2 = 1 - p1
      psii(ir,:) = p1*psiit(irt,:) + p2*psiit(irt-1,:)
      if( nb_Emis > 0 ) Psi_Emis(ir,:) = p1*Psi_Emist(irt,:) + p2*Psi_Emist(irt-1,:)
    end do
  endif

  if( icheck > 0 ) then
    write(3,120)
    do it = 0,ntype
      if( nonexc .and. it == 0 ) cycle
      write(3,130) it, com(it), Numat(it), ( nvval(it,L), Lvval(it,L), popatv(it,L), L = 1,nlat(it))
    end do
    if( .not. nonexc ) write(3,140) necrantage, Lecrantage, Ecrantage(1:nspin)
  endif
  if( icheck > 1 ) then
    write(3,150)
    do ir = 1,nrato(itabs)
      write(3,160) rato(ir,itabs)*bohr, psii(ir,:)
    end do
  endif

  if( nonexc ) itabs = itabs_t

  return
  110 format(//' The absorbing atom cannot be the number',i3,' because it is an empty sphere !'//)
  120 format(/' Atom type',21x,'Z  n  L  popatv')
  130 format(i3,1x,a25,i3,8(2i3,f6.2))
  140 format(/' Default or imposed orbital screening :',/ &
              '      When default is used, if the screening orbital is full,',/ &
              '      it is the next one which is filled',/ &
              '   n_screening_orbital =',i2,/ &
              '   l_screening_orbital =',i2,/ &
              '   Screening =',2f6.3)
  150 format(/' Core wave function after interpolation' )
  160 format(f12.8,2f11.7)
end

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

! Calculation of the electronic configuration of the excited atom

subroutine Screendef(Ecrantage,Force_ecr,icheck,Lecrantage,Lqnexc,Lseuil,Lvval,mpirank0,n_orbexc,necrantage, &
        nlat,nlatm,nnlm,nqnexc,nseuil,nspin,ntype,nvval,popexc,popval,Z)

  use declarations
  implicit none

  integer:: i, iaug, icheck, io, ip, ipr, ispin, it, L, Lecrantage, Lseuil, mpirank0, n_coeur, n_orbexc, necrantage, &
            nlatm, nmax, nnlm, nseuil, nspin, ntype, Z

  integer, dimension(nnlm):: Lqnexc, nqnexc
  integer, dimension(0:ntype):: nlat
  integer, dimension(0:ntype,nlatm):: Lvval, nvval

  logical:: Dirac_eq, Force_ecr

  real(kind=db):: Occupancy_max
  real(kind=db), dimension(nnlm):: nel, rqn
  real(kind=db), dimension(0:ntype,nlatm,nspin):: popval
  real(kind=db), dimension(nspin) :: dp, dpp, Ecrantage
  real(kind=db), dimension(nnlm,nspin):: popexc

  if( necrantage == 0 .or. .not. Force_ecr ) then
    select case( Z )
      case(1,2,3)
        necrantage = 2
        Lecrantage = 0
      case(4,5,6,7,8,9)
        necrantage = 2
        Lecrantage = 1
      case(10,11)
        necrantage = 3
        Lecrantage = 0
      case(12,13,14,15,16,17)
        necrantage = 3
        Lecrantage = 1
      case(18,19,20)
        necrantage = 4
        Lecrantage = 0
      case(21,22,23,24,25,26,27,28,29,30)
        necrantage = 3
        Lecrantage = 2
      case(31,32,33,34,35)
        necrantage = 4
        Lecrantage = 1
      case(36,37,38)
        necrantage = 5
        Lecrantage = 0
      case(39,40,41,42,43,44,45,46,47,48)
        necrantage = 4
        Lecrantage = 2
      case(49,50,51,52,53)
        necrantage = 5
        Lecrantage = 1
      case(54,55,56)
        necrantage = 6
        Lecrantage = 0
      case(57,58,59,60,61,62,63,64,65,66,67,68,69,70,71)
        necrantage = 4
        Lecrantage = 3
      case(72,73,74,75,76,77,78,79,80)
        necrantage = 5
        Lecrantage = 2
      case(81,82,83,84,85)
        necrantage = 6
        Lecrantage = 1
      case(86,87,88)
        necrantage = 7
        Lecrantage = 0
      case(89,90,91,92,93,94,95,96,97,98,99,100,101)
        necrantage = 5
        Lecrantage = 3
      case(102,103)
        necrantage = 6
        Lecrantage = 2
      case default
        call write_error
        do ipr = 3,9,3
          if( ipr == 3 .and. icheck == 0 ) cycle
          write(ipr,100) Z
        end do
        close(9)
        stop
    end select
  endif

  Dirac_eq = .false.
  call config(Z,Dirac_eq,n_coeur,n_orbexc,nnlm,nqnexc,Lqnexc,rqn,nel)

  do ispin = 1,nspin
    popexc(1:n_orbexc,ispin) = nel(1:n_orbexc) / nspin
  end do

  if( Force_ecr ) then
    do L = 1,nlat(0)
      if( nvval(0,L) == necrantage .and. Lvval(0,L) == Lecrantage ) exit
    end do
    if( L > nlat(0) ) then
      nlat(0) = L
      nvval(0,L) = necrantage
      Lvval(0,L) = Lecrantage

      popval(0,L,1:nspin) = 0._db
      do ip = 1,n_orbexc
        if( nqnexc(ip) /= necrantage .or. Lqnexc(ip) /= Lecrantage ) cycle
        popval(0,L,1:nspin) = popexc(ip,1:nspin)
        exit
      end do

    endif
  endif

  it = 0

! On modifie la configuration electronique, compte tenu des entrees
  boucle_io: do io = 1,nlat(it)
    do ip = 1,n_orbexc
      if( nqnexc(ip) /= nvval(it,io) .or. Lqnexc(ip) /= Lvval(it,io)) cycle
      popexc(ip,1:nspin) = popval(it,io,1:nspin)
      cycle boucle_io
    end do
! On doit constuire une orbitale supplementaire
    n_orbexc = n_orbexc + 1
    if( n_orbexc > nnlm .and. mpirank0 == 0 ) then
      call write_error
      do ipr = 3,9,3
        if( ipr == 3 .and. icheck == 0 ) cycle
        write(ipr,103)
      end do
      close(9)
      stop
    endif
    nqnexc(n_orbexc) = nvval(it,io)
    Lqnexc(n_orbexc) = Lvval(it,io)
    popexc(n_orbexc,1:nspin) = popval(it,io,1:nspin)
  end do boucle_io

! On enleve L'electron de coeur
  do io = 1,n_orbexc
    if( nqnexc(io) /= nseuil .or. Lqnexc(io) /= Lseuil ) cycle
    do ispin = 1,nspin
      popexc(io,ispin) = popexc(io,ispin) - 1._db / nspin
    end do
    exit
  end do

! On ajoute L'ecrantage

  if( Force_ecr ) then

    do io = 1,n_orbexc
      if( necrantage /= nqnexc(io) .or. Lecrantage /= Lqnexc(io) ) cycle
      popexc(io,1:nspin) = popexc(io,1:nspin) + ecrantage(1:nspin)
      exit
    end do

    if( io > n_orbexc ) then
      n_orbexc = n_orbexc + 1
      nqnexc(n_orbexc) = necrantage
      Lqnexc(n_orbexc) = Lecrantage
      popexc(n_orbexc,1:nspin) = ecrantage(1:nspin)
    endif

  else

    dp(1:nspin) = ecrantage(1:nspin)

    boucle_i: do i = 1,2
      do io = 1,n_orbexc
        if( nqnexc(io) < nseuil .or. ( nqnexc(io) == nseuil .and. Lqnexc(io) <= Lseuil ) ) cycle

        if( i == 1 .and. ( necrantage /= nqnexc(io) .or. Lecrantage /= Lqnexc(io) ) ) cycle
        if( i == 2 .and. ( necrantage == nqnexc(io) .and. Lecrantage == Lqnexc(io) ) ) cycle

        Occupancy_max = ( 2 + 4._db * Lqnexc(io) ) / nspin
        do ispin = 1,nspin
          dpp(ispin) = min(Occupancy_max - popexc(io,ispin), dp(ispin) )
          popexc(io,ispin) = popexc(io,ispin) + dpp(ispin)
          dp(ispin) = dp(ispin) - dpp(ispin)
        end do
        if( sum( dp(:) ) < eps10 ) exit boucle_i
        if( sum( popexc(io,:) ) < nspin * Occupancy_max - eps10 ) then
          dpp(1) = min(Occupancy_max - popexc(io,1), dp(nspin) )
          dpp(nspin) = min(Occupancy_max - popexc(io,nspin), dp(1) )
          popexc(io,:) = popexc(io,:) + dpp(:)
          dp(1) = dp(1) - dpp(nspin)
          dp(nspin) = dp(nspin) - dpp(1)
        endif
        if( sum( dp(:) ) < eps10 ) exit boucle_i
        if( i == 1 ) exit
      end do
    end do boucle_i

    if( dp(1) > eps10 .or. dp(nspin) > eps10 ) then
      nmax = 0
      do io = 1,n_orbexc
        nmax = max(nqnexc(io),nmax)
      end do
      if( nmax == 1 ) then
        iaug = 1
      else
        iaug = 0
        do io = 1,n_orbexc
          if( nqnexc(io) == nmax .and. Lqnexc(io) == 1 ) then
            iaug = 1
            exit
          endif
        end do
      endif
      n_orbexc = n_orbexc + 1
      if( iaug == 1 ) then
        nqnexc(n_orbexc) = nmax + 1
        Lqnexc(n_orbexc) = 0
      elseif( Z == 20 .or. Z == 38 .or.Z == 56 .or. Z == 88 ) then
        nqnexc(n_orbexc) = nmax - 1
        Lqnexc(n_orbexc) = 2
      else
        nqnexc(n_orbexc) = nmax
        Lqnexc(n_orbexc) = 1
      endif
      do ispin = 1,nspin
        if( dp(ispin) > eps10 ) then
          popexc(n_orbexc,ispin) = dp(ispin)
        else
          popexc(n_orbexc,ispin) = 0._db
        endif
      end do
    endif
  endif

  if( icheck > 1 ) then
    write(3,120)
    do io = 1,n_orbexc
      write(3,130) nqnexc(io), Lqnexc(io), popexc(io,1:nspin)
    end do
  endif

  return
  100 format(///'   Z =',i4,' > 103 in Screendef',//)
  103 format(///'   n_orb < nnlm ',// ' Contact the authors of the code !')
  120 format(/'  n  L popexc')
  130 format(2i3,2f7.3)
end

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

! Allocation des tableaux itypepr et popatm pour L'excite

subroutine Pop_mod(chargat,Chargm,Chargm_SCF,Doping,Flapw,iabsorbeur,icheck,igreq,itabs,iprabs,itype,itype_dop,itypepr,Lqnexc, &
        Lvval,n_atom_proto,n_orbexc,neqm,ngreq,ngroup,nlat,nlatm,nnlm,Nonexc,nqnexc,nspin,ntype,numat_abs,nvval,popatm,popexc, &
        Self_nonexc)

  use declarations
  implicit none

  integer:: iabsorbeur, icheck, igrabs, io, ipr, iprabs, itabs, itype_dop, jo, L, n_atom_proto, n_orbexc, neqm, ngroup, nl, &
    nlatm, nnlm, nspin, ntype, numat_abs

  integer, dimension(nnlm):: Lqnexc, nqnexc
  integer, dimension(ngroup):: itype
  integer, dimension(0:n_atom_proto):: itypepr, ngreq
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(0:ntype):: nlat
  integer, dimension(0:ntype,nlatm):: Lvval, nvval

  logical:: Doping, Flapw, Nonexc, Self_nonexc

  real(kind=db):: Chargm, Chargm_SCF
  real(kind=db), dimension(0:n_atom_proto):: chargat
  real(kind=db), dimension(0:n_atom_proto,nlatm,nspin):: popatm
  real(kind=db), dimension(nnlm,nspin):: popexc

  boucle_iprabs: do iprabs = 1,n_atom_proto
    do igrabs = 1,ngreq(iprabs)
      if( igreq(iprabs,igrabs) == iabsorbeur ) exit boucle_iprabs
    end do
  end do boucle_iprabs

  itypepr(:) = 0

  if( flapw ) then

    do ipr = 1,n_atom_proto
      itypepr(ipr) = abs( itype( igreq(ipr,1) ) )
    end do

  else

    itypepr(0) = 0
    do ipr = 1,n_atom_proto
      if( Doping .and. ipr == n_atom_proto ) then
        itypepr(ipr) = abs( itype_dop )
      else
        itypepr(ipr) = abs( itype( igreq(ipr,1) ) )
      endif
    end do

    igreq(0,1) = igreq(iprabs,igrabs)
    ngreq(0) = 1

    chargat(0) = numat_abs - sum( popexc(1:n_orbexc,1:nspin) )

    do io = 1,nlat(itabs)
      do jo = 1,n_orbexc
        if( nvval(itabs,io) /= nqnexc(jo) .or. Lvval(itabs,io) /= Lqnexc(jo) ) cycle
        popatm(0,io,1:nspin) = popexc(jo,1:nspin)
        exit
      end do
    end do

    if( Self_nonexc ) Chargm_SCF = Chargm
    if( .not. Nonexc ) then
      Chargm = chargm + chargat(0) - chargat(iprabs)
      if( .not. Self_nonexc ) Chargm_SCF = Chargm
    endif

    if( icheck > 2 ) then
      write(3,120) iprabs
      if( nspin == 1 ) then
        write(3,130)
      else
        write(3,140)
      endif
      do ipr = 0,n_atom_proto
        nl = nlat( itypepr(ipr) )
        write(3,150) ipr, itypepr(ipr), chargat(ipr), ( popatm(ipr,L,1:nspin), L = 1,nl )
      end do
    endif

  endif

  return
  120 format(/' ---- Pop_mod ------',100('-')//,' iprabs =', i3)
  130 format(/'  ipr  it    charge   popatm(1)  popatm(2)')
  140 format(/'  ipr  it    charge   popatm(1,up)  popatm(1,dn) ...')
  150 format(2i4,11f11.5)
end

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

! Dilatation of the atomic orbitals (can be usefull for anions)

subroutine dilatorb(cdil,icheck,it,itdil,Ldil,nlatm,norbdil,nr,nrm,ntype,popatv,psival,r,rhoit)

  use declarations
  implicit none

  integer:: icheck, io, ir, it, jr, jr1, L, nlatm, norbdil, nr, nrm, ntype

  integer, dimension(norbdil):: itdil, Ldil

  real(kind=db):: cd, charge, dc, f_integr3, p1, p2, uns4pi

  real(kind=db), dimension(norbdil):: cdil
  real(kind=db), dimension(0:nrm):: psin, psit, r, rhn, rht, rhnr2, rn
  real(kind=db), dimension(0:ntype,nlatm) :: popatv
  real(kind=db), dimension(0:nrm,0:ntype):: rhoit
  real(kind=db), dimension(0:nrm,nlatm,0:ntype):: psival

  p1 = r(2) / ( r(2) - r(1) )
  p2 = 1 - p1

  do io = 1,norbdil

    if( itdil(io) /= it ) cycle
    L = Ldil(io)

! Orbital expansion
    cd = 1 + cdil(io)
    rn(0:nr) = r(0:nr) * cd
    psit(1:nr) = psival(1:nr,L,it)
    psit(0) = 0
    psin(0) = 0
    jr1 = 1
    do ir = 1,nr
      if( r(ir) > rn(nr) ) then
        psin(ir:nr) = 0._db
        exit
      endif
      do jr = jr1,nr
        if( rn(jr) > r(ir) ) exit
      end do
      jr1 = jr
      p1 = ( rn(jr) - r(ir) ) / ( rn(jr) - rn(jr-1) )
      psin(ir) = p1 * psit(jr-1) + ( 1 - p1 ) * psit(jr)
    end do

! Charge calculation and renormalization
    uns4pi = 1 / quatre_pi
    rhn(1:nr) = uns4pi * ( psin(1:nr) / r(1:nr) )**2
    rhnr2(1:nr) = uns4pi * psin(1:nr)**2
    rhnr2(0) = 0._db
    rht(1:nr) = uns4pi * ( psit(1:nr) / r(1:nr) )**2
    rht(0) = p1*rht(1) + p2*rht(2)
    rhn(0) = rht(0)
    charge = quatre_pi * f_integr3(r,rhnr2,0,nrm,r(nr))
    rhn(0:nr) = rhn(0:nr) / charge
    dc = 1 / sqrt( charge )

    psival(0:nr,L,it) = dc * psin(0:nr)
    rhoit(0:nr,it) = rhoit(0:nr,it) + popatv(it,L) * ( rhn(0:nr) - rht(0:nr) )

    if( icheck > 1 ) then
      write(3,110)
      write(3,120) it, L
      do ir = 1,nr
        write(3,130) r(ir)*bohr, psit(ir), psival(ir,L,it), rhoit(ir,it)
      end do
    endif

  end do

  return
  110 format(/' ---- Dilat --------',100('-'))
  120 format(/5x,'it =',i3,',  L =',i2,/ '     rato    psi_before_dil    psival          rho')
  130 format(1p,9e13.5)
end

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

function extract_nenerg(multi_run,nom_fich_extract,Optic,Tddft)

  use declarations
  implicit none

  integer:: extract_nenerg, eof, i, ipr, istat, multi_run, nenerg

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

  logical:: Optic, Tddft

  open(1, file = nom_fich_extract, status='old', iostat=istat)
  if( istat /= 0 ) call write_open_error(nom_fich_extract,istat,1)

  i = 0
  do
    read(1,'(A)',iostat=istat) mot
    if( istat /= 0 ) then
      call write_error
      do ipr = 6,9,3
        write(ipr,'(//A//)') ' "Absorbing atom" words not found in the file to extract data !'
      end do
      stop
    endif
    if( mot(2:15) /= 'Absorbing atom' ) cycle
    i = i + 1
    if( i == multi_run ) exit
  end do

  eof = 0
  if( tddft ) then
    do while(eof==0)
      read(1,'(A)',iostat=eof) mot
      if( mot(2:12) == 'Cycle TDDFT' .or. mot(2:12) == 'Cycle Tddft' ) exit
    end do

    if( eof /= 0 ) then
      call write_error
      do ipr = 6,9,3
        write(ipr,110)
      end do
      stop
    endif

  endif

  nenerg = 0
  boucle_je: do
    do
      read(1,'(A)',iostat=eof) mot
      if( eof /= 0 ) exit boucle_je
      if( mot(2:12) == 'Cycle TDDFT' .or. mot(2:12) == 'Cycle Tddft' .or. mot(2:15) == 'Absorbing atom' ) exit boucle_je
      if( ( .not. Optic .and. mot(7:11) == 'Coabs' ) .or. ( Optic .and. mot(7:11) == 'Tau -' ) ) nenerg = nenerg + 1
    end do
  end do boucle_je

  Close(1)

  extract_nenerg = nenerg

  return
  110 format(//' Error in the the indata file:',// ' An extraction of tensors calculated using TDDFT is asked.', &
           /' The corresponding file does not contain TDDFT outputs !!')
end

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

subroutine Extract_energ(Energ_s,Eseuil,multi_run,nbbseuil,nbseuil,nenerg_s,nom_fich_extract,Optic,Tddft)

  use declarations
  implicit none

  integer:: i, ie, istat, multi_run, nbbseuil, nbseuil, nenerg_s

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

  logical:: Optic, Tddft

  real(kind=db), dimension(nbseuil):: Eseuil
  real(kind=db), dimension(nenerg_s):: energ_s

  open(1, file = nom_fich_extract, status='old', iostat=istat)
  if( istat /= 0 ) call write_open_error(nom_fich_extract,istat,1)

  i = 0
  do
    read(1,'(A)' ) mot
    if( mot(2:15) /= 'Absorbing atom' ) cycle
    i = i + 1
    if( i == multi_run ) exit
  end do

  if( tddft ) then
    do
      read(1,'(A)') mot
      if( mot(2:12) == 'Cycle TDDFT' .or. mot(2:12) == 'Cycle Tddft' ) exit
    end do
  endif

  boucle_ie: do ie = 1,nenerg_s

    do
      read(1,'(A)') mot
      if( ( .not. Optic .and. mot(7:11) == 'Coabs' ) .or. ( Optic .and. mot(7:11) == 'Tau -' ) ) exit
    end do

    do
      read(1,'(A)') mot
      if( mot(6:10) == 'energ' .or. mot(5:10) == 'Energy' .or. mot(9:13) == 'Energ') then
        read(1,*) Energ_s(ie)
        Energ_s(ie) = Energ_s(ie) / rydb
        cycle boucle_ie
      endif
    end do

  end do boucle_ie

  if( energ_s(nenerg_s) > Eseuil(min(nbbseuil,nbseuil)) .and. Eseuil(nbbseuil) > energ_s(nenerg_s) - energ_s(1) ) then
    do ie = 1,nenerg_s
      energ_s(ie) = energ_s(ie) - Eseuil(min(nbbseuil,nbseuil))
    end do
  endif

  Close(1)

  return
end

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

subroutine init_clust(angxyz,angxyz_bulk,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho,Bulk_step,Center_s,Centre,dcosxyz,deccent, &
        Dist_atom_min,iabsfirst,multrmax,n_atom_bulk,n_atom_int,n_atom_per,n_atom_uc,n_radius,ngroup,Noncentre,One_run_s,posn, &
        posn_bulk,R_SCF_c,R_self,R_self_bulk,Rmax,Rpotmax,Rsorte_s)

  use declarations
  implicit none

  integer:: iabsfirst, multrmax, n_atom_bulk, n_atom_int, n_atom_per, n_atom_uc, n_radius, ngroup

  logical:: Base_ortho, Bulk_step, Center_s, Noncentre, One_run_s

  real(kind=db):: Dist_atom_min, R_SCF_c, R_self, R_self_bulk, Rmax, Rpotmax

  real(kind=db), dimension(3):: angxyz, angxyz_bulk, axyz, axyz_bulk, axyz_int, axyz_sur, Centre, dcosxyz, deccent
  real(kind=db), dimension(n_radius):: Rsorte_s
  real(kind=db), dimension(3,n_atom_bulk):: posn_bulk
  real(kind=db), dimension(3,n_atom_uc):: posn

! Minimum interatomic distance (distance H-H in H2 = 0.7414 A)
  Dist_atom_min = 0.7_db / bohr

  if( Bulk_step ) then
    dcosxyz(:) = 2 * cos( angxyz_bulk(:) )
    R_SCF_c = R_self_bulk
  else
    dcosxyz(:) = 2 * cos( angxyz(:) )
    R_SCF_c = R_self
 endif

  if( abs( dcosxyz(1) ) < eps10 .and. abs( dcosxyz(2) ) < eps10 .and. abs( dcosxyz(3) ) < eps10 ) then
    Base_ortho = .true.
  else
    Base_ortho = .false.
  endif

  if( Rpotmax > eps4 ) then
    Rmax = Rpotmax
  else
    Rmax = max( Rsorte_s(1), R_SCF_c ) + multrmax * 2.5_db / bohr
  endif

! The absorbing atom is set at the center (in case of One_run, it is the first absorbing atom )
  deccent(:) = 0._db
  if( Bulk_step ) then
    deccent(:) = posn_bulk(:,iabsfirst-ngroup+n_atom_bulk) * axyz_bulk(:)
  elseif( Center_s .or. One_run_s ) then
    if( iabsfirst <= n_atom_per ) then
      deccent(1:2) = Centre(1:2) * axyz(1:2)
      deccent(3) = posn(3,iabsfirst) * axyz(3)
    elseif( iabsfirst <= n_atom_per+n_atom_int ) then
      deccent(1:2) = Centre(1:2) * axyz_int(1:2)
      deccent(3) = posn(3,iabsfirst) * axyz_int(3)
    else
      deccent(1:2) = Centre(1:2) * axyz_sur(1:2)
      deccent(3) = posn(3,iabsfirst) * axyz_sur(3)
    endif
  elseif( Noncentre ) then
    if( iabsfirst <= n_atom_per ) then
      deccent(:) = Centre(:) * axyz(:)
    elseif( iabsfirst <= n_atom_per+n_atom_int ) then
      deccent(:) = Centre(:) * axyz_int(:)
    else
      deccent(:) = Centre(:) * axyz_sur(:)
    endif
  else
    if( iabsfirst <= n_atom_per ) then
      deccent(:) = posn(:,iabsfirst) * axyz(:)
    elseif( iabsfirst <= n_atom_per+n_atom_int ) then
      deccent(:) = posn(:,iabsfirst) * axyz_int(:)
    else
      deccent(:) = posn(:,iabsfirst) * axyz_sur(:)
    endif
  endif

  return
end

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

! Calculation of the number of atoms in the clusters used for potential calculation and xanes calculation

subroutine natomp_cal(angxyz,angxyz_bulk,angxyz_int,angxyz_sur,ATA,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho,Base_ortho_int, &
        Base_ortho_sur,Bulk,Bulk_step,Center_s,Chargat,Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster,d_ecrant,dcosxyz, &
        deccent,deccent_bulk,Delta_bulk,Delta_film,Delta_int,Delta_sur,Dist_atom_min,Doping,dpos,Film_shift,Film_thickness, &
        First_run,Flapw, &
        iabsorbeur,iabsfirst,icheck,igr_dop,igreq,Interface_shift,itabs,itype,Kgroup,Matper,mpirank0,n_atom_bulk,n_atom_int, &
        n_atom_per,n_atom_proto,n_atom_proto_uc,n_atom_sur,n_atom_uc,n_counter_ato,n_counter_dip,n_counter_ion,n_radius, &
        natomeq_coh,natomeq_s,natomp,natomp_ato,natomp_dip,natomp_ion,neqm,ngreq,ngroup,ngroup_pdb,ngroup_taux,Noncentre,posn, &
        One_SCF_surf,posn_bulk,Proto_all,R_SCF_c,rsorte_s,Rmax,Surface_shift,Sym_2D,Taux_oc)

  use declarations
  implicit none

  integer:: i_radius, iaabs, iaabsfirst, iabsfirst, iabsorbeur, icheck, igr_dop, ipr, itabs,  mpirank0, &
     n_atom_bulk, n_atom_int, n_atom_per, n_atom_proto, n_atom_proto_uc, n_atom_sur, n_atom_uc, n_counter_ato, n_counter_dip, &
     n_counter_ion, n_radius, natomeq_coh, natomp, natomp_ato, natomp_dip, natomp_ion, natomr, neqm, ngroup, ngroup_pdb, &
     ngroup_taux

  integer, dimension(ngroup):: itype
  integer, dimension(n_radius):: natomeq_s
  integer, dimension(ngroup_pdb):: Kgroup
  integer, dimension(0:n_atom_proto):: ngreq
  integer, dimension(0:n_atom_proto,neqm):: igreq

  integer, dimension(:), allocatable:: igroup, igroup_ato, igroup_dip, igroup_ion, itypep

  logical:: ATA, Base_ortho, Base_ortho_int, Base_ortho_sur,Bulk, Bulk_step, Center_s, &
        Doping, First_run, Flapw, Matper, Noncentre, Numbering, One_SCF_surf, Proto_all, Sym_2D
  logical, dimension(2):: Cylinder_cluster
  logical, dimension(:), allocatable:: Atom_SCF_clust

  real(kind=db):: d_ecrant, Delta_bulk, Delta_film, Delta_int, Delta_sur, Dist_atom_min, Film_thickness, R_SCF_c, Rmax, Rsortm

  real(kind=db), dimension(n_radius):: rsorte_s
  real(kind=db), dimension(3):: angxyz, angxyz_bulk, angxyz_int, angxyz_sur, axyz, axyz_bulk, axyz_int, axyz_sur, dcosxyz, &
                                deccent, deccent_bulk, dpos
  real(kind=db), dimension(4):: Film_shift, Interface_shift, Surface_shift
  real(kind=db), dimension(ngroup_taux):: Taux_oc
  real(kind=db), dimension(3,n_atom_uc):: posn
  real(kind=db), dimension(3,n_atom_bulk):: posn_bulk
  real(kind=db), dimension(0:n_atom_proto):: chargat
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(6,n_counter_dip):: Counter_dip
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion

  real(kind=db), dimension(:,:), allocatable:: Pos, Pos_ato, Pos_dip, Pos_ion

  Numbering = .true.

  natomp = 0
  natomp_ato = 0
  natomp_dip = 0
  natomp_ion = 0

  allocate( Atom_SCF_clust(natomp) )
  allocate( igroup(natomp) )
  allocate( igroup_ato(natomp_ato) )
  allocate( igroup_dip(natomp_dip) )
  allocate( igroup_ion(natomp_ion) )
  allocate( itypep(natomp) )
  allocate( Pos(3,natomp) )
  allocate( Pos_ato(3,natomp_ato) )
  allocate( Pos_dip(3,natomp_dip) )
  allocate( Pos_ion(3,natomp_ion) )

  if( One_SCF_surf ) then
    call Cluster_building_surf(angxyz_bulk,angxyz_sur,ATA,Atom_SCF_clust,axyz_bulk,axyz_sur,Base_ortho_sur,Bulk_step, &
        Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster,deccent,deccent_bulk,Delta_bulk,Delta_sur,Dist_atom_min, &
        First_run,iaabs,iaabsfirst,iabsorbeur,igreq,igroup,igroup_ato,igroup_dip,igroup_ion,itabs, &
        itype,itypep,n_atom_bulk,n_atom_proto,n_atom_proto_uc,n_atom_uc,n_counter_ato,n_counter_dip,n_counter_ion,n_radius, &
        natomeq_coh,natomeq_s,natomp,natomp_ato,natomp_dip,natomp_ion,neqm,ngreq,ngroup,ngroup_taux, &
        Numbering,posn,Pos,Pos_ato,Pos_dip,Pos_ion,posn_bulk,Proto_all,R_SCF_c,Rsorte_s,Rmax,Surface_shift, &
        Taux_oc)
  else
    call Cluster_building(angxyz,angxyz_bulk,angxyz_int,angxyz_sur,ATA,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho, &
        Base_ortho_int,Base_ortho_sur,Bulk,Bulk_step,Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster, &
        dcosxyz,deccent,Delta_bulk,Delta_film,Delta_int,Delta_sur,Dist_atom_min,Doping,Film_shift,Film_thickness, &
        First_run,iaabs,iaabsfirst,iabsfirst,iabsorbeur,igr_dop,igreq,igroup,igroup_ato,igroup_dip,igroup_ion,Interface_shift, &
        itabs,itype,itypep,Kgroup,Matper,n_atom_bulk,n_atom_int, &
        n_atom_per,n_atom_proto,n_atom_proto_uc,n_atom_sur,n_atom_uc,n_counter_ato,n_counter_dip,n_counter_ion,n_radius, &
        natomeq_coh,natomeq_s,natomp,natomp_ato,natomp_dip,natomp_ion,neqm,ngreq,ngroup,ngroup_pdb,ngroup_taux, &
        Numbering,posn,Pos,Pos_ato,Pos_dip,Pos_ion,posn_bulk,Proto_all,R_SCF_c,rsorte_s,Rmax,Surface_shift, &
        Sym_2D,Taux_oc)
  endif

  deallocate( Atom_SCF_clust, igroup, igroup_ato, igroup_dip, igroup_ion, itypep, Pos, Pos_ato, Pos_dip, Pos_ion )

  if( .not. Flapw .and. Matper .and. .not. Cylinder_cluster(1) .and. .not. Sym_2D ) then
    rsortm = max( R_SCF_c, rsorte_s(1) )
    call Reduc_natomp(angxyz,angxyz_bulk,angxyz_int,angxyz_sur,ATA,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho,Base_ortho_int, &
            Base_ortho_sur,Bulk,Bulk_step,Center_s,chargat,Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster,d_ecrant,dcosxyz, &
            deccent,deccent_bulk,Delta_bulk,Delta_film,Delta_int,Delta_sur,Dist_atom_min,Doping,dpos,Film_shift,Film_thickness, &
            First_run,iabsorbeur,iabsfirst,icheck,igr_dop,igreq,Interface_shift,itabs,itype,Kgroup,matper,mpirank0,n_atom_bulk, &
            n_atom_int,n_atom_per,n_atom_proto,n_atom_sur,n_atom_uc,n_counter_ato,n_counter_dip,n_counter_ion,natomp,natomp_ato, &
            natomp_dip,natomp_ion,natomr,ngreq,ngroup,ngroup_pdb,ngroup_taux,Noncentre,One_SCF_surf,posn,posn_bulk,R_SCF_c,Rmax, &
            Rsortm,Surface_shift,Sym_2D,Taux_oc)
    natomp = natomr
  endif

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

  do ipr = 3,6,3
    if( icheck == 0 .and. ipr == 3 ) cycle
    if( mpirank0 /= 0 .and. ipr == 6 ) cycle
    write(ipr,150) ( Rsorte_s(i_radius)*bohr, natomeq_s(i_radius), i_radius = 1,n_radius )
    if( Cylinder_cluster(2) ) then
      write(ipr,170) R_SCF_c*bohr, natomeq_coh
    else
      write(ipr,180) R_SCF_c*bohr, natomeq_coh
    endif
    if( Cylinder_cluster(1) ) then
      write(ipr,190) Rmax*bohr, natomp
    else
      write(ipr,200) Rmax*bohr, natomp
    endif
  end do

  return
  110 format(/' ---- Natomp_cal ----',100('-'))
  150 format(/' Cluster radius =',f5.2,' A, nb. of atom =',i4)
  170 format(' Fermi energy calculation : cluster radius =',f5.2,' A, nb. of atom =',i4,', with cylinder cluster')
  180 format(' Fermi energy calculation : cluster radius =',f5.2,' A, nb. of atom =',i4)
  190 format(' Potential sup calculation: cluster radius =',f5.2,' A, nb. of atom =',i4,', with cylinder cluster')
  200 format(' Potential sup calculation: cluster radius =',f5.2,' A, nb. of atom =',i4)
   end

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

! Calculation of the number of atoms in the clusters used for potential calculation and xanes calculation
! or building of it.
! Called by Natomp_cal (Numbering = true) and Clust (Numbering = false)

subroutine Cluster_building(angxyz,angxyz_bulk,angxyz_int,angxyz_sur,ATA,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho, &
        Base_ortho_int,Base_ortho_sur,Bulk,Bulk_step,Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster, &
        dcosxyz,deccent,Delta_bulk,Delta_film,Delta_int,Delta_sur,Dist_atom_min,Doping,Film_shift,Film_thickness, &
        First_run,iaabs,iaabsfirst,iabsorbeur,iabsfirst,igr_dop,igreq,igroup,igroup_ato,igroup_dip,igroup_ion,Interface_shift, &
        itabs,itype,itypep,Kgroup,Matper,n_atom_bulk,n_atom_int, &
        n_atom_per,n_atom_proto,n_atom_proto_uc,n_atom_sur,n_atom_uc,n_counter_ato,n_counter_dip,n_counter_ion,n_radius, &
        natomeq_coh,natomeq_s,natomp,natomp_ato,natomp_dip,natomp_ion,neqm,ngreq,ngroup,ngroup_pdb,ngroup_taux, &
        Numbering,posn,Pos,Pos_ato,Pos_dip,Pos_ion,posn_bulk,Proto_all,R_SCF_c,Rsorte_s,Rmax,Surface_shift, &
        Sym_2D,Taux_oc)

  use declarations
  implicit none

  integer:: i, i_radius, ia, ia_ato, ia_dip, ia_ion, iaabs, iaabsfirst, iabs_slab, iabsfirst, iabsfirst_slab, iabsorbeur, ib, &
     igr, igr_b, igr_dop, igr_slab, igr0, ipr, iprint, itabs, ix, iy, iz, jgr, jgr_b, &
     n, n_atom_bulk, n_atom_int, n_atom_per, n_atom_proto, n_atom_proto_uc, n_atom_sur, n_atom_uc, n_counter_ato, n_counter_dip, &
     n_counter_ion, n_radius, natomeq_coh, natomp, natomp_ato, natomp_dip, natomp_ion, neqm, ngroup, ngroup_pdb, &
     ngroup_taux, n_igr, nxmaille, nymaille, nzmaille

  integer, dimension(natomp):: igroup, itypep
  integer, dimension(ngroup):: itype
  integer, dimension(n_radius):: natomeq_s
  integer, dimension(ngroup_pdb):: Kgroup
  integer, dimension(0:n_atom_proto):: ngreq
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(natomp_ato):: igroup_ato
  integer, dimension(natomp_dip):: igroup_dip
  integer, dimension(natomp_ion):: igroup_ion

  logical:: Abs_case, ATA, Base_ortho, Base_ortho_bulk, Base_ortho_int, Base_ortho_sur,Bulk, Bulk_step, &
        Counter, Counter_a, Counter_d, Different_slab, Doping, First_run, Matper, Numbering, Proto_all, Sym_2D

  logical, dimension(2):: Cylinder_cluster
  logical, dimension(n_atom_proto):: ipr_ok

  real(kind=db):: cos_z, cos_z_b, cos_z_i, cos_z_s, Delta_bulk, Delta_film, Delta_int, Delta_sur, dist, dist_pot, &
    dist_SCF, Dist_atom_min, Film_thickness, R_SCF_c, Rmax, Vnorme

  real(kind=db), dimension(n_radius):: rsorte_s
  real(kind=db), dimension(3):: angxyz, angxyz_bulk, angxyz_int, angxyz_sur, axyz, axyz_bulk, axyz_int, axyz_g, axyz_sur, &
                                dcosxyz, dcosxyz_bulk, dcosxyz_int, dcosxyz_sur, deccent, p, ps, v
  real(kind=db), dimension(4):: Film_shift, Interface_shift, Surface_shift
  real(kind=db), dimension(ngroup_taux):: Taux_oc
  real(kind=db), dimension(3,n_atom_uc):: posn
  real(kind=db), dimension(3,n_atom_bulk):: posg_bulk, posn_bulk
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(6,n_counter_dip):: Counter_dip
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion
  real(kind=db), dimension(3,n_counter_ato):: posg_ato, ps_ato
  real(kind=db), dimension(3,n_counter_dip):: posg_dip, ps_dip
  real(kind=db), dimension(3,n_counter_ion):: posg_ion, ps_ion
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(3,natomp_ato):: Pos_ato
  real(kind=db), dimension(3,natomp_dip):: Pos_dip
  real(kind=db), dimension(3,natomp_ion):: Pos_ion

  real(kind=db), dimension(:,:), allocatable:: pos_t, posg

  if( Bulk_step ) then
    igr0 = ngroup - n_atom_bulk + 1
    n_igr = ngroup
    axyz_g(:) = axyz_bulk(:)
  else
    igr0 = 1
    if( Sym_2D ) then
      n_igr = n_atom_uc
      dcosxyz_int(:) = 2 * cos( angxyz_int(:) )
      dcosxyz_sur(:) = 2 * cos( angxyz_sur(:) )
      cos_z = sqrt( sin( angxyz(2) )**2 - ( ( cos( angxyz(1) ) - cos( angxyz(3) ) * cos( angxyz(2) ) ) &
            / sin( angxyz(3) ) )**2 )
      if( n_atom_int > 0 ) &
        cos_z_i = sqrt( sin( angxyz_int(2) )**2 - ( ( cos( angxyz_int(1) ) - cos( angxyz_int(3) ) * cos( angxyz_int(2) ) ) &
                / sin( angxyz_int(3) ) )**2 )
      if( n_atom_sur > 0 ) &
        cos_z_s = sqrt( sin( angxyz_sur(2) )**2 - ( ( cos( angxyz_sur(1) ) - cos( angxyz_sur(3) ) * cos( angxyz_sur(2) ) ) &
                / sin( angxyz_sur(3) ) )**2 )
      if( n_atom_bulk > 0 ) &
        cos_z_b = sqrt( sin( angxyz_bulk(2) )**2 - ( ( cos( angxyz_bulk(1) ) - cos( angxyz_bulk(3) ) * cos( angxyz_bulk(2) ) ) &
                / sin( angxyz_sur(3) ) )**2 )
    else
! When the is no interface with the film of when no film n_atom_per = n_atom_uc
      n_igr = n_atom_per
    endif
    axyz_g(:) = axyz(:)
  endif

  allocate( posg(3,igr0:n_igr) )

  if( Bulk_step ) then
    do igr = igr0,n_igr
      posg(1:3,igr) = posn_bulk(1:3,igr-ngroup+n_atom_bulk) * axyz_g(1:3) - deccent(1:3)
    end do
  else
    do igr = igr0,n_atom_per
      posg(1:3,igr) = posn(1:3,igr) * axyz(1:3) - deccent(1:3)
    end do
    if( Sym_2D ) then
      do igr = n_atom_per + 1, n_atom_per + n_atom_sur
        posg(1:3,igr) = posn(1:3,igr) * axyz_sur(1:3) - deccent(1:3)

        if( Numbering ) cycle

        do i = 1,n_counter_ion
          if( nint( Counter_ion(6,i) ) /= igr ) cycle
          posg_ion(1:3,i) = Counter_ion(1:3,i) * axyz_sur(1:3) - deccent(1:3)
        end do
        do i = 1,n_counter_dip
          if( nint( Counter_dip(6,i) ) /= igr ) cycle
          posg_dip(1:3,i) = Counter_dip(1:3,i) * axyz_sur(1:3) - deccent(1:3)
        end do
        do i = 1,n_counter_ato
          if( nint( Counter_ato(6,i) ) /= igr ) cycle
          posg_ato(1:3,i) = Counter_ato(1:3,i) * axyz_sur(1:3) - deccent(1:3)
        end do

      end do

      do igr = n_atom_per + n_atom_sur + 1, n_atom_per + n_atom_sur + n_atom_int
        posg(1:3,igr) = posn(1:3,igr) * axyz_int(1:3) - deccent(1:3)
      end do

    endif
  endif

  if( Matper ) then
    nxmaille = nint( Rmax / axyz(1) ) + 3
    nymaille = nint( Rmax / axyz(2) ) + 3
    if( n_atom_per == 0 .and. .not. Bulk_step ) then
      nzmaille = 0
    elseif( Sym_2D ) then
      if( n_atom_int /= 0 ) then
        nxmaille = max( nxmaille, nint( Rmax / axyz_int(1) ) + 3 )
        nymaille = max( nymaille, nint( Rmax / axyz_int(2) ) + 3 )
      endif
      if( n_atom_sur /= 0 ) then
        nxmaille = max( nxmaille, nint( Rmax / axyz_sur(1) ) + 3 )
        nymaille = max( nymaille, nint( Rmax / axyz_sur(2) ) + 3 )
      endif
      nzmaille = nint( Film_thickness / axyz(3) ) + 3
    else
      nzmaille = nint( Rmax / axyz(3) ) + 3
    endif
  else
    nxmaille = 0
    nymaille = 0
    nzmaille = 0
  endif

  if( Numbering ) then
    natomeq_s(:) = 0
    natomeq_coh = 0
    natomp = 0
    natomp_ato = 0
    natomp_dip = 0
    natomp_ion = 0
    ipr_ok(:) = .false.
    n = ngroup * ( 2 * nxmaille + 1 ) * ( 2 * nymaille + 1 ) * ( 2 * nzmaille + 1 )
    allocate( pos_t(3,n) )
  else
    iaabs = 0
    ia = 0
    ia_ato = 0
    ia_dip = 0
    ia_ion = 0
  endif

  if( iabsorbeur <= n_atom_per ) then
    iabs_slab = 1
  elseif( iabsorbeur <= n_atom_per + n_atom_sur ) then
    iabs_slab = 2
  else
    iabs_slab = 3 ! in the interface
  endif

  if( iabsfirst <= n_atom_per ) then
    iabsfirst_slab = 1
  elseif( iabsfirst <= n_atom_per + n_atom_sur ) then
    iabsfirst_slab = 2
  else
    iabsfirst_slab = 3 ! in the interface
  endif

  do ix = -nxmaille,nxmaille
    do iy = -nymaille,nymaille
      do iz = -nzmaille,nzmaille
        boucle_igr: do igr = igr0,n_igr
          if( Sym_2D ) then
            if( ( igr > n_atom_per .and. iz /= 0 ) .or. iz < 0 ) cycle
          endif
          if( ngroup_pdb > 0 ) then
            if( Kgroup(iabsorbeur) /= Kgroup(igr) .and. Kgroup(iabsorbeur) /= 0 .and. Kgroup(igr) /= 0 ) cycle
          endif

          if( igr <= n_atom_per ) then
            igr_slab = 1
          elseif( igr <= n_atom_per + n_atom_sur ) then
            igr_slab = 2
          else
            igr_slab = 3 ! in the interface
          endif

          Different_slab = igr_slab /= iabs_slab

          Abs_case = ix == 0 .and. iy == 0 .and. iz == 0 .and. ( ( Doping .and. igr == igr_dop ) .or. igr == iabsorbeur )

          if( ix == 0 .and. iy == 0 .and. iz == 0 .and. itype(igr) /= itype(iabsorbeur) .and. .not. Different_slab ) then
            if( Doping ) then
              if( igr /= igr_dop .and. sum( abs(posg(:,igr) - posg(:,igr_dop)) ) < eps6 ) cycle
            else
              if( sum( abs(posg(:,igr) - posg(:,iabsorbeur)) ) < eps6 ) cycle
            endif
          endif
          if( Bulk .or. igr <= n_atom_per ) then
            v(1) = ix * axyz_g(1)
            v(2) = iy * axyz_g(2)
            v(3) = iz * axyz_g(3)
          elseif( igr <= n_atom_per + n_atom_int ) then
            v(1) = ix * axyz_int(1)
            v(2) = iy * axyz_int(2)
            v(3) = iz * axyz_int(3)
          else
            v(1) = ix * axyz_sur(1)
            v(2) = iy * axyz_sur(2)
            v(3) = iz * axyz_sur(3)
          endif
          ps(1:3) = posg(1:3,igr) + v(1:3)

          if( .not. Numbering ) then
            Counter = .false.
            do i = 1,n_counter_ion
              if( nint( Counter_ion(6,i) ) /= igr ) cycle
              ps_ion(1:3,i) = posg_ion(1:3,i) + v(1:3)
              Counter = .true.
            end do
            Counter_d = .false.
            do i = 1,n_counter_dip
              if( nint( Counter_dip(6,i) ) /= igr ) cycle
              ps_dip(1:3,i) = posg_dip(1:3,i) + v(1:3)
              Counter_d = .true.
            end do
            Counter_a = .false.
            do i = 1,n_counter_ato
              if( nint( Counter_ato(6,i) ) /= igr ) cycle
              ps_ato(1:3,i) = posg_ato(1:3,i) + v(1:3)
              Counter_a = .true.
            end do
          endif

          if( Sym_2D ) then

            if( igr_slab == 1 ) then

              if( ps(3) * cos_z + deccent(3) > Film_thickness + eps10 ) cycle
              if( iabsfirst_slab == 3 ) then
                ps(3) = ps(3) + ( Delta_Film - Delta_int ) / cos_z
                ps(1:2) = ps(1:2) + Film_shift(1:2)
              elseif( iabsfirst_slab == 2 ) then
                ps(3) = ps(3) - ( Delta_film - Delta_sur ) / cos_z
                ps(1:2) = ps(1:2) - Surface_shift(1:2)
              endif

            elseif( iabsfirst_slab == 3 .and. igr_slab == 2 ) then

              ps(3) = ps(3) + ( Delta_sur - Delta_int ) / cos_z_s
              ps(1:2) = ps(1:2) + Film_shift(1:2) + Surface_shift(1:2)

              if( .not. Numbering ) then
                if( Counter ) then
                  do i = 1,n_counter_ion
                    if( nint( Counter_ion(6,i) ) /= igr ) cycle
                    ps_ion(1:2,i) = ps_ion(1:2,i) + Film_shift(1:2) + Surface_shift(1:2)
                  end do
                endif
                if( Counter_d ) then
                  do i = 1,n_counter_dip
                    if( nint( Counter_dip(6,i) ) /= igr ) cycle
                    ps_dip(1:2,i) = ps_dip(1:2,i) + Film_shift(1:2) + Surface_shift(1:2)
                  end do
                endif
                if( Counter_a ) then
                  do i = 1,n_counter_ato
                    if( nint( Counter_ato(6,i) ) /= igr ) cycle
                    ps_ato(1:2,i) = ps_ato(1:2,i) + Film_shift(1:2) + Surface_shift(1:2)
                  end do
                endif
              endif

            elseif( iabsfirst_slab == 2 .and. igr_slab == 3 ) then

              ps(3) = ps(3) - ( Delta_sur - Delta_int ) / cos_z_i
              ps(1:2) = ps(1:2) - Film_shift(1:2) - Surface_shift(1:2)

            endif

          endif

          if( Numbering ) then

            if( .not. Abs_case ) then
              do ib = 1,natomp
                p(:) = ps(:) - pos_t(:,ib)
                if( Bulk_step .or. igr <= n_atom_per ) then
                  dist = Vnorme(Base_ortho,dcosxyz,p)
                elseif( igr <= n_atom_per + n_atom_int ) then
                  dist = Vnorme(Base_ortho_int,dcosxyz_int,p)
                else
                  dist = Vnorme(Base_ortho_sur,dcosxyz_sur,p)
                endif
                if( dist < Dist_atom_min .and. .not. ( dist < eps10 .and. ATA ) ) cycle boucle_igr
              end do
            endif

          else

 ! Check on atoms too close
            do ib = 1,ia
              jgr = igroup(ib)

              p(:) = pos(:,ib) - ps(:)
              if( Bulk_step .or. igr <= n_atom_per ) then
                dist = Vnorme(Base_ortho,dcosxyz,p)
              elseif( igr <= n_atom_per + n_atom_int ) then
                dist = Vnorme(Base_ortho_int,dcosxyz_int,p)
              else
                dist = Vnorme(Base_ortho_sur,dcosxyz_sur,p)
              endif
              if( dist > Dist_atom_min .or. ( dist < eps10 .and. ATA ) ) cycle

              if( ngroup_taux == 0 ) then
                call write_error
                do iprint = 6,9,3
                  write(iprint,120)
                  write(iprint,125)
                  write(iprint,128) jgr, posn(1:3,jgr), igr, posn(1:3,igr)
                end do
                stop
              else
                if( Taux_oc( jgr ) + Taux_oc( igr ) > 1._db + eps10 ) then
                  call write_error
                  do iprint = 6,9,3
                    write(iprint,120)
                    write(iprint,130) jgr, posn(1:3,jgr), Taux_oc( jgr ), igr, posn(1:3,igr), Taux_oc( igr )
                  end do
                  stop
                endif
              endif

              if( Taux_oc( igroup(ib) ) <= Taux_oc( igr ) - eps10 .or. Abs_case ) then
                itypep(ib) = abs( itype(igr) )
                igroup(ib) = igr
              endif
              cycle boucle_igr

            end do

          endif

          if( Bulk_step .or. igr <= n_atom_per ) then
            dist = Vnorme(Base_ortho,dcosxyz,ps)
            dist_pot = dist
            dist_SCF = dist
          elseif( igr <= n_atom_per + n_atom_int ) then
            dist = Vnorme(Base_ortho_int,dcosxyz_int,ps)
            dist_pot = dist
            dist_SCF = dist
          else
            dist = Vnorme(Base_ortho_sur,dcosxyz_sur,ps)
! In surface, for the potential superposition one takes all the cylinder from the central point up to the surface
            if( Cylinder_cluster(1) .and. Posg(3,igr) > 0._db ) then
              p(1:2) = ps(1:2)
              p(3) = 0._db
              dist_pot = Vnorme(Base_ortho_sur,dcosxyz_sur,p)
              if( Cylinder_cluster(2) ) then
                dist_SCF = dist_pot
              else
                dist_SCF = dist
              endif
            else
              dist_pot = dist
              dist_SCF = dist
            endif
          endif

          if( Numbering ) then

            if( dist_SCF <= R_SCF_c + eps10 ) then
              natomeq_coh = natomeq_coh + 1
              boucle_ipr: do ipr = 1,n_atom_proto
                do jgr = 1,ngreq(ipr)
                  if( igreq(ipr,jgr) /= igr ) cycle
                  ipr_ok(ipr) = .true.
                  exit boucle_ipr
                end do
              end do boucle_ipr
            endif
            do i_radius = 1,n_radius
              if( dist > rsorte_s(i_radius) + eps10 ) cycle
              natomeq_s(i_radius) = natomeq_s(i_radius) + 1
            end do

            if( dist_pot <= Rmax + eps10 ) then
              natomp = natomp + 1
              pos_t(:,natomp) = ps(:)
              if( n_counter_ato > 0 ) then
                do i = 1,n_counter_ato
                  if( nint( Counter_ato(6,i) ) /= igr ) cycle
                  natomp_ato = natomp_ato + 1
                end do
              endif
              if( n_counter_dip > 0 ) then
                do i = 1,n_counter_dip
                  if( nint( Counter_dip(6,i) ) /= igr ) cycle
                  natomp_dip = natomp_dip + 1
                end do
              endif
              if( n_counter_ion > 0 ) then
                do i = 1,n_counter_ion
                  if( nint( Counter_ion(6,i) ) /= igr ) cycle
                  natomp_ion = natomp_ion + 1
                end do
              endif
            endif

          else

            if( dist_pot > Rmax + eps10 ) cycle
            ia = ia + 1
            pos(1:3,ia) = ps(1:3)
            if( Counter ) then
              do i = 1,n_counter_ion
                if( nint( Counter_ion(6,i) ) /= igr ) cycle
                ia_ion = ia_ion + 1
                pos_ion(1:3,ia_ion) = ps_ion(1:3,i)
                igroup_ion(ia_ion) = i
              end do
            endif
            if( Counter_d ) then
              do i = 1,n_counter_dip
                if( nint( Counter_dip(6,i) ) /= igr ) cycle
                ia_dip = ia_dip + 1
                pos_dip(1:3,ia_dip) = ps_dip(1:3,i)
                igroup_dip(ia_dip) = i
              end do
            endif
            if( Counter_a ) then
              do i = 1,n_counter_ato
                if( nint( Counter_ato(6,i) ) /= igr ) cycle
                ia_ato = ia_ato + 1
                pos_ato(1:3,ia_ato) = ps_ato(1:3,i)
                igroup_ato(ia_ato) = i
             end do
            endif

            if( Doping .and. igr == igr_dop .and. ix == 0 .and. iy == 0 .and. iz == 0 ) then
              igroup(ia) = n_atom_uc + 1
            else
              igroup(ia) = igr
            endif

            if( Abs_case ) then
              itypep(ia) = itabs
              iaabs = ia
            else
              itypep(ia) = abs( itype(igr) )
            endif
          endif

        end do boucle_igr
      end do
    end do
  end do

  if( Numbering ) deallocate( pos_t )

  if( Sym_2D .and. Bulk ) then

    do igr = 1,n_atom_bulk
      posg_bulk(1:3,igr) = posn_bulk(1:3,igr) * axyz_bulk(1:3)
    end do

    dcosxyz_bulk(:) = 2 * cos( angxyz_bulk(:) )
    if( abs( dcosxyz_bulk(1) ) < eps10 .and. abs( dcosxyz_bulk(2) ) < eps10 .and. abs( dcosxyz_bulk(3) ) < eps10 ) then
      Base_ortho_bulk = .true.
    else
      Base_ortho_bulk = .false.
    endif

    nxmaille = nint( rmax / axyz_bulk(1) ) + 3
    nymaille = nint( rmax / axyz_bulk(2) ) + 3
    nzmaille = nint( rmax / axyz_bulk(3) ) + 3

    do ix = -nxmaille,nxmaille
      v(1) = ix * axyz_bulk(1)
      do iy = -nymaille,nymaille
        v(2) = iy * axyz_bulk(2)
        do iz = 0,-nzmaille,-1
          v(3) = iz * axyz_bulk(3)

          boucle_igr_bulk: do igr_b = 1,n_atom_bulk

            igr = ngroup - n_atom_bulk + igr_b

            ps(1:3) = posg_bulk(1:3,igr_b) + v(1:3)
            if( iabsfirst_slab == 3 ) then
              ps(3) = ps(3) + ( Delta_bulk - Delta_int ) / cos_z_b
              ps(1:2) = ps(1:2) - Interface_shift(1:2)
            elseif( iabsfirst_slab == 2 ) then
              ps(3) = ps(3) + ( Delta_bulk - Delta_sur ) / cos_z_b
              ps(1:2) = ps(1:2) - Interface_shift(1:2) - Film_shift(1:2) - Surface_shift(1:2)
            endif
            ps(:) = ps(:) - deccent(:)

            if( Numbering ) then

              if( .not. ATA ) then
                do jgr_b = 1,igr_b - 1
                 if( sum( abs( posg_bulk(:,igr_b) - posg_bulk(:,jgr_b) ) ) < Dist_atom_min )  cycle boucle_igr_bulk
                end do
              endif

              dist = Vnorme(Base_ortho_bulk,dcosxyz_bulk,ps)
              if( dist <= R_SCF_c + eps10 ) then
                natomeq_coh = natomeq_coh + 1
                boucle_ipr_bis: do ipr = 1,n_atom_proto
                  do jgr = 1,ngreq(ipr)
                    if( igreq(ipr,jgr) /= igr ) cycle
                    ipr_ok(ipr) = .true.
                    exit boucle_ipr_bis
                  end do
                end do boucle_ipr_bis
              endif
              do i_radius = 1,n_radius
                if( dist <= rsorte_s(i_radius) + eps10 ) natomeq_s(i_radius) = natomeq_s(i_radius) + 1
              end do
              if( dist <= rmax + eps10 ) then
                natomp = natomp + 1
              endif

            else

 ! Check on atoms too close
              do ib = 1,ia
                jgr = igroup(ib)
                if( jgr > ngroup-n_atom_bulk ) then
                  jgr_b = - ngroup + n_atom_bulk + jgr
                else
                  jgr_b = jgr
                endif

                p(:) = pos(:,ib) - ps(:)
                dist = Vnorme(Base_ortho_bulk,dcosxyz_bulk,p)

                if( dist > Dist_atom_min .or. ( dist < eps10 .and. ATA ) ) cycle

                if( ngroup_taux == 0 ) then
                  call write_error
                  do iprint = 6,9,3
                    write(iprint,120)
                    write(iprint,125)
                    if( jgr > ngroup-n_atom_bulk ) then
                      write(iprint,128) jgr, posn_bulk(1:3,jgr_b), igr, posn_bulk(1:3,igr_b)
                    else
                      write(iprint,128) jgr, posn(1:3,jgr), igr, posn_bulk(1:3,igr_b)
                    endif
                  end do
                  stop
                else
                  if( Taux_oc( jgr ) + Taux_oc( igr ) > 1._db + eps10 ) then
                    call write_error
                    do iprint = 6,9,3
                      write(iprint,120)
                      if( jgr > ngroup-n_atom_bulk ) then
                        write(iprint,130) jgr, posn_bulk(1:3,jgr_b), Taux_oc( jgr ), igr, posn_bulk(1:3,igr_b), Taux_oc( igr )
                      else
                        write(iprint,130) jgr, posn(1:3,jgr), Taux_oc( jgr ), igr, posn_bulk(1:3,igr_b), Taux_oc( igr )
                      endif
                    end do
                    stop
                  endif
                endif

! Substitution
                if( Taux_oc( jgr ) <= Taux_oc( igr ) - eps10 ) then
                  itypep(ib) = abs( itype(igr) )
                  igroup(ib) = igr
                endif

                cycle boucle_igr_bulk

              end do

              dist = Vnorme(Base_ortho_bulk,dcosxyz_bulk,ps)
              if( dist > rmax + eps10 ) cycle
              ia = ia + 1
              pos(1:3,ia) = ps(1:3)
              igroup(ia) = igr
              itypep(ia) = abs( itype( igr ) )

            endif

          end do boucle_igr_bulk

        end do
      end do
    end do

  endif

  if( Numbering ) then
! Proto_all is used in routine fdm to define the Full_atom mode
    Proto_all = .true.
    do ipr = 1,n_atom_proto
      if( Bulk_step .and. ipr <= n_atom_proto_uc ) cycle
      if( ipr_ok(ipr) ) cycle
      Proto_all = .false.
      exit
    end do

  else

    if( First_run ) iaabsfirst = iaabs

  endif

  deallocate( Posg )

  return
  120 format(//' Error in the indata file:',/ &
               ' Two atoms are too close with the sum of their occupancy > 1',/)
  122 format(//' Error in the indata file:',/ &
               ' Two atoms in the bulk are too close with the sum of their occupancy > 1',/)
  125 format(' Possibly after a unit cell shift',/)
  128 format(' Atoms',i5,' at p =',3f11.7,/'   and',i5,' at p =',3f11.7)
  130 format(' Atoms',i5,' at p =',3f11.7,', with occupancy =',f7.3,/'   and',i5,' at p =',3f11.7,', with occupancy =',f7.3)
  140 format(3i4,4f13.7)
end

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

! Calculation of the number of atoms in the clusters used for potential calculation and xanes calculation
! or building of it.
! Called by Natomp_cal (Numbering = true) and Clust (Numbering = false)
! Work only in surface cases with bulk and surface atoms and without interface

subroutine Cluster_building_surf(angxyz_bulk,angxyz_sur,ATA,Atom_SCF_clust,axyz_bulk,axyz_sur,Base_ortho_sur,Bulk_step, &
        Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster,deccent,deccent_bulk,Delta_bulk,Delta_sur,Dist_atom_min, &
        First_run,iaabs,iaabsfirst,iabsorbeur,igreq,igroup,igroup_ato,igroup_dip,igroup_ion,itabs, &
        itype,itypep,n_atom_bulk,n_atom_proto,n_atom_proto_uc,n_atom_uc,n_counter_ato,n_counter_dip,n_counter_ion,n_radius, &
        natomeq_coh,natomeq_s,natomp,natomp_ato,natomp_dip,natomp_ion,neqm,ngreq,ngroup,ngroup_taux, &
        Numbering,posn,Pos,Pos_ato,Pos_dip,Pos_ion,posn_bulk,Proto_all,R_SCF_c,Rsorte_s,Rmax,Surface_shift, &
        Taux_oc)

  use declarations
  implicit none

  integer:: i, i_radius, ia, ia_ato, ia_dip, ia_ion, iaabs, iaabsfirst, iabsorbeur, ib, igr, ipr, iprint, itabs, &
     ix, iy, iz, jgr, n, n_atom_bulk, n_atom_proto, n_atom_proto_uc, n_atom_uc, n_counter_ato, n_counter_dip, &
     n_counter_ion, n_radius, natomeq_coh, natomp, natomp_ato, natomp_dip, natomp_ion, neqm, ngroup, &
     ngroup_taux

  integer, dimension(3):: n_maille, n_maille_bulk, n_maille_sur
  integer, dimension(natomp):: igroup, itypep
  integer, dimension(ngroup):: itype
  integer, dimension(n_radius):: natomeq_s
  integer, dimension(0:n_atom_proto):: ngreq
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(natomp_ato):: igroup_ato
  integer, dimension(natomp_dip):: igroup_dip
  integer, dimension(natomp_ion):: igroup_ion

  logical:: Abs_case, ATA, Base_ortho_bulk, Base_ortho_sur, Bulk_step, Counter, Counter_a, Counter_d, &
        First_run, Force_inversion, Numbering, Proto_all, Surface_atom

  logical, dimension(2):: Cylinder_cluster
  logical, dimension(n_atom_proto):: ipr_ok
  logical, dimension(natomp):: Atom_SCF_clust

  real(kind=db):: cos_z_b, cos_z_s, Delta_bulk, Delta_sur, dist, dist_abs, dist_pot, &
    dist_SCF, Dist_atom_min, R_SCF_c, Rmax, Vnorme

  real(kind=db), dimension(n_radius):: rsorte_s
  real(kind=db), dimension(3):: angxyz_bulk, angxyz_sur, axyz_bulk, axyz_sur, dcosxyz_bulk, dcosxyz_sur, deccent, deccent_bulk, &
                                Delta_Surf_Bulk, P, Ps, Ps_abs, Q, V
  real(kind=db), dimension(4):: Surface_shift
  real(kind=db), dimension(ngroup_taux):: Taux_oc
  real(kind=db), dimension(3,n_atom_uc):: posn
  real(kind=db), dimension(3,n_atom_bulk):: posn_bulk
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(6,n_counter_dip):: Counter_dip
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion
  real(kind=db), dimension(3,n_counter_ato):: posg_ato, ps_ato
  real(kind=db), dimension(3,n_counter_dip):: posg_dip, ps_dip
  real(kind=db), dimension(3,n_counter_ion):: posg_ion, ps_ion
  real(kind=db), dimension(3,natomp):: Pos
  real(kind=db), dimension(3,natomp_ato):: Pos_ato
  real(kind=db), dimension(3,natomp_dip):: Pos_dip
  real(kind=db), dimension(3,natomp_ion):: Pos_ion

  real(kind=db), dimension(:,:), allocatable:: pos_t, posg

  dcosxyz_sur(:) = 2 * cos( angxyz_sur(:) )
  cos_z_s = sqrt( sin( angxyz_sur(2) )**2 - ( ( cos( angxyz_sur(1) ) - cos( angxyz_sur(3) ) * cos( angxyz_sur(2) ) ) &
          / sin( angxyz_sur(3) ) )**2 )

  if( n_atom_bulk > 0 ) &
    cos_z_b = sqrt( sin( angxyz_bulk(2) )**2 - ( ( cos( angxyz_bulk(1) ) - cos( angxyz_bulk(3) ) * cos( angxyz_bulk(2) ) ) &
            / sin( angxyz_bulk(3) ) )**2 )

  dcosxyz_bulk(:) = 2 * cos( angxyz_bulk(:) )
  if( abs( dcosxyz_bulk(1) ) < eps10 .and. abs( dcosxyz_bulk(2) ) < eps10 .and. abs( dcosxyz_bulk(3) ) < eps10 ) then
    Base_ortho_bulk = .true.
  else
    Base_ortho_bulk = .false.
  endif

  allocate( Posg(3,ngroup) )

  if( Bulk_step ) then
    Delta_Surf_Bulk(:) = 0._db
  else
!    Delta_Surf_Bulk(:) = - deccent(:) + deccent_bulk(:)
    Delta_Surf_Bulk(:) = - deccent(:)

    Delta_Surf_Bulk(1:2) = Delta_Surf_Bulk(1:2) - Surface_shift(1:2)
!    Delta_Surf_Bulk(3) = Delta_Surf_Bulk(3) + ( Delta_bulk - Delta_sur ) / cos_z_s
    Delta_Surf_Bulk(3) =  Delta_Surf_Bulk(3) - Delta_sur / cos_z_s

  endif

  do igr = 1, n_atom_uc

!    V(:) =  - deccent(:)
    V(:) =  - deccent_bulk(:)
! Relative shift between Surface and bulk. The origin is at the absorbing site of the current calculation
!   if( Bulk_step ) then
      V(1:2) = V(1:2) + Surface_shift(1:2)
      V(3) = V(3) - ( Delta_bulk - Delta_sur ) / cos_z_s
!      V(3) = V(3) + Delta_sur / cos_z_s
!   endif

    Posg(1:3,igr) = posn(1:3,igr) * axyz_sur(1:3) + V(1:3)

    if( Numbering ) cycle

    do i = 1,n_counter_ion
      if( nint( Counter_ion(6,i) ) /= igr ) cycle
      posg_ion(1:3,i) = Counter_ion(1:3,i) * axyz_sur(1:3) + V(1:3)
    end do
    do i = 1,n_counter_dip
      if( nint( Counter_dip(6,i) ) /= igr ) cycle
      posg_dip(1:3,i) = Counter_dip(1:3,i) * axyz_sur(1:3) + V(1:3)
    end do
    do i = 1,n_counter_ato
      if( nint( Counter_ato(6,i) ) /= igr ) cycle
      posg_ato(1:3,i) = Counter_ato(1:3,i) * axyz_sur(1:3) + V(1:3)
    end do

  end do

! bulk
  V(:) =  - deccent_bulk(:)
!  V(:) =  - deccent(:)
! Relative shift between Surface and bulk. The origin is at the absorbing site of the current calculation
!  if( .not. Bulk_step ) then
!    V(1:2) = V(1:2) - Surface_shift(1:2)
!    V(3) = V(3) + ( Delta_bulk - Delta_sur ) / cos_z_s
!  endif
  do igr = n_atom_uc+1,ngroup
    posg(1:3,igr) = posn_bulk(1:3,igr-n_atom_uc) * axyz_bulk(1:3) + V(1:3)
  end do

  n_maille_bulk(:) = nint( Rmax / axyz_bulk(:) ) + 3

  n_maille_sur(1:2) = nint( Rmax / axyz_sur(1:2) ) + 3
  n_maille_sur(3) = 0

  do i = 1,3
    n_maille(i) = max( n_maille_bulk(i), n_maille_sur(i) )
  end do

 ! if( Bulk_step ) n_maille(3) = 0
  n_maille(3) = 0

  if( Numbering ) then
    natomeq_s(:) = 0
    natomeq_coh = 0
    natomp = 0
    natomp_ato = 0
    natomp_dip = 0
    natomp_ion = 0
    ipr_ok(:) = .false.
    n = 2 * n_atom_uc * ( 2 * n_maille_sur(1) + 1 ) * ( 2 * n_maille_sur(2) + 1 ) &
      + n_atom_bulk * ( 2 * n_maille_bulk(1) + 1 ) * ( 2 * n_maille_bulk(2) + 1 ) * ( 2 * n_maille_bulk(3) + 1 )
    allocate( Pos_t(3,n) )
  else
    iaabs = 0
    ia = 0
    ia_ato = 0
    ia_dip = 0
    ia_ion = 0
  endif

  do ix = -n_maille(1), n_maille(1)
    do iy = -n_maille(2), n_maille(2)
      do iz = -n_maille(3), 0

        boucle_igr: do igr = 1,ngroup

          Surface_atom = igr <= n_atom_uc

          if( Surface_atom .and. iz < 0 ) cycle

          Abs_case = ix == 0 .and. iy == 0 .and. iz == 0 .and. igr == iabsorbeur

          if( ix == 0 .and. iy == 0 .and. iz == 0 .and. itype(igr) /= itype(iabsorbeur) ) then
            if( sum( abs(posg(:,igr) - posg(:,iabsorbeur)) ) < eps6 ) cycle
          endif

          Force_inversion = Surface_atom
!          if( Bulk_step .and. Posg(3,igr) < - eps10 ) cycle
          if( Posg(3,igr) < - eps10 ) cycle

          if( Surface_atom ) then
            V(1) = ix * axyz_sur(1)
            V(2) = iy * axyz_sur(2)
            V(3) = 0._db
          else
            V(1) = ix * axyz_bulk(1)
            V(2) = iy * axyz_bulk(2)
            V(3) = iz * axyz_bulk(3)
          endif

          Ps(1:3) = Posg(1:3,igr) + V(1:3)
          Ps_abs(1:3) = Ps(1:3) + Delta_Surf_Bulk(1:3)

          if( Surface_atom .and. .not. Numbering ) then
            Counter = .false.
            do i = 1,n_counter_ion
              if( nint( Counter_ion(6,i) ) /= igr ) cycle
              ps_ion(1:3,i) = posg_ion(1:3,i) + V(1:3)
              Counter = .true.
            end do
            Counter_d = .false.
            do i = 1,n_counter_dip
              if( nint( Counter_dip(6,i) ) /= igr ) cycle
              ps_dip(1:3,i) = posg_dip(1:3,i) + V(1:3)
              Counter_d = .true.
            end do
            Counter_a = .false.
            do i = 1,n_counter_ato
              if( nint( Counter_ato(6,i) ) /= igr ) cycle
              ps_ato(1:3,i) = posg_ato(1:3,i) + V(1:3)
              Counter_a = .true.
            end do
          endif

! Check on atoms too close
          if( Numbering ) then
            if( .not. Abs_case ) then
              do ib = 1,natomp
                P(:) = Ps(:) - Pos_t(:,ib)
                if( Bulk_step ) then
                  dist = Vnorme(Base_ortho_bulk,dcosxyz_bulk,P)
                else
                  dist = Vnorme(Base_ortho_sur,dcosxyz_sur,P)
                endif
                if( dist < Dist_atom_min .and. .not. ( dist < eps10 .and. ATA ) ) cycle boucle_igr
              end do
            endif

          else

 ! Check on atoms too close
            do ib = 1,ia
              jgr = igroup(ib)

              p(:) = pos(:,ib) - ps(:)
              if( Bulk_step ) then
                dist = Vnorme(Base_ortho_bulk,dcosxyz_bulk,p)
              else
                dist = Vnorme(Base_ortho_sur,dcosxyz_sur,p)
              endif
              if( dist > Dist_atom_min .or. ( dist < eps10 .and. ATA ) ) cycle

              if( ngroup_taux > 0 ) then
                if( Taux_oc( jgr ) + Taux_oc( igr ) < 1._db + eps10 ) then
                  if( Taux_oc( igroup(ib) ) <= Taux_oc( igr ) - eps10 .or. Abs_case ) then
                    itypep(ib) = abs( itype(igr) )
                    igroup(ib) = igr
                  endif
                  cycle boucle_igr
                endif
              endif

              if( igr <= n_atom_uc ) then
                P(1:3) = Posn(1:3,igr)
              else
                P(1:3) = Posn_bulk(1:3,igr-n_atom_uc)
              endif
              if( jgr <= n_atom_uc ) then
                Q(1:3) = Posn(1:3,jgr)
              else
                Q(1:3) = Posn_bulk(1:3,jgr-n_atom_uc)
              endif

              call write_error
              do iprint = 6,9,3
                write(iprint,120)
                if( ngroup_taux == 0 ) then
                  write(iprint,125)
                  write(iprint,128) jgr, Q(1:3), igr, P(1:3)
                else
                  write(iprint,130) jgr, Q(1:3), Taux_oc( jgr ), igr, P(1:3), Taux_oc( igr )
                endif
              end do
              stop

            end do

          endif

          if( Surface_atom ) then
            dist = Vnorme(Base_ortho_sur,dcosxyz_sur,Ps)
            dist_abs = Vnorme(Base_ortho_sur,dcosxyz_sur,Ps_abs)
          else
            dist = Vnorme(Base_ortho_bulk,dcosxyz_bulk,Ps)
            dist_abs = dist
          endif
! In surface, for the potential superposition one takes all the cylinder from the central point up to the surface
          if( Cylinder_cluster(1) .and. Posg(3,igr) > 0._db ) then
            P(1:2) = Ps(1:2)
            P(3) = 0._db
            dist_pot = Vnorme(Base_ortho_sur,dcosxyz_sur,P)
            if( Cylinder_cluster(2) ) then
              dist_SCF = dist_pot
            else
              dist_SCF = dist
            endif
          else
            dist_pot = dist
            dist_SCF = dist
          endif

          if( Numbering ) then

            if( dist_SCF <= R_SCF_c + eps10 ) then
              natomeq_coh = natomeq_coh + 1
              if( Force_inversion ) natomeq_coh = natomeq_coh + 1
              boucle_ipr: do ipr = 1,n_atom_proto
                do jgr = 1,ngreq(ipr)
                  if( igreq(ipr,jgr) /= igr ) cycle
                  ipr_ok(ipr) = .true.
                  exit boucle_ipr
                end do
              end do boucle_ipr
            endif
            do i_radius = 1,n_radius
              if( dist_abs > rsorte_s(i_radius) + eps10 ) cycle
              natomeq_s(i_radius) = natomeq_s(i_radius) + 1
              if( Force_inversion ) natomeq_s(i_radius) = natomeq_s(i_radius) + 1
            end do

            if( dist_pot <= Rmax + eps10 ) then
              natomp = natomp + 1
              pos_t(:,natomp) = ps(:)
              if( Force_inversion ) then
                natomp = natomp + 1
                pos_t(:,natomp) = - ps(:)
              endif
              if( n_counter_ato > 0 ) then
                do i = 1,n_counter_ato
                  if( nint( Counter_ato(6,i) ) /= igr ) cycle
                  natomp_ato = natomp_ato + 1
                  if( Force_inversion ) natomp_ato = natomp_ato + 1
                end do
              endif
              if( n_counter_dip > 0 ) then
                do i = 1,n_counter_dip
                  if( nint( Counter_dip(6,i) ) /= igr ) cycle
                  natomp_dip = natomp_dip + 1
                  if( Force_inversion ) natomp_dip = natomp_dip + 1
                end do
              endif
              if( n_counter_ion > 0 ) then
                do i = 1,n_counter_ion
                  if( nint( Counter_ion(6,i) ) /= igr ) cycle
                  natomp_ion = natomp_ion + 1
                  if( Force_inversion ) natomp_ion = natomp_ion + 1
                end do
              endif
            endif

          else

            if( dist_pot > Rmax + eps10 ) cycle
            ia = ia + 1
            igroup(ia) = igr
            pos(1:3,ia) = ps(1:3)
            if( Abs_case ) then
              itypep(ia) = itabs
              iaabs = ia
            else
              itypep(ia) = abs( itype(igr) )
            endif
            Atom_SCF_clust(ia) = dist_SCF <= R_SCF_c + eps10

            if( Force_inversion ) then
              ia = ia + 1
              igroup(ia) = igr
              pos(1:3,ia) = - ps(1:3)
              itypep(ia) = abs( itype(igr) )
              Atom_SCF_clust(ia) = dist_SCF <= R_SCF_c + eps10
            endif

            if( Counter ) then
              do i = 1,n_counter_ion
                if( nint( Counter_ion(6,i) ) /= igr ) cycle
                ia_ion = ia_ion + 1
                pos_ion(1:3,ia_ion) = ps_ion(1:3,i)
                igroup_ion(ia_ion) = i
                if( Force_inversion ) then
                  ia_ion = ia_ion + 1
                  pos_ion(1:3,ia_ion) = - ps_ion(1:3,i)
                  igroup_ion(ia_ion) = i
                endif
              end do
            endif
            if( Counter_d ) then
              do i = 1,n_counter_dip
                if( nint( Counter_dip(6,i) ) /= igr ) cycle
                ia_dip = ia_dip + 1
                pos_dip(1:3,ia_dip) = ps_dip(1:3,i)
                igroup_dip(ia_dip) = i
                if( Force_inversion ) then
                  ia_dip = ia_dip + 1
                  pos_dip(1:3,ia_dip) = - ps_dip(1:3,i)
                  igroup_dip(ia_dip) = i
                endif
              end do
            endif
            if( Counter_a ) then
              do i = 1,n_counter_ato
                if( nint( Counter_ato(6,i) ) /= igr ) cycle
                ia_ato = ia_ato + 1
                pos_ato(1:3,ia_ato) = ps_ato(1:3,i)
                igroup_ato(ia_ato) = i
                if( Force_inversion ) then
                  ia_ato = ia_ato + 1
                  pos_ato(1:3,ia_ato) = - ps_ato(1:3,i)
                  igroup_ato(ia_ato) = i
                endif
             end do
            endif

          endif

        end do boucle_igr

      end do
    end do
  end do

  if( Numbering ) then

    deallocate( Pos_t )

! Proto_all is used in routine fdm to define the Full_atom mode
    Proto_all = .true.
    do ipr = 1,n_atom_proto
      if( Bulk_step .and. ipr <= n_atom_proto_uc ) cycle
      if( ipr_ok(ipr) ) cycle
      Proto_all = .false.
      exit
    end do

  else

    if( First_run ) iaabsfirst = iaabs
    if( .not. Bulk_step ) then
      do ia = 1,natomp
        Pos(:,ia) = Pos(:,ia) + Delta_Surf_Bulk(:)
      end do
      do ia = 1,natomp_ato
        Pos_ato(:,ia) = Pos_ato(:,ia) + Delta_Surf_Bulk(:)
      end do
      do ia = 1,natomp_dip
        Pos_dip(:,ia) = Pos_dip(:,ia) + Delta_Surf_Bulk(:)
      end do
      do ia = 1,natomp_ion
        Pos_ion(:,ia) = Pos_ion(:,ia) + Delta_Surf_Bulk(:)
      end do
    endif

  endif

  deallocate( Posg )

  return
  120 format(//' Error in the indata file:',/ &
               ' Two atoms are too close with the sum of their occupancy > 1',/)
  122 format(//' Error in the indata file:',/ &
               ' Two atoms in the bulk are too close with the sum of their occupancy > 1',/)
  125 format(' Possibly after a unit cell shift',/)
  128 format(' Atoms',i5,' at p =',3f11.7,/'   and',i5,' at p =',3f11.7)
  130 format(' Atoms',i5,' at p =',3f11.7,', with occupancy =',f7.3,/'   and',i5,' at p =',3f11.7,', with occupancy =',f7.3)
  140 format(3i4,4f13.7)
end

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

subroutine Reduc_natomp(angxyz,angxyz_bulk,angxyz_int,angxyz_sur,ATA,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho,Base_ortho_int, &
            Base_ortho_sur,Bulk,Bulk_step,Center_s,chargat,Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster,d_ecrant,dcosxyz, &
            deccent,deccent_bulk,Delta_bulk,Delta_film,Delta_int,Delta_sur,Dist_atom_min,Doping,dpos,Film_shift,Film_thickness, &
            First_run,iabsorbeur,iabsfirst,icheck,igr_dop,igreq,Interface_shift,itabs,itype,Kgroup,matper,mpirank0,n_atom_bulk, &
            n_atom_int,n_atom_per,n_atom_proto,n_atom_sur,n_atom_uc,n_counter_ato,n_counter_dip,n_counter_ion,natomp,natomp_ato, &
            natomp_dip,natomp_ion,natomr,ngreq,ngroup,ngroup_pdb,ngroup_taux,Noncentre,One_SCF_surf,posn,posn_bulk,R_SCF_c,Rmax, &
            Rsortm,Surface_shift,Sym_2D,Taux_oc)

  use declarations
  implicit none

  integer:: ia, iaabs, iaabsfirst, iabsorbeur, iabsfirst, icheck, igr, igr_dop, ipr, itabs, mpirank0, &
    n_atom_bulk, n_atom_int, n_atom_per, n_atom_proto, n_atom_sur, n_atom_uc, n_counter_ato, n_counter_dip, n_counter_ion, na, &
    natomp, natomp_ato, natomp_dip, natomp_ion, natomq, natomr, ngroup, ngroup_pdb, ngroup_taux
  integer, dimension(natomp):: iaproto, igroup, itypep
  integer, dimension(natomp_ato):: igroup_ato
  integer, dimension(natomp_dip):: igroup_dip
  integer, dimension(natomp_ion):: igroup_ion
  integer, dimension(ngroup_pdb):: Kgroup
  integer, dimension(ngroup):: itype
  integer, dimension(0:n_atom_proto):: ngreq
  integer, dimension(0:n_atom_proto,ngroup):: igreq

  logical:: ATA, Base_ortho, Base_ortho_int, Base_ortho_sur, Bulk, Bulk_step, Center_s, Doping, First_run, Matper, Noncentre, &
            OK, One_SCF_surf, Sym_2D
  logical, dimension(2):: Cylinder_cluster

  real(kind=db):: Ch, Ch_min, Ch_test, Chagreg, Chg, d_ecrant, Delta_bulk, Delta_film, Delta_int, Delta_sur, &
    Dist_atom_min, Film_thickness, R_SCF_c, Rmax, Rsortm

  real(kind=db), dimension(3):: angxyz, angxyz_bulk, angxyz_int, angxyz_sur, axyz, axyz_bulk, axyz_int, axyz_sur, dcosxyz, &
                                deccent, deccent_bulk, dpos
  real(kind=db), dimension(4):: Film_shift, Interface_shift, Surface_shift
  real(kind=db), dimension(natomp):: dista
  real(kind=db), dimension(3,natomp):: pos
  real(kind=db), dimension(3,natomp_ato):: Pos_ato
  real(kind=db), dimension(3,natomp_dip):: Pos_dip
  real(kind=db), dimension(3,natomp_ion):: Pos_ion
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(6,n_counter_dip):: Counter_dip
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion
  real(kind=db), dimension(3,n_atom_bulk):: posn_bulk
  real(kind=db), dimension(3,n_atom_uc):: posn
  real(kind=db), dimension(ngroup_taux):: Taux_oc
  real(kind=db), dimension(0:n_atom_proto):: chargat

  Matper = .true.

  call Clust(angxyz,angxyz_bulk,angxyz_int,angxyz_sur,ATA,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho,Base_ortho_int, &
              Base_ortho_sur,Bulk,Bulk_step,Center_s,Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster,dcosxyz,deccent, &
              deccent_bulk, &
              Delta_bulk,Delta_film,Delta_int,Delta_sur,Dist_atom_min,dista,Doping,dpos,Film_shift,Film_thickness,First_run,iaabs, &
              iaabsfirst,iabsorbeur,iabsfirst,igr_dop,igroup,igroup_ato,igroup_dip,igroup_ion,Interface_shift,itabs,itype,itypep, &
              Kgroup,Matper,mpirank0,n_atom_bulk,n_atom_int,n_atom_per,n_atom_sur,n_atom_uc,n_counter_ato,n_counter_dip, &
              n_counter_ion,natomp,natomp_ato,natomp_dip,natomp_ion,ngroup,ngroup_pdb,ngroup_taux,Noncentre,One_SCF_surf,Pos, &
              Pos_ato,Pos_dip,Pos_ion,Posn,Posn_bulk,R_SCF_c,Rmax,Surface_shift,Sym_2D,Taux_oc)

  do ia = 1,natomp
    boucle_i: do ipr = 1,n_atom_proto
      do igr = 1,ngreq(ipr)
        if( igroup(ia) == igreq(ipr,igr) ) exit boucle_i
      end do
    end do boucle_i
    if( ipr > n_atom_proto ) then
      call write_error
      do ipr = 6,9,3
        write(ipr,'(//A)') '  Error in reduc_natomp'
        write(ipr,'(/a38,i4/)') '  Prototypical atom not found for atom', ia
      end do
      stop
    endif
    iaproto(ia) = ipr
  end do

! Calculation of the cluster charge:
  chagreg = 0._db
  do ia = 1,natomp
    if( igroup(ia) > ngroup - n_atom_bulk ) cycle
    ipr = iaproto(ia)
    chagreg = chagreg + chargat( ipr )
  end do

  if( abs( chagreg ) < eps10 ) then
    natomr = natomp
    return
  endif

  do ia = 1,natomp-1
    if( dista(ia+1) > rsortm ) exit
  end do
  natomq = ia

  na = natomq

  OK = .false.

  ch = chagreg
  do ia = natomp-1,natomq,-1
    if( igroup(ia) <= ngroup - n_atom_bulk ) then
      ipr = iaproto(ia+1)
      ch = ch - chargat(ipr)
    endif
    if( abs( dista(ia+1) - dista(ia) ) > 1.e-08_db ) then
      if( abs( ch - d_ecrant ) > eps10  ) cycle
      na = ia
      chg = ch
      OK = .true.
      exit
    endif
  end do

  if( .not. OK ) then
    na = natomp
    ch_min = chagreg - d_ecrant
    chg = chagreg
    do ia = natomp-1,natomq,-1
      if( igroup(ia) <= ngroup - n_atom_bulk ) then
        ipr = iaproto(ia+1)
        chg = chg - chargat(ipr)
      endif
      if( abs( dista(ia+1) - dista(ia) ) < 1.e-08_db ) cycle
      ch_test = chg - d_ecrant
      if( abs(ch_test) > abs(ch_min) - eps10 ) cycle
      ch_min = ch_test
      na = ia
    end do
  endif

  if( na > natomq .and. na < natomp ) then
    natomr = na
    chagreg = chg
    if( icheck > 0 ) write(3,110) na, dista(na)*bohr
    rmax = dista(natomr) + eps10
  else
    natomr = natomp
  endif

  return
  110 format(/' natomp reduced at =',i4,', dista(natomp) =',f11.5)
end

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

subroutine Clust(angxyz,angxyz_bulk,angxyz_int,angxyz_sur,ATA,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho,Base_ortho_int, &
              Base_ortho_sur,Bulk,Bulk_step,Center_s,Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster,dcosxyz,deccent, &
              deccent_bulk, &
              Delta_bulk,Delta_film,Delta_int,Delta_sur,Dist_atom_min,dista,Doping,dpos,Film_shift,Film_thickness,First_run, &
              iaabs,iaabsfirst,iabsorbeur,iabsfirst,igr_dop,igroup,igroup_ato,igroup_dip,igroup_ion,Interface_shift,itabs,itype, &
              itypep,Kgroup,Matper,mpirank0,n_atom_bulk,n_atom_int,n_atom_per,n_atom_sur,n_atom_uc,n_counter_ato,n_counter_dip, &
              n_counter_ion,natomp,natomp_ato,natomp_dip,natomp_ion,ngroup,ngroup_pdb,ngroup_taux,Noncentre,One_SCF_surf,Pos, &
              Pos_ato,Pos_dip,Pos_ion,Posn,Posn_bulk,R_SCF_c,Rmax,Surface_shift,Sym_2D,Taux_oc)

  use declarations
  implicit none

  ! not used here
  integer, parameter:: n_atom_proto = 0
  integer, parameter:: n_atom_proto_uc = 0
  integer, parameter:: n_atom_coh = 0
  integer, parameter:: n_radius = 0
  integer, parameter:: natomeq_coh = 0
  integer, parameter:: neqm = 0

  integer:: ia, ia1, ia2, iaabs, iaabsfirst, iabsorbeur, iabsfirst, ib, igr_dop, &
    igr12, ipr, itabs, ity12, mpirank0, n_atom_bulk, n_atom_int, n_atom_per, n_atom_sur, &
    n_atom_uc, n_counter_ato, n_counter_dip, n_counter_ion, natomp, natomp_ato, natomp_dip, natomp_ion, ngroup, &
    ngroup_pdb, ngroup_taux

  integer, dimension(ngroup):: itype
  integer, dimension(natomp):: igroup, itypep
  integer, dimension(natomp_ato):: igroup_ato
  integer, dimension(natomp_dip):: igroup_dip
  integer, dimension(natomp_ion):: igroup_ion
  integer, dimension(ngroup_pdb):: Kgroup

  integer, dimension(:), allocatable:: igroup_m, itypep_m

!not used
  integer, dimension(0:n_atom_proto):: ngreq
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(n_radius):: natomeq_s

  logical:: ATA, Atom_clust_12, Base_ortho, Base_ortho_bulk, Base_ortho_int, Base_ortho_sur, Bulk, Bulk_step, Center_s, &
    Doping, First_run, Matper, Noncentre, Numbering, One_SCF_surf, Proto_all, &
    Sym_2D

  logical, dimension(2):: Cylinder_cluster
  logical, dimension(natomp):: Atom_SCF_clust
  logical, dimension(:), allocatable:: Mouv

  real(kind=db):: Delta_bulk, Delta_film, Delta_int, Delta_sur, dist, Dist_atom_min, &
    dist12, Film_thickness, R_SCF_c, Rmax, Vnorme

  real(kind=db), dimension(3):: angxyz, angxyz_bulk, angxyz_int, angxyz_sur, axyz, axyz_bulk, axyz_int, axyz_sur, &
                                dcosxyz, dcosxyz_bulk, dcosxyz_int, dcosxyz_sur, deccent, deccent_bulk, dpos, p, v
  real(kind=db), dimension(4):: Film_shift, Interface_shift, Surface_shift
  real(kind=db), dimension(ngroup_taux):: Taux_oc
  real(kind=db), dimension(natomp):: dista
  real(kind=db), dimension(natomp_ato):: dista_ato
  real(kind=db), dimension(natomp_dip):: dista_dip
  real(kind=db), dimension(natomp_ion):: dista_ion
  real(kind=db), dimension(3,n_atom_uc):: posn
  real(kind=db), dimension(3,n_atom_bulk):: posn_bulk
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(6,n_counter_dip):: Counter_dip
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion
  real(kind=db), dimension(3,natomp):: pos
  real(kind=db), dimension(3,natomp_ato):: Pos_ato
  real(kind=db), dimension(3,natomp_dip):: Pos_dip
  real(kind=db), dimension(3,natomp_ion):: Pos_ion

  real(kind=db), dimension(:), allocatable:: dista_m
  real(kind=db), dimension(:,:), allocatable:: pos_m

! not used
  real(kind=db), dimension(n_radius):: rsorte_s

  Numbering = .false.

  if( One_SCF_surf ) then
    call Cluster_building_surf(angxyz_bulk,angxyz_sur,ATA,Atom_SCF_clust,axyz_bulk,axyz_sur,Base_ortho_sur,Bulk_step, &
        Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster,deccent,deccent_bulk,Delta_bulk,Delta_sur,Dist_atom_min, &
        First_run,iaabs,iaabsfirst,iabsorbeur,igreq,igroup,igroup_ato,igroup_dip,igroup_ion,itabs, &
        itype,itypep,n_atom_bulk,n_atom_proto,n_atom_proto_uc,n_atom_uc,n_counter_ato,n_counter_dip,n_counter_ion,n_radius, &
        natomeq_coh,natomeq_s,natomp,natomp_ato,natomp_dip,natomp_ion,neqm,ngreq,ngroup,ngroup_taux, &
        Numbering,posn,Pos,Pos_ato,Pos_dip,Pos_ion,posn_bulk,Proto_all,R_SCF_c,Rsorte_s,Rmax,Surface_shift, &
        Taux_oc)
  else
    call Cluster_building(angxyz,angxyz_bulk,angxyz_int,angxyz_sur,ATA,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho, &
        Base_ortho_int,Base_ortho_sur,Bulk,Bulk_step,Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster, &
        dcosxyz,deccent,Delta_bulk,Delta_film,Delta_int,Delta_sur,Dist_atom_min,Doping,Film_shift,Film_thickness, &
        First_run,iaabs,iaabsfirst,iabsfirst,iabsorbeur,igr_dop,igreq,igroup,igroup_ato,igroup_dip,igroup_ion,Interface_shift, &
        itabs,itype,itypep,Kgroup,Matper,n_atom_bulk,n_atom_int, &
        n_atom_per,n_atom_proto,n_atom_proto_uc,n_atom_sur,n_atom_uc,n_counter_ato,n_counter_dip,n_counter_ion,n_radius, &
        natomeq_coh,natomeq_s,natomp,natomp_ato,natomp_dip,natomp_ion,neqm,ngreq,ngroup,ngroup_pdb,ngroup_taux, &
        Numbering,posn,Pos,Pos_ato,Pos_dip,Pos_ion,posn_bulk,Proto_all,R_SCF_c,rsorte_s,Rmax,Surface_shift, &
        Sym_2D,Taux_oc)

! not used in this case
    Atom_SCF_clust(:) = .true.
  endif

  if( .not. Bulk_step .and. iaabsfirst /= 0 ) then
    if( Noncentre ) then
      pos(:,iaabsfirst) = pos(:,iaabsfirst) + dpos(:)
    elseif( Center_s ) then
      pos(1:2,iaabsfirst) = pos(1:2,iaabsfirst) + dpos(1:2)
      do ia = 1,natomp
        if( ia /= iaabsfirst ) pos(3,ia) = pos(3,ia) - dpos(3)
      end do
    else
      do ia = 1,natomp
        if( ia /= iaabsfirst ) pos(:,ia) = pos(:,ia) - dpos(:)
      end do
    endif
  endif

! Ordering versus distance from center
  dcosxyz_int(:) = 2 * cos( angxyz_int(:) )
  dcosxyz_sur(:) = 2 * cos( angxyz_sur(:) )
  if( n_atom_bulk > 0 ) then
    dcosxyz_bulk(:) = 2 * cos( angxyz_bulk(:) )
    if( abs( dcosxyz_bulk(1) ) < eps10 .and. abs( dcosxyz_bulk(2) ) < eps10 .and. abs( dcosxyz_bulk(3) ) < eps10 ) then
      Base_ortho_bulk = .true.
    else
      Base_ortho_bulk = .false.
    endif
  endif

  do ia = 1,natomp
    v(:) = pos(:,ia)
    if( ( igroup(ia) > ngroup - n_atom_bulk ) .and. .not. Bulk_step ) then
      dista(ia) = Vnorme(Base_ortho_bulk,dcosxyz_bulk,v)
    elseif( igroup(ia) > n_atom_per .and. igroup(ia) <= n_atom_per + n_atom_int ) then
      dista(ia) = Vnorme(Base_ortho_int,dcosxyz_int,v)
    elseif( igroup(ia) > n_atom_per + n_atom_int .and. igroup(ia) <= n_atom_uc ) then
      dista(ia) = Vnorme(Base_ortho_sur,dcosxyz_sur,v)
    else
      dista(ia) = Vnorme(Base_ortho,dcosxyz,v)
    endif
  end do

  do ia1 = 1,natomp
    do ia2 = ia1+1,natomp
      if( dista(ia1) < dista(ia2)+eps10 ) cycle
      dist12 = dista(ia1)
      dista(ia1) = dista(ia2)
      dista(ia2) = dist12
      igr12 = igroup(ia1)
      igroup(ia1) = igroup(ia2)
      igroup(ia2) = igr12
      ity12 = itypep(ia1)
      itypep(ia1) = itypep(ia2)
      itypep(ia2) = ity12
      v(:) = pos(:,ia1)
      pos(:,ia1) = pos(:,ia2)
      pos(:,ia2) = v(:)
      Atom_clust_12 = Atom_SCF_clust(ia1)
      Atom_SCF_clust(ia1) = Atom_SCF_clust(ia2)
      Atom_SCF_clust(ia2) = Atom_clust_12
      if( ia1 == iaabs ) then
!!!! 2025/08/04
        if( iaabsfirst == iaabs ) iaabsfirst = ia2
        iaabs = ia2
      elseif( ia2 == iaabs ) then
        if( iaabsfirst == iaabs ) iaabsfirst = ia1
        iaabs = ia1
      endif
    end do
  end do

  if( natomp_ion > 0 ) then
    do ia = 1,natomp_ion
      v(:) = Pos_ion(:,ia)
      dista_ion(ia) = Vnorme(Base_ortho_sur,dcosxyz_sur,v)
    end do

    do ia1 = 1,natomp_ion
      do ia2 = ia1+1,natomp_ion
        if( dista_ion(ia1) < dista_ion(ia2)+eps10 ) cycle
        dist12 = dista_ion(ia1)
        dista_ion(ia1) = dista_ion(ia2)
        dista_ion(ia2) = dist12
        igr12 = igroup_ion(ia1)
        igroup_ion(ia1) = igroup_ion(ia2)
        igroup_ion(ia2) = igr12
        v(:) = Pos_ion(:,ia1)
        Pos_ion(:,ia1) = Pos_ion(:,ia2)
        Pos_ion(:,ia2) = v(:)
      end do
    end do
  endif

  if( natomp_dip > 0 ) then
    do ia = 1,natomp_dip
      v(:) = Pos_dip(:,ia)
      dista_dip(ia) = Vnorme(Base_ortho_sur,dcosxyz_sur,v)
    end do

    do ia1 = 1,natomp_dip
      do ia2 = ia1+1,natomp_dip
        if( dista_dip(ia1) < dista_dip(ia2)+eps10 ) cycle
        dist12 = dista_dip(ia1)
        dista_dip(ia1) = dista_dip(ia2)
        dista_dip(ia2) = dist12
        igr12 = igroup_dip(ia1)
        igroup_dip(ia1) = igroup_dip(ia2)
        igroup_dip(ia2) = igr12
        v(:) = Pos_dip(:,ia1)
        Pos_dip(:,ia1) = Pos_dip(:,ia2)
        Pos_dip(:,ia2) = v(:)
      end do
    end do
  endif

  if( natomp_ato > 0 ) then
    do ia = 1,natomp_ato
      v(:) = Pos_ato(:,ia)
      dista_ato(ia) = Vnorme(Base_ortho_sur,dcosxyz_sur,v)
    end do

    do ia1 = 1,natomp_ato
      do ia2 = ia1+1,natomp_ato
        if( dista_ato(ia1) < dista_ato(ia2)+eps10 ) cycle
        dist12 = dista_ato(ia1)
        dista_ato(ia1) = dista_ato(ia2)
        dista_ato(ia2) = dist12
        igr12 = igroup_ato(ia1)
        igroup_ato(ia1) = igroup_ato(ia2)
        igroup_ato(ia2) = igr12
        v(:) = Pos_ato(:,ia1)
        Pos_ato(:,ia1) = Pos_ato(:,ia2)
        Pos_ato(:,ia2) = v(:)
      end do
    end do
  endif

! One sets the atoms for potential only after the other ones
  if( Cylinder_cluster(2) .and. ( .not. Bulk_step .or. One_SCF_surf ) ) then
    allocate( dista_m(natomp) )
    allocate( igroup_m(natomp) )
    allocate( itypep_m(natomp) )
    allocate( Mouv(natomp) )
    allocate( pos_m(3,natomp) )

    if( One_SCF_surf ) then
      dista_m(:) = dista(:)
      igroup_m(:) = igroup(:)
      itypep_m(:) = itypep(:)
      Pos_m(:,:) = Pos(:,:)

      ib = 0
      do ia = 1,natomp
        if( .not. Atom_SCF_clust(ia) ) cycle
        ib = ib + 1

        dista(ib) = dista_m(ia)
        igroup(ib) = igroup_m(ia)
        itypep(ib) = itypep_m(ia)
        Pos(:,ib) = Pos_m(:,ia)
      end do

      do ia = 1,natomp
        if( Atom_SCF_clust(ia) ) cycle
        ib = ib + 1

        dista(ib) = dista_m(ia)
        igroup(ib) = igroup_m(ia)
        itypep(ib) = itypep_m(ia)
        Pos(:,ib) = Pos_m(:,ia)
      end do

    else

      Mouv(:) = .false.
      do ia = 1,natomp
        p(1:2) = pos(1:2,ia)
        if( pos(3,ia) > - eps10 ) then
          p(3) = 0._db
        else
          p(3) = pos(3,ia)
        endif
        dist = Vnorme(Base_ortho_sur,dcosxyz_sur,p)
        Mouv(ia) = dist > R_SCF_c + eps10
      end do

      ib = 0
      do ia = 1,natomp
        if( Mouv(ia) ) cycle
        ib = ib + 1
        pos_m(:,ib) = pos(:,ia)
        dista_m(ib) = dista(ia)
        igroup_m(ib) = igroup(ia)
        itypep_m(ib) = itypep(ia)
      end do
      do ia = 1,natomp
        if( .not. Mouv(ia) ) cycle
        ib = ib + 1
        pos_m(:,ib) = pos(:,ia)
        dista_m(ib) = dista(ia)
        igroup_m(ib) = igroup(ia)
        itypep_m(ib) = itypep(ia)
      end do

      pos(:,:) = pos_m(:,:)
      dista(:) = dista_m(:)
      igroup(:) = igroup_m(:)
      itypep(:) = itypep_m(:)

      endif

    deallocate( dista_m, itypep_m, igroup_m, Mouv, pos_m )
  endif

  if( iaabs == 0 .and. mpirank0 == 0 ) then
    call write_error
    do ipr = 6,9,3
      write(ipr,'(/A)') ' There is no absorbing atom in the calculation sphere !'

      write(ipr,'(/A)') '  ia igr  it      posx         posy         posz          dist'
      do ia = 1,natomp
        write(ipr,140) ia, igroup(ia), itypep(ia), pos(:,ia)*bohr, dista(ia)*bohr
      end do

    end do
    stop
  endif

  return
  120 format(//' Error in the indata file:',/ &
               ' Two atoms are too close with the sum of their occupancy > 1',/)
  122 format(//' Error in the indata file:',/ &
               ' Two atoms in the bulk are too close with the sum of their occupancy > 1',/)
  125 format(' Possibly after a unit cell shift',/)
  128 format(' Atoms',i5,' at p =',3f11.7,/'   and',i5,' at p =',3f11.7)
  130 format(' Atoms',i5,' at p =',3f11.7,', with occupancy =',f7.3,/'   and',i5,' at p =',3f11.7,', with occupancy =',f7.3)
  140 format(3i4,4f13.7)
  145 format(3i4,4f13.7,L5)
end

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

! Cluster building and ponctual group evaluation

! The punctual group of the cluster is evaluated with the absorbing atom eventually excited including for the ground state SCF step
! Nevertheless the reduction of symmetry is only when the absorbing atom is not at the center

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

  use declarations
  implicit none

  integer:: i, ia, iaabs, iaabsfirst, iabsorbeur, iabsfirst, ib, ic, icheck, igr, igr_dop, igrpt, igrpt_nomag, igrpt_sg, &
    igrpt_sg_cmp, igrpt_sg_cal, igrpt_sg_so, igrpt0, igrptn, ipr, ired, istop, it, itabs, k, mpirank0, n_atom_bulk, n_atom_int, &
    n_atom_per, n_atom_proto, n_atom_sur, n_atom_uc, n_counter_ato, n_counter_dip, n_counter_ion, natomp, natomp_ato, natomp_dip, &
    natomp_ion, nb_rep, nb_sym_op, neqm, ngroup, ngroup_m, ngroup_pdb, ngroup_taux, nlatm, npr1, nspin, ntype, Za, Zb

  integer, dimension(natomp):: iaproto, igroup, itypep
  integer, dimension(natomp_ato):: igroup_ato
  integer, dimension(natomp_dip):: igroup_dip
  integer, dimension(natomp_ion):: igroup_ion
  integer, dimension(nopsm):: iopsymc, iopsymr
  integer, dimension(0:ntype):: nlat, Numat
  integer, dimension(0:n_atom_proto):: iapot, ngreq
  integer, dimension(ngroup):: itype
  integer, dimension(ngroup_pdb):: Kgroup
  integer, dimension(0:n_atom_proto,neqm):: igreq

  character(len=8):: PointGroup, PointGroup_name, PointGroup_nomag_name, PointGroup_Sch, &
                     PointSubGroup_name, PointSubGroup_Sch
  character(len=5):: Struct, Struct_bulk

  logical:: ATA, Atom_mag_cal, Base_hexa, Base_ortho, Base_ortho_int, Base_ortho_sur, Bulk, Bulk_step, &
    Center_s, Doping, First_run, Mag_axis_free, Magnetic, Matper, No_cluster_rotation, Not_centered, One_SCF_surf, &
    PointGroup_Auto, Self_nonexc, Spin_axis_free, Spinorbite, Sym_2D, Sym_4, Sym_cubic, Symmol, Taux

  logical, dimension(2):: Cylinder_cluster
  logical, dimension(0:ngroup_m):: Atom_with_axe

  real(kind=db):: Angle, Charge_ato, Charge_ion, Delta_bulk, Delta_film, Delta_int, Delta_sur, Dist, Dist_atom_min, &
    Dist_max, Distm, Dsa, Dsb, Fac, Film_thickness, Prod, R_SCF_c, rad_i, Rmax, Test_dist_min

  real(kind=db), dimension(3):: angxyz, angxyz_bulk, angxyz_int, angxyz_sur, Axe_spin, Axe_spin_0, axyz, axyz_bulk, axyz_int, &
    axyz_sur, dcosxyz, deccent, deccent_bulk, dpos, E_moment_axis, E_moment_axis_loc, E_moment_axis_loc_0, pa, pb, V
  real(kind=db), dimension(4):: Film_shift, Interface_shift, Surface_shift
  real(kind=db), dimension(3,3):: Cubmat, Cubmat_bulk, Orthmat, Orthmati, Orthmatt, Rot_un, Rotmat, Rot_cluster, Rot_so, &
                                  Rot_Spinor, Rot_tem, Rotspin
  real(kind=db), dimension(natomp):: dista
  real(kind=db), dimension(3,natomp):: Axe_atom_clu, Pos
  real(kind=db), dimension(3,n_atom_uc):: posn
  real(kind=db), dimension(3,ngroup_m):: Axe_atom_gr
  real(kind=db), dimension(3,n_atom_bulk):: posn_bulk
  real(kind=db), dimension(3,natomp_ato):: Pos_ato
  real(kind=db), dimension(3,natomp_dip):: Pos_dip
  real(kind=db), dimension(3,natomp_ion):: Pos_ion
  real(kind=db), dimension(8,n_counter_ato):: Counter_ato
  real(kind=db), dimension(6,n_counter_dip):: Counter_dip
  real(kind=db), dimension(6,n_counter_ion):: Counter_ion
  real(kind=db), dimension(ngroup,nlatm,nspin) :: popats
  real(kind=db), dimension(0:n_atom_proto):: chargat
  real(kind=db), dimension(3,3,ngroup_m):: Rot_Atom_gr
  real(kind=db), dimension(3,3,natomp):: Rot_Atom_spin
  real(kind=db), dimension(ngroup_taux):: taux_oc

  complex(kind=db), dimension(nopsm,nrepm):: karact

  common/PointGroup_name/ PointGroup_name, PointGroup_nomag_name
  common/PointGroup_Sch/ PointGroup_Sch
  common/PointSubGroup_name/ PointSubGroup_name, PointSubGroup_Sch

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

! to avoid overwriting when several absorbing atoms
  E_moment_axis_loc(:) = E_moment_axis(:)

  call Clust(angxyz,angxyz_bulk,angxyz_int,angxyz_sur,ATA,axyz,axyz_bulk,axyz_int,axyz_sur,Base_ortho,Base_ortho_int, &
              Base_ortho_sur,Bulk,Bulk_step,Center_s,Counter_ato,Counter_dip,Counter_ion,Cylinder_cluster,dcosxyz,deccent, &
              deccent_bulk, &
              Delta_bulk,Delta_film,Delta_int,Delta_sur,Dist_atom_min,dista,Doping,dpos,Film_shift,Film_thickness,First_run, &
              iaabs,iaabsfirst,iabsorbeur,iabsfirst,igr_dop,igroup,igroup_ato,igroup_dip,igroup_ion,Interface_shift,itabs,itype, &
              itypep,Kgroup,Matper,mpirank0,n_atom_bulk,n_atom_int,n_atom_per,n_atom_sur,n_atom_uc,n_counter_ato,n_counter_dip, &
              n_counter_ion,natomp,natomp_ato,natomp_dip,natomp_ion,ngroup,ngroup_pdb,ngroup_taux,Not_centered,One_SCF_surf,Pos, &
              Pos_ato,Pos_dip,Pos_ion,Posn,Posn_bulk,R_SCF_c,Rmax,Surface_shift,Sym_2D,Taux_oc)

  if( icheck > 0 ) write(3,130) iaabs

  call cal_iaeqrmt(iaabs,iaproto,iapot,igreq,igroup,n_atom_proto,natomp,neqm,ngreq,Self_nonexc)

  if( Magnetic ) then
    do igr = 1,ngroup
      do ia = 1,natomp
        if( igroup(ia) == igr ) Axe_atom_clu(:,ia) = Axe_atom_gr(:,igr)
      end do
    end do
  else
    Axe_atom_clu(:,:) = 0._db
  endif

  if( Bulk ) call cal_cubmat(angxyz_bulk,Cubmat_bulk,Struct_bulk)

! Change in orthogonal basis
  if( Struct /= 'cubic' ) then
    do ia = 1,natomp
      v(:) = pos(:,ia)
      if( ( .not. Bulk_step .and. igroup(ia) > ngroup - n_atom_bulk ) .or. Bulk_step ) then
        v = Matmul( Cubmat_bulk, v )
      else
        v = Matmul( Cubmat, v )
      endif
      pos(1:3,ia) = v(1:3)
    end do

    if( natomp_ion > 0 ) then
      do ia = 1,natomp_ion
        v(:) = pos_ion(:,ia)
        v = Matmul( Cubmat, v )
        pos_ion(1:3,ia) = v(1:3)
      end do
    endif

    if( natomp_dip > 0 ) then
      do ia = 1,natomp_dip
        v(:) = pos_dip(:,ia)
        v = Matmul( Cubmat, v )
        pos_dip(1:3,ia) = v(1:3)
      end do
    endif

    if( natomp_ato > 0 ) then
      do ia = 1,natomp_ato
        v(:) = pos_ato(:,ia)
        v = Matmul( Cubmat, v )
        pos_ato(1:3,ia) = v(1:3)
      end do
    endif

    if( sum( abs( E_moment_axis_loc(:) ) ) > eps10 ) then
      if( Bulk_step ) then
        E_moment_axis_loc = Matmul( Cubmat_bulk, E_moment_axis_loc )
      else
        E_moment_axis_loc = Matmul( Cubmat, E_moment_axis_loc )
      endif
    endif

  endif

  Orthmatt(:,:) = 0._db
  do k = 1,3
    if( Bulk_step ) then
      orthmatt(k,k) = axyz_bulk(k)
    else
      orthmatt(k,k) = axyz(k)
    endif
  end do
  if( Bulk_step ) then
    Orthmatt = matmul( cubmat_bulk, orthmatt )
  else
    Orthmatt = matmul( cubmat, orthmatt )
  endif

  Orthmat = Orthmatt

  rot_un(:,:) = 0._db
  do i = 1,3
    rot_un(i,i) = 1._db
  end do
  Rotspin(:,:) = Rot_un(:,:)
  Rot_spinor(:,:) = Rot_un(:,:)
  Rotmat(:,:) = Rot_un(:,:)

! The spin axis of the absorbing atom is taken as the z axis
! Wrong when working in "one_run" with spin axis not parallel.
  Axe_spin(:) = 0._db
  Atom_with_axe(0) = .false.
  if( Magnetic ) then
    if( Spin_axis_free ) then
      Atom_with_axe(0) = .true.
      Axe_spin(1:2) = 0._db; Axe_spin(3) = 1._db
    else
      do ia = 1,natomp
        if( ia /= iaabs ) cycle
        igr = igroup(ia)
        if( .not. Atom_with_axe(igr) ) cycle
        Atom_with_axe(0) = Atom_with_axe(igr)
        Rotspin(:,:) = Rot_Atom_gr(:,:,igr)
        Rotspin = transpose( Rotspin )  ! because used to rotate the cluster towards the spin
        Axe_spin(:) = Axe_atom_clu(:,ia)
        exit
      end do
    endif
  endif

  do ia = 1,natomp
    Rot_Atom_spin(:,:,ia) = Rot_un(:,:)
  end do

  if( Mag_axis_free ) Rot_Spinor(:,:) = Rotspin(:,:)

! Rotation of the internal basis when spin axis is not along z
  if( Atom_with_axe(0) ) then

    orthmat = matmul( Rotspin, orthmat )

    do ia = 1,natomp
      v(:) = pos(:,ia)
      v = matmul( rotspin, v )
      pos(:,ia) = v(:)
    end do

    if( natomp_ion > 0 ) then
      do ia = 1,natomp_ion
        v(:) = pos_ion(:,ia)
        v = Matmul( rotspin, v )
        pos_ion(1:3,ia) = v(1:3)
      end do
    endif

    if( natomp_dip > 0 ) then
      do ia = 1,natomp_dip
        v(:) = pos_dip(:,ia)
        v = Matmul( rotspin, v )
        pos_dip(1:3,ia) = v(1:3)
      end do
    endif

    if( natomp_ato > 0 ) then
      do ia = 1,natomp_ato
        v(:) = pos_ato(:,ia)
        v = Matmul( rotspin, v )
        pos_ato(1:3,ia) = v(1:3)
      end do
    endif

    do ia = 1,natomp
      v(:) = Axe_atom_clu(:,ia)
      v = matmul( rotspin, v )
      Axe_atom_clu(:,ia) = v(:)
    end do

    if( ngroup_m > 0 ) then
      do ia = 1,natomp
        igr = igroup(ia)
        if( Atom_with_axe(igr) .or. Spin_axis_free ) then
          Rot_tem(:,:) = Rot_Atom_gr(:,:,igr)
!      Rotspin been already transpose, when same rotation, result = unity.
          Rot_tem = Matmul( Rotspin, Rot_tem )
          Rot_Atom_spin(:,:,ia) = Rot_tem(:,:)
        else
          Rot_Atom_spin(:,:,ia) = Rot_un(:,:)
        endif
      end do
    endif

    Axe_spin = matmul( Rotspin, Axe_spin )

    E_moment_axis_loc = matmul( Rotspin, E_moment_axis_loc )

  endif

! Determination of the symmetries of the ponctual group (iopsymc)

  if( PointGroup_Auto ) then

    rot_so = rot_un
    Axe_spin_0(:) = Axe_spin(:)
    E_moment_axis_loc_0(:) = E_moment_axis_loc(:)

    do i = 1,2

      call Sym_cluster( Atom_with_axe, Axe_atom_clu, E_moment_axis_loc, iaabs, igroup, iopsymc, itype, itypep, &
             natomp, ngroup, ngroup_m, nlat, nlatm, nspin, ntype, Numat, popats, pos, Symmol )

      call Cluster_rot(iopsymc,rot_tem)

      if( ( No_cluster_rotation .and. sum( abs( Rotspin(:,:) - rot_un(:,:) ) ) < eps10 ) &
                                 .or. sum( abs( rot_tem(:,:) - rot_un(:,:) ) ) < eps10  ) exit

      orthmat = matmul( rot_tem, orthmat )
      rotmat = matmul( rot_tem, rotmat )

      do ia = 1,natomp
        v(:) = pos(:,ia)
        v = matmul( rot_tem, v )
        pos(:,ia) = v(:)
      end do

      if( natomp_ion > 0 ) then
        do ia = 1,natomp_ion
          v(:) = pos_ion(:,ia)
          v = Matmul( rot_tem, v )
          pos_ion(1:3,ia) = v(1:3)
        end do
      endif

      if( natomp_dip > 0 ) then
        do ia = 1,natomp_dip
          v(:) = pos_dip(:,ia)
          v = Matmul( rot_tem, v )
          pos_dip(1:3,ia) = v(1:3)
        end do
      endif

      if( natomp_ato > 0 ) then
        do ia = 1,natomp_ato
          v(:) = pos_ato(:,ia)
          v = Matmul( rot_tem, v )
          pos_ato(1:3,ia) = v(1:3)
        end do
      endif

      if( Magnetic .and. .not. Spin_axis_free ) then
        do ia = 1,natomp
          v(:) = Axe_atom_clu(:,ia)
          v = matmul( rot_tem, v )
          Axe_atom_clu(:,ia) = v(:)
        end do
        Axe_spin = matmul( rot_tem, Axe_spin )
      endif
      E_moment_axis_loc = matmul( rot_tem, E_moment_axis_loc )
      if( sum( abs( axe_spin(:) - axe_spin_0(:) ) ) > eps10 ) rot_so = matmul( rot_so, transpose(rot_tem) )

    end do

    call Sym_cluster( Atom_with_axe, Axe_atom_clu, E_moment_axis_loc, iaabs, igroup, iopsymc, itype, itypep, &
             natomp, ngroup, ngroup_m, nlat, nlatm, nspin, ntype, Numat, popats, pos, Symmol )

    call numgrpt(iopsymc,igrpt,igrpt_nomag,mpirank0,.false.)

    orthmat = matmul( rot_so, orthmat )
    rotmat = matmul( rot_so, rotmat )

    do ia = 1,natomp
      v(:) = pos(:,ia)
      v = matmul( rot_so, v )
      pos(:,ia) = v(:)
    end do

    if( natomp_ion > 0 ) then
      do ia = 1,natomp_ion
        v(:) = pos_ion(:,ia)
        v = Matmul( rot_so, v )
        pos_ion(1:3,ia) = v(1:3)
      end do
    endif

    if( natomp_dip > 0 ) then
      do ia = 1,natomp_dip
        v(:) = pos_dip(:,ia)
        v = Matmul( rot_so, v )
        pos_dip(1:3,ia) = v(1:3)
      end do
    endif

    if( natomp_ato > 0 ) then
      do ia = 1,natomp_ato
        v(:) = pos_ato(:,ia)
        v = Matmul( rot_so, v )
        pos_ato(1:3,ia) = v(1:3)
      end do
    endif

    if( Magnetic .and. .not. Spin_axis_free ) then
      do ia = 1,natomp
        v(:) = Axe_atom_clu(:,ia)
        v = matmul( rot_so, v )
        Axe_atom_clu(:,ia) = v(:)
      end do
      Axe_spin = matmul( rot_so, Axe_spin )
      E_moment_axis_loc = matmul( rot_so, E_moment_axis_loc )
    endif

    call Sym_cluster( Atom_with_axe, Axe_atom_clu, E_moment_axis_loc, iaabs, igroup, iopsymc, itype, itypep, &
             natomp, ngroup, ngroup_m, nlat, nlatm, nspin, ntype, Numat, popats, pos, Symmol )

    call numgrpt(iopsymc,igrpt,igrpt_nomag,mpirank0,.false.)

  else

    call grp_opsym_imp(iopsymc,igrpt,igrpt_nomag,mpirank0,PointGroup)

  endif

! iopsymc contains all symmetry operations
! iopsymr corresponds to a sub group with unnidimentionnal representations

  if( icheck > 0 ) then
    npr1 = 3
  else
    npr1 = 6
  endif

  if( mpirank0 == 0 ) then
    do ipr = npr1,6,3
      if( igrpt > 32 ) then
        write(ipr,140) PointGroup_name, igrpt
        write(ipr,150) PointGroup_nomag_name, PointGroup_Sch
        if( PointGroup_Auto ) write(ipr,160) PointSubgroup_name, PointSubgroup_Sch
      else
        write(ipr,170) PointGroup_name, PointGroup_Sch
      endif
    end do
    if( icheck > 0 ) then
      write(3,'(/A)') ' iopsymc ='
      call write_iopsym(iopsymc,3)
    endif
  endif

! One takes a subgroup
  igrptn = igrpt
  if( PointGroup_Auto ) then
    call numgrpt(iopsymc,igrpt,igrpt_nomag,mpirank0,.true.)
    igrpt_sg = igrpt_sg_cal(.false.,igrpt,igrpt_nomag, Spinorbite)
  else
    igrpt_sg = igrpt
  endif

  Sym_cubic = .false.
  Sym_4 = .false.
  if( igrpt_sg /= 1 .and. .not. Spinorbite ) then
    if( igrpt_nomag > 27 ) then
      sym_cubic = .true.
    elseif( igrpt_nomag >= 12 .and. igrpt_nomag <= 15 ) then
      sym_4 = .true.
    endif
  endif

  if( igrpt_sg /= igrpt_nomag .or. igrptn /= igrpt ) then
    PointGroup = 'SousGr'
    igrpt_nomag = igrpt_sg
    iopsymr(:) = iopsymc(:)
    call grp_opsym_imp(iopsymr,igrpt,igrpt_nomag,mpirank0,PointGroup)
    ired = 1
  else
    iopsymr(:) = iopsymc(:)
    ired = 0
  endif
  if( Spinorbite .or. igrpt_sg /= 8 ) then
    igrpt_sg = igrpt_sg_so(igrpt,igrpt_nomag)
    if( igrpt_sg /= igrpt_nomag ) then
      PointGroup = 'SousGr'
      igrpt_nomag = igrpt_sg
      iopsymr(:) = iopsymc(:)
      call grp_opsym_imp(iopsymr,igrpt,igrpt_nomag,mpirank0,PointGroup)
      ired = 1
    endif
    igrpt_sg = igrpt_sg_cmp(igrpt,igrpt_nomag)
    if( igrpt_sg /= igrpt_nomag ) then
      PointGroup = 'SousGr'
      igrpt_nomag = igrpt_sg
      iopsymr(:) = iopsymc(:)
      call grp_opsym_imp(iopsymr,igrpt,igrpt_nomag,mpirank0,PointGroup)
      ired = 1
    end if
  endif

  Atom_with_axe(0) = Atom_mag_cal(igrpt)

! igrpt0 est transporte dans la routine Point_group_atom
  igrpt0 = igrpt

  if( ired == 1 .and. mpirank0 == 0 ) then
    do ipr = npr1,6,3
      if( igrpt > 32 ) then
        write(ipr,180) PointGroup_name, igrpt
        write(ipr,150) PointGroup_nomag_name, PointGroup_Sch
        if( PointGroup_Auto ) write(ipr,160) PointSubgroup_name, PointSubgroup_Sch
      else
        write(ipr,182) Pointgroup_name, Pointgroup_Sch
      endif
    end do
    if( icheck > 0 ) then
      write(3,'(/A)') ' iopsymr ='
      call write_iopsym(iopsymr,3)
    endif
  endif

  call character_table(icheck,igrpt_nomag,karact,nb_rep)

  call invermat(Orthmat,Orthmati)

  Rotmat = matmul( Rotmat, Rotspin )
  call invermat(Rotmat,Rot_cluster)

! Number of symmetry operation in the point group whci is used
  nb_sym_op = sum( abs( iopsymr(:) ) )

  if( icheck > 0 ) then
    write(3,185)
    write(3,'(/A)') ' Transformation Crystal Bases - Bases R1:'
    write(3,200) ( Orthmatt(i,1:3), i = 1,3 )
    write(3,'(/A)') ' Transformation Crystal Normalized Bases - Bases R1:'
    write(3,200) ( Cubmat(i,1:3), i = 1,3 )
    write(3,'(/A)') ' Rotation Bases R1 - Bases R2:'
    write(3,200) ( Rotmat(i,1:3), i = 1,3 )
    write(3,'(/A)') ' Inverse matrix:'
    write(3,200) ( Rot_cluster(i,1:3), i = 1,3 )
    write(3,'(/A)') ' Transformation Crystal Bases - Bases R2:'
    write(3,200) ( Orthmat(i,1:3), i = 1,3 )
    write(3,'(/A)') ' Inverse matrix:'
    write(3,200) ( Orthmati(i,1:3), i = 1,3 )
    if( Taux ) then
      write(3,210)
    else
      write(3,215)
    endif
    do ia = 1,natomp
      if( igroup(ia) <= ngroup ) then
        ipr = iaproto(ia)
        it = itypep(ia)
        if( Taux ) then
          write(3,220) Numat(it), pos(:,ia)*bohr, dista(ia)*bohr, Taux_oc( igroup(ia) ), ia, igroup(ia), it, ipr, chargat( ipr )
        else
          write(3,230) Numat(it), pos(:,ia)*bohr, dista(ia)*bohr, ia, igroup(ia), it, ipr, chargat( ipr )
        endif
      else
        if( Taux ) then
          write(3,220) iaproto(ia), pos(:,ia)*bohr, dista(ia)*bohr, 1._db, ia, igroup(ia), iaproto(ia), iaproto(ia), 0._db
        else
          write(3,230) iaproto(ia), pos(:,ia)*bohr, dista(ia)*bohr, ia, igroup(ia), iaproto(ia), iaproto(ia), 0._db
        endif
      endif
    end do

    if( icheck > 1 ) then
      write(3,'(/A)') ' ipr   iapot'
      do ipr = 0,n_atom_proto
        write(3,'(i4,i6)') ipr, iapot(ipr)
      end do
    endif

! Angles of bounds around the central atom
    if( natomp > 2 ) write(3,'(/A)') '   ia   ib   Za   Zb   Angle(a,O,b)'
    rad_i = 180._db / pi
    Distm = 3.2_db / bohr
    Dist_max = Dista(iaabs) + Distm
    do ia = 1,natomp
      if( Dista(ia) > Dist_max ) exit
      if( ia == iaabs ) cycle
      pa(:) = pos(:,ia) - pos(:,iaabs)
      Dsa = sqrt( sum( pa(:)**2 ) )
      if( Dsa > Distm ) cycle
      do ib = ia + 1, natomp
        if( dista(ib) > Dist_max ) exit
        if( ib == iaabs ) cycle
        pb(:) = pos(:,ib) - pos(:,iaabs)
        Dsb = sqrt( sum( pb(:)**2 ) )
        if( Dsb > Distm ) cycle
        Prod = sum( pa(:) * pb(:) ) / ( Dsa * Dsb )
        if( Prod < -1._db + eps10 ) then
          Angle = 180._db
        elseif( Prod > 1._db - eps10 ) then
          Angle = 0._db
        else
          Angle = rad_i * acos( Prod )
        endif
        if( ia > ngroup ) then
          Za = iaproto(ia)
        else
          Za = Numat(itypep(ia))
        endif
        if( ib > ngroup ) then
          Zb = iaproto(ib)
        else
          Zb = Numat(itypep(ib))
        endif
        write(3,'(4i5,f13.3)') ia, ib, Za, Zb, Angle
      end do
    end do

    if( natomp_ion > 0 ) then
      write(3,'(/A)') '  Counter ions'
      write(3,'(A)') '            Px             Py             Pz            ia igr ref  Charge    Sigma'
      do ia = 1,natomp_ion
        igr = igroup_ion(ia)
        write(3,240) Pos_ion(:,ia)*bohr, ia, igr, nint( Counter_ion(6,igr) ), Counter_ion(4,igr), Counter_ion(5,igr)*bohr
      end do
    endif

    if( natomp_dip > 0 ) then
      Fac = c_light * e_electron * bohr
      write(3,'(/A)') '  Counter dipoles'
      write(3,'(A)') '            Px             Py             Pz            ia igr ref  Moment(D) Sigma'
      do ia = 1,natomp_dip
        igr = igroup_dip(ia)
        write(3,240) Pos_dip(:,ia)*bohr, ia, igr, nint( Counter_dip(6,igr) ), Counter_dip(4,igr)*Fac, Counter_dip(5,igr)*bohr
      end do
    endif

    if( natomp_ato > 0 ) then
      write(3,'(/A)') '  Counter atoms'
      write(3,'(A)') '            Px             Py             Pz            ia igr ref     Z   Sigma   Charge  Occupancy'
      do ia = 1,natomp_ato
        igr = igroup_ato(ia)
        write(3,245) Pos_ato(:,ia)*bohr, ia, igr, nint( Counter_ato(6,igr) ), nint( Counter_ato(4,igr) ), &
                                                       Counter_ato(5,igr)*bohr, Counter_ato(7:8,igr)
      end do
    endif

  endif

  Charge_ion = 0._db
  do ia = 1,natomp_ion
    igr = igroup_ion(ia)
    Charge_ion = Charge_ion + Counter_ion(4,igr)
  end do

  Charge_ato = 0._db
  do ia = 1,natomp_ato
    igr = igroup_ato(ia)
  ! The charge is multiplied by the occupancy
    Charge_ato = Charge_ato + Counter_ato(7,igr) * Counter_ato(8,igr)
  end do

! Just the sum is needed in Vsphere, whatever it comes from
  Charge_ion = Charge_ion + Charge_ato

  if( icheck > 0 .and. Mag_axis_free ) then
    write(3,'(/A)') ' FDM grid - magnetic frame rotation matrix:'
    write(3,200) ( Rot_Spinor(i,1:3), i = 1,3 )
  endif

! For 3-fold axis, hexagonal mesh.
  if( ( abs(iopsymc(49)) == 1 .or. abs(iopsymc(53)) == 1 ) &
       .or. (  ( Mag_axis_free .or. Spin_axis_free ) .and. abs( Angxyz(1) - pi/2 ) < eps10 &
               .and. abs( Angxyz(2) - pi/2 ) < eps10 .and. abs( Angxyz(3) - 2*pi/3 ) < eps10 ) ) then
    Base_hexa = .true.
  else
    Base_hexa = .false.
  endif

  istop = 0
  do ia = 1,natomp
    do ib = ia + 1,natomp
      dist = sqrt( sum( ( pos(:,ia) - pos(:,ib) )**2 ) )
      if( dist < Test_dist_min ) then
        if( istop == 0 ) call write_error
        if( ia > ngroup ) then
          do ic = 1,ngroup
            if( iaproto(ia) == iaproto(ic) ) exit
          end do
          if( ic <= ngroup ) then
            Za = Numat(itypep(ic))
          else
            Za = - iaproto(ia)
          endif
        else
          Za = Numat(itypep(ia))
        endif
        if( ib > ngroup ) then
          do ic = 1,ngroup
            if( iaproto(ib) == iaproto(ic) ) exit
          end do
          if( ic <= ngroup ) then
            Zb = Numat(itypep(ic))
          else
            Zb = - iaproto(ib)
          endif
        else
          Zb = Numat(itypep(ib))
        endif
        do ipr = 3,9,3
          if( ipr == 3 .and. icheck == 0 ) cycle
          if( istop == 0 ) write(ipr,'(/A/)') '  The following atoms are too close :'
          if( Za > 0 .and. Zb > 0 ) then
            write(ipr,260) iaproto(ia), ia, igroup(ia), Za, pos(1:3,ia)*bohr, &
                           iaproto(ib), ib, igroup(ib), Zb, pos(1:3,ib)*bohr, dist*bohr
          else
            write(ipr,265) iaproto(ia), ia, igroup(ia), pos(1:3,ia)*bohr, &
                           iaproto(ib), ib, igroup(ib), pos(1:3,ib)*bohr, dist*bohr
          endif
        end do
        istop = 1
      endif
    end do
  end do
  if( istop /= 0 ) then
    do ipr = 3,9,3
      if( ipr == 3 .and. icheck == 0 ) cycle
      write(ipr,270) Test_dist_min*bohr
    end do
    stop
  endif

  return
  110 format(/' ---- Agregat ------',100('-'))
  130 format(/' Index of the absorbing atom, iaabs =',i3)
  140 format(/' Point group : ',a8,'     number =',i3)
  150 format( '   Non magnetic corresponding point group   : ',a8,' (',a5,')')
  160 format( '   Subgroup not multiplied by time reversal : ',a8,' (',a5,')')
  170 format(/' Point group : ',a8,' (',a5,')')
  180 format(/' Point group used : ',a8,'     number =',i3)
  182 format(/' Point group used : ',a8,' (',a5,')')
  185 format(/' Transformation matrices :',/ &
              '    R1: internal orthonormal bases with z along c, y along c x a',/ &
              '        but for trigonal symmetry where z is along the hexagonal axis,',/ &
              '        used for the tensorial expansion',/ &
              '    R2: internal orthonormal bases used for the electronic structure calculation')
  200 format(3x,3f11.5)
  210 format(/' Cluster: atom positions in order, in the internal R2 bases',/ &
              '   Z        posx           posy           posz            dista     Taux_oc  ia   igr ity ipr  chargat')
  215 format(/' Cluster: atom positions in order, in the internal R2 bases',/ &
              '   Z        posx           posy           posz            dista    ia   igr ity ipr  chargat')
  220 format(i4,3f15.10,'   ! ',f11.6,f10.5,i4,i6,2i4,f9.5)
  230 format(i4,3f15.10,'   ! ',f11.6,i4,i6,2i4,f9.5)
  240 format(4x,3f15.10,'   ! ',3i4,2f9.5)
  245 format(4x,3f15.10,'   ! ',3i4,i6,3f9.5)
  260 format(' Atoms ipr = ',i4,', ia =',i5,', igr =',i5,', Z =',i3,', pos =',3f12.7,/ &
             '   and ipr = ',i4,', ia =',i5,', igr =',i5,', Z =',i3,', pos =',3f12.7,// &
             '  Distance =',f10.5,' A')
  265 format(' Atoms ipr = ',i4,', ia =',i5,', igr =',i5,', pos =',3f12.7,/ &
             '   and ipr = ',i4,', ia =',i5,', igr =',i5,', pos =',3f12.7,// &
             '  Distance =',f10.5,' A')
  270 format(/'  Minimal distance is set at =',f10.5,' A', // &
              '  The positions are the one in the cluster.', / &
              '  ipr is the index of the non equivalent atoms in the unit cell, ia is the index in the cluster,',/ &
              '  igr is the index in the unit cell.', // &
              '  Note that this can come from structure obtained by crystallographic refinement giving', / &
              '  the same atom at 2 different positions with partial occupancy.', / &
              '  Check your cif or pdb file if you use one !', // &
              '  For calculations with surfaces, it can comes from a bad surface-bulk shift.')
end

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

function Vsphere_cal(Chargat,Charge_ion,Chargm,Counter_linear,dista_natomp,Flapw,iaproto,icheck,Matper,n_atom_proto,natomp)

  use declarations
  implicit none

  integer:: ia,icheck, ipr, n_atom_proto, natomp
  integer, dimension(natomp):: iaproto

  logical:: Counter_linear, Flapw, Matper

  real(kind=db):: Chagreg, Charge_ion, Chargm, dista_natomp, Vsphere_cal
  real(kind=db), dimension(0:n_atom_proto):: Chargat

! Calculation of the cluster charge
  if( .not. Flapw .and. Matper ) then
    if( Counter_linear ) then
      Chagreg = 0._db
    else
      Chagreg = Charge_ion
    endif
    do ia = 1,natomp
      ipr = iaproto(ia)
      Chagreg = Chagreg + Chargat( ipr )
    end do

! On met une charge opposee sur la sphere a dista(natomp) du centre
    if( natomp > 1 ) then
      Vsphere_cal = 2 * ( Chagreg - Chargm ) / dista_natomp
    else
      Vsphere_cal = 0._db
    endif
    if( icheck > 0 ) then
      write(3,110) Chagreg, Vsphere_cal * rydb
      if( abs( Charge_ion ) > eps10 ) write(3,120) Charge_ion
    endif
  else
    Vsphere_cal = 0._db
  endif

  return
  110 format(/' Cluster charge =',f11.5,'  Vsphere =',f11.5,' eV')
  120 format(' including the charge from the counter ions or counter atoms =',f11.5)
end

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

! Determination du sous groupe ayant toutes les representations utiles
! de dimension 1.

! En cas de green on prend dans certains cas une symetrie plus basse
! a cause d'une erreur non trouvee dans la symetrisation (peut-etre
! calcul de Cmat dans la routine mat).
! (En cas de hubbard et fdm on prend un sous groupe a representations
! reelles) --> supprime

  integer function igrpt_sg_cal(Hubbard,igrpt,igrpt_nomag, Spinorbite)

  implicit none

  integer:: igrpt, igrpt_nomag, igrpt_sg

  logical:: Hubbard, Spinorbite

  igrpt_sg = igrpt_nomag

!      if( hubbard .and. .not. green ) then
  if( hubbard ) then

    select case(igrpt_nomag)
      case(9,10,22,25,26)
        igrpt_sg = 4
      case(11,23,27)
        igrpt_sg = 5
      case(12)
        igrpt_sg = 6
      case(13,14,28,30,31)
        igrpt_sg = 7   ! D2
      case(15,29)
        if( igrpt /= igrpt_nomag ) then
          igrpt_sg = 5
        else
          igrpt_sg = 8
        endif
      case(16,18,19)
        igrpt_sg = 1
      case(17,20)
        igrpt_sg = 2
      case(21,24)
        igrpt_sg = 3
      case(32)
        igrpt_sg = 8   ! D2h

    end select

  else

    select case(igrpt_nomag)
      case(12)
        igrpt_sg = 9    ! C4 a la place de C2v (mm2)
      case(13)
        igrpt_sg = 10   ! S4 a la place de D2 (222)
      case(14)
        igrpt_sg = 9    ! C4 a la place de D2 (222)
      case(28)
        igrpt_sg = 7
      case(15,29)
        if( igrpt /= igrpt_nomag ) then
          igrpt_sg = 11
        else
          igrpt_sg = 8
        endif
      case(18,19)
        igrpt_sg = 16
      case(20)
        igrpt_sg = 17
      case(24)
        igrpt_sg = 21
      case(25,26)
        igrpt_sg = 22
      case(27)
        igrpt_sg = 23
      case(30)
!            if( l_val_max > 2 .or. green ) then
          igrpt_sg = 10  ! S4 a la place de D2 (222)
!            else
!              igrpt_sg = 13  ! D2d
!            endif
      case(31)
!            if( l_val_max > 2 .or. green ) then
          igrpt_sg = 9   ! C4 a la place de D2 (222)
!            else
!              igrpt_sg = 14  ! D4
!            endif
      case(32)
!            if( l_val_max > 2 .or. green .or. Spinorbite ) then
        if( Spinorbite ) then
          igrpt_sg = 11   ! C4h a la place de D2h
        else
          igrpt_sg = 8  ! D2h = mmm
        endif
    end select

  endif

  igrpt_sg_cal = igrpt_sg

  return
end

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

subroutine write_iopsym(iopsym,ipr)

  use declarations
  implicit none

  integer:: i, i1, i2, ipr, L, ligne, ln, ni

  integer, dimension(nopsm):: iopsym

  character(len=9):: mot9, nomsym
  character(len=42):: mot

  i1 = 1
  do ligne = 1,20
    select case(ligne)
      case(1,9)
        ni = 1
      case(4,5,6,7,8,10,11,14,15,16)
        ni = 3
      case(2,3,12,13,17,18,19,20)
        ni = 4
    end select
    i2 = i1 + ni - 1
    mot = ' '
    do i = i1,i2
      L = len_trim(mot)
      L = L + 1
      mot9 = adjustl( nomsym(i) )
      ln = len_trim( mot9 )
      mot(L+1:L+ln) = mot9(1:ln)
      if( i < i2 ) mot(L+ln+1:L+ln+1) = ','
    end do
    write(ipr,110) adjustr(mot),iopsym(i1:i2)
    i1 = i2 + 1
  end do

  return
  110 format(a,' : ',8i2)
end

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

  real(kind=db) function Vnorme(Base_ortho,dcosxyz,v)

  use declarations
  implicit none

  logical Base_ortho

  real(kind=db), dimension(3):: dcosxyz, v

  if( Base_ortho ) then
    Vnorme = sqrt( sum( v(:)**2 ) )
  else
    Vnorme = sqrt( sum( v(:)**2 ) + v(1)*v(2)*dcosxyz(3) + v(1)*v(3)*dcosxyz(2) + v(2)*v(3)*dcosxyz(1) )
  endif

  return
end

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

! Calculation of the rotation matrix to reach a standard ponctual group

subroutine Cluster_rot(iopsym,Rotmat)

  use declarations
  implicit none

  integer:: i, i2, is, n_opsym, n_opsym_2, n_opsym_3, n_opsym_s
  integer, dimension(nopsm):: iops, iopsym

  real(kind=db):: cs, sn, vn, wn
  real(kind=db), dimension(3):: k, v, w, x
  real(kind=db), dimension(3,3):: rotmat

  iops(:) = abs( iopsym(:) )

  rotmat(:,:) = 0._db
  rotmat(1,1) = 1._db; rotmat(2,2) = 1._db; rotmat(3,3) = 1._db;

  n_opsym = sum( iops(:) )

  n_opsym_3 = sum( iops(2:9) )

 ! Cubic symmetry, no rotation
  if( n_opsym_3 == 8 ) return

  v(:) = 0._db
  k(1) = 0._db; k(2) = 0._db; k(3) = 1._db

! Two-fold axis
  n_opsym_2 = sum( iops(10:15) ) + sum( iops(22:24) ) + sum( iops(58:64:2) )
  if( n_opsym_2 == 1 ) then
    do i = 10,15
      if( iops(i) == 1 ) i2 = i
    end do
    do i = 22,24
      if( iops(i) == 1 ) i2 = i
    end do
    do i = 58,64,2
      if( iops(i) == 1 ) i2 = i
    end do
  else
    i2 = 0
  endif

! Symmetry planes
  n_opsym_s = sum( iops(40:48) ) + sum( iops(57:63:2) )
  if( n_opsym_s == 1 ) then
    do i = 40,48
      if( iops(i) == 1 ) is = i
    end do
    do i = 57,63,2
      if( iops(i) == 1 ) is = i
    end do
  else
    is = 0
  endif

  if( n_opsym_3 == 2 .and. n_opsym_2 == 3 ) then
    if( iops(2) == 1 ) then
      v(1) = 1._db; v(2) = 1._db; v(3) = 1._db
    elseif( iops(4) == 1 ) then
      v(1) = 1._db; v(2) = -1._db; v(3) = 1._db
    elseif( iops(6) == 1 ) then
      v(1) = -1._db; v(2) = 1._db; v(3) = 1._db
    elseif( iops(8) == 1 ) then
      v(1) = 1._db; v(2) = 1._db; v(3) = -1._db
    endif
    if( iops(10) == 1 ) then
      x(1) = 1._db; x(2) = 1._db; x(3) = 0._db
    elseif( iops(11) == 1 ) then
      x(1) = -1._db; x(2) = 1._db; x(3) = 0._db
    elseif( iops(12) == 1 ) then
      x(1) = 1._db; x(2) = 0._db; x(3) = 1._db
    elseif( iops(13) == 1 ) then
      x(1) = -1._db; x(2) = 0._db; x(3) = -1._db
    endif

    vn = sqrt( sum(v(:)**2) )
    v(:) = v(:) / vn
    vn = sqrt( sum(x(:)**2) )
    x(:) = x(:) / vn

    call prodvec(w,v,x)
    rotmat(1,:) = x(:)
    rotmat(2,:) = w(:)
    rotmat(3,:) = v(:)

    return
  endif

  if( n_opsym_2 == 1 .or. n_opsym_s == 1 ) then

    if( i2 == 10 .or. is == 48 ) then
      v(1) = 1._db; v(2) = 1._db; v(3) = 0._db
    elseif( i2 == 11 .or. is == 45 ) then
      v(1) = -1._db; v(2) = 1._db; v(3) = 0._db
    elseif( i2 == 12 .or. is == 47 ) then
      v(1) = 1._db; v(2) = 0._db; v(3) = 1._db
    elseif( i2 == 13 .or. is == 44 ) then
      v(1) = -1._db; v(2) = 0._db; v(3) = 1._db
    elseif( i2 == 14 .or. is == 46 ) then
      v(1) = 0._db; v(2) = 1._db; v(3) = 1._db
    elseif( i2 == 15 .or. is == 43 ) then
      v(1) = 0._db; v(2) = -1._db; v(3) = 1._db
    elseif( i2 == 22 .or. is == 40 )then
      v(1) = 1._db; v(2) =  0._db; v(3) = 0._db
    elseif( i2 == 23 .or. is == 41 )then
      v(1) = 0._db; v(2) =  1._db; v(3) = 0._db
    elseif( i2 == 58 .or. is == 61 ) then
      v(1) = sqrt3s2; v(2) = 0.5_db; v(3) = 0._db
    elseif( i2 == 60 .or. is == 63 ) then
      v(1) = 0.5_db; v(2) = sqrt3s2; v(3) = 0._db
    elseif( i2 == 62 .or. is == 57 ) then
      v(1) = -0.5_db; v(2) = sqrt3s2; v(3) = 0._db
    elseif( i2 == 64 .or. is == 59 ) then
      v(1) = msqrt3s2; v(2) = 0.5_db; v(3) = 0._db
    endif

! Horizontal 4-fold axis
  elseif( ( iops(18) == 0 .and. iops(28) == 0 ) .and. ( iops(16) == 1 .or. iops(26) == 1 ) ) then
    v(1) = 1._db; v(2) =  0._db; v(3) = 0._db

  elseif( ( iops(18) == 0 .and. iops(28) == 0 ) .and. ( iops(17) == 1 .or. iops(27) == 1 ) ) then
    v(1) = 0._db; v(2) =  1._db; v(3) = 0._db

! Lowering from cubic
  elseif( iops(24) == 0 .and. ( iops(2) == 1 .or. iops(32) == 1 ) ) then
    v(1) = 1._db; v(2) = 1._db; v(3) = 1._db

  elseif( iops(24) == 0 .and. ( iops(4) == 1 .or. iops(34) == 1 ) ) then
    v(1) = 1._db; v(2) = -1._db; v(3) = 1._db

  elseif( iops(24) == 0 .and. ( iops(6) == 1 .or. iops(36) == 1 ) ) then
    v(1) = -1._db; v(2) = 1._db; v(3) = 1._db

  elseif( iops(24) == 0 .and. ( iops(8) == 1 .or. iops(38) == 1 ) ) then
    v(1) = 1._db; v(2) = 1._db; v(3) = -1._db

! Around Ox
  elseif( ( ( iops(41) == 0 .and. iops(42) == 0 ) .and. ( iops(43) == 1 .or. iops(46) == 1 ) ) .or. &
      ( ( iops(23) == 0 .and. iops(24) == 0 ) .and. ( iops(14) == 1 .or. iops(15) == 1 ) ) ) then
      v(1) = 0._db; v(2) = 1._db; v(3) = 1._db

! Around Oy
  elseif( ( ( iops(42) == 0 .and. iops(40) == 0 ) .and. ( iops(44) == 1 .or. iops(47) == 1 ) ) .or. &
      ( ( iops(22) == 0 .and. iops(24) == 0 ) .and. ( iops(12) == 1 .or. iops(13) == 1 ) ) ) then
      v(1) = 1._db; v(2) = 0._db; v(3) = 1._db

  endif

  vn = sqrt( sum(v(:)**2) )

  if( vn > eps10 ) then

    v(:) = v(:) / vn
    call prodvec(w,v,k)
    wn = sqrt( sum(w(:)**2) )
    w(:) = w(:) / wn
    call prodvec(x,v,w)
    rotmat(1,:) = w(:)
    rotmat(2,:) = x(:)
    rotmat(3,:) = v(:)

! Rotations around Oz

! Rotation of + 45 degres when D2d ou D2h
  elseif( iops(49) == 0 .and. iops(2) == 0 .and. ( ( iops(40) == 1 .and. iops(41) == 1 .and. &
                iops(45) == 0 .and. iops(48) == 0 .and. iops(22) == 0 .and. iops(23) == 0 .and. &
                iops(10) == 1 .and. iops(11) == 1  ) .or. ( iops(40) == 0 .and. iops(41) == 0 .and. &
                iops(22) == 0 .and. iops(23) == 0 .and. ( iops(45) == 1 .or. iops(48) == 1 .or. &
                iops(10) == 1 .or. iops(11) == 1 ) ) ) ) then
    rotmat(1,1) = sqrt_1o2;  rotmat(1,2) = sqrt_1o2; rotmat(1,3) = 0._db
    rotmat(2,1) =-sqrt_1o2;  rotmat(2,2) = sqrt_1o2; rotmat(2,3) = 0._db
    rotmat(3,1) =    0._db;  rotmat(3,2) =    0._db; rotmat(3,3) = 1._db

! Rotation of 30 degres for 3-folf axis along Oz
  elseif( ( iops(58) == 1 .and. iops(22) == 0 .and. iops(57) == 0 ) .or. &
      ( iops(49) == 1 .and. iops(41) == 1 .and. iops(22) == 1 .and. iops(57) == 0 .and. iops(58) == 0 ) .or. & ! D3h
      ( iops(57) == 0 .and. iops(61) == 0 .and. iops(59) == 1 .and. iops(63) == 1 ) .or. &
      ( iops(58) == 0 .and. iops(62) == 0 .and. iops(60) == 1 .and. iops(64) == 1 ) ) then

    cs = cos( pi / 6 )
    sn = sin( pi / 6 )
    rotmat(1,1) =   cs;  rotmat(1,2) =  -sn; rotmat(1,3) = 0._db
    rotmat(2,1) =   sn;  rotmat(2,2) =   cs; rotmat(2,3) = 0._db
    rotmat(3,1) = 0._db;  rotmat(3,2) = 0._db; rotmat(3,3) = 1._db

  elseif( ( iops(58) == 1 .and. iops(62) == 1 .and. iops(60) == 0 .and. iops(64) == 1 ) .or. &
          ( iops(57) == 1 .and. iops(61) == 1 .and. iops(59) == 0 .and. iops(63) == 0 ) ) then

    cs = cos( pi / 6 )
    sn = - sin( pi / 6 )
    rotmat(1,1) =   cs;  rotmat(1,2) =  -sn; rotmat(1,3) = 0._db
    rotmat(2,1) =   sn;  rotmat(2,2) =   cs; rotmat(2,3) = 0._db
    rotmat(3,1) = 0._db;  rotmat(3,2) = 0._db; rotmat(3,3) = 1._db

  elseif( n_opsym_s == 3 .and. iops(49) == 1 .and. iops(59) == 1) then

    cs = cos( pi / 6 )
    sn = sin( pi / 6 )
    rotmat(1,1) =   cs;  rotmat(1,2) =  -sn; rotmat(1,3) = 0._db
    rotmat(2,1) =   sn;  rotmat(2,2) =   cs; rotmat(2,3) = 0._db
    rotmat(3,1) = 0._db;  rotmat(3,2) = 0._db; rotmat(3,3) = 1._db

! Magnetic groups

! Rotation de + 45 degres en cas 4'/mm'm' --> 4'/mmm
  elseif(  iopsym(18) == -1 .and. iopsym(25) == 1 &
     .and. iopsym(40) == -1 .and. iopsym(41) == -1 .and. iopsym(45) == 1 ) then
    rotmat(1,1) = sqrt_1o2;  rotmat(1,2) = sqrt_1o2; rotmat(1,3) = 0._db
    rotmat(2,1) =-sqrt_1o2;  rotmat(2,2) = sqrt_1o2; rotmat(2,3) = 0._db
    rotmat(3,1) =    0._db;     rotmat(3,2) = 0._db; rotmat(3,3) = 1._db

! Rotation of + 45 degres when 4'm'm --> 4'mm'   (the second "m" is the diagonal plane)
  elseif( n_opsym == 8 .and. iopsym(18) == -1  &
     .and. iopsym(40) == -1 .and. iopsym(41) == -1 .and. iopsym(45) == 1 ) then
    rotmat(1,1) = sqrt_1o2;  rotmat(1,2) = sqrt_1o2; rotmat(1,3) = 0._db
    rotmat(2,1) =-sqrt_1o2;  rotmat(2,2) = sqrt_1o2; rotmat(2,3) = 0._db
    rotmat(3,1) = 0._db;  rotmat(3,2) = 0._db; rotmat(3,3) = 1._db

! mm'm' --> m'm'm
  elseif(  iopsym(40) == 1 .and. iopsym(41) == -1 .and. iopsym(42) == -1 .and. iopsym(52) == 0 ) then
    rotmat(1,1) = 0._db;  rotmat(1,2) = 0._db; rotmat(1,3) = -1._db
    rotmat(2,1) = 0._db;  rotmat(2,2) = 1._db; rotmat(2,3) = 0._db
    rotmat(3,1) = 1._db;  rotmat(3,2) = 0._db; rotmat(3,3) = 0._db

! m'mm' --> m'm'm
  elseif(  iopsym(40) == 1 .and. iopsym(41) == -1 .and. iopsym(42) == -1 .and. iopsym(52) == 0 ) then
    rotmat(1,1) = 1._db;  rotmat(1,2) = 0._db; rotmat(1,3) = 0._db
    rotmat(2,1) = 0._db;  rotmat(2,2) = 0._db; rotmat(2,3) = -1._db
    rotmat(3,1) = 0._db;  rotmat(3,2) = 1._db; rotmat(3,3) = 0._db

! m'mm --> mmm'
  elseif(  iopsym(40) == -1 .and. iopsym(41) == 1 .and. iopsym(42) == 1 .and. iopsym(52) == 0 ) then
    rotmat(1,1) = 0._db;  rotmat(1,2) = 0._db; rotmat(1,3) = -1._db
    rotmat(2,1) = 0._db;  rotmat(2,2) = 1._db; rotmat(2,3) = 0._db
    rotmat(3,1) = 1._db;  rotmat(3,2) = 0._db; rotmat(3,3) = 0._db

! mm'm --> mmm'
  elseif(  iopsym(40) == 1 .and. iopsym(41) == -1 .and. iopsym(42) == 1 .and. iopsym(52) == 0 ) then
    rotmat(1,1) = 1._db;  rotmat(1,2) = 0._db; rotmat(1,3) = 0._db
    rotmat(2,1) = 0._db;  rotmat(2,2) = 0._db; rotmat(2,3) = -1._db
    rotmat(3,1) = 0._db;  rotmat(3,2) = 1._db; rotmat(3,3) = 0._db

! 2'mm' --> 2'm'm
  elseif( n_opsym == 4 .and. iopsym(24) == -1 .and. iopsym(40) == 1 .and. iopsym(41) == -1 ) then
    rotmat(1,1) = 0._db;  rotmat(1,2) = 1._db; rotmat(1,3) = 0._db
    rotmat(2,1) = -1._db;  rotmat(2,2) = 0._db; rotmat(2,3) = 0._db
    rotmat(3,1) = 0._db;  rotmat(3,2) = 0._db; rotmat(3,3) = 1._db

! 2'2'2 --> 22'2'   (ordre z,y,x)
  elseif( n_opsym == 4 .and. iopsym(22) == 1 .and. iopsym(23) == -1 .and. iopsym(24) == -1 ) then
    rotmat(1,1) = 0._db;  rotmat(1,2) = 0._db; rotmat(1,3) = -1._db
    rotmat(2,1) = 0._db;  rotmat(2,2) = 1._db; rotmat(2,3) = 0._db
    rotmat(3,1) = 1._db;  rotmat(3,2) = 0._db; rotmat(3,3) = 0._db

! 2'22' --> 22'2'   (ordre z,y,x)
  elseif( n_opsym == 4 .and. iopsym(22) == -1 .and. iopsym(23) == 1 .and. iopsym(24) == -1 ) then
    rotmat(1,1) = 1._db;  rotmat(1,2) = 0._db; rotmat(1,3) = 0._db
    rotmat(2,1) = 0._db;  rotmat(2,2) = 0._db; rotmat(2,3) = -1._db
    rotmat(3,1) = 0._db;  rotmat(3,2) = 1._db; rotmat(3,3) = 0._db

! Rotation 30 degres (6'mm --> 6'mm' and family)
  elseif( iopsym(40) == -1 .and. iopsym(41) == 1 .and. iopsym(51) == -1 ) then
    cs = cos( pi / 6 )
    sn = sin( pi / 6 )
    rotmat(1,1) =   cs;  rotmat(1,2) =  -sn; rotmat(1,3) = 0._db
    rotmat(2,1) =   sn;  rotmat(2,2) =   cs; rotmat(2,3) = 0._db
    rotmat(3,1) = 0._db;  rotmat(3,2) = 0._db; rotmat(3,3) = 1._db

  endif

  return
end

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

! Calculation of the ponctual group of the cluster

subroutine Sym_cluster( Atom_with_axe, Axe_atom_clu, E_moment_axis, iaabs, igroup, iopsym, itype, itypep, &
             natomp, ngroup, ngroup_m, nlat, nlatm, nspin, ntype, Numat, popats, pos, Symmol )

  use declarations
  implicit none

  integer:: ia, iaabs, ib, igr, igra, igrb, io, iok, is, isg, isp, ispin, it, ita, itb, na, natomp, nb, ngroup, ngroup_m, nla, &
    nlatm, nlb, nspin, ntype

  integer, dimension(natomp):: igroup, itypep
  integer, dimension(ngroup):: itype
  integer, dimension(0:ntype):: itequ, nlat, Numat
  integer, dimension(ngroup):: itypegen
  integer, dimension(nopsm):: iopsym

  logical:: E_moment_sym, Symmol
  logical, dimension(0:ngroup_m):: Atom_with_axe

  real(kind=db):: dpop, x

  real(kind=db), dimension(3):: Axe_atom_c, Axe_atom_s, E_moment_axis, ps, pt, v, vspin, vspini, wspin, wspini
  real(kind=db), dimension(3,3):: matopsym
  real(kind=db), dimension(ngroup,nlatm,nspin) :: popats
  real(kind=db), dimension(3,natomp):: Axe_atom_clu, pos

  do it = 0,ntype
    itequ(it) = it
  end do

  do ita = 0,ntype
    na = Numat(ita)
    nla = nlat(ita)
    do igra = 1,ngroup
      if( abs(itype(igra)) == ita ) exit
    end do
    if( igra > ngroup ) cycle
    do itb = ita+1,ntype
      if( itequ(itb) /= itb ) cycle
      nb = Numat(itb)
      if( nb /= na ) cycle
      nlb = nlat(itb)
      if( nlb /= nla ) cycle
      do igrb = 1,ngroup
        if( abs(itype(igrb)) == itb ) exit
      end do
      if( igrb > ngroup ) cycle

      dpop = 0._db
      do io = 1,nlb
        do isp = 1,nspin
          dpop = dpop + abs( popats(igra,io,isp) - popats(igrb,io,isp) )
        end do
      end do
      if( dpop < eps6 ) then
        itequ(itb) = ita
      elseif( nspin > 1 ) then
        dpop = 0._db
        do io = 1,nlb
          do isp = 1,nspin
            dpop = dpop + abs( popats(igra,io,isp) - popats(igrb,io,nspin-isp+1) )
          end do
        end do
        if( dpop < eps6 ) itequ(itb) = -ita
      endif

    end do
  end do

  do igr = 1,ngroup
    it = abs( itype(igr) )
    itypegen(igr) = itequ(it)
  end do

  iopsym(1) = 1; iopsym(2:nopsm) = 0

  boucle_sym: do is = 2,nopsm

    if( .not. E_moment_sym( is, E_moment_axis ) ) cycle

    call opsym(is,matopsym)

    boucle_exter: do ispin = 1,nspin

      if( ispin == 1 ) then
        isg = 1
      else
        isg = - 1
      endif

      do ia = 1,natomp
        ita = itypep(ia)
        igra = igroup(ia)
        ps(:) = pos(:,ia)
        pt = matmul( matopsym, ps )
        iok = 0
        if( ngroup_m > 0 ) then
          if( Atom_with_axe(igra) ) then
            Axe_atom_c(:) = Axe_atom_clu(:,ia)
            if( abs(Axe_atom_c(1)) < eps6 ) then
              wspin(1) = 1._db;  wspin(2:3) = 0._db
            else
              wspin(3) = 1._db;  wspin(1:2) = 0._db
            endif
            call prodvec( vspin, Axe_atom_c, wspin )
            x = sqrt( sum( vspin(:)**2 ) )
            vspin(:) = vspin(:) / x

            call prodvec( wspin, Axe_atom_c, vspin )

            vspini = matmul( matopsym, vspin )
            wspini = matmul( matopsym, wspin )
            call prodvec(Axe_atom_s,vspini,wspini)
            if( ispin == 2 ) Axe_atom_s(:) = - Axe_atom_s(:)

          endif
        endif

        do ib = 1,natomp
          if( .not. Symmol ) then   ! When nonexc, Symmol is automaticaly true
            if( ( ia == iaabs .and. ib /= iaabs ) .or. ( ia /= iaabs .and. ib == iaabs ) ) cycle
          endif
          v(1:3) = pos(1:3,ib) - pt(1:3)
          if( ia == ib ) then
            if( abs( v(1) ) > 1.e-8_db .or. abs( v(2) ) > 1.e-8_db .or. abs( v(3) ) > 1.e-8_db ) cycle
!            if( abs( v(1) ) > eps10 .or. abs( v(2) ) > eps10 .or. abs( v(3) ) > eps10 ) cycle
          else
            if( abs( v(1) ) > epspos .or. abs( v(2) ) > epspos .or. abs( v(3) ) > epspos ) cycle
          endif
          igrb = igroup(ib)
          if( abs(itypegen(igrb)) /= abs(itypegen(igra)) ) cycle

          if( ngroup_m == 0 ) then
            iok = 1
            exit
          endif
          if( .not. ( Atom_with_axe(igra) .or. Atom_with_axe(igrb) ) ) then
            iok = 1
            exit
          endif

          if( ( Atom_with_axe(igra) .and. .not. Atom_with_axe(igrb)) &
          .or.(.not. Atom_with_axe(igra) .and. Atom_with_axe(igrb))) cycle boucle_exter

          if( Atom_with_axe(igra) ) then
! L'axe de L'atome a ete renverse dans symsite si l'atome est antiferro
              if( abs( Axe_atom_clu(1,ib) - Axe_atom_s(1) ) > epspos .or. abs( Axe_atom_clu(2,ib) - Axe_atom_s(2) ) &
                                                    > epspos .or. abs( Axe_atom_clu(3,ib) - Axe_atom_s(3) ) &
                                    > epspos ) cycle boucle_exter
          else

            if(   ( abs( Axe_atom_clu(1,ib) - Axe_atom_s(1) ) > epspos &
             .and.  abs( Axe_atom_clu(1,ib) + Axe_atom_s(1) ) > epspos ) &
             .or. ( abs( Axe_atom_clu(2,ib) - Axe_atom_s(2) ) > epspos &
             .and.  abs( Axe_atom_clu(2,ib) + Axe_atom_s(2) ) > epspos ) &
             .or. ( abs( Axe_atom_clu(3,ib) - Axe_atom_s(3) ) > epspos &
             .and.  abs( Axe_atom_clu(3,ib) + Axe_atom_s(3) ) > epspos ) ) cycle boucle_sym

          endif

          iok = 1
          exit

        end do

        if( iok == 0 ) cycle boucle_exter

      end do

      iopsym(is) = isg
      exit

    end do boucle_exter

  end do boucle_sym

  return
end

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

! Matrices of the symmetry operations

subroutine opsym(is,matopsym)

  use declarations
  implicit none

  integer:: is

  real(kind=db):: Angle, Cos_a, Sin_a
  real(kind=db):: matsym1(3,3,6), matsym2(3,3,7:12), matsym3(3,3,13:18), matsym4(3,3,19:24), &
                 matsym5(3,3,25:30), matsym6(3,3,31:36), matsym7(3,3,37:42), matsym8(3,3,43:48), &
                 matsym9(3,3,49:54), matsym10(3,3,55:60), matsym11(3,3,61:nopsm), matopsym(3,3)

!      1 : identity
!      2 : rot 2*pi/3 around (1,1,1)
!      3 : rot 4*pi/3 around (1,1,1)
!      4 : rot 2*pi/3 around (1,-1,1)
!      5 : rot 4*pi/3 around (1,-1,1)
!      6 : rot 2*pi/3 around (-1,1,1)
  data matsym1/ 1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, &
                0.0_db, 0.0_db, 1.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, &
                0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 1.0_db, 0.0_db, 0.0_db, &
                0.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 1.0_db, 0.0_db, 0.0_db, &
                0.0_db, 0.0_db, 1.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, &
                0.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db,-1.0_db, 0.0_db, 0.0_db/
!      7 : rot 4*pi/3 around (-1,1,1)
!      8 : rot 2*pi/3 around (1,1,-1)
!      9 : rot 4*pi/3 around (1,1,-1)
!      10 : rot 2*pi/2 around (1,1,0)
!      11 : rot 2*pi/2 around (-1,1,0)
!      12 : rot 2*pi/2 around (1,0,1)
  data matsym2/ 0.0_db, 0.0_db,-1.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, &
                0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db,-1.0_db, 0.0_db, 0.0_db, &
                0.0_db, 0.0_db,-1.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, &
                0.0_db, 1.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, &
                0.0_db,-1.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, &
                0.0_db, 0.0_db, 1.0_db, 0.0_db,-1.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db/
!      13 : rot 2*pi/2 around (-1,0,1)
!      14 : rot 2*pi/2 around (0,1,1)
!      15 : rot 2*pi/2 around (0,-1,1)
!      16 : C4x, rot 2*pi/4 around 0x
!      17 : C4y, rot 2*pi/4 around 0y
!      18 : C4z, rot 2*pi/4 around 0z
  data matsym3/ 0.0_db, 0.0_db,-1.0_db, 0.0_db,-1.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db, &
               -1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, 1.0_db, 0.0_db, &
               -1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db,-1.0_db, 0.0_db, &
                1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, 1.0_db, 0.0_db, &
                0.0_db, 0.0_db, 1.0_db, 0.0_db, 1.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db, &
                0.0_db,-1.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db/
!      19 : -C4x, rot -2*pi/4 around 0x
!      20 : -C4y, rot -2*pi/4 around 0y
!      21 : -C4z, rot -2*pi/4 around 0z
!      22 : rot 2*pi/2 around 0x
!      23 : rot 2*pi/2 around 0y
!      24 : rot 2*pi/2 around 0z
  data matsym4/ 1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, &
                0.0_db, 1.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, -1.0_db, 0.0_db, 0.0_db, &
                0.0_db, 0.0_db, 1.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, &
               -1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, -1.0_db, 0.0_db, 0.0_db, &
                0.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db/
!      25 : inversion
!      26 : S4x, rot 2*pi/4 around 0x and miror
!      27 : S4y, rot 2*pi/4 around 0y and miror
!      28 : S4z, rot 2*pi/4 around 0z and miror
!      29 : -S4x, rot -2*pi/4 around 0x an dmiror
!      30 : -S4y, rot -2*pi/4 around 0y an dmiror
  data matsym5/ -1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, -1.0_db, 0.0_db, 0.0_db, &
                 0.0_db, 0.0_db,-1.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db,-1.0_db, 0.0_db, &
                -1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, &
                -1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, &
                 0.0_db,-1.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db/
!      31 : -S4z, rot -2*pi/4 around 0z and miror
!      32 : rot 2*pi/3 around (1,1,1) and inversion
!      33 : rot 4*pi/3 around (1,1,1) and inversion
!      34 : rot 2*pi/3 around (1,-1,1) and inversion
!      35 : rot 4*pi/3 around (1,-1,1) and inversion
!      36 : rot 2*pi/3 around (-1,1,1) and inversion
  data matsym6/ 0.0_db, 1.0_db, 0.0_db, -1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db,-1.0_db, &
               -1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, &
               -1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, -1.0_db, 0.0_db, 0.0_db, &
                0.0_db, 0.0_db,-1.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, &
                0.0_db, 0.0_db,-1.0_db, 1.0_db, 0.0_db, 0.0_db/
!      37 : rot 4*pi/3 around (-1,1,1) and inversion
!      38 : rot 2*pi/3 around (1,1,-1) and inversion
!      39 : rot 4*pi/3 around (1,1,-1) and inversion
!      40 : plane perpendicular to 0x
!      41 : plane perpendicular to 0y
!      42 : plane perpendicular to 0z
  data matsym7/ 0.0_db, 0.0_db, 1.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, &
                0.0_db, 0.0_db, 1.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, -1.0_db, 0.0_db, 0.0_db, &
                0.0_db, 1.0_db, 0.0_db, -1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, &
                1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 1.0_db, 0.0_db, 0.0_db, &
                0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db/
!      43 : plane diagonal y = z parallel to 0x
!      44 : plane diagonal x = z parallel to 0y
!      45 : plane diagonal x = y parallel to 0z
!      46 : plane diagonal y = -z parallel to 0x
!      47 : plane diagonal x = -z parallel to 0y
!      48 : plane diagonal x = -y parallel to Oz,
  data matsym8/ 1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, &
                0.0_db, 1.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db, 0.0_db, 1.0_db, 0.0_db, 0.0_db, &
                0.0_db, 0.0_db, 1.0_db, 1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db,-1.0_db, 0.0_db, &
                0.0_db, 0.0_db,-1.0_db, 0.0_db, 1.0_db, 0.0_db, -1.0_db, 0.0_db, 0.0_db, 0.0_db,-1.0_db, 0.0_db, &
               -1.0_db, 0.0_db, 0.0_db, 0.0_db, 0.0_db, 1.0_db/
!      49 : rot 2*pi/3 around 0z
!      50 : rot 4*pi/3 around 0z
!      51 : rot 2*pi/6 around 0z
!      52 : rot 10*pi/6 around 0z
!      53 : rot 2*pi/3 around 0z, negative axis
!      54 : rot 4*pi/3 around 0z, negative axis
  data matsym9/ -0.5_db,msqrt3s2,  0.0_db, sqrt3s2, -0.5_db,  0.0_db,  0.0_db,  0.0_db,  1.0_db, &
                -0.5_db, sqrt3s2,  0.0_db,msqrt3s2, -0.5_db,  0.0_db,  0.0_db,  0.0_db,  1.0_db, &
                 0.5_db,msqrt3s2,  0.0_db, sqrt3s2,  0.5_db,  0.0_db,  0.0_db,  0.0_db,  1.0_db, &
                 0.5_db, sqrt3s2,  0.0_db,msqrt3s2,  0.5_db,  0.0_db,  0.0_db,  0.0_db,  1.0_db, &
                -0.5_db,msqrt3s2,  0.0_db, sqrt3s2, -0.5_db,  0.0_db,  0.0_db,  0.0_db, -1.0_db, &
                -0.5_db, sqrt3s2,  0.0_db,msqrt3s2, -0.5_db,  0.0_db,  0.0_db,  0.0_db, -1.0_db/
!      55 : rot 2*pi/6 around 0z, negative axis
!      56 : rot 10*pi/6 around 0z, negative axis
!      57 : symmetry plane parallel to Oz, at phi = 30 degres
!      58 : 2-fold axis perpendicular to Oz, at phi = 30 degres
!      59 : symmetry plane parallel to Oz, at phi = 60 degres
!      60 : 2-fold axis perpendicular to Oz, at phi = 60 degres
  data matsym10/ 0.5_db,msqrt3s2,  0.0_db, sqrt3s2,  0.5_db,  0.0_db,  0.0_db,  0.0_db, -1.0_db, &
                 0.5_db, sqrt3s2,  0.0_db,msqrt3s2,  0.5_db,  0.0_db,  0.0_db,  0.0_db, -1.0_db, &
                 0.5_db, sqrt3s2,  0.0_db, sqrt3s2, -0.5_db,  0.0_db,  0.0_db,  0.0_db,  1.0_db, &
                 0.5_db, sqrt3s2,  0.0_db, sqrt3s2, -0.5_db,  0.0_db,  0.0_db,  0.0_db, -1.0_db, &
                -0.5_db, sqrt3s2,  0.0_db, sqrt3s2,  0.5_db,  0.0_db,  0.0_db,  0.0_db,  1.0_db, &
                -0.5_db, sqrt3s2,  0.0_db, sqrt3s2,  0.5_db,  0.0_db,  0.0_db,  0.0_db, -1.0_db/
!      61 : symmetry plane parallel to Oz, at phi = 120 degres
!      62 : 2-fold axis perpendicular to Oz, at phi = 120 degres
!      63 : symmetry plane parallel to Oz, at phi = 150 degres
!      64 : 2-fold axis perpendicular to Oz, at phi = 150 degres
  data matsym11/-0.5_db,msqrt3s2,  0.0_db,msqrt3s2,  0.5_db,  0.0_db,  0.0_db,  0.0_db,  1.0_db, &
                -0.5_db,msqrt3s2,  0.0_db,msqrt3s2,  0.5_db,  0.0_db,  0.0_db,  0.0_db, -1.0_db, &
                 0.5_db,msqrt3s2,  0.0_db,msqrt3s2, -0.5_db,  0.0_db,  0.0_db,  0.0_db,  1.0_db, &
                 0.5_db,msqrt3s2,  0.0_db,msqrt3s2, -0.5_db,  0.0_db,  0.0_db,  0.0_db, -1.0_db/

  if( is <= 6 ) then
    matopsym(:,:) = matsym1(:,:,is)
  elseif( is <= 12 ) then
    matopsym(:,:) = matsym2(:,:,is)
  elseif( is <= 18 ) then
    matopsym(:,:) = matsym3(:,:,is)
  elseif( is <= 24 ) then
    matopsym(:,:) = matsym4(:,:,is)
  elseif( is <= 30 ) then
    matopsym(:,:) = matsym5(:,:,is)
  elseif( is <= 36 ) then
    matopsym(:,:) = matsym6(:,:,is)
  elseif( is <= 42 ) then
    matopsym(:,:) = matsym7(:,:,is)
  elseif( is <= 48 ) then
    matopsym(:,:) = matsym8(:,:,is)
  elseif( is <= 54 ) then
    matopsym(:,:) = matsym9(:,:,is)
  elseif( is <= 60 ) then
    matopsym(:,:) = matsym10(:,:,is)
  elseif( is <= 64 ) then
    matopsym(:,:) = matsym11(:,:,is)
  else
! 5-fold axis not yet coded elsewhere
    select case(is)
      case(65,69) ! Axe 5
        Angle = 2 * pi / 5
      case(66,70) ! Axe 2 x 5
        Angle = 4 * pi / 5
      case(67,71) ! Axe 3 x 5
        Angle = 6 * pi / 5
      case(68,72) ! Axe 4 x 5
        Angle = 8 * pi / 5
    end select
    Cos_a = Cos( Angle )
    Sin_a = Sin( Angle )
    matopsym(1,1) =   Cos_a;  matopsym(1,2) = Sin_a;  matopsym(1,3) = 0._db
    matopsym(2,1) = - Sin_a;  matopsym(2,2) = Cos_a;  matopsym(2,3) = 0._db
    matopsym(3,1) =   0._db;  matopsym(3,2) = 0._db
    if( is <= 68 ) then
      matopsym(3,3) = 1._db
    else
      matopsym(3,3) = - 1._db
    endif
  endif

! Because data in fortran loop on columns inside lines
  matopsym = transpose( matopsym )

  return
end

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

subroutine numgrpt(iopsym,igrpt,igrpt_nomag,mpirank0,Sgrp)

  use declarations
  implicit none

  integer:: i, igr_sg, igrpt, igrpt_nomag, is, k, mpirank0, nb_ord, nb_sym, ni

  integer, dimension(nopsm):: iopsymc, iopsym

  character(len=8) PointGroup_name, PointGroup_nomag_name, PointGroup_Sch, PointSubGroup_name, &
                   PointSubGroup_Sch, ptgrname_int, ptgrname_int_nomag, ptgrname_sch

  logical:: Sgrp

  common/PointGroup_name/ PointGroup_name, PointGroup_nomag_name
  common/PointGroup_Sch/ PointGroup_Sch
  common/PointSubGroup_name/ PointSubGroup_name, PointSubGroup_Sch

  nb_sym = sum( abs(iopsym(:)) )

! La sphere est transformee en m3m
  if( sum( abs(iopsym(:)) ) == 64 ) iopsym(49:64) = 0
! Le cylindre est transformee en 6/mmm
  if( abs(iopsym(51)) == 1 .and. abs(iopsym(45)) == 1 ) then
    iopsym(10:11) = 0
    iopsym(18:21:3) = 0
    iopsym(28:31:3) = 0
    iopsym(45:48:3) = 0
  endif

! For S6 ponctual group, the symmetry below (C2x and C2 at 60 and 120 degres ) are a special, and unuseful case
  if( nb_sym == 9 .and. iopsym(25) == 1 .and. iopsym(49) == 1 .and. iopsym(55) == 1 ) then
    if( iopsym(22) == 1 .and. iopsym(60) == 1 .and. iopsym(62) == 1 ) then
      iopsym(22) = 0
      iopsym(60) = 0
      iopsym(62) = 0
    elseif( iopsym(23) == 0 .and. iopsym(58) == 1 .and. iopsym(64) == 1 ) then
      iopsym(23) = 0
      iopsym(58) = 0
      iopsym(64) = 0
    endif
  endif

  if( nb_sym == 2 ) then
    do i = 10,15
      if( iopsym(i) == -1 ) iopsym(i) = 0
    end do
    if( iopsym(22) == -1 ) iopsym(22) = 0
    if( iopsym(23) == -1 ) iopsym(23) = 0
    if( iopsym(40) == -1 ) iopsym(40) = 0
    if( iopsym(41) == -1 ) iopsym(41) = 0
    if( iopsym(58) == -1 ) iopsym(58) = 0
    if( iopsym(60) == -1 ) iopsym(60) = 0
    if( iopsym(62) == -1 ) iopsym(62) = 0
    if( iopsym(64) == -1 ) iopsym(64) = 0
  elseif( nb_sym == 4 ) then
    if( iopsym(11) == -1 .and. iopsym(45) == -1 .and. iopsym(25) == 1  ) then
      iopsym(11) = 0
      iopsym(45) = 0
    elseif( iopsym(22) == -1 .and. iopsym(40) == -1 .and. iopsym(25) == 1  ) then
      iopsym(22) = 0
      iopsym(40) = 0
    elseif( iopsym(23) == -1 .and. iopsym(41) == -1 .and. iopsym(25) == 1  ) then
      iopsym(23) = 0
      iopsym(41) = 0
    elseif( iopsym(22) == -1 .and. iopsym(41) == -1 .and. iopsym(42) == 1  ) then
      iopsym(22) = 0
      iopsym(41) = 0
    elseif( iopsym(23) == -1 .and. iopsym(40) == -1 .and. iopsym(42) == 1  ) then
      iopsym(23) = 0
      iopsym(40) = 0
    endif
  endif

  if( sgrp ) then
    ni = 2
  else
    ni = 1
  endif

  do i = 1,ni

    boucle_grpt: do igrpt = 1,ngrptmagm

      call grp_opsym(igr_sg,igrpt,igrpt_nomag,iopsymc,nb_ord)

      do k = 1,nopsm
        if( iopsym(k) /= iopsymc(k) ) cycle boucle_grpt
      end do

      PointGroup_name = ptgrname_int(igrpt)
      if( igrpt > ngrptm ) then
        PointSubGroup_name = ptgrname_int_nomag(igr_sg)
        PointSubGroup_Sch = ptgrname_Sch(igr_sg)
      endif
      PointGroup_nomag_name = ptgrname_int_nomag(igrpt_nomag)
      PointGroup_Sch = ptgrname_sch(igrpt_nomag)

      return

    end do boucle_grpt

! Case of magnetic groups where one takes a sub-group to get the spin axis convenient
    if( Sgrp .and. i == 1 ) then
      is = nopsm
      if( abs( iopsym(25) ) == 1 ) then
        is = 25
      elseif( iopsym(42) == 1 ) then
        is = 42
      elseif( iopsym(24) == 1 ) then
        is = 24
      endif
      iopsym(2:is-1) = 0
      iopsym(is+1:nopsm) = 0
    endif

  end do

! Desesperate cases. I suppress most  or all symmetries...
  if( iopsym(18) == 1 ) then
! 4 fold axis around z
    is = 18
    iopsym(2:is-1) = 0
    iopsym(is+1:nopsm) = 0
    igrpt = 9
  elseif( iopsym(25) == 1 ) then
! inversion
    is = 25
    iopsym(2:is-1) = 0
    iopsym(is+1:nopsm) = 0
    igrpt = 2
  elseif(iopsym(24) == 1 ) then
! 2 fold axis around z
    is = 24
    iopsym(2:is-1) = 0
    iopsym(is+1:nopsm) = 0
    igrpt = 4
  else
    iopsym(2:nopsm) = 0
    igrpt = 1
  endif
  call grp_opsym(igr_sg,igrpt,igrpt_nomag,iopsymc,nb_ord)

  PointGroup_name = ptgrname_int(igrpt)
  PointGroup_nomag_name = ptgrname_int_nomag(igrpt_nomag)
  PointGroup_Sch = ptgrname_sch(igrpt_nomag)

 ! if( mpirank0 == 0 ) then
 !   call write_error
 !   do ipr = 6,9,3
 !     write(ipr,'(/A)') ' Point group not found !'
 !     write(ipr,'(/A)') ' iopsymc ='
 !     call write_iopsym(iopsym,ipr)
 !   end do
 !   stop
 ! endif

  return
end

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

! Simplified version with all group and not magnetic

subroutine numgrpt_s(iopsym,igrpt,igrpt_nomag,mpirank0,Sgrp)

  use declarations
  implicit none

  integer:: i, igr_sg, igrpt, igrpt_nomag, ipr, is, k, mpirank0, nb_ord, ni

  integer, dimension(nopsm):: iopsymc, iopsym

  character(len=8) PointGroup_name, PointGroup_nomag_name, PointGroup_Sch, PointSubGroup_name, &
                   PointSubGroup_Sch, ptgrname_int, ptgrname_int_nomag, ptgrname_sch

  logical:: Sgrp

  common/PointGroup_name/ PointGroup_name, PointGroup_nomag_name
  common/PointGroup_Sch/ PointGroup_Sch
  common/PointSubGroup_name/ PointSubGroup_name, PointSubGroup_Sch

! La sphere est transformee en m3m
  if( sum( abs(iopsym(:)) ) == 64 ) iopsym(49:64) = 0
! Le cylindre est transformee en 6/mmm
  if( abs(iopsym(51)) == 1 .and. abs(iopsym(45)) == 1 ) then
    iopsym(10:11) = 0
    iopsym(18:21:3) = 0
    iopsym(28:31:3) = 0
    iopsym(45:48:3) = 0
!    iopsym(65:72) = 0
  endif
!  if( iopsym(65) /= 0 .or. iopsym(69) /= 0 ) then
!    iopsym(2:41) = 0
!    iopsym(43:64) = 0
!  endif

  if( sgrp ) then
    ni = 2
  else
    ni = 1
  endif

  do i = 1,ni

    boucle_grpt: do igrpt = 1,ngrptmagm+ngrpt_compm+ngrptmag_compm

      call grp_opsym_s(igr_sg,igrpt,igrpt_nomag,iopsymc,nb_ord)

      do k = 1,nopsm
        if( iopsym(k) /= iopsymc(k) ) cycle boucle_grpt
      end do

      if( igrpt <= ngrptmagm+ngrpt_compm ) then
        PointGroup_name = ptgrname_int_nomag(igrpt)
      else
        PointGroup_name = ptgrname_int(igrpt)
      endif
      if( igrpt > ngrptm+ngrpt_compm ) then
        PointSubGroup_name = ptgrname_int_nomag(igr_sg)
        PointSubGroup_Sch = ptgrname_Sch(igr_sg)
      endif
      PointGroup_nomag_name = ptgrname_int_nomag(igrpt_nomag)
      PointGroup_Sch = ptgrname_sch(igrpt_nomag)

      return

    end do boucle_grpt

! Cas des groupes magnetiques ou on prend un sous-groupe pour avoir
! L'axe du spin conforme.
    if( Sgrp .and. i == 1 ) then
      is = nopsm
      if( abs( iopsym(25) ) == 1 ) then
        is = 25
      elseif( iopsym(42) == 1 ) then
        is = 42
      elseif( iopsym(24) == 1 ) then
        is = 24
      endif
      iopsym(2:is-1) = 0
      iopsym(is+1:nopsm) = 0
    endif

  end do

  if( mpirank0 == 0 ) then
    call write_error
    do ipr = 6,9,3
      write(ipr,'(/A)') ' Point group not found !'
      write(ipr,'(/A)') ' iopsymc ='
      call write_iopsym(iopsym,ipr)
    end do
    stop
  endif

  return
end

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

subroutine grp_opsym_imp(iopsymc,igrpt,igrpt_nomag,mpirank0,PointGroup)

  use declarations
  implicit none

  integer:: igrpt, igr_sg, igrpt_nomag, igrpt_nomagt, igrptt, ipr, k, mpirank0, nb_ord

  integer, dimension(nopsm):: iopsymc, iopsymt

  character(len=8) PointGroup, PointGroup_name, PointGroup_nomag_name, PointGroup_Sch, ptgrname_int, ptgrname_sch

  common/PointGroup_name/ PointGroup_name, PointGroup_nomag_name
  common/PointGroup_Sch/ PointGroup_Sch

  if( PointGroup == 'SousGr' ) then

    boucle_grpt1: do igrptt = 1,ngrptmagm

      call grp_opsym(igr_sg,igrptt,igrpt_nomagt,iopsymt,nb_ord)

      if( igrpt_nomagt /= igrpt_nomag ) cycle

      do k = 1,nopsm
        if( iopsymt(k) == 0 ) cycle
        if( iopsymt(k) /= iopsymc(k) ) cycle boucle_grpt1
      end do

      exit

    end do boucle_grpt1

    igrpt = igrptt
    igrpt_nomag = igrpt_nomagt
    iopsymc(:) = iopsymt(:)

    PointGroup_name = ptgrname_int(igrpt)
    PointGroup_nomag_name = ptgrname_int(igrpt_nomag)
    PointGroup_Sch = ptgrname_sch(igrpt_nomag)

    return

  else

    boucle_grpt: do igrpt = 1,ngrptmagm

      if( PointGroup /= ptgrname_int(igrpt) ) then
        if( igrpt > ngrptm ) cycle
        if( PointGroup /= ptgrname_sch(igrpt) ) cycle
      endif

      call grp_opsym(igr_sg,igrpt,igrpt_nomag,iopsymc,nb_ord)

      PointGroup_name = ptgrname_int(igrpt)
      PointGroup_nomag_name = ptgrname_int(igrpt_nomag)
      PointGroup_Sch = ptgrname_sch(igrpt_nomag)

      return

    end do boucle_grpt

  endif

  if( mpirank0 == 0 ) then
    call write_error
    do ipr = 6,9,3
      write(ipr,'(/A)') ' Point group not found !'
    end do
    stop
  endif

  return
end

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

subroutine grp_opsym(igr_sg,igrpt,igrpt_nomag,iopsymc,nb_ord)

  use declarations
  implicit none

  integer:: ideb, igr_sg, igrpt, igrpt_nomag, ios, is, jdeb, js, nb_ord, nb_ord_sg, numbops

  integer, dimension(ngrptm+1:ngrptmagm+ngrptmag_compm):: ngref, ngnmg
  integer, dimension(nopsm):: iopsymc

! Numero de groupe non magnetique reference pour les groupes magnetiques
  data ngref/ 2, 4, 3, 5, 5, 5, 7, 6, 6, 8, 8, 8,19,18,21,24,24,24, 9,10,14,14,11,11,11,12,12,13,13,13, &
             15,15,15,15,15,22,17,20,20,20,26,26,23,23,23,25,25,27,27,27,27,27,29,30,31,32,32,32, &
              7, 7, 6, 8, 8, 8, 8,12,26,25/

! Numero du sous-groupe non magnetique non multiplie par le renversement
! du temps pour les groupes magnetiques
  data ngnmg/ 1, 1, 1, 4, 3, 2, 4, 4,34, 7, 6, 5,16,16,16,21,18,41, 4, 4, 9, 7, 9,10, 5, 9, 6,10, 7,42, &
             14,12, 8,13,11,16,16,19,18,17,22,19,22,17,21,22,18,24,20,23,26,25,28,28,28,31,30,29, &
             35,36,33,39,40,37,38,42,41,43/

  iopsymc(:) = 0

  if( igrpt > ngrptm ) then
    igrpt_nomag = ngref(igrpt)
  else
    igrpt_nomag = igrpt
  endif

  nb_ord = numbops( igrpt_nomag )

  ideb = 0
  do is = 1,igrpt_nomag - 1
    ideb = ideb + numbops(is)
  end do

  do is = 1,nb_ord
    iopsymc( ios(ideb+is) ) = 1
  end do

! Groupes magnetiques : on met un signe negatif pour les operations
! multipliees par le renversement du temps.

  if( igrpt > ngrptm ) then

! Sous-groupe contenant les operations non multiplies par le
! renversement du temps
    igr_sg = ngnmg(igrpt)
    nb_ord_sg = numbops(igr_sg)
    jdeb = 0
    do is = 1,igr_sg - 1
      jdeb = jdeb + numbops(is)
    end do
    boucle_is: do is = 1,nb_ord
      do js = 1,nb_ord_sg
        if( ios(ideb+is) == ios(jdeb+js) ) cycle boucle_is
      end do
      iopsymc( ios(ideb+is) ) = - iopsymc( ios(ideb+is) )
    end do boucle_is

  endif

  return
end

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

subroutine grp_opsym_s(igr_sg,igrpt,igrpt_nomag,iopsymc,nb_ord)

  use declarations
  implicit none

  integer:: ideb, igr_sg, igrpt, igrpt_nomag, ios, is, jdeb, js, nb_ord, nb_ord_sg, numbops

  integer, dimension(ngrptm+ngrpt_compm+1:ngrptmagm+ngrpt_compm+ngrptmag_compm):: ngref, ngnmg
  integer, dimension(nopsm):: iopsymc

! Numero de groupe non magnetique reference pour les groupes magnetiques
  data ngref/ 2, 4, 3, 5, 5, 5, 7, 6, 6, 8, 8, 8,19,18,21,24,24,24, 9,10,14,14,11,11,11,12,12,13,13,13, &
             15,15,15,15,15,22,17,20,20,20,26,26,23,23,23,25,25,27,27,27,27,27,29,30,31,32,32,32, &
              7, 7, 6, 8, 8, 8, 8,12,26,25/

! Numero du sous-groupe non magnetique non multiplie par le renversement
! du temps pour les groupes magnetiques
  data ngnmg/ 1, 1, 1, 4, 3, 2, 4, 4,34, 7, 6, 5,16,16,16,21,18,41, 4, 4, 9, 7, 9,10, 5, 9, 6,10, 7,42, &
             14,12, 8,13,11,16,16,19,18,17,22,19,22,17,21,22,18,24,20,23,26,25,28,28,28,31,30,29, &
             35,36,33,39,40,37,38,42,41,43/

  iopsymc(:) = 0

  if( igrpt > ngrptm+ngrpt_compm ) then
    igrpt_nomag = ngref(igrpt)
  else
    igrpt_nomag = igrpt
  endif

  nb_ord = numbops( igrpt_nomag )

  ideb = 0
  do is = 1,igrpt_nomag - 1
    ideb = ideb + numbops(is)
  end do

  do is = 1,nb_ord
    iopsymc( ios(ideb+is) ) = 1
  end do

! Groupes magnetiques : on met un signe negatif pour les operations
! multipliees par le renversement du temps.

  if( igrpt > ngrptm+ngrpt_compm ) then

! Sous-groupe contenant les operations non multiplies par le
! renversement du temps
    igr_sg = ngnmg(igrpt)
    nb_ord_sg = numbops(igr_sg)
    jdeb = 0
    do is = 1,igr_sg - 1
      jdeb = jdeb + numbops(is)
    end do
    boucle_is: do is = 1,nb_ord
      do js = 1,nb_ord_sg
        if( ios(ideb+is) == ios(jdeb+js) ) cycle boucle_is
      end do
      iopsymc( ios(ideb+is) ) = - iopsymc( ios(ideb+is) )
    end do boucle_is

  endif

  return
end

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

subroutine Character_table(icheck,igrpt_nomag,karact,nb_rep)

  use declarations
  implicit none

  integer, parameter:: nclasm = 12

  integer:: i, ic, icheck, id, ideb, ifin, igrpt_nomag, ios, irep, is, j, jc, k, L, nb_cla, nb_rep, nc, nr, numbops

  integer, dimension(ngrptm):: nb_cla_table, nb_rep_table
  integer, dimension(nopsm):: nb_sympcl(nclasm)

  character(len=8):: PointGroup_name, PointGroup_nomag_name
  character(len=9):: nomsym
  character(len=36), dimension(12):: ch
  character(len=144):: mot

  complex(kind=db), dimension(nclasm,nrepm):: kar
  complex(kind=db), dimension(nopsm,nrepm):: karact

  logical:: inversion, jexp, kexp

  real(kind=db):: r

  common/PointGroup_name/ PointGroup_name, PointGroup_nomag_name

  data nb_cla_table/1,2,2,2,4,4,4,8,4,4, 8,5,5,5,10,3,6,3,3,6, 6,6,12,6,6,6,12,4,6,5, 5,10/

  data nb_rep_table/1,2,2,2,4,4,4,8,3,3, 6,5,5,5,10,2,4,3,3,6, 4,4,8,6,6,6,12,3,6,5, 5,10/

  nb_cla = nb_cla_table(igrpt_nomag)
  nb_rep = nb_rep_table(igrpt_nomag)

  inversion = .false.

  select case(PointGroup_nomag_name)

    case('1')                      ! C1 1
      ch(1) = '  1'

    case('-1','m','2')             ! Ci, Cs, C2, 2 3 4
      inversion = .true.
      ch(1) = '  1'

    case('2/m','mm','222')         ! C2h, C2v, D2 5 6 7
      inversion = .true.
      ch(1) = '  1  1'
      ch(2) = '  1 -1'

    case('mmm')                    ! D2h 8
      inversion = .true.
      ch(1) = '  1  1  1  1'
      ch(2) = '  1  1 -1 -1'
      ch(3) = '  1 -1  1 -1'
      ch(4) = '  1 -1 -1  1'

    case('4','-4')                 ! C4, S4 9 10
      ch(1) = '  1  1  1  1'
      ch(2) = '  1  1 -1 -1'
      ch(3) = '  1 -1  i -i'

    case('4/m')                    ! C4h 11
      inversion = .true.
      ch(1) = '  1  1  1  1'
      ch(2) = '  1 -1  1 -1'
      ch(3) = '  1  i -1 -i'

    case('4mm','-42m','422')       ! C4v, D2d, D4   12 13 14
      ch(1) = '  1  1  1  1  1'
      ch(2) = '  1  1  1 -1 -1'
      ch(3) = '  1  1 -1  1 -1'
      ch(4) = '  1  1 -1 -1  1'
      ch(5) = '  2 -2  0  0  0'

    case('4/mmm')                  ! D4h  15
      inversion = .true.
      ch(1) = '  1  1  1  1  1'
      ch(2) = '  1  1  1 -1 -1'
      ch(3) = '  1 -1  1  1 -1'
      ch(4) = '  1 -1  1 -1  1'
      ch(5) = '  2  0 -2  0  0'

    case('3')                      ! C3  16
      ch(1) = '  1  1  1'
      ch(2) = '  1  j j2'

    case('-6')                     ! C3h   21
      ch(1) = '  1  1  1  1  1  1'
      ch(2) = '  1  j j2  1  j j2'
      ch(3) = '  1  1  1 -1 -1 -1'
      ch(4) = '  1  j j2 -1 k5  k'

    case('-3','6')            ! S6, C6   17 22
      inversion = .true.
      ch(1) = '  1  1  1'
      ch(2) = '  1  j j2'

    case('3m','32')                ! C3v D3  18 19
      ch(1) = '  1  1  1'
      ch(2) = '  1  1 -1'
      ch(3) = '  2 -1  0'

    case('-3m','-6m2','6mm','622') ! D3d D3h C6v D6  20 24 25 26
      inversion = .true.
      ch(1) = '  1  1  1'
      ch(2) = '  1  1 -1'
      ch(3) = '  2 -1  0'

    case('6/m')                    ! C6h  23
      inversion = .true.
      ch(1) = '  1  1  1  1  1  1'
      ch(2) = '  1 -1  1 -1  1 -1'
      ch(3) = '  1  k  j -1 j2 k5'
      ch(4) = '  1  j j2  1  j j2'

    case('6/mmm')                  ! D6h 27
      inversion = .true.
      ch(1) = '  1  1  1  1  1  1'
      ch(2) = '  1  1  1  1 -1 -1'
      ch(3) = '  1 -1  1 -1  1 -1'
      ch(4) = '  1 -1  1 -1 -1  1'
      ch(5) = '  2  1 -1 -2  0  0'
      ch(6) = '  2 -1 -1  2  0  0'

    case('23')                     ! T 28
      ch(1) = '  1  1  1  1'
      ch(2) = '  1  1  j j2'
      ch(3) = '  3 -1  0  0'

    case('m3')                     ! Th 29
      inversion = .true.
      ch(1) = '  1  1  1  1'
      ch(2) = '  1  j j2  1'
      ch(3) = '  3  0  0 -1'

    case('-43m','432')             ! Td, O  30 31
      ch(1) = '  1  1  1  1  1'
      ch(2) = '  1  1  1 -1 -1'
      ch(3) = '  2 -1  2  0  0'
      ch(4) = '  3  0 -1 -1  1'
      ch(5) = '  3  0 -1  1 -1'

    case('m3m')                    ! Oh 32
      inversion = .true.
      ch(1) = '  1  1  1  1  1'
      ch(2) = '  1  1 -1 -1  1'
      ch(3) = '  2 -1  0  0  2'
      ch(4) = '  3  0 -1  1 -1'
      ch(5) = '  3  0  1 -1 -1'

  end select

  if( inversion ) then
    nc = nb_cla / 2
    nr = nb_rep / 2
  else
    nc = nb_cla
    nr = nb_rep
  endif

  if( inversion ) then
    do irep = 1,nr
      mot = ch(irep)
      L = len_trim(mot)
      mot(L+1:2*L) = mot(1:L)
      ch(irep) = mot
      do ic = nc+1, nb_cla
        j = 3*ic-1
        select case( mot(j:j) )
          case(' ')
            mot(j:j) = '-'
          case('-')
            mot(j:j) = ' '
          case('j')
            mot(j:j+1) = ' k'
          case('k')
            mot(j:j+1) = ' j'
        end select
      end do
      ch(irep+nr) = mot
    end do
  endif

  r = sqrt( 3._db ) / 2

  do j = 1,nr
    jc = -3
    mot = ch(j)
    do i = 1,nc
      jc = jc + 3

      select case(mot(jc+2:jc+3))
        case(' 0')
          kar(i,j) = (0._db,0._db)
        case(' 1')
          kar(i,j) = (1._db,0._db)
        case('-1')
          kar(i,j) = (-1._db,0._db)
        case(' 2')
          kar(i,j) = (2._db,0._db)
        case('-2')
          kar(i,j) = (-2._db,0._db)
        case(' 3')
          kar(i,j) = (3._db,0._db)
        case('-3')
          kar(i,j) = (-3._db,0._db)
        case(' i')
          kar(i,j) = (0._db,1._db)
        case('-i')
          kar(i,j) = (0._db,-1._db)
        case(' j')
          kar(i,j) = cmplx(-0.5_db,r,db)
        case('j2')
          kar(i,j) = cmplx(-0.5_db,-r,db)
        case(' k')
          kar(i,j) = cmplx(0.5_db,r,db)
        case('k5')
          kar(i,j) = cmplx(0.5_db,-r,db)
      end select
    end do
  end do

  if( inversion ) then
    do j = 1,nc
      kar(j+nc,1:nr) = kar(j,1:nr)
    end do
    do i = 1,nr
      kar(1:nc,i+nr) = kar(1:nc,i)
      kar(nc+1:nb_cla,i+nr) = - kar(nc+1:nb_cla,i)
    end do
  endif

  nb_sympcl(1:nc) = 1

  select case(PointGroup_nomag_name)

    case('4mm  ','-42m ','422  ')
      nb_sympcl(3:5) = 2

    case('4/mmm')
      nb_sympcl(2) = 2; nb_sympcl(4:5) = 2

    case('3m','32','-3m','-6m2','6mm','622')
      nb_sympcl(2) = 2; nb_sympcl(3) = 3

    case('23')
      nb_sympcl(2) = 3; nb_sympcl(3) = 4; nb_sympcl(4) = 3

    case('m3')
      nb_sympcl(2) = 4; nb_sympcl(3) = 4; nb_sympcl(4) = 3

    case('-43m','432')
      nb_sympcl(2) = 8; nb_sympcl(3) = 3; nb_sympcl(4:5) = 6

    case('m3m')
      nb_sympcl(2) = 8; nb_sympcl(3:4) = 6; nb_sympcl(5) = 3

  end select

  if( inversion ) then
    do j = 1,nc
      nb_sympcl(j+nc) = nb_sympcl(j)
    end do
  endif

  ideb = 0
  do is = 1,igrpt_nomag - 1
    ideb = ideb + numbops(is)
  end do

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

  boucle_is: do is = 1,numbops( igrpt_nomag )

    k = 0
    do i = 1,nb_cla
      do j = 1,nb_sympcl(i)
        k = k + 1
        if( k == is ) then
          karact(ios(ideb+is),1:nb_rep) = kar(i,1:nb_rep)
          cycle boucle_is
        endif
      end do
    end do

  end do boucle_is

  if( icheck > 0 ) then
    ifin = 0
    do is = 1,igrpt_nomag
      ifin = ifin + numbops(is)
    end do
    write(3,110)
    write(3,'(5x,48i3)') ( ios(is), is = ideb+1,ifin )
    do irep = 1,nb_rep
      mot = ch(irep)
      ic = 0
      do i = 1,nb_cla
        ic = ic + 3
        if( nb_sympcl(i) > 1 ) then
          id = 3 * nb_sympcl(i) - 3
          L = len_trim(mot)
          mot(ic+1+id:L+id) = mot(ic+1:L)
          mot(ic+1:ic+id) = ' '
          ic = ic + id
        endif
      end do
      write(3,'(5x,a)') mot
    end do
    jexp = .false.; kexp = .false.
    do i = 1,len_trim(mot)
      if( mot(i:i) == 'j' ) jexp = .true.
      if( mot(i:i) == 'k' ) kexp = .true.
    end do
    if( jexp .or. kexp ) then
      write(3,'(/A)') ' Symmetry code      Character code'
    else
      write(3,'(/A)') ' Symmetry code:'
    endif
    do is = ideb+1,ifin
      if( is == ideb+1 .and. jexp ) then
        write(3,120) ios(is), nomsym(ios(is))
      elseif( is == ideb+1 .and. kexp ) then
        write(3,130) ios(is), nomsym(ios(is))
      elseif( is == ideb+2 .and. jexp .and. kexp ) then
        write(3,130) ios(is), nomsym(ios(is))
      else
        write(3,140) ios(is), nomsym(ios(is))
      endif
    end do
  endif

  return
  110 format(/' Character table :')
  120 format(2x,i3,a9,'     j = exp(2.i.pi/3)')
  130 format(2x,i3,a9,'     k = exp(i.pi/3)')
  140 format(2x,i3,a9)
end

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

! Subprogram evaluating the tensor shapes
! Result used in tenseur_car subroutine

subroutine Tensor_shape( Atom_with_axe, Nonsph, Axe_atom_clu, Dipmag, E_moment_axis, E1E2_imp, E1E2e, &
            Green, iaabs, icheck, igroup, igrpt0, iopsymc, iopsymr, itype, itypep, ldip, loct, lqua, Lseuil, Magnetic, &
            mpirank0, msymdd, msymddi, msymdq, msymdqi, msymdo, msymdoi, msymoo, msymooi, msymqq, msymqqi, Multipole, n_oo, &
            natomp, ngroup, ngroup_m, nlat, nlatm, nspin, ntype, Numat, Octupole, Popats, Pos, Quadrupole, Rot_atom_abs, &
            Rot_atom_spin, Rot_cluster, Spinorbite, State_all, Symmol, Tensor_imp )

  use declarations
  implicit none

  integer:: he, hs, i, iaabs, ical, icheck, igrpt, igrpt0, ii, j, j1, j2, je, jhe, jhs, jj, jj1, jj2, js, k, ke, kk, ks, L, &
    Lseuil, mpirank0, n, n_oo, natomp, ngroup, ngroup_m, nlatm, nspin, ntype

  integer, dimension(3):: ldip, ldipimp
  integer, dimension(12):: Tensor_imp
  integer, dimension(3,3):: lqua, lquaimp, msymdd, msymddi
  integer, dimension(3,3,3):: loct, msymdq, msymdqi
  integer, dimension(3,3,3,3):: msymdo, msymdoi, msymqq, msymqqi
  integer, dimension(3,n_oo,3,n_oo):: msymoo, msymooi
  integer, dimension(nopsm):: iopsym_abs, iopsymc, iopsymr, iopsymt, irotiops
  integer, dimension(natomp):: igroup, itypep
  integer, dimension(ngroup):: itype
  integer, dimension(0:ntype):: nlat, Numat

  logical:: Atom_comp, Atom_comp_cal, Atom_mag, Atom_mag_cal, Nonsph, Dipmag, E1E1, E1E2, E1E2_imp, E1E2e, E1E3, &
     E2E2, E3E3, Green, magnet, Magnetic, Octupole, Quadrupole, Spinorbite, State_all, Symmol
  logical, dimension(13):: Multipole
  logical, dimension(0:ngroup_m):: Atom_with_axe

  real(kind=db), dimension(3):: E_moment_axis, ps
  real(kind=db), dimension(3,3):: Rot_atom_abs, Rot_cluster, Rot_tem
  real(kind=db), dimension(3,natomp):: Axe_atom_clu, pos
  real(kind=db), dimension(3,3,natomp):: Rot_atom_spin
  real(kind=db), dimension(ngroup,nlatm,nspin):: popats

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

  E1E1 = Multipole(1); E1E3 = Multipole(3);
  E2E2 = Multipole(6); E3E3 = Multipole(7);

  msymdd(:,:) = 0
  msymddi(:,:) = 0

  ldipimp(1:3) = Tensor_imp(1:3)
  k = 3
  do i = 1,3
    do j = 1,3
      k = k + 1
      lquaimp(i,j) = Tensor_imp(k)
    end do
  end do

! Evaluation of the absorbing atom symmetry
  if( Magnetic ) then
    Atom_mag = Atom_mag_cal(igrpt0)
  else
    Atom_mag = .false.
  endif
  Atom_comp = Atom_comp_cal(igrpt0)

  ps(:) = pos(:,iaabs)
  if( nspin == 1 .and. sum( abs( pos(:,iaabs) ) ) < eps10 ) then
    iopsym_abs(:) = iopsymc(:)
  else
    if( spinorbite ) then
      call Point_group_atom(Atom_comp,Atom_mag,Atom_with_axe,Nonsph,Axe_atom_clu,E_moment_axis, &
        iaabs,iaabs,icheck,igroup,igrpt,igrpt0,iopsym_abs,iopsymr,itype,itypep,Magnetic,mpirank0, &
        natomp,ngroup,ngroup_m,nlat,nlatm,nspin,ntype,Numat,popats,pos,ps,Rot_atom_abs,Rot_atom_spin,Spinorbite,Symmol,.false.)
    else
! Here one uses the complete symmetry (iopsymc)
      call Point_group_atom(Atom_comp,Atom_mag,Atom_with_axe,Nonsph,Axe_atom_clu,E_moment_axis, &
        iaabs,iaabs,icheck,igroup,igrpt,igrpt0,iopsym_abs,iopsymc,itype,itypep,Magnetic,mpirank0, &
        natomp,ngroup,ngroup_m,nlat,nlatm,nspin,ntype,Numat,popats,pos,ps,Rot_atom_abs,Rot_atom_spin,Spinorbite,Symmol,.false.)
    endif
  endif
! The rotation is calculated with the used symmetry (iopsymr)
  call Point_group_atom(Atom_comp,Atom_mag,Atom_with_axe,Nonsph,Axe_atom_clu,E_moment_axis, &
      iaabs,iaabs,icheck,igroup,igrpt,igrpt0,iopsymt,iopsymr,itype,itypep,Magnetic,mpirank0, &
      natomp,ngroup,ngroup_m,nlat,nlatm,nspin,ntype,Numat,popats,pos,ps,Rot_atom_abs,Rot_atom_spin,Spinorbite,Symmol,.false.)

!  if( Spin_axis_free ) then
!    Rot_atom_abs(:,:) = 0._db
!    Rot_atom_abs(1,1) = 1._db; Rot_atom_abs(2,2) = 1._db; Rot_atom_abs(3,3) = 1._db
!  endif

  if( spinorbite .or. ( nspin == 2 .and. Lseuil > 0 ) ) then
    magnet = .true.
  else
    magnet = .false.
  endif

  do ical = 1,2
    if( State_all ) then
      irotiops(:) = 0
      irotiops(1) = 1
    else
      if( ical == 1 ) then
        rot_tem = transpose(matmul(Rot_cluster,transpose(rot_atom_abs)))
        if( abs( rot_tem(1,1) - 1 ) < eps10 .and. abs( rot_tem(2,2) - 1 ) < eps10 .and. &
            abs( rot_tem(3,3) - 1 ) < eps10 ) cycle
        call iop_rot(icheck,irotiops,rot_tem)
        where( irotiops /= 0 ) irotiops = iopsym_abs(irotiops)
      else
        irotiops = iopsym_abs
      endif
    endif

! Tensor shape calculation
    if( E1E1 .or. dipmag ) call tensdd(irotiops,magnet,msymdd,msymddi)
    if( E1E2e ) call tensdq(irotiops,magnet,msymdq,msymdqi)
    if( E2E2 ) call tensqq(irotiops,magnet,msymqq,msymqqi)
    if( E1E3 ) call tensdo(irotiops,magnet,msymdo,msymdoi)
    if( E3E3 ) call tensoo(irotiops,magnet,msymoo,msymooi,n_oo)

! Terme d'interference dipole - quadrupole
    E1E2 = E1E2e
    if( E1E2e .and. .not. E1E2_imp ) then
      n = maxval( abs(msymdq) )
      n = max( n, maxval( abs(msymdqi) ) )
      if( n == 0 ) E1E2 = .false.
    endif
    Multipole(2) = E1E2

    if( icheck > 0 ) then
      if( ical == 1 ) then
        write(3,102)
      else
        write(3,104)
      endif
      if( magnet ) then
        if( E1E1 .or. dipmag ) then
          write(3,110)
          do i = 1,3
            write(3,120) ( msymdd(i,k), msymddi(i,k), k = 1,3)
          end do
        endif
        if( E1E2e ) then
          write(3,130)
          do j = 1,3
            write(3,120) ( ( msymdq(i,j,k), msymdqi(i,j,k), k =1,3), i = 1,3 )
          end do
        endif
        if( E2E2 ) then
          write(3,140)
          do i = 1,3
            write(3,150) i, i, i
            do k = 1,3
              write(3,120) ( ( msymqq(i,j,k,L), msymqqi(i,j,k,L), L = 1,3), j = 1,3 )
            end do
          end do
        endif
        if( E1E3 ) then
          write(3,160)
          do i = 1,3
            write(3,150) i, i, i
            do k = 1,3
              write(3,120) ( (msymdo(i,j,k,L), msymdoi(i,j,k,L), L = 1,3 ), j = 1,3 )
            end do
          end do
        endif
        if( E3E3 ) then
          write(3,165)
          do hs = 1,3
            do js = 1,3
              jhs = 3 * ( js - 1 ) + hs
              write(3,155) (k, js, hs, k = 1,3)
              do he = 1,3
                do je = 1,3
                  jhe = 3 * ( je - 1 ) + he
                  write(3,167) je, he, ( ( msymoo(i,jhe,k,jhs), msymooi(i,jhe,k,jhs), i = 1,3), k =1,3)
                end do
              end do
            end do
          end do
        endif
      else
        if( E1E1 .or. dipmag ) then
          write(3,110)
          do i = 1,3
            write(3,170) msymdd(i,:)
          end do
        endif
        if( E1E2e ) then
          write(3,180)
          do j = 1,3
            write(3,170) (msymdq(i,j,:), i = 1,3)
          end do
        endif
        if( E2E2 ) then
          write(3,140)
          do i = 1,3
            write(3,190) i, i, i
            do k = 1,3
              write(3,170) (msymqq(i,j,k,:), j = 1,3)
            end do
          end do
        endif
        if( E1E3 ) then
          write(3,160)
          do i = 1,3
            write(3,190) i, i, i
            do k = 1,3
              write(3,170) (msymdo(i,j,k,:), j = 1,3)
            end do
          end do
        endif
        if( E3E3 ) then
          write(3,165)
          do hs = 1,3
            do js = 1,3
              jhs = 3 * ( js - 1 ) + hs
              write(3,195) (k, js, hs, k = 1,3)
              do he = 1,3
                do je = 1,3
                  jhe = 3 * ( je - 1 ) + he
                  write(3,168) je, he, (msymoo(:,jhe,k,jhs), k =1,3)
                end do
              end do
            end do
          end do
        endif
      endif
    endif

  end do

! Selection of tensor components to calculate
  ldip(:) = 0
  lqua(:,:) = 0
  loct(:,:,:) = 0

  if( E1E1 .or. Dipmag ) then
    n = maxval( abs(msymdd) )
    n = max( n, maxval( abs(msymddi) ) )
    do i = 1,n
      boucle_dip: do ke = 3,1,-1
        do ks = 3,1,-1
          if( abs(msymdd(ke,ks)) == i .or. abs(msymddi(ke,ks)) == i ) exit boucle_dip
        end do
      end do boucle_dip
      ldip(ke) = 1
      ldip(ks) = 1
    end do
  endif

  if( E2E2 ) then
    n = maxval(abs(msymqq))
    n = max( n, maxval( abs(msymqqi) ) )
    do i = 1,n
      boucle_qua: do ke = 1,3
        do ks = 1,3
          do je = 1,3
            do js = 1,3
              if( abs(msymqq(ke,je,ks,js)) == i .or. abs(msymqqi(ke,je,ks,js)) == i) exit boucle_qua
            end do
          end do
        end do
      end do boucle_qua
      kk = min(ke,je)
      jj = max(ke,je)
      lqua(kk,jj) = 1
      kk = min(ks,js)
      jj = max(ks,js)
      lqua(kk,jj) = 1
    end do
  endif

! Interference term dipole - quadrupole
  if( E1E2 ) then
    n = maxval(abs(msymdq))
    n = max( n, maxval( abs(msymdqi) ) )
    do i = 1,n
      boucle_int: do ke = 3,1,-1
        do ks = 3,1,-1
          do js = 3,1,-1
            if( abs(msymdq(ke,ks,js)) == i .or. abs(msymdqi(ke,ks,js)) == i ) exit boucle_int
          end do
        end do
      end do boucle_int
      ldip(ke) = 1
      kk = min(ks,js)
      jj = max(ks,js)
      lqua(kk,jj) = 1
    end do
  endif

  if( E1E3 ) then
    n = maxval(abs(msymdo))
    n = max( n, maxval( abs(msymdoi) ) )
    do i = 1,n
      boucle_oct: do ke = 3,1,-1
        do ks = 3,1,-1
          do j1 = 3,1,-1
            do j2 = 3,1,-1
              if( abs(msymdo(ke,ks,j1,j2)) == i .or. abs(msymdoi(ke,ks,j1,j2)) == i ) exit boucle_oct
            end do
          end do
        end do
      end do boucle_oct
      ldip(ke) = 1
      kk = min(ks,j1,j2)
      jj2 = max(ks,j1,j2)
      if( (ks == kk .and. j1 == jj2) .or. (j1 == kk .and. ks == jj2) ) then
        jj1 = j2
      elseif( (ks == kk .and. j2 == jj2) .or. (j2 == kk .and. ks == jj2) ) then
        jj1 = j1
      else
        jj1 = ks
      endif
      loct(kk,jj1,jj2) = 1
    end do
  endif

  if( E3E3 ) then
    n = maxval(abs(msymoo))
    n = max( n, maxval( abs(msymooi) ) )
    do i = 1,n
      boucle_oo: do ke = 3,1,-1
        do je = 3,1,-1
          do he = 3,1,-1
            jhe = 3*(je - 1) + he
            do ks = 3,1,-1
              do js = 3,1,-1
                do hs = 3,1,-1
                  jhs = 3*(js - 1) + hs
                  if( abs(msymoo(ke,jhe,ks,jhs)) == i .or. abs(msymooi(ke,jhe,ks,jhs)) == i ) exit boucle_oo
                end do
              end do
            end do
          end do
        end do
      end do boucle_oo

   end do
     loct(:,:,:) = 1
  endif

  if( icheck > 0 ) write(3,210) ldip(1:3)

  if( ( E1E1 .or. Dipmag ) .and. ldipimp(1) /= -1 .and. .not. green ) then
    ldip(:) = ldipimp(:)
    if( icheck > 0 ) write(3,215) ldip(1:3)
  endif

  if( Quadrupole .or. Octupole ) then
    if( icheck > 0 ) write(3,220) (lqua(i,1:3), i = 1,3)

    if( lquaimp(1,1) /= -1  .and. .not. green ) then
      lqua(:,:) = 0
      do i = 1,3
        do j = 1,3
          if( lquaimp(i,j) == 0 ) cycle
          ii = min(i,j)
          jj = max(i,j)
          lqua(ii,jj) = 1
        end do
      end do
      if( icheck > 0 ) write(3,225) (lqua(i,1:3), i = 1,3)
    endif
  endif

  if( icheck > 0 .and. Octupole ) write(3,230) ( (loct(i,j,1:3), j = 1,3 ), i = 1,3 )

  return
  100 format(//' ---- Tensor_shape --------',100('-'))
  102 format(/'  Internal basis, z along c :')
  104 format(/'  Absorbing atom basis :')
  110 format(/'  Dipole-dipole matrix shape :'/)
  120 format(3(3x,3(i4,i3)))
  130 format(/'  Dipole-quadrupole matrix shape :'/,/ 11x,'(1,j,k)',17x,'(2,j,k)',17x,'(3,j,k)')
  140 format(/'  Quadrupole-quadrupole matrix shape :'/)
  150 format( 10x,'(',i1,',1,k,L)',15x,'(',i1,',2,k,L)',15x,'(',i1,',3,k,L)')
  155 format(/' je he',3(13x,'(:,je,he',3(',',i1),')'))
  160 format(/'  Dipole-Octupole matrix shape :'/)
  165 format(/'  Octupole-Octupole matrix shape :'/)
  167 format(2i3,3(6x,3(i4,i3)))
  168 format(2i3,5x,3(3i4,8x))
  170 format(3(3x,3i3))
  180 format(/'  Dipole-quadrupole matrix shape :'/,/ 5x,'(1,j,k)     (2,j,k)     (3,j,k)')
  190 format(/'    (',i1,',1,k,L)   (',i1,',2,k,L)   (',i1,',3,k,L)')
  195 format(/' je he',3(5x,'(:,je,he',3(',',i1),')'))
  210 format(/' ldip = (',3i2,')')
  215 format(/' ldip = (',3i2,'), apres imposition')
  220 format(/' lqua = (',3i2,')',2(/8x,'(',3i2,')'))
  225 format(/' lqua = (',3i2,'), apres imposition',2(/8x,'(',3i2,')'))
  230 format(/' loct = ',3('(',3i2,')  '),2(/8x,3('(',3i2,')  ')))
end

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

! Calculation of tensor dipole-dipole (E1-E1)

subroutine Tensdd(iopsymt,magnet,msymdd,msymddi)

  use declarations
  implicit none

  integer:: i, ii, iis, iordresym, is, isg, isgi, isgmag, iss, j, jj, jjs, ke, kk, kkk, kkkmax, ks, n

  integer, dimension(3):: im
  integer, dimension(nopsm):: iopsymt
  integer, dimension(3,3):: msymdd, msymddi

  logical Magnet
  logical, dimension(9):: impos, imposi

  real(kind=db):: matopsym(3,3)

  msymdd(:,:) = 0;  msymddi(:,:) = 0;
  impos(:) = .false.
  if( magnet ) then
   imposi(:) = .false.
  else
   imposi(:) = .true.
  endif

  kkk = 0
  do i = 1,3
    do j = i,3
      if( msymdd(i,j) /= 0 .or. msymddi(i,j) /= 0 ) cycle
      kkk = kkk + 1
      msymdd(i,j) = kkk
      msymdd(j,i) = kkk
      if( i /= j ) then
        msymddi(i,j) = kkk
        msymddi(j,i) = - kkk
      endif

      do iss = 2,min(48,nopsm)

        is = iordresym(iss)
        if( iopsymt(is) == 0 ) cycle
        isgmag = iopsymt(is)
        call opsym(is,matopsym)
        do ii = 1,3
          do jj = 1,3
            if( abs(matopsym(jj,ii)) < 0.0001_db ) cycle
            im(ii) = jj * nint( matopsym(jj,ii) )
            exit
          end do
        end do
        ii = abs( im(i) )
        iis = ii / im(i)
        jj = abs( im(j) )
        jjs = jj / im(j)
        isg = iis * jjs
        isgi = isg * isgmag

        if( ( isg > 0 .and. msymdd(ii,jj) == - kkk ) .or. ( isg < 0 .and. msymdd(ii,jj) == kkk ) ) impos(kkk) = .true.
        if( .not. impos(kkk) ) then
          msymdd(ii,jj) = isg * kkk
          msymdd(jj,ii) = isg * kkk
        endif
        if( ii == jj ) cycle
        if( is /= 51 .and. is /= 52 .and. is < 55 ) then
          if( ( isgi > 0 .and. msymddi(ii,jj) == - kkk ) .or. ( isgi < 0 .and. msymddi(ii,jj) == kkk ) ) &
                                                 imposi(kkk) =.true.
          if( .not. imposi(kkk) .and. isgmag /= 0 ) then
            msymddi(ii,jj) = isgi * kkk
            msymddi(jj,ii) = - isgi * kkk
          endif
        endif

      end do

    end do
  end do

  kkkmax = kkk
  kk = 0
  do kkk = 1,kkkmax
    kk = kk + 1
    if( impos(kkk) ) where( abs(msymdd) == kk ) msymdd = 0
    if( imposi(kkk) ) where( abs(msymddi) == kk ) msymddi = 0
    if( impos(kkk) .and. imposi(kkk) ) then
      where( abs(msymdd) > kk ) msymdd = msymdd - abs(msymdd)/msymdd
      where( abs(msymddi) > kk ) msymddi = msymddi - abs(msymddi) / msymddi
      kk = kk - 1
    endif
  end do

  n = maxval( abs(msymdd) )
  boucle_i: do i = 1,n
    do ke = 1,3
      do ks = 1,3
        if( abs(msymdd(ke,ks)) == i .or. abs(msymddi(ke,ks)) == i ) cycle boucle_i
      end do
    end do
    where( abs(msymdd) > i ) msymdd = msymdd - abs(msymdd) / msymdd
    where( abs(msymddi) > i ) msymddi = msymddi - abs(msymddi) / msymddi
  end do boucle_i

  return
end

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

function ismag(is)

  use declarations
  implicit none

  integer:: is, ismag

  select case(is)

    case(1,18,21,24,25,28,31,42,49,50,51,52,53,54,55,56)
      ismag = 1

    case(2,3,4,5,6,7,8,9,12,13,14,15,16,17,19,20,26,27,29,30,32,33, 34,35,36,37,38,39,43,44,46,47)
      ismag = 0

    case(10,11,22,23,40,41,45,48,57,58,59,60,61,62,63,64)
      ismag = -1

  end select

  return
end

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

subroutine Tensdq(iopsymt,magnet,msymdq,msymdqi)

  use declarations
  implicit none

  integer:: i, ii, iis, iordresym, is, isg, isgi, isgmag, iss, j, jj, jjs, k, kk, kkk, kkkmax, kks, L, m, n

  integer, dimension(3):: im
  integer, dimension(nopsm):: iopsymt
  integer, dimension(3,3,3):: msymdq, msymdqi

  logical magnet
  logical, dimension(27):: impos, imposi

  real(kind=db):: matopsym(3,3)

  msymdq(:,:,:) = 0; msymdqi(:,:,:) = 0
  impos(:) = .false.
  if( magnet ) then
   imposi(:) = .false.
  else
   imposi(:) = .true.
  endif

  kkk = 0
  do i = 1,3
    do j = 1,3
      do k = j,3
        if( msymdq(i,j,k) /= 0 .or. msymdqi(i,j,k) /= 0 ) cycle
        kkk = kkk + 1
        msymdq(i,j,k) = kkk
        msymdq(i,k,j) = kkk
        msymdqi(i,j,k) = kkk
        msymdqi(i,k,j) = kkk

        do iss = 2,min(48,nopsm)

          is = iordresym(iss)
          if( is > 48 ) cycle
          if( iopsymt(is) == 0 ) cycle
          isgmag = iopsymt(is)
          call opsym(is,matopsym)
          do ii = 1,3
            do jj = 1,3
              if( abs(matopsym(jj,ii)) < 0.0001_db ) cycle
              im(ii) = jj * nint( matopsym(jj,ii) )
              exit
            end do
          end do
          ii = abs( im(i) )
          iis = ii / im(i)
          jj = abs( im(j) )
          jjs = jj / im(j)
          kk = abs( im(k) )
          kks = kk / im(k)
          isg = iis * jjs * kks
          isgi = isg * isgmag

          if( ( isg > 0 .and. msymdq(ii,jj,kk) == - kkk ) .or. ( isg < 0 .and. msymdq(ii,jj,kk) == kkk ) ) &
                                                 impos(kkk) = .true.
          if( ( isgi > 0 .and. msymdqi(ii,jj,kk) == - kkk ).or. ( isgi < 0 .and. msymdqi(ii,jj,kk) == kkk ) ) &
                                                 imposi(kkk) =.true.

          if( .not. impos(kkk) ) then
            msymdq(ii,jj,kk) = isg * kkk
            msymdq(ii,kk,jj) = isg * kkk
          endif
          if( .not. imposi(kkk) .and. isgmag /= 0 ) then
            msymdqi(ii,jj,kk) = isgi * kkk
            msymdqi(ii,kk,jj) = isgi * kkk
          endif

        end do

      end do
    end do
  end do

  kkkmax = kkk

  kk = 0
  do kkk = 1,kkkmax
    kk = kk + 1
    if( impos(kkk) ) where( abs(msymdq) == kk ) msymdq = 0
    if( imposi(kkk) ) where( abs(msymdqi) == kk ) msymdqi = 0
    if( impos(kkk) .and. imposi(kkk) ) then
      where( abs(msymdq) > kk ) msymdq = msymdq - abs(msymdq)/msymdq
      where( abs(msymdqi) > kk ) msymdqi = msymdqi - abs(msymdqi) / msymdqi
      kk = kk - 1
    endif
  end do

  n = maxval( abs(msymdq) )
  boucle_i: do i = 1,n
    do k = 1,3
      do L = 1,3
        do m = 1,3
          if( abs(msymdq(k,L,m)) == i .or. abs(msymdqi(k,L,m)) == i ) cycle boucle_i
        end do
      end do
    end do
    where( abs(msymdq) > i ) msymdq = msymdq - abs(msymdq) / msymdq
    where( abs(msymdqi) > i ) msymdqi = msymdqi - abs(msymdqi) / msymdqi
  end do boucle_i

  return
end

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

! Calculation of the tensor quadrupole-quadrupole E2E2

subroutine Tensqq(iopsymt,magnet,msymqq,msymqqi)

  use declarations
  implicit none

  integer:: i, ii, iis, iordresym, is, isg, isgi, isgmag, iss, j, jj, jjs, k, kk, kkk, kkkmax, kks, L, LL, LLs, m, n

  integer, dimension(3):: im
  integer, dimension(nopsm):: iopsymt
  integer, dimension(3,3,3,3):: msymqq, msymqqi

  logical magnet
  logical, dimension(81):: impos, imposi

  real(kind=db):: matopsym(3,3)

  msymqq(:,:,:,:) = 0; msymqqi(:,:,:,:) = 0
  impos(:) = .false.
  if( magnet ) then
   imposi(:) = .false.
  else
   imposi(:) = .true.
  endif

  kkk = 0
  do i = 1,3
    do j = i,3
      do k = 1,3
        do L = k,3
          if( msymqq(i,j,k,L) /= 0 .or. msymqqi(i,j,k,L) /= 0) cycle
          kkk = kkk + 1
          msymqq(i,j,k,L) = kkk
          msymqq(j,i,k,L) = kkk
          msymqq(i,j,L,k) = kkk
          msymqq(j,i,L,k) = kkk
          msymqq(k,L,i,j) = kkk
          msymqq(L,k,i,j) = kkk
          msymqq(k,L,j,i) = kkk
          msymqq(L,k,j,i) = kkk
          if( i /= k .or. j /= L ) then
            msymqqi(i,j,k,L) = kkk
            msymqqi(j,i,k,L) = kkk
            msymqqi(i,j,L,k) = kkk
            msymqqi(j,i,L,k) = kkk
            msymqqi(k,L,i,j) = - kkk
            msymqqi(L,k,i,j) = - kkk
            msymqqi(k,L,j,i) = - kkk
            msymqqi(L,k,j,i) = - kkk
          endif

          do iss = 2,min(48,nopsm)

            is = iordresym(iss)
            if( is > 48 ) cycle
            if( iopsymt(is) == 0 ) cycle
            isgmag = iopsymt(is)
            call opsym(is,matopsym)
            do ii = 1,3
              do jj = 1,3
                if( abs(matopsym(jj,ii)) < 0.0001_db ) cycle
                im(ii) = jj * nint( matopsym(jj,ii) )
                exit
              end do
            end do
            ii = abs( im(i) )
            iis = ii / im(i)
            jj = abs( im(j) )
            jjs = jj / im(j)
            kk = abs( im(k) )
            kks = kk / im(k)
            ll = abs( im(L) )
            lls = ll / im(L)
            isg = iis * jjs * kks * lls
            isgi = isg * isgmag

            if( ( isg > 0 .and. msymqq(ii,jj,kk,ll) == - kkk ) .or. ( isg < 0 .and. msymqq(ii,jj,kk,ll) == kkk ) ) &
                                                 impos(kkk) = .true.
            if( ( isgi > 0 .and. msymqqi(ii,jj,kk,ll) == - kkk ).or. ( isgi < 0 .and. msymqqi(ii,jj,kk,ll) == kkk ) ) &
                                                 imposi(kkk) =.true.

            if( .not. impos(kkk) ) then
              msymqq(ii,jj,kk,ll) = isg * kkk
              msymqq(jj,ii,kk,ll) = isg * kkk
              msymqq(ii,jj,ll,kk) = isg * kkk
              msymqq(jj,ii,ll,kk) = isg * kkk
              msymqq(kk,ll,ii,jj) = isg * kkk
              msymqq(ll,kk,ii,jj) = isg * kkk
              msymqq(kk,ll,jj,ii) = isg * kkk
              msymqq(ll,kk,jj,ii) = isg * kkk
            endif

            if( .not. imposi(kkk) .and. isgmag /= 0 ) then
              msymqqi(ii,jj,kk,ll) = isgi * kkk
              msymqqi(jj,ii,kk,ll) = isgi * kkk
              msymqqi(ii,jj,ll,kk) = isgi * kkk
              msymqqi(jj,ii,ll,kk) = isgi * kkk
              msymqqi(kk,ll,ii,jj) = - isgi * kkk
              msymqqi(ll,kk,ii,jj) = - isgi * kkk
              msymqqi(kk,ll,jj,ii) = - isgi * kkk
              msymqqi(ll,kk,jj,ii) = - isgi * kkk
            endif

          end do

        end do
      end do
    end do
  end do

  kkkmax = kkk
  kk = 0
  do kkk = 1,kkkmax
    kk = kk + 1
    if( impos(kkk) ) where( abs(msymqq) == kk ) msymqq = 0
    if( imposi(kkk) ) where( abs(msymqqi) == kk ) msymqqi = 0
    if( impos(kkk) .and. imposi(kkk) ) then
      where( abs(msymqq) > kk ) msymqq = msymqq - abs(msymqq)/msymqq
      where( abs(msymqqi) > kk ) msymqqi = msymqqi - abs(msymqqi) / msymqqi
      kk = kk - 1
    endif
  end do

  n = maxval( abs(msymqq) )
  boucle_i: do i = 1,n
    do j = 1,3
      do k = 1,3
        do L = 1,3
          do m = 1,3
            if( abs(msymqq(j,k,L,m)) == i .or. abs(msymqqi(j,k,L,m)) == i ) cycle boucle_i
          end do
        end do
      end do
    end do
    where( abs(msymqq) > i ) msymqq = msymqq - abs(msymqq) / msymqq
    where( abs(msymqqi) > i ) msymqqi = msymqqi - abs(msymqqi) / msymqqi
  end do boucle_i

  return
end

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

! Calculation of the tensor dipole-octupole

subroutine Tensdo(iopsymt,magnet,msymdo,msymdoi)

  use declarations
  implicit none

  integer:: i, ii, iis, iordresym, is, isg, isgi, isgmag, iss, j, jj, jjs, k, kk, kkk, kkkmax, kks, L, LL, LLs, m, n

  integer, dimension(3):: im
  integer, dimension(nopsm):: iopsymt
  integer, dimension(3,3,3,3):: msymdo, msymdoi

  logical magnet
  logical, dimension(81):: impos, imposi

  real(kind=db):: matopsym(3,3)

  msymdo(:,:,:,:) = 0; msymdoi(:,:,:,:) = 0
  impos(:) = .false.
  if( magnet ) then
   imposi(:) = .false.
  else
   imposi(:) = .true.
  endif

  kkk = 0
  do i = 1,3
    do j = 1,3
      do k = j,3
        do L = k,3
          if( msymdo(i,j,k,L) /= 0 .or. msymdoi(i,j,k,L) /= 0 )cycle
          kkk = kkk + 1
          msymdo(i,j,k,L) = kkk
          msymdo(i,j,L,k) = kkk
          msymdo(i,k,j,L) = kkk
          msymdo(i,L,j,k) = kkk
          msymdo(i,k,L,j) = kkk
          msymdo(i,L,k,j) = kkk
          msymdoi(i,j,k,L) = kkk
          msymdoi(i,j,L,k) = kkk
          msymdoi(i,k,j,L) = kkk
          msymdoi(i,L,j,k) = kkk
          msymdoi(i,k,L,j) = kkk
          msymdoi(i,L,k,j) = kkk

          do iss = 2,min(48,nopsm)

            is = iordresym(iss)

            if( iopsymt(is) == 0 ) cycle
            isgmag = iopsymt(is)
            call opsym(is,matopsym)
            do ii = 1,3
              do jj = 1,3
                if( abs(matopsym(jj,ii)) < 0.0001_db ) cycle
                im(ii) = jj * nint( matopsym(jj,ii) )
                exit
              end do
            end do
            ii = abs( im(i) )
            iis = ii / im(i)
            jj = abs( im(j) )
            jjs = jj / im(j)
            kk = abs( im(k) )
            kks = kk / im(k)
            ll = abs( im(L) )
            lls = ll / im(L)
            isg = iis * jjs * kks * lls
            isgi = isg * isgmag

            if( ( isg > 0 .and. msymdo(ii,jj,kk,ll) == - kkk ) .or. ( isg < 0 .and. msymdo(ii,jj,kk,ll) == kkk ) ) &
                                                 impos(kkk) = .true.
            if( ( isgi > 0 .and. msymdoi(ii,jj,kk,ll) == - kkk ).or. ( isgi < 0 .and. msymdoi(ii,jj,kk,ll) == kkk ) ) &
                                                 imposi(kkk) =.true.


            if( .not. impos(kkk) ) then
              msymdo(ii,jj,kk,ll) = isg * kkk
              msymdo(ii,jj,ll,kk) = isg * kkk
              msymdo(ii,kk,jj,ll) = isg * kkk
              msymdo(ii,ll,jj,kk) = isg * kkk
              msymdo(ii,kk,ll,jj) = isg * kkk
              msymdo(ii,ll,kk,jj) = isg * kkk
            endif

            if( .not. impos(kkk) .and. isgmag /= 0 ) then
              msymdoi(ii,jj,kk,ll) = isgi * kkk
              msymdoi(ii,jj,ll,kk) = isgi * kkk
              msymdoi(ii,kk,jj,ll) = isgi * kkk
              msymdoi(ii,ll,jj,kk) = isgi * kkk
              msymdoi(ii,kk,ll,jj) = isgi * kkk
              msymdoi(ii,ll,kk,jj) = isgi * kkk
            endif

          end do

        end do
      end do
    end do
  end do

  kkkmax = kkk
  kk = 0
  do kkk = 1,kkkmax
    kk = kk + 1
    if( impos(kkk) ) where( abs(msymdo) == kk ) msymdo = 0
    if( imposi(kkk) ) where( abs(msymdoi) == kk ) msymdoi = 0
    if( impos(kkk) .and. imposi(kkk) ) then
      where( abs(msymdo) > kk ) msymdo = msymdo - abs(msymdo)/msymdo
      where( abs(msymdoi) > kk ) msymdoi = msymdoi - abs(msymdoi) / msymdoi
      kk = kk - 1
    endif
  end do

  n = maxval( abs(msymdo) )
  boucle_i: do i = 1,n
    do j = 1,3
      do k = 1,3
        do L = 1,3
          do m = 1,3
            if( abs(msymdo(j,k,L,m)) == i .or. abs(msymdoi(j,k,L,m)) == i ) cycle boucle_i
          end do
        end do
      end do
    end do
    where( abs(msymdo) > i ) msymdo = msymdo - abs(msymdo) / msymdo
    where( abs(msymdoi) > i ) msymdoi = msymdoi - abs(msymdoi) / msymdoi
  end do boucle_i

  return
end

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

! Calculation of the tensor E3E3

subroutine tensoo(iopsymt,magnet,msymoo,msymooi,n_oo)

  use declarations
  implicit none

  integer:: he, hhe, hhe_s, hhs, hhs_s, hs, i, i1, i2, i3, ii, iie, &
    iis, is, isg, isgi, iordresym, isgmag, iss, j, j1, j2, j3, je, jhe, jhs, jj, jje, jje_s, jjhe, jjhs, &
    jjs, jjs_s, js, ke, kk, kke, kke_s, kkk, kkkmax, kks, kks_s, ks, n, n_oo
  integer, dimension(3):: im(3)
  integer, dimension(nopsm):: iopsymt
  integer, dimension(3,n_oo,3,n_oo):: msymoo, msymooi

  logical:: Magnet
  logical, dimension(9*n_oo**2):: impos, imposi

  real(kind=db):: matopsym(3,3)

  msymoo(:,:,:,:) = 0; msymooi(:,:,:,:) = 0
  impos(:) = .false.
  if( Magnet ) then
   imposi(:) = .false.
  else
   imposi(:) = .true.
  endif

  kkk = 0
  do ke = 1,3
    do je = 1,3
      do he = 1,3
        jhe = 3 * ( je - 1 ) + he
        do ks = 1,3
          do js = 1,3
            do hs = 1,3
              jhs = 3 * ( js - 1 ) + hs

              if( msymoo(ke,jhe,ks,jhs) /= 0 .or. msymooi(ke,jhe,ks,jhs) /= 0 ) cycle

              kkk = kkk + 1

              do iie = 1,6
                select case(iie)
                  case(1)
                    i1 = ke; i2 = je; i3 = he
                  case(2)
                    i1 = ke; i2 = he; i3 = je
                    if( i2 == i3 ) cycle
                  case(3)
                    i1 = je; i2 = ke; i3 = he
                    if( i1 == i2 ) cycle
                  case(4)
                    i1 = he; i2 = ke; i3 = je
                    if( i1 == i3 ) cycle
                  case(5)
                    i1 = je; i2 = he; i3 = ke
                    if( i2 == i3 ) cycle
                  case(6)
                    i1 = he; i2 = je; i3 = ke
                    if( i1 == i3 ) cycle
                end select
                i = 3 * ( i2 - 1 ) + i3

                do iis = 1,6
                  select case(iie)
                    case(1)
                      j1 = ks; j2 = js; j3 = hs
                    case(2)
                      j1 = ks; j2 = hs; j3 = js
                      if( j2 == j3 ) cycle
                    case(3)
                      j1 = js; j2 = ks; j3 = hs
                      if( j1 == j2 ) cycle
                    case(4)
                      j1 = hs; j2 = ks; j3 = js
                      if( j1 == j3 ) cycle
                    case(5)
                      j1 = js; j2 = hs; j3 = ks
                      if( j2 == j3 ) cycle
                    case(6)
                      j1 = hs; j2 = js; j3 = ks
                      if( j1 == j3 ) cycle
                  end select
                  j = 3 * ( j2 - 1 ) + j3

                  msymoo(i1,i,j1,j) = kkk
                  msymoo(j1,j,i1,i) = kkk

                  if( ke /= ks .or. je /= js .or. he /= hs ) then
                    msymooi(i1,i,j1,j) = kkk
                    msymooi(j1,j,i1,i) = - kkk
                  endif

                end do
              end do  ! fin boucle iie

              do iss = 2,min(48,nopsm)

                is = iordresym(iss)
                if( is > 48 ) cycle
                if( iopsymt(is) == 0 ) cycle
                isgmag = iopsymt(is)
                call opsym(is,matopsym)
                do ii = 1,3
                  do jj = 1,3
                    if( abs(matopsym(jj,ii)) < 0.0001_db ) cycle
                    im(ii) = jj * nint( matopsym(jj,ii) )
                    exit
                  end do
                end do
                kke = abs( im(ke) )
                kke_s =  kke / im(ke)
                jje = abs( im(je) )
                jje_s =  jje / im(je)
                hhe = abs( im(he) )
                hhe_s =  hhe / im(he)
                kks = abs( im(ks) )
                kks_s =  kks / im(ks)
                jjs = abs( im(js) )
                jjs_s =  jjs / im(js)
                hhs = abs( im(hs) )
                hhs_s =  hhs / im(hs)
                isg = kke_s * jje_s * hhe_s * kks_s * jjs_s * hhs_s
                isgi = isg * isgmag

                jjhe = 3 * ( jje - 1 ) + hhe
                jjhs = 3 * ( jjs - 1 ) + hhs

                if( ( isg > 0 .and. msymoo(kke,jjhe,kks,jjhs) == - kkk ) .or. ( isg < 0 .and. &
                          msymoo(kke,jjhe,kks,jjhs) == kkk ) ) impos(kkk) = .true.
                if( ( isgi > 0 .and. msymooi(kke,jjhe,kks,jjhs) == - kkk ).or. ( isgi < 0 .and. &
                          msymooi(kke,jjhe,kks,jjhs) == kkk ) ) imposi(kkk) =.true.

                if( impos(kkk) .and. imposi(kkk) ) cycle

                do iie = 1,6
                  select case(iie)
                    case(1)
                      i1 = kke; i2 = jje; i3 = hhe
                    case(2)
                      i1 = kke; i2 = hhe; i3 = jje
                      if( i2 == i3 ) cycle
                    case(3)
                      i1 = jje; i2 = kke; i3 = hhe
                      if( i1 == i2 ) cycle
                    case(4)
                      i1 = hhe; i2 = kke; i3 = jje
                      if( i1 == i3 ) cycle
                    case(5)
                      i1 = jje; i2 = hhe; i3 = kke
                      if( i2 == i3 ) cycle
                    case(6)
                      i1 = hhe; i2 = jje; i3 = kke
                      if( i1 == i3 ) cycle
                  end select
                  i = 3 * ( i2 - 1 ) + i3

                  do iis = 1,6
                    select case(iie)
                      case(1)
                        j1 = kks; j2 = jjs; j3 = hhs
                      case(2)
                        j1 = kks; j2 = hhs; j3 = jjs
                        if( j2 == j3 ) cycle
                      case(3)
                        j1 = jjs; j2 = kks; j3 = hhs
                        if( j1 == j2 ) cycle
                      case(4)
                        j1 = hhs; j2 = kks; j3 = jjs
                        if( j1 == j3 ) cycle
                      case(5)
                        j1 = jjs; j2 = hhs; j3 = kks
                        if( j2 == j3 ) cycle
                      case(6)
                        j1 = hhs; j2 = jjs; j3 = kks
                        if( j1 == j3 ) cycle
                    end select
                    j = 3 * ( j2 - 1 ) + j3

                    if( .not. impos(kkk) ) then
                      msymoo(i1,i,j1,j) = isg * kkk
                      msymoo(j1,j,i1,i) = isg * kkk
                    endif

                    if( .not. imposi(kkk) .and. isgmag /= 0 .and. (kke /= kks .or. jje /= jjs .or. hhe /= hhs) ) then
                      msymooi(i1,i,j1,j) = isgi * kkk
                      msymooi(j1,j,i1,i) = - isgi * kkk
                    endif

                  end do
                end do  ! fin boucle iie

              end do  ! boucle_iss

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

  kkkmax = kkk
  kk = 0
  do kkk = 1,kkkmax
    kk = kk + 1
    if( impos(kkk) ) where( abs(msymoo) == kk ) msymoo = 0
    if( imposi(kkk) ) where( abs(msymooi) == kk ) msymooi = 0
    if( impos(kkk) .and. imposi(kkk) ) then
      where( abs(msymoo) > kk ) msymoo = msymoo - abs(msymoo)/msymoo
      where( abs(msymooi) > kk ) msymooi = msymooi - abs(msymooi) / msymooi
      kk = kk - 1
    endif
  end do

  n = maxval( abs(msymoo) )
  boucle_i: do i = 1,n
    do ke = 1,3
      do jhe = 1,n_oo
        do ks = 1,3
          do jhs = 1,n_oo
            if( abs(msymoo(ke,jhe,ks,jhs)) == i .or. abs(msymooi(ke,jhe,ks,jhs)) == i ) cycle boucle_i
          end do
        end do
      end do
    end do
    where( abs(msymoo) > i ) msymoo = msymoo - abs(msymoo) / msymoo
    where( abs(msymooi) > i ) msymooi = msymooi - abs(msymooi) / msymooi
  end do boucle_i

  return
end

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

subroutine cal_iaeqrmt(iaabs,iaproto,iapot,igreq,igroup,n_atom_proto,natomp,neqm,ngreq,Self_nonexc)

  use declarations
  implicit none

  integer:: ia, iaabs, igr, ipr, n_atom_proto, natomp, neqm

  integer, dimension(natomp):: igroup, iaproto
  integer, dimension(0:n_atom_proto):: iapot, ngreq
  integer, dimension(0:n_atom_proto,neqm):: igreq

  logical:: Self_nonexc

! iapot gives the index of the atoms in the non-symmetrized cluster
  iapot(:) = 0
! Choix des atomes prototypiques dont le potentiel sera calcule
  iapot(0) = iaabs
  do ipr = 1,n_atom_proto
    iapot(ipr) = 0
    boucle_ia: do ia = 1,natomp
      if( ia == iaabs .and. .not. self_nonexc ) cycle
      do igr = 1,ngreq(ipr)
        if( igroup(ia) == igreq(ipr,igr) ) then
          iapot(ipr) = ia
          exit boucle_ia
        endif
      end do
    end do boucle_ia
  end do

  do ia = 1,natomp
    boucle_i: do ipr = 1,n_atom_proto
      do igr = 1,ngreq(ipr)
        if( igroup(ia) == igreq(ipr,igr) ) exit boucle_i
      end do
    end do boucle_i
    iaproto(ia) = ipr
  end do

  return
end

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

! Calculation of f' and f" = absorption before the edge (output is in MBarn)
! fp_avantseuil is just the forward scattering

  complex(kind=db) function f_cal(Bulk_step,Doping,Eseuil,icheck,itypepr,n_atom_proto,n_atom_proto_uc,nbseuil, &
                        ngreq,ntype,Numat,Z_abs,Taux_ipr,Volume_maille)

  use declarations
  implicit none

  character(len=4):: elemv
  character(len=2):: Chemical_symbol

  integer:: icheck, ipr, n_atom_proto, n_atom_proto_uc, nbseuil, ntype, Z, Z_abs
  integer, dimension(0:ntype):: Numat
  integer, dimension(0:n_atom_proto):: itypepr, ngreq

  logical:: Bulk_step, Doping

  real(kind=db):: Conv_mbarn_nelec, Ea, fp_avantseuil, fp_avantseuil_m, fpp_avantseuil, &
                  fpp_avantseuil_m, getf0, Volume_maille
  real(kind=db), dimension(nbseuil):: Eseuil
  real(kind=db), dimension(n_atom_proto):: f0, fpa, fppa, Taux_ipr

  fpp_avantseuil = 0._db
  fp_avantseuil = 0._db
  fppa(:) = 0._db
  fpa(:) = 0._db

  if( Eseuil(nbseuil) > eps10 ) then ! Not optic case

    do ipr = 1,n_atom_proto
      if( .not. Bulk_step .and. ipr > n_atom_proto_uc ) exit
      if( Bulk_step .and. ipr <= n_atom_proto_uc ) cycle
      if( Doping .and. ipr == n_atom_proto_uc + 1 ) cycle
      Z = Numat( itypepr( ipr ) )
      if( Z == 0 ) cycle
      Ea = Eseuil(nbseuil) - 1
      Ea = max( Ea,  0.5_db )
      call fprime(Z,Ea,fppa(ipr),fpa(ipr))

      fpp_avantseuil = fpp_avantseuil + Taux_ipr(ipr) * ngreq(ipr) * fppa(ipr)

      if( Z /= Z_abs ) fp_avantseuil = fp_avantseuil + Taux_ipr(ipr) * ngreq(ipr) * fpa(ipr)

      elemv = ' '
      elemv(1:2) = Chemical_Symbol(Z)
      f0(ipr) = getf0(elemv,0._db)
      fp_avantseuil = fp_avantseuil + Taux_ipr(ipr) * ngreq(ipr) * f0(ipr)
    end do

! Conversion in Megabarn (= 10^-18 cm2 = 10^-22 m2 = 10^-2 A2)
    fpp_avantseuil = fpp_avantseuil / conv_mbarn_nelec(Ea)
    fp_avantseuil = fp_avantseuil / conv_mbarn_nelec(Ea)

! Conversion in linear absorption coefficient in micrometer^-1
    if( Volume_maille > eps10 ) then
      fpp_avantseuil_m = 100 * fpp_avantseuil /( Volume_maille * bohr**3 )
      fp_avantseuil_m = 100 * fp_avantseuil /( Volume_maille * bohr**3 )
    endif

    if( icheck > 0 ) then
      write(3,310)
      do ipr = 1,n_atom_proto
        if( .not. Bulk_step .and. ipr > n_atom_proto_uc ) exit
        if( Bulk_step .and. ipr <= n_atom_proto_uc ) cycle
        if( Doping .and. ipr == n_atom_proto_uc + 1 ) cycle
        write(3,320) ipr, Numat( itypepr(ipr) ), f0(ipr), fpa(ipr), fppa(ipr)
      end do
      if( Volume_maille > eps10 ) write(3,330) fpp_avantseuil_m, fp_avantseuil_m
      write(3,340) fpp_avantseuil
    endif

  endif

  f_cal = cmplx( fp_avantseuil, fpp_avantseuil )

  return
  310 format(/' Absorption before the edge :',/ &
          ' Site  Z      f0           fp          fpp    (per atom in nbr of electron)')
  320 format(2i4,1p,3e13.5)
  330 format(/' Complex linear absorption coefficient :',1p,2e13.5,' micrometer^(-1)')
  340 format(/' Absorption cross section before the edge :',1p,e13.5,' Mbarn')
end

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

! Subroutine giving the probed orbitals from the selection rules

subroutine Etafin(E1M1,icheck,iopsymr,irep_util,Jseuil,karact,ldip,lmoins1,loct,lplus1,lqua,Lseuil, &
                  M1M1,mpirank0,nb_rep,nbseuil,ngrph,nspino,Spinorbite,State_all,Sym_cubic,Ylm_comp)

  use declarations
  implicit none

  integer:: icheck, init, iseuil, iop, isinitl, ism, ispin, ispo, Jseuil, jspin, kpl, kspin, kv2, kvo, &
    L, lf, lf1, lf2, lg, linitl, lo, Lseuil, m, m_initl, mi, mm, mo, mpirank0, ms, nb_rep, nbseuil, ngrph, nlfm, nlfm0, &
    noperat, nselec, nsm, nspino

  integer, dimension(2):: ninit
  integer, dimension(6):: loperat, moperat
  integer, dimension(nopsm):: iopsymr
  integer, dimension(nrepm,2):: irep_util(nrepm,2)
  integer, dimension(3):: ldip
  integer, dimension(3,3):: lqua
  integer, dimension(3,3,3):: loct
  integer, dimension(:), allocatable:: iselec, lselec, mselec

  complex(kind=db):: gnt
  complex(kind=db), dimension(nopsm,nrepm):: karact

  logical:: E1M1, lmoins1, lplus1, M1M1, Spinorbite, state_all, sym_cubic, Ylm_comp

  real(kind=db):: Gaunt_r, jzinitl
  real(kind=db), dimension(2):: jinitl

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

  linitl = Lseuil

! Calcul du (L,m) = (linitl,minitl) de L'etat initial
  select case(Jseuil)
    case(1,3,5,7)
      isinitl = 1
    case default
      isinitl = -1
  end select

  do iseuil = 1,nbseuil
    if( iseuil == 2 ) isinitl = - isinitl
    jinitl(iseuil) = linitl + 0.5_db * isinitl
    ninit(iseuil) = nint( 2 * jinitl(iseuil) + 1 )
  end do

  if( Ylm_comp ) then
    nsm = 2
  else
    nsm = 1
  endif

  nlfm0 = 52

  nlfm = nlfm0

  do     ! Boucle dimension

  allocate( iselec(nlfm) )
  allocate( lselec(nlfm) )
  allocate( mselec(nlfm) )

! Calcul des (L,m) = (lselec,mselec) des etats d'arrivee
  lf = 0
! Boucle sur toutes les transitions possibles, on est dans la base de
! L'atome absorbeur.
  do kv2 = 0,3
  do kvo = 0,3
  do kpl = 0,3
    if( kpl == 0 ) then
      if( .not. ( M1M1 .or. E1M1 ) ) cycle
      if( kv2 /= 0 .or. kvo /= 0 ) cycle
    else
      if( kvo == 0 ) then
        if( ldip(kpl) == 0 ) cycle
      else
        if( kvo < kpl ) cycle
      endif
      if( kv2 == 0 ) then
        if( kvo > 0 ) then
          if( lqua(kpl,kvo) == 0 ) cycle
        endif
      else
        if( kv2 < kvo .or. kvo == 0 ) cycle
        if( loct(kpl,kvo,kv2) == 0 ) cycle
      endif
    endif

! Calcul du (L,m) = (loperat,moperat) de la transition
    call lmtrans(kpl,kvo,kv2,noperat,loperat,moperat,Spinorbite)

    if( icheck > 1 ) then
      if( kvo == 0 ) then
        write(3,130) kpl
      elseif( kv2 == 0 ) then
        write(3,140) kpl, kvo
      else
        write(3,150) kpl, kvo, kv2
      endif
      do iop = 1,noperat
        write(3,160) loperat(iop), moperat(iop)
      end do
    endif

    do iseuil = 1,nbseuil

      do init = 1,ninit(iseuil)
        jzinitl = - jinitl(iseuil) + init - 1

        do ispin = 1,2
          m_initl = nint( jzinitl + ispin - 1.5_db )
          jspin = min(ispin,nspino)
          if( m_initl > linitl .or. m_initl < -linitl ) cycle

          do iop = 1,noperat
            lo = loperat(iop)
            mo = moperat(iop)

            lf1 = abs( linitl - lo )
            lf2 = linitl + lo
            if( lplus1 ) lf1 = lf2
            if( lmoins1 ) lf2 = lf1

            m = mo + m_initl

            do ispo = 1,nspino
              if( ispo == 1 ) then
                kspin = jspin
              else
                kspin = 3 - jspin
                if( jspin == 1 ) then
                  m = m + 1
                else
                  m = m - 1
                endif
              endif

            boucle_ll: do L = lf1,lf2,2

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

              if( Ylm_comp ) then

                boucle_ism: do ism = 1,nsm
                  if( ism == 1 ) then
                    mm = m
                  else
                    if( m == 0 ) cycle
                    mm = - m
                  endif
                  do lg = 1,min(lf,nlfm)
                    if( lselec(lg) == L .and. mselec(lg) == mm .and. iselec(lg) == kspin ) cycle boucle_ism
                  end do
                  lf = lf + 1
                  if( lf > nlfm ) cycle
                  lselec(lf) = L
                  mselec(lf) = mm
                  iselec(lf) = kspin
                end do boucle_ism

              else  ! on passe en base reelle

                do ms = -1,1,2
                  if( m_initl == 0 .and. ms == 1 ) exit
                  mi = ms * abs( m_initl )
                  gnt = Gaunt_r(L,m,lo,mo,linitl,mi)
                  if( abs(gnt) < eps6 ) cycle
                  do lg = 1,min(lf,nlfm)
                    if( lselec(lg) == L .and. mselec(lg) == m ) cycle boucle_ll
                  end do
                  lf = lf + 1
                  if( lf > nlfm ) cycle
                  lselec(lf) = L
                  mselec(lf) = m
                  iselec(lf) = kspin
                end do

              endif

            end do boucle_ll
          end do
          end do

        end do  ! fin de la boucle sur les operateurs

       end do
    end do
  end do
  end do
  end do
  nselec = lf

  if( Sym_cubic .and. .not. Ylm_comp ) then
    do lf = 1,nselec
      if( lselec(lf) == 2 ) exit
    end do
    if( lf < nselec + 1 ) then
      do lg = lf,min(nselec,nlfm)
        if( lselec(lg) == 2 .and. mselec(lg) == - 2 ) exit
      end do
      if( lg == nselec + 1 ) then
        nselec = nselec + 1
        if( nselec <= nlfm ) then
         lselec(nselec) = 2
         mselec(nselec) = -2
         iselec(nselec) = 1
        endif
      endif
    endif
  endif

    if( nselec <= nlfm ) exit

    nlfm = 2 * nlfm
    deallocate( iselec, lselec, mselec )

  end do   ! fin boucle dimension

  if( mpirank0 == 0 .and. nselec > nlfm0 ) write(3,170) nselec

  if( state_all ) then
    call irep_util_all(icheck,iopsymr,irep_util,karact,nb_rep, ngrph,nspino,Spinorbite)
  else
    call cal_irep(icheck,iopsymr,irep_util,iselec,karact,lselec, mselec,nb_rep,ngrph,nlfm,nselec,nspino,Spinorbite)
  endif

  deallocate( iselec, lselec, mselec )

  return
  110 format(/' ---- Etafin -------',100('-'))
  130 format(/' Dipole, kpl =',i2)
  140 format(/' Quadrupole, kpl =',i2,', kvo =',i2)
  150 format(/' Octupole, kpl =',i2,', kvo =',i2,', kv2 =',i2)
  160 format('   (loperat,moperat) = (',2i2,')')
  170 format(/' nselec =',i2)
end

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

subroutine cal_irep(icheck,iopsymr,irep_util,iselec,karact,lselec,mselec,nb_rep,ngrph,nlfm,nselec,nspino,spinorbite)

  use declarations
  implicit none

  integer:: i, icheck, igrph, irep, is, isg, isp, ispf, ispg, ispin, jgrph, ngrph, L, lf, lg, Lm, m, n_supress, nb_rep, nlfm, &
            nselec, nspino

  character(len=9):: nomsym

  complex(kind=db), dimension(nopsm,nrepm):: karact
  complex(kind=db), dimension(nopsm):: kopsymo

  integer, dimension(nopsm):: iopsymr
  integer, dimension(nrepm):: nlmrep
  integer, dimension(nselec):: irepo, lass
  integer, dimension(nrepm,2):: irep_util(nrepm,2)
  integer, dimension(nrepm,nlfm):: lmrep
  integer, dimension(nselec):: iselec, lselec, mselec
  integer, dimension(:), allocatable:: igr_eq

  logical:: Spinorbite
  logical, dimension(nselec):: fait
  logical, dimension(:), allocatable:: Supr

  if( icheck > 1 ) then
    write(3,110)
    write(3,120)
    call write_iopsym(iopsymr,3)
  endif

  irepo(:) = 0
  lass(:) = 0
  fait(:) = .false.
  do lf = 1,nselec

    if( fait(lf) ) cycle

    L = lselec(lf)
    m = mselec(lf)
    ispin = iselec(lf)
    fait(lf) = .true.

    do isp = 1,nspino

      if( isp == 2 ) then
        if( ispin == 1 ) then
          m = m + 1
        else
          m = m - 1
        endif
        ispin = 3 - ispin
        if( m > L .or. m < -L ) cycle
        do lg = 1,nselec
          if( fait(lg) ) cycle
          if( lselec(lg) == L .and. mselec(lg) == m .and. iselec(lg) == ispin ) then
            fait(lg) = .true.
            lass(lf) = lg
            lass(lg) = lf
            exit
          endif
        end do
      endif

! Calcul des characteres des orbitales d'arrivee :
! Dans la base de L'atome absorbeur
      call symorb(L,m,kopsymo)

! Recherche de la representation a laquelle appartient l'orbitale
      boucle_irep: do irep = 1,nb_rep

        do is = 1,nopsm
          if( iopsymr(is) == 0 ) cycle
          if( abs( karact(is,irep) - kopsymo(is) ) > eps10 ) cycle boucle_irep
        end do
        if( isp == 1 ) then
          irepo(lf) = irep
        else
          irepo(lg) = irep
        endif
        exit

      end do boucle_irep

    end do
  end do

! Cas des representations conjuguees
  if( spinorbite ) then
    do lf = 1,nselec
      if( irepo(lf) /= 0 ) cycle
      L = lselec(lf)
      m = - mselec(lf)
      do lg = 1,nselec
        if( L == lselec(lg) .and. m == mselec(lg) ) exit
      end do
      if( lg == nselec + 1 ) then
        call symorb(L,m,kopsymo)
        boucle_irep2: do irep = 1,nb_rep
          do is = 1,nopsm
            if( iopsymr(is) == 0 ) cycle
            if( abs( karact(is,irep) - kopsymo(is) ) > eps10 ) cycle boucle_irep2
          end do
          irepo(lf) = - irep
        end do boucle_irep2
      else
        irepo(lf) = - irepo(lg)
      endif
    end do
  endif

  if(icheck > 1 .and. lf <= nlfm ) then
    write(3,'(/A)') '  lselec mselec iselec  irep   lass'
    do lf = 1,nselec
      write(3,190) lselec(lf), mselec(lf), iselec(lf), irepo(lf), lass(lf)
    end do
  endif

  ngrph = 0
  irep_util(:,:) = 0

  if( nb_rep == 1 ) then
    ngrph = 1
    irep_util(ngrph,:) = 1
  else
    boucle_l: do lf = 1,nselec
      if( irepo(lf) == 0 ) cycle
      lg = lass(lf)
      if( lg == 0 ) cycle
      ispf = iselec(lf)
      ispg = nspino + 1 - ispf
      do igrph = 1,ngrph
        if( irep_util(igrph,ispf) == irepo(lf) .and. irep_util(igrph,ispg) == irepo(lg) ) cycle boucle_l
      end do
      ngrph = ngrph + 1
      irep_util(ngrph,ispf) = irepo(lf)
      irep_util(ngrph,ispg) = irepo(lg)
    end do boucle_l

    boucle_l2: do lf = 1,nselec
      if( irepo(lf) == 0 ) cycle
      lg = lass(lf)
      if( lg /= 0 ) cycle
      ispf = iselec(lf)
      do igrph = 1,ngrph
        if( irep_util(igrph,ispf) == irepo(lf) ) cycle boucle_l2
      end do
      ngrph = ngrph + 1
      irep_util(ngrph,ispf) = irepo(lf)
    end do boucle_l2
  endif

  nlmrep(:) = 0
  boucle_igrph: do igrph = 1,ngrph
    do lf = 1,nselec
      if( irepo(lf) /= irep_util(igrph,iselec(lf)) ) cycle
      nlmrep(igrph) = nlmrep(igrph) + 1
      lmrep(igrph,nlmrep(igrph)) = lf
    end do
  end do boucle_igrph

! Cas ou aucune fonction n'a ete trouve pour une des 2 representations
  if( spinorbite ) then
    do igrph = 1,ngrph
      if( irep_util(igrph,1) /= 0 .and. irep_util(igrph,nspino) /= 0 ) cycle
      lf = lmrep(igrph,1)
      isp = iselec(lf)
      L = lselec(lf)
      m = mselec(lf)

      if( isp == 1 ) then
        m = m + 1
      else
        m = m - 1
      endif
      L = L + 4

      boucle_isg: do isg = 1,-1,-2
        m = isg * m
        call symorb(L,m,kopsymo)

        boucle_irep3: do irep = 1,nb_rep

          do is = 1,nopsm
            if( iopsymr(is) == 0 ) cycle
            if( abs( karact(is,irep) - kopsymo(is) ) > eps10 ) cycle boucle_irep3
          end do
          irep_util(igrph,nspino+1-isp) = isg * irep
          exit boucle_isg

        end do boucle_irep3
      end do boucle_isg
    end do

  endif

! Check to see if the same representation is counted 2 times
  if( Spinorbite ) then
    allocate( Supr( ngrph ) )
    allocate( igr_eq( ngrph ) )

    Supr( : ) = .false.
    n_supress = 0
    do igrph = 1,ngrph
      do jgrph = igrph+1,ngrph
        if( Supr( jgrph ) ) cycle
        if( irep_util(igrph,1) /= irep_util(jgrph,1) .or. irep_util(igrph,2) /= irep_util(jgrph,2) ) cycle
        Supr( jgrph ) = .true.
        igr_eq( jgrph ) = igrph
        n_supress = n_supress + 1
      end do
    end do

    do i = 1,n_supress
      do igrph = 1,ngrph
        if( .not. Supr( igrph ) ) cycle

        jgrph = igr_eq( igrph )
        Lmrep( jgrph, nlmrep(jgrph)+1:nlmrep(jgrph)+nlmrep(igrph) )= Lmrep( igrph, 1:nlmrep(igrph) )
        nlmrep(jgrph) = nlmrep(jgrph) + nlmrep(igrph)
        do jgrph = igrph+1, ngrph - i
          irep_util(jgrph,:) = irep_util(jgrph+1,:)
          Supr( jgrph ) = Supr( jgrph+1 )
          nlmrep(jgrph) =  nlmrep(jgrph+1)
          Lmrep(jgrph,:) = Lmrep(jgrph+1,:)
        end do
        exit
      end do
    end do

    ngrph = ngrph - n_supress

    deallocate( igr_eq, Supr )
  endif

  if( icheck > 0 ) then
    do igrph = 1,ngrph
      write(3,220) igrph
      if( spinorbite ) then
        write(3,230) irep_util(igrph,1:nspino)
      else
        write(3,240) irep_util(igrph,1:nspino)
      endif
      write(3,'(/A)') '  Orbitals belonging to the representation :'
      if( spinorbite ) then
        write(3,250) ( lselec(lmrep(igrph,Lm)), mselec(lmrep(igrph,Lm)), iselec(lmrep(igrph,Lm)), Lm = 1,nlmrep(igrph) )
      else
        write(3,260) ( lselec(lmrep(igrph,Lm)), mselec(lmrep(igrph,Lm)), Lm = 1,nlmrep(igrph) )
      endif
      write(3,'(/A)') '     is  Symmetry    Character'
      do isp = 1,nspino
        irep = abs(irep_util(igrph,isp))
        if( irep == 0 ) cycle
        do is = 1,nopsm
          if( abs( karact(is,irep) ) < eps10 ) cycle
          if( irep_util(igrph,isp) > 0 ) then
            write(3,270) is, nomsym(is), karact(is,irep)
          else
            write(3,270) is, nomsym(is), conjg( karact(is,irep) )
          endif
        end do
      end do
    end do
  endif

  return
  110 format(/' ---- Cal_irep -------',100('-'))
  120 format(/' iopsymr =')
  190 format(5i7)
  220 format(/' Useful representation number',i3,' :')
  230 format(/'   Number of the corresponding representation :',i2, ' x',i2)
  240 format(/'   Number of the corresponding representation :',i2)
  250 format(30(2x,3i3))
  260 format(30(2x,2i3))
  270 format(i7,a9,13(1x,2f7.3))
end

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

! Stockage dans irep_util de toutes les representations
! Utilisee dans le cas d'un calcul autocoherent car pour calculer
! la densite totale, il faut avoir toutes les representations.

subroutine irep_util_all(icheck,iopsymr,irep_util,karact,nb_rep,ngrph,nspino,spinorbite)

  use declarations
  implicit none

  integer, parameter:: nlfm = 52

  integer:: icheck, isp, L, m, nb_rep, ngrph, nselec, nspino

  integer, dimension(nopsm):: iopsymr
  integer, dimension(:), allocatable:: iselec, lselec, mselec
  integer, dimension(nrepm,2):: irep_util(nrepm,2)

  complex(kind=db), dimension(nopsm,nrepm):: karact

  logical:: Spinorbite

  allocate( iselec(nlfm) )
  allocate( lselec(nlfm) )
  allocate( mselec(nlfm) )

  nselec = 0

  do L = 0,3
    do m = -L,L
      do isp = 1,nspino
        nselec = nselec + 1
        lselec(nselec) = L
        mselec(nselec) = m
        iselec(nselec) = isp
      end do
    end do
  end do

  call cal_irep(icheck,iopsymr,irep_util,iselec,karact,lselec,mselec,nb_rep,ngrph,nlfm,nselec,nspino,Spinorbite)

  deallocate( iselec, lselec, mselec )

  return
end

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

! Subroutine calculating polarisations and wave vectors

subroutine Polond(axyz,Dipmag,icheck,ltypcal,Moyenne,mpirank0,msymdd,msymqq,n_mat_polar,ncolm,ncolr,nomabs,nple,nplr, &
        nplrm,nxanout,Octupole,Orthmatt,Multipole,pdp,pdpolar,pol,polar,Polarise,Python,Quadrupole,Veconde,Vec,Xan_atom)

  use declarations
  implicit none

  integer:: i, icheck, ii, ipl, ipr, j, jj, jpl, k, kpl, mpirank0, n_mat_polar, ncolm, ncolr, nj, nple, nplr, nplr_xan, nplrm, &
            nxanout

  character(len=Length_word):: nomab
  character(len=Length_word), dimension(ncolm):: nomabs
  character(len=5), dimension(nplrm):: ltypcal

  complex(kind=db), dimension(3,nplrm):: pol

  integer, dimension(3):: ipol, kpol
  integer, dimension(3,3):: msymdd
  integer, dimension(3,3,3,3):: msymqq

  logical:: Dipmag, Moyenne, Octupole, Polarise, Python, Quadmag, Quadrupole, Xan_atom
  logical, dimension(13):: Multipole

  real(kind=db):: pdt, plmin, pp, pp1, pp2, pv, r, vomin, vv
  real(kind=db), dimension(3):: axyz, p, pl, v, v1, v2, vo, w
  real(kind=db), dimension(3,3):: Orthmatt, Orthmati
  real(kind=db), dimension(3,nple):: polar, veconde
  real(kind=db), dimension(nple,2):: pdpolar
  real(kind=db), dimension(3,nplrm):: vec
  real(kind=db), dimension(nplrm,2):: pdp

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

  call invermat(Orthmatt,Orthmati)

  pol(:,:) = 0._db
  vec(:,:) = 0._db
  pdp(:,:) = 0._db
  ltypcal(:) = 'linear'

  Quadmag = Multipole(5) .or. Multipole(9) .or. Multipole(10) .or. Multipole(13)

  jpl = 0

! Si aucune polarisation n'est definie en entree, on en construit par defaut
! On les definit dans le repere orthonorme interne.
  if( nple - n_mat_polar == 0 ) then

    if( Quadrupole .or. Octupole ) then

      boucle_ij: do i = 1,3
        j = mod(i,3) + 1
        do ii = 1,i-1
          jj = mod(ii,3) + 1
          if( abs(msymdd(i,i)) == abs(msymdd(ii,ii)) .and. abs(msymqq(i,j,i,j)) == abs(msymqq(ii,jj,ii,jj) ) ) &
               cycle boucle_ij
        end do
        jpl = jpl + 1
        pol(i,jpl) = 1._db
        vec(j,jpl) = 1._db
        jpl = jpl + 1
        pol(i,jpl) = sqrt_1o2
        vec(i,jpl) = sqrt_1o2
        pol(j,jpl) = sqrt_1o2
        vec(j,jpl) = - sqrt_1o2
        do ii = 1,3
          jj = mod(ii,3) + 1
          if( abs(msymdd(i,i)) == abs(msymdd(ii,ii)) .and. abs(msymqq(i,j,i,j)) == abs(msymqq(ii,jj,ii,jj)) ) then
            pdp(jpl-1,1) = pdp(jpl-1,1) + 1._db
            pdp(jpl-1,2) = pdp(jpl-1,2) + 1.5_db
            pdp(jpl,2) = pdp(jpl,2) + 1._db
          endif
        end do
      end do boucle_ij

    else

      boucle_exter: do i = 1,3
        do ii = 1,i-1
          if( abs( msymdd(i,i) ) == abs( msymdd(ii,ii)) ) cycle boucle_exter
        end do
        jpl = jpl + 1
        pol(i,jpl) = 1._db
        do ii = 1,3
          if( abs(msymdd(i,i)) == abs( msymdd(ii,ii)) ) pdp(jpl,1) = pdp(jpl,1) + 1._db
        end do
      end do boucle_exter

      if( dipmag .or. Quadmag ) then
        select case(jpl)
          case(1)
            if( abs( pol(1,1) ) < 0.99_db ) then
              v(2:3) = 0._db; v(1) = 1._db
            else
              v(1:2) = 0._db; v(3) = 1._db
            endif
            p(1:3) = real( pol(1:3,1), db )
            call prodvec(w,p,v)
            w = w / sqrt( sum( w(:)**2 ) )
            call prodvec(v,w,p)
            vec(1:3,1) = v(1:3)
          case(2)
            p(1:3) = real( pol(1:3,1), db )
            w(1:3) = real( pol(1:3,2), db )
            call prodvec(v,p,w)
            vec(1:3,1) = v
            vec(1:3,2) = real( pol(1:3,1) )
          case(3)
            vec(1:3,1) = real( pol(1:3,2), db )
            vec(1:3,2) = real( pol(1:3,3), db )
            vec(1:3,3) = real( pol(1:3,1), db )
        end select
      endif

    endif

    nplr = jpl

    pdt = sum( pdp(1:nplr,1) )
    pdp(1:nplr,1) = pdp(1:nplr,1) / pdt
    if( Quadrupole .or. Octupole ) then
      pdt = sum( pdp(1:nplr,2) )
      pdp(1:nplr,2) = pdp(1:nplr,2) / pdt
    endif

  endif

  do ipl = 1,nple

    pl(:) = 0._db
    vo(:) = 0._db

! On passe en base interne (orthonormee)
    p(:) = polar(:,ipl) / axyz(:)
    pp = sum( p(:)**2 )
    if( abs(pp) > eps6 ) call trvec(mpirank0,Orthmatt,p,pl)

    v(:) = veconde(:,ipl) / axyz(:)
    vv = sum( v(:)**2 )
    if( vv > eps6 ) call trvec(mpirank0,Orthmatt,v,vo)

! Test on orthogonality
    if( Quadrupole .or. Octupole .or. Dipmag .or. Quadmag ) then
      pv = abs( sum( vo(:) * pl(:) ) )
      if( pv > eps4 ) then
        if( mpirank0 == 0 ) then
          call write_error
          do ipr = 3,9,3
            if( ipr == 3 .and. icheck == 0 ) cycle
            write(ipr,110) ipl, p(:), v(:)
          end do
        endif
        stop
      endif
    endif

    jpl = jpl + 1

    if( pp > eps6 ) then

      pol(:,jpl) = cmplx( pl(1:3), 0._db, db)
      vec(:,jpl) = vo(:)
      pdp(jpl,:) = pdpolar(ipl,:)

      if( ipl > nple - n_mat_polar ) ltypcal(jpl) = 'ss   '

    else

! When in the indata file, polarisation is zero, it means it is circular
      do i = 1,3
        if( abs( vo(i) ) > eps4 ) exit
      end do
      j = i - 1
      if( j == 0 ) j = 3
      v(:) = 0._db
      v(j) = 1._db
      call prodvec(v1,v,vo)
      r = sqrt( sum( v1(:)**2 ) )
      v1(:) = v1(:) / r
      call prodvec(v2,vo,v1)
      pol(:,jpl) = cmplx( v1(:), v2(:), db ) * sqrt_1o2
      vec(:,jpl) = vo(:)
      pdp(jpl,:) = 0.5_db*pdpolar(ipl,:)
      ltypcal(jpl) = 'left '

      jpl = jpl + 1
      pol(:,jpl) = cmplx( v1(:), - v2(:), db ) * sqrt_1o2
      vec(:,jpl) = vo(:)
      pdp(jpl,:) = 0.5_db*pdpolar(ipl,:)
      ltypcal(jpl) = 'right'

    endif

    if( ipl > nple - n_mat_polar ) then
! One calculates the pi polarization
      call prodvec(v1,vo,pl)
      r = sqrt( sum( v1(:)**2 ) )
      v1(:) = v1(:) / r

      jpl = jpl + 1
      pol(:,jpl) = cmplx( v1(1:3), 0._db, db)
      vec(:,jpl) = vo(:)
      pdp(jpl,:) = pdpolar(ipl,:)
      ltypcal(jpl) = 'sp   '

      jpl = jpl + 1
      pol(:,jpl) = pol(:,jpl-2)
      vec(:,jpl) = vo(:)
      pdp(jpl,:) = pdpolar(ipl,:)
      ltypcal(jpl) = 'ps   '

      jpl = jpl + 1
      pol(:,jpl) = pol(:,jpl-2)
      vec(:,jpl) = vo(:)
      pdp(jpl,:) = pdpolar(ipl,:)
      ltypcal(jpl) = 'pp   '

    endif

  end do

  nplr = jpl
  nplr_xan = nplr - 4 * n_mat_polar

! Determination of the column name for the output files

  jpl = 0   ! index of column
  ipl = 0

  do kpl = 1,nplr_xan

    jpl = jpl + 1
    ipl = ipl + 1

    if( ltypcal(kpl) == 'left ' ) then   ! circular dichroism

      vo(:) = veconde(:,ipl)
      vomin = 1._db
      do k = 1,3
        pp = abs( vo(k) )
        if( pp > eps4 ) vomin = min( vomin, pp)
      end do
      kpol(:) = nint( vo(:) / vomin )

      if( Python ) then
        nomab = ' Abs_'
      else
        nomab = ' Abs('
      endif
      j = 5
      call trnom(j,kpol,Length_word,nomab)
      j = j + 1
      if( j <= Length_word .and. .not. Python ) nomab(j:j) = ')'
      nomabs(jpl) = nomab

    elseif( ltypcal(kpl) == 'right' ) then

      ipl = ipl - 1
      if( Python ) then
        nomab(2:4) = 'Dic_'
      else
        nomab(2:4) = 'Dic('
      endif
      nomabs(jpl) = nomab

    else

      if( nple /= n_mat_polar ) then
        pl(:) = polar(:,ipl)
        vo(:) = veconde(:,ipl)
      else
        ipl = ipl - 1
! On se place dans la base cristallographique
        pl(:) = pol(:,kpl)
        pl = matmul( orthmati, pl)
        pl(:) = pl(:) * axyz(:)
        vo(:) = vec(:,kpl)
        vo = matmul( orthmati, vo)
        vo(:) = vo(:) * axyz(:)
      endif

      plmin = 1._db
      do k = 1,3
        pp = abs( pl(k) )
        if( pp > eps4 ) plmin = min( plmin, pp )
      end do
      ipol(:) = nint( pl(:) / plmin )
      vomin = 1._db
      do k = 1,3
        pp = abs( vo(k) )
        if( pp > eps4 ) vomin = min( vomin, pp)
      end do
      kpol(:) = nint( vo(:) / vomin )

      j = 0
      nomab = ' '
      call trnom(j,ipol,Length_word,nomab)
      if( ( kpol(1) /= 0 .or. kpol(2) /= 0 .or. kpol(3) /= 0 ) .and. ( Quadrupole .or. Octupole .or. Dipmag ) ) then
        j = j + 1
        nomab(j:j) = ','
        call trnom(j,kpol,Length_word,nomab)
      endif
      nj = j
      if( nj < Length_word-2 .and. .not. Python ) nomab(nj+1:nj+1) = ')'
      if( nj < Length_word-1 ) then
        if( Python ) then
          nomab(1:Length_word) = 'P' // nomab(1:Length_word-1)
        else
          nomab(1:Length_word) = '(' // nomab(1:Length_word-1)
        endif
      else
        nomab(1:Length_word) = ' ' // nomab(1:Length_word-1)
      endif

      nomabs(jpl) = nomab // 'pp'

    endif
  end do

  pp1 = sum( pdp(1:nplr_xan,1) )
  pp2 = sum( pdp(1:nplr_xan,2) )
  pp = sum( abs(pdp(1:nplr_xan,:)) )
  if( .not. Polarise ) jpl = nplr_xan
  if( nplr_xan > 1 .and. pp > eps4 ) then
    if( abs(pp1) > eps4 ) pdp(1:nplr_xan,1) = pdp(1:nplr_xan,1) / pp1
    if( ( Quadrupole .or. Octupole ) .and. abs(pp2) > eps4 ) pdp(1:nplr_xan,2) = pdp(1:nplr_xan,2) / pp2
    Moyenne = .true.
    jpl = jpl + 1
    if( abs(pp1+pp2) > eps4 ) then
      nomabs(jpl) = '    <xanes>  '
    else
      nomabs(jpl) = '    dichroi  '
    endif
  else
    Moyenne = .false.
  endif

! nxanout is the index of the column from wich one prints
  if( Polarise ) then
    nxanout = 1
  else
    if( nplr_xan == 1 ) nomabs(1) = '    <xanes>  '
    nxanout = jpl
  endif

  if( xan_atom ) then
    jpl = jpl + 1
    nomabs(jpl) = '  XANES_atom '
  endif

  do kpl = nplr_xan+1,nplr

    jpl = jpl + 1
    ipl = ipl + 1

 ! one stokes the "first" polarization (sigma) and wave vector
    if( ltypcal(kpl) /= 'ss   ' ) ipl = ipl - 1
    pl(:) = polar(:,ipl)
    vo(:) = veconde(:,ipl)

    plmin = 1._db
    do k = 1,3
      pp = abs( pl(k) )
      if( pp > eps4 ) plmin = min( plmin, pp )
    end do
    ipol(:) = nint( pl(:) / plmin )
    vomin = 1._db
    do k = 1,3
      pp = abs( vo(k) )
      if( pp > eps4 ) vomin = min( vomin, pp)
    end do
    kpol(:) = nint( vo(:) / vomin )

    j = 0
    nomab = ' '
    call trnom(j,ipol,Length_word,nomab)
    j = j + 1
    nomab(j:j) = ','
    call trnom(j,kpol,Length_word,nomab)
    nj = j
    if( nj < Length_word-6 .and. .not. Python ) nomab(nj+1:nj+1) = ')'
    if( nj < Length_word-5 ) then
      if( Python ) then
        nomab(1:Length_word) = 'P' // nomab(1:Length_word-1)
      else
        nomab(1:Length_word) = '(' // nomab(1:Length_word-1)
      endif
    else
      nomab(1:Length_word) = ' ' // nomab(1:Length_word-1)
    endif
    nj = len_trim(nomab) + 1
    nomab(nj:nj) = '_'
    nomab(nj+1:nj+2) = ltypcal(kpl)(1:2)
    nomabs(jpl) = nomab

    if( ltypcal(kpl) == 'sp   ' .or.  ltypcal(kpl) == 'ps   ' ) then
      if( nj+4 < Length_word ) then
        nomab(nj+3:nj+4) = '_r'
      elseif( nj+3 < Length_word ) then
        nomab(nj+3:nj+3) = 'r'
      endif
      nomabs(jpl) = nomab
      jpl = jpl + 1
      if( nj+4 < Length_word ) then
        nomab(nj+3:nj+4) = '_i'
      elseif( nj+3 < Length_word ) then
        nomab(nj+3:nj+3) = 'i'
      endif
      nomabs(jpl) = nomab
    endif

  end do

! ncolr correspond au nombre de colonnes ecrites pour le xanes
  ncolr = jpl

  if( icheck > 0 ) then
    write(3,155)
    do ipl = 1,nplr
      write(3,160)
      write(3,160) pol(1,ipl), vec(1,ipl), ltypcal(ipl), pdp(ipl,:)
      do i= 2,3
        write(3,160) pol(i,ipl), vec(i,ipl)
      end do
    end do
  endif

  return
  100 format(/' ---- Polond -----',100('-'))
  110 format(/' The incoming wave vector and the polarization must be perpendicular !'/, &
              ' ipl =',i3,'   Pol =',3f10.5,/ 12x,'vec =',3f10.5)
  155 format(/'  Polarization and wave vectors in the internal basis R1 ( orthogonal basis, z along c crystal )',// &
              '         Pol           Vec     Type   Weight_d Weight_q')
  160 format(2f9.5,1x,f9.5,3x,a6,2f9.5)
end

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

subroutine trnom(j,ind,Length_word,nomab)

  implicit none

  integer:: j, k, Length_word

  character(len=Length_word):: nomab, nomac

  integer, dimension(3):: ind

  nomac = ' '
  nomac(1:Length_word-1) = nomab(1:Length_word-1)
  do k = 1,3
    call ad_number(ind(k),nomac,Length_word)
  end do
  nomab(1:Length_word-1) = nomac(1:Length_word-1)
  j = len_trim(nomab)

  return
end

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

subroutine trnom_r(j,ind,nomab)

  use declarations
  implicit none

  integer:: j, k

  character(len=Length_word):: nomab, nomac

  real(kind=db), dimension(3):: ind

  nomac = ' '
  nomac(1:Length_word-1) = nomab(1:Length_word-1)
  do k = 1,3
    call ad_number_r(ind(k),nomac)
  end do
  nomab(1:Length_word-1) = nomac(1:Length_word-1)
  j = len_trim(nomab)

  return
end

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

subroutine trvec(mpirank0,Orthmat,ve,vs)

  use declarations
  implicit none

  integer:: ipr, mpirank0

  real(kind=db):: pp
  real(kind=db), dimension(3):: ve, vs, w
  real(kind=db), dimension(3,3):: Orthmat

! On se place en base orthonormee
  w = matmul( Orthmat, ve )

! Normalisation
  pp = sqrt( sum( w(:)**2 ) )
  if( pp > eps4 ) then
    w(:) = w(:) / pp
  elseif( mpirank0 == 0 ) then
    call write_error
    do ipr = 6,9,3
      write(ipr,110)
    end do
    stop
  endif

  vs(:) = w(:)

  return
  110 format(//' The polarisation vector is zero in routine trvec !'/)
end

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

! Calcul du (L,m) = (loperat,moperat) de la transition

subroutine Lmtrans(kpl,kvo,kv2,noperat,loperat,moperat,Spinorbite)

  use declarations
  implicit none

  integer:: iop, jop, kpl, kprod, kvo, kv2, noperat

  integer, dimension(6) :: loperat, moperat

  logical:: Spinorbite

! Monople

  if( kpl == 0 ) then

    noperat = 1
    loperat(1) = 0
    moperat(1) = 0

! dipole
  elseif( kvo == 0 ) then

    noperat = 1
    loperat(1) = 1
    select case(kpl)
      case(1)
        moperat(1) = 1
      case(2)
        moperat(1) = -1
      case(3)
        moperat(1) = 0
    end select

! quadrupole
  elseif( kv2 == 0 ) then

    kprod = kpl * kvo

    select case(kprod)
      case(2)
        noperat = 1
        loperat(1) = 2
        moperat(1) = -2
      case(6)
        noperat = 1
        loperat(1) = 2
        moperat(1) = -1
      case(3)
        noperat = 1
        loperat(1) = 2
        moperat(1) = 1
      case(1,4)
        noperat = 3
        loperat(1) = 0
        moperat(1) = 0
        loperat(2:3) = 2
        moperat(2) = 0
        moperat(3) = 2
      case(9)
        noperat = 2
        loperat(1) = 0
        moperat(1) = 0
        loperat(2) = 2
        moperat(2) = 0
    end select

! octupole
  else

    kprod = kpl * kvo * kv2

    select case(kprod)
      case(6)
        noperat = 1
        loperat(1) = 3
        moperat(1) = -2
      case(2)
        noperat = 3
        loperat(1) = 1
        moperat(1) = -1
        loperat(2:3) = 3
        moperat(2) = -3
        moperat(3) = -1
      case(4)
        noperat = 3
        loperat(1) = 1
        moperat(1) = 1
        loperat(2:3) = 3
        moperat(2) = 3
        moperat(3) = 1
      case(3,12)
        noperat = 3
        loperat(1) = 1
        moperat(1) = 0
        loperat(2:3) = 3
        moperat(2) = 0
        moperat(3) = 2
      case(18)
        noperat = 2
        loperat(1) = 1
        moperat(1) = -1
        loperat(2) = 3
        moperat(2) = -1
      case(9)
        noperat = 2
        loperat(1) = 1
        moperat(1) = 1
        loperat(2) = 3
        moperat(2) = 1
      case(1)
        noperat = 3
        loperat(1) = 1
        moperat(1) = 1
        loperat(2:3) = 3
        moperat(2) = 3
        moperat(3) = 1
      case(8)
        noperat = 3
        loperat(1) = 1
        moperat(1) = -1
        loperat(2:3) = 3
        moperat(2) = -3
        moperat(3) = -1
      case(27)
        noperat = 2
        loperat(1) = 1
        moperat(1) = 0
        loperat(2) = 3
        moperat(2) = 0
    end select

  endif

  if( Spinorbite ) then
    jop = noperat
    do iop = 1,noperat
      if( moperat(iop) == 0 ) cycle
      jop = jop + 1
      loperat(jop) = loperat(iop)
      moperat(jop) = - moperat(iop)
    end do
    noperat = jop
  endif

  return
end

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

subroutine symorb(L,m,kopsymo)

  use declarations
  implicit none

  integer:: im, is, L, m, m2, m4, mlm, mm

  complex(kind=db), dimension(nopsm):: kopsymo

  integer, dimension(nopsm):: iopsymo

  logical:: lpair, pair

  if( L == 0 ) then
    kopsymo(:) = (1._db, 0._db)
    return
  endif
  pair = .false.
  iopsymo(:) = 0
  iopsymo(1) = 1
  lpair = mod(L,2) == 0

! Axes 2
  im = abs( m )
  do is = 22,24
    select case(is)
      case(22)   ! Axe 2 Ox
        mm = mod(L+im,2)
        pair = (mm == 0 .and. m >= 0) .or. (mm == 1 .and. m < 0)
      case(23)   ! Axe 2 Oy
        mm = mod(L+2*im,2)
        pair = (mm == 0 .and. m >= 0) .or. (mm == 1 .and. m < 0)
      case(24)   ! Axe 2 Oz
        mm = mod(im,2)
        pair = mm == 0
    end select
    if( pair ) then
      iopsymo(is) = 1
    else
      iopsymo(is) = -1
    endif
  end do

! Axes 2 selon (110) et (1-10)
  m4 = mod(im,4)
  mlm = mod(L+im,2)
  if( ( m >= 0 .and. ( ( m4 == 0 .and. mlm == 0 ) .or. ( m4 == 2 .and. mlm == 1 ) ) ) &
   .or. ( m < 0 .and. ( ( m4 == 2 .and. mlm == 0 ) .or. ( m4 == 0 .and. mlm == 1 ) ) ) ) then
    iopsymo(10:11) = 1
  elseif( ( m >= 0 .and. ( ( m4 == 0 .and. mlm == 1 ) .or. ( m4 == 2 .and. mlm == 0 ) ) ) &
   .or. ( m < 0 .and. ( ( m4 == 2 .and. mlm == 1 ) .or. ( m4 == 0 .and. mlm == 0 ) ) ) ) then
    iopsymo(10:11) = -1
  endif

! Axe 3 Oz
! Quand la valeur est differente de 1 ou - 1, le chiffre represente n
! pour le caractere egal a exp(n*i*pi/12).
  mm = m
  do
    if( mm >= 0 ) exit
    mm = mm + 3
  end do
  mm = mod(mm,3)
  select case(mm)
    case(0)
      iopsymo(49:50) = 1
    case(1)
      iopsymo(49) = 4; iopsymo(50) = 8
    case(2)
      iopsymo(49) = 8; iopsymo(50) = 4
  end select
! Axes 3 negatif
  if( mod(L+m,2) == 0 ) then
    iopsymo(53:54) = iopsymo(49:50)
  else
    select case(mm)
      case(0)
        iopsymo(53:54) = -1
      case(1)
        iopsymo(53) = 10; iopsymo(54) = 2
      case(2)
        iopsymo(53) = 2;  iopsymo(54) = 10
    end select
  endif

! Axe 4 Oz
  mm = m
  do
    if( mm >= 0 ) exit
    mm = mm + 4
  end do
  mm = mod(mm,4)
  select case(mm)
    case(0)
      iopsymo(18:21:3) = 1
    case(1)
      iopsymo(18) = 3; iopsymo(21) = 9
    case(2)
      iopsymo(18:21:3) = -1
    case(3)
      iopsymo(18) = 9; iopsymo(21) = 3
  end select
! Axes S4
  if( mod(L+m,2) == 0 ) then
    iopsymo(28:31:3) = iopsymo(18:21:3)
  else
    select case(mm)
      case(0)
        iopsymo(28:31:3) = -1
      case(1)
        iopsymo(28) = 9; iopsymo(31) = 3
      case(2)
        iopsymo(28:31:3) = 1
      case(3)
        iopsymo(28) = 3; iopsymo(31) = 9
      end select
  endif

! Axe 6 Oz
  mm = m
  do
    if( mm >= 0 ) exit
    mm = mm + 6
  end do
  mm = mod(mm,6)
  select case(mm)
    case(0)
      iopsymo(51:52) = 1
    case(1)
      iopsymo(51) = 2; iopsymo(52) = 10
    case(2)
      iopsymo(51) = 4; iopsymo(52) = 8
    case(3)
      iopsymo(51:52) = -1
    case(4)
      iopsymo(51) = 8; iopsymo(52) = 4
    case(5)
      iopsymo(51) = 10; iopsymo(52) = 2
  end select
! Axes 6 negatif
  if( mod(L+m,2) == 0 ) then
    iopsymo(55:56) = iopsymo(51:52)
  else
    select case(mm)
      case(0,3)
        iopsymo(55:56) = - iopsymo(51:52)
      case default
        do is = 51,52
          if( iopsymo(is) < 6 ) then
            iopsymo(is+4) = iopsymo(is) + 6
          else
            iopsymo(is+4) = iopsymo(is) - 6
          endif
        end do
    end select
  endif

! Centrosymmetie
  if( lpair ) then
    iopsymo(25) = 1
  else
    iopsymo(25) = - 1
  endif

! Plans de symetrie
  m2 = mod(im,2)

  if( (m > 0 .and. m2 == 1) .or. (m < 0 .and. m2 == 0) ) then
    iopsymo(40) = -1
  else
    iopsymo(40) = 1
  endif
  if( m < 0 ) then
    iopsymo(41) = -1
  else
    iopsymo(41) = 1
  endif
  if( mod(L+m,2) == 1 ) then
    iopsymo(42) = -1
  else
    iopsymo(42) = 1
  endif

! Plans diagonaux contenant Oz
  m4 = mod(abs(m),4)
  if( (m4 == 0 .and. m >= 0) .or. (m4 == 2 .and. m < 0) ) then
    iopsymo(45:48:3) = 1
  elseif((m4 == 0 .and. m < 0) .or. (m4 == 2 .and. m >= 0)) then
    iopsymo(45:48:3) = -1
  else
    iopsymo(45:48:3) = 0
  endif

! Quand la valeur est differente de 1 ou - 1, le chiffre represente n
! pour le caractere egal a exp(n*i*pi/12).
  do is = 1,nopsm
    select case( iopsymo(is) )
      case(0)
        kopsymo(is) = (0._db, 0._db)
      case(1)
        kopsymo(is) = (1._db, 0._db)
      case(-1)
        kopsymo(is) = (-1._db, 0._db)
      case default
        kopsymo(is) = exp( iopsymo(is) * img * pi / 6 )
    end select
  end do

  return
end

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

function natome_cal(igrpt_nomag,iopsymr,mpirank0,natomeq,natomp,pos)

  use declarations
  implicit none

  integer:: ia, igrpt_nomag, isym, mpirank0, natome, natome_cal, natomeq, natomp

  integer, dimension(nopsm):: iopsymr

  real(kind=db), dimension(3):: dp, ps
  real(kind=db), dimension(3,natomp):: pos

  natome = 0
  do ia = 1,natomeq
    ps(:) = pos(:,ia)
    call posequiv(mpirank0,ps,iopsymr,isym,igrpt_nomag)
    dp(:) = abs( ps(:) - pos(:,ia) )
    if( dp(1) > epspos .or. dp(2) > epspos .or. dp(3) > epspos ) cycle
    natome = natome + 1
  end do
  natome_cal = natome

  return
end

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

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

  use declarations
  implicit none

  integer:: ia, ib, igrpt_nomag, ipr, isym, mpirank0, n_atom_proto, n_atom_proto_bulk, natome, natomeq, natomp

  integer, dimension(natomp):: iaproto
  integer, dimension(natome):: iaprotoi
  integer, dimension(0:n_atom_proto):: nb_eq_2D
  integer, dimension(nopsm):: iopsymr

  logical, dimension(0:n_atom_proto):: Proto_calculated

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

  nb_eq_2D(:) = 0
  do ia = 1,natomeq
    nb_eq_2D( iaproto(ia) ) = nb_eq_2D( iaproto(ia) ) + 1
  end do

! Check on atoms non equivalent in space group but equivalent in ponctual group
  do ia = 1,natomeq
    ipr = iaproto(ia)
    if( nb_eq_2D( ipr ) == 0 .or. Proto_calculated( ipr ) .or. ipr  > n_atom_proto - n_atom_proto_bulk ) cycle
    ps(:) = pos(:,ia)
    call posequiv(mpirank0,ps,iopsymr,isym,igrpt_nomag)
    do ib = 1,natome
      dp(:) = abs( ps(:) - posi(:,ib) )
      if( dp(1) < epspos .and. dp(2) < epspos .and. dp(3) < epspos ) exit
    end do
    if( ib > natome ) cycle
    nb_eq_2D( ipr ) = nb_eq_2D( ipr ) - 1
    nb_eq_2D( iaprotoi(ib) ) = nb_eq_2D( iaprotoi(ib) ) + 1
  end do

  return
end

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

! Selection of the atoms for the "small" cluster
! Evaluation of their ponctual group in this cluster

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

  use declarations
  implicit none

  character(len=8):: ptgrname_int, ptgrname_int_nomag

  integer:: i, i_self, ia, ia1, ia2, iaabs, iaabsi, iabsorbeur, iapr, ib, ich, icheck, ie, ig, iga, igr, igrpt_nomag, igrpt_p, &
     igrpt0, ind_rep, iord, ipr, ipr1, is, isp, istop, isym, it, itq_1, itq_2, it1, it2, j, js, L, L_hubbard, m, m_hubb, mp, &
     m_hubb_e, mpirank0, n_atom_0_self, n_atom_ind_self, n_atom_proto, na_ligne, na1, na2, natome, natomeq, natomp, natomsym, &
     nb_sym_op, neqm, ngroup, ngroup_hubb, ngroup_m, nlatm, nspin, nspinp, ntype, nx

  integer, dimension(nopsm):: iopsyma, iopsymr
  integer, dimension(natomsym):: isymeq
  integer, dimension(nopsm,natome):: iopsym_atom
  integer, dimension(natome):: iaprotoi, iatomp, igroupi, igrpt, itypei, nb_eq
  integer, dimension(0:n_atom_proto,neqm):: igreq
  integer, dimension(natomeq):: ia_eq_inv
  integer, dimension(nb_sym_op,natome):: ia_eq, ia_eq_sym, is_eq
  integer, dimension(nb_sym_op,natome,natome):: ia_rep, nb_rep_t
  integer, dimension(natome,natome):: nb_rpr
  integer, dimension(natomp):: iaproto, igroup, itypep
  integer, dimension(ngroup):: itype
  integer, dimension(0:ntype):: itequ, nlat, Numat
  integer, dimension(0:n_atom_proto):: itypepr, ngreq

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

  logical:: Atom_c, Atom_m, Atom_mag_cal, Nonsph, Atom_occ_mat, Full_atom, Green, Hubbard, magnetic, overad, &
          Simplified, Spinorbite, Symmol, Ylm_comp
  logical, dimension(nb_sym_op):: Fait
  logical, dimension(natome):: Atom_comp, Atom_axe
  logical, dimension(0:natome):: Atom_mag
  logical, dimension(0:ngroup_m):: Atom_with_axe
  logical, dimension(0:n_atom_proto):: Proto_calculated

  real(kind=db):: Adimp, Dist, Rm, Rmax, Rsort, Rsorte, Roverad

  real(kind=db), dimension(3):: dp, E_moment_axis, ps, v
  real(kind=db), dimension(3,3):: matopsym, rot_a
  real(kind=db), dimension(0:ntype) :: rmt, V_hubbard
  real(kind=db), dimension(3,natome):: Axe_atom_clui, posi
  real(kind=db), dimension(natome):: distai
  real(kind=db), dimension(natomp):: dista
  real(kind=db), dimension(3,natomp):: Axe_atom_clu, pos
  real(kind=db), dimension(3,3,natome):: Rot_atom
  real(kind=db), dimension(3,3,natomp):: Rot_atom_spin, Rot_atomp
  real(kind=db), dimension(ngroup,nlatm,nspin):: popats
  real(kind=db), dimension(-m_hubb_e:m_hubb_e,-m_hubb_e:m_hubb_e,nspin,ngroup_hubb):: occ_hubb_e

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

! Selection of the atoms where we make a developent in spherical harmonics, taking into account the symmetry

  iaabsi = 0

  ib = 0
  Proto_calculated(0) = .true.
  Proto_calculated(1:n_atom_proto) = .false.
  do ia = 1,natomeq
    ps(:) = pos(:,ia)
    call posequiv(mpirank0,ps,iopsymr,isym,igrpt_nomag)
    dp(:) = abs( ps(:) - pos(:,ia) )
    if( dp(1) > epspos .or. dp(2) > epspos .or. dp(3) > epspos ) cycle
    ib = ib + 1
    iatomp(ib) = ia
    iaprotoi(ib) = iaproto(ia)
    itypei(ib) = itypep(ia)
    igroupi(ib) = igroup(ia)
    posi(:,ib) = pos(:,ia)
    Axe_atom_clui(:,ib) = Axe_atom_clu(:,ia)
    distai(ib) = dista(ia)
    Proto_calculated( iaproto(ia) ) = .true.
  end do

  boucle_ipr: do ipr = ipr1,n_atom_proto
    do igr = 1,ngreq(ipr)
      if( igreq(ipr,igr) == iabsorbeur ) exit boucle_ipr
    end do
  end do boucle_ipr

  if( Atom_occ_mat .and. hubbard .and. i_self == 1 ) then
    V_hubb(:,:,:,:,:) = ( 0._db, 0._db )
    do iapr = n_atom_0_self,n_atom_ind_self
      if( Full_atom ) then
        igr = igroupi(iapr)
        it = itypei(iapr)
      else
        igr = igreq(iapr,1)
        ipr = iaprotoi(igr)
        it = itypepr(ipr)
      end if
      L = L_hubbard( Numat(it) )
      do m = -L,L
        do mp = -L,L
          do isp = 1,nspin
            if( m == mp ) V_hubb(m,isp,mp,isp,iapr) = cmplx( 0.5_db * V_hubbard(it), 0._db )
            V_hubb(m,isp,mp,isp,iapr) = V_hubb(m,isp,mp,isp,iapr) - cmplx( V_hubbard(it) * Occ_hubb_e(m,isp,mp,igr), 0._db )
            if( nspinp > nspin ) V_hubb(-mp,nspinp,-m,nspinp,iapr) = V_hubb(m,isp,mp,isp,iapr)
          end do
        end do
      end do
    end do
  end if

! Elaboration of the list of equivalent atoms
! The representative one is set in first position
  nb_eq(:) = 0
  do ia = 1,natomeq
    ps(:) = pos(:,ia)
    call posequiv(mpirank0,ps,iopsymr,isym,igrpt_nomag)
    if( abs(isym) /= 1 ) cycle
    it1 = itypep(ia)
    itq_1 = abs( itequ(it1) )
    do ib = 1,natome
      dp(:) = abs( ps(:) - posi(:,ib) )
      it2 = itypei(ib)
      itq_2 = abs( itequ(it2) )
      if( dp(1) > epspos .or. dp(2) > epspos .or. dp(3) > epspos .or. itq_1 /= itq_2 ) cycle
      nb_eq(ib) = nb_eq(ib) + 1
      ia_eq( nb_eq(ib), ib ) = ia
      is_eq( nb_eq(ib), ib ) = isym
      exit
    end do
  end do
  do ia = 1,natomeq
    ps(:) = pos(:,ia)
    call posequiv(mpirank0,ps,iopsymr,isym,igrpt_nomag)
    if( abs(isym) == 1 ) cycle
    it1 = itypep(ia)
    itq_1 = abs( itequ(it1) )
    do ib = 1,natome
      dp(:) = abs( ps(:) - posi(:,ib) )
      it2 = itypei(ib)
      itq_2 = abs( itequ(it2) )
   ! Atoms in bulk and surface are not of the same type.
      if( dp(1) > epspos .or. dp(2) > epspos .or. dp(3) > epspos .or. itq_1 /= itq_2 ) cycle
      nb_eq(ib) = nb_eq(ib) + 1
      ia_eq( nb_eq(ib), ib ) = ia
      is_eq( nb_eq(ib), ib ) = isym
      exit
    end do
  end do

  do ib = 1,natome
    do i = 1,nb_eq(ib)
      ia_eq_inv( ia_eq( i, ib ) ) = ib
    end do
  end do

  do ia = 1,natome
    js = 0
    it2 = itypei(ia)
    itq_2 = abs( itequ(it2) )
    do is = 1,nopsm
      if( iopsymr(is) == 0 ) cycle
      js = js + 1
      call opsym(is,matopsym)
      ps(:) = posi(:,ia)
      v = matmul( matopsym, ps )
      do i = 1,nb_eq(ia)
        ie = ia_eq(i,ia)
        it1 = itypep(ie)
        itq_1 = abs( itequ(it1) )
        dp(:) = abs( v(:) - pos(:,ie) )
        if( dp(1) > epspos .or. dp(2) > epspos .or. dp(3) > epspos .or. itq_1 /= itq_2 ) cycle
        ia_eq_sym(js,ia) = i
        exit
      end do
    end do
  end do

! Calcul du nombre d'atomes n' tels que S(n0) = n0 et S(n1) = n'
! et evaluation des n1
  nb_rpr(:,:) = 0
  nb_rep_t(:,:,:) = 0
  do ia = 1,natome
    do ib = 1,natome

      Fait(:) = .false.
      ind_rep = 0

      do i = 1,nb_eq(ib)

!          Fait(:) = .false.
        ie = ia_eq(i,ib)
        if( Fait(i) ) cycle  ! i est deja represente ou representant

        ind_rep = ind_rep + 1
        ia_rep(ind_rep,ia,ib) = ie

        do is = 1,nopsm
          if( iopsymr(is) == 0 ) cycle
          call opsym(is,matopsym)
          ps(:) = posi(:,ia)
          v = matmul( matopsym, ps )
          dp(:) = abs( v(:) - ps(:) )
          if( dp(1) > epspos .or. dp(2) > epspos .or. dp(3) > epspos ) cycle         ! S(ia) /= ia

          ps(:) = pos(:,ie)
          ps = matmul( matopsym, ps )

          do j = 1,nb_eq(ib)   ! recherche du n' = S(n1)
            if( Fait(j) ) cycle
            ig = ia_eq(j,ib)
            dp(:) = abs( pos(:,ig) - ps(:) )
            if( dp(1) > epspos .or. dp(2) > epspos .or. dp(3) > epspos  .or. itypep(ie) /= itypep(ig) ) cycle
            nb_rep_t(ind_rep,ia,ib) = nb_rep_t(ind_rep,ia,ib) + 1
            Fait(j) = .true.
          end do

        end do

      end do

      nb_rpr(ia,ib) = ind_rep
    end do
  end do

  if( magnetic ) then
    Atom_mag(0) = Atom_mag_cal(igrpt0)
  else
    Atom_mag(0) = .false.
  endif

  istop = 0
  boucle_igr: do igr = 1,ngreq(ipr)
    do ia = 1,natome
      do i = 1,nb_eq(ia)
        ib = ia_eq(i,ia)
        if( iaproto(ib) /= ipr ) cycle
        if( igreq(ipr,igr) == igroup(ib) ) then
          if( igr > 1 .and. isymeq(1) /= isymeq(igr) ) then
            call write_error
            do ipr = 3,9,3
              if( ipr == 3 .and. icheck == 0 ) cycle
              write(ipr,120)
            end do
            istop = 1
          endif
          iaabsi = ia
          exit boucle_igr
        endif
      end do
    end do
  end do boucle_igr

! Evaluation of local symmetry
  Simplified = .not. Magnetic
  ich = max( 0, icheck - 1 )
  do ia = 1,natome
    if( icheck > 1 ) write(3,130) ia
    ps(:) = posi(:,ia)
    call Point_group_atom(Atom_comp(ia),Atom_mag(ia),Atom_with_axe,Nonsph,Axe_atom_clu,E_moment_axis, &
        iaabs,iatomp(ia),ich,igroup,igrpt(ia),igrpt0,iopsyma,iopsymr,itype,itypep,magnetic,mpirank0,natomp, &
        ngroup,ngroup_m,nlat,nlatm,nspin,ntype,Numat,popats,pos,ps,rot_a,Rot_atom_spin,Spinorbite,Symmol,Simplified)

    Atom_comp(ia) = Ylm_comp

    if( magnetic ) then
      Axe_atom_clui(:,ia) = rot_a(:,3)
    else
      Atom_mag(ia) = .false.
    endif
    iopsym_atom(:,ia) = iopsyma(:)
    Rot_atom(:,:,ia) = rot_a(:,:)

  end do

  do ia = 1,natomp
    if( icheck > 1 ) write(3,130) ia
    ps(:) = Pos(:,ia)
    call Point_group_atom(Atom_c,Atom_m,Atom_with_axe,Nonsph,Axe_atom_clu,E_moment_axis, &
        iaabs,ia,ich,igroup,igrpt_p,igrpt0,iopsyma,iopsymr,itype,itypep,magnetic,mpirank0,natomp, &
        ngroup,ngroup_m,nlat,nlatm,nspin,ntype,Numat,popats,pos,ps,Rot_a,Rot_atom_spin,Spinorbite,Symmol,Simplified)

    Rot_atomp(:,:,ia) = rot_a(:,:)
  end do

! Atoms setting on the cluster axis
  do ia = 1,natome
    if( sum( abs( posi(1:2,ia) ) ) < eps10 ) then
      Atom_axe(ia) = .true.
    else
      Atom_axe(ia) = .false.
    endif
  end do

! Parameters of the FDM grid of points
  if( Green ) then
    rsort = min( rsorte, distai(natome) ) + epspos
  else
    it = itypei(natome)
    if( overad ) then
      rm = distai(natome) + rmt(it) + roverad
    else
      rm = distai(natome) + rmt(it) + Adimp
    endif
    rsort = max( rsorte, rm + Adimp )
  endif
  rsort = max( rsort, rmt(itypei(1)) + Adimp )
  rmax = ( rsort / Adimp + sqrt_2 * ( iord / 2 ) + epspos ) / cos( pi / 6 )
  nx = nint( rmax )

  if( icheck > 0 .or. istop == 1 ) then
    write(3,140) rsort*bohr
    write(3,150) nx
    write(3,160) natome, igrpt0, Ylm_comp, Atom_mag(0)
    if( Full_atom ) then
      write(3,'(/A)') '  Full atom mode: atomic basis corresponds to the local punctual group'
    else
      write(3,'(/A)') '  No full atom mode: atomic basis corresponds to the space group'
    endif
    write(3,165)
    do ipr = 3,9,3
      if( ipr == 3 .and. icheck == 0 ) cycle
      if( ipr == 9 .and. istop == 0 ) cycle

      if( Magnetic .or. Nonsph ) then
        write(ipr,170)
      else
        write(ipr,180)
      endif
      do ia = 1,natome
        it = itypei(ia)
        if( atom_mag(ia) ) then
          write(ipr,190) ia, Numat(it), it, igroupi(ia), iaprotoi(ia), iatomp(ia), posi(1:3,ia)*bohr, igrpt(ia), &
                ptgrname_int(igrpt(ia)), Ylm_comp, Atom_axe(ia), Atom_mag(ia), Axe_atom_clui(:,ia)
        else
          write(ipr,190) ia, Numat(it), it, igroupi(ia), iaprotoi(ia), iatomp(ia), posi(1:3,ia)*bohr, igrpt(ia), &
                ptgrname_int_nomag(igrpt(ia)), Ylm_comp, Atom_axe(ia), Atom_mag(ia)
        endif
      end do
    end do

    write(3,'(/A)') ' Atom rotation matrices :'
    na_ligne = 4
    do iga = 1,(natome-1)/na_ligne + 1
      na1 = na_ligne * iga - na_ligne + 1
      na2 = min(na1+na_ligne-1,natome)
      write(3,200) (ia, ia = na1,na2)
      do i = 1,3
        write(3,210) ( rot_atom(i,:,ia), ia = na1,na2)
      end do
    end do

    write(3,'(/A)') ' Atom  ia_eq  is_eq'
    do ia = 1,natome
      write(3,230) ia, ( ia_eq(i,ia), is_eq(i,ia), i = 1,nb_eq(ia) )
    end do

  endif

  if( icheck > 1 ) then
    write(3,'(/A)') ' Atom  ia_eq_inv'
    do ia = 1,natomeq
      write(3,230) ia, ia_eq_inv(ia)
    end do
    write(3,240) ( ia, ia = 1,natome )
    js = 0
    do is = 1,nopsm
      if( iopsymr(is) == 0 ) cycle
      js = js + 1
      write(3,250) is, ( ia_eq_sym(js,ia), ia = 1,natome )
    end do
  endif
  if( icheck > 2 ) then
    write(3,'(/A)') ' Atom Atom ia_rep, nb_rep_t'
    do ia = 1,natome
      do ib = 1,natome
      write(3,270) ia, ib, ( ia_rep(i,ia,ib), nb_rep_t(i,ia,ib), i = 1,nb_rpr(ia,ib) )
      end do
    end do
  endif

! The elaboration of the grid of points is done around all the atoms, defining an atomic zone inside a small muffin-tin sphere.
! These muffin-tin radius must be such that the interatomic space between the atoms must let the space for at least one FDM point.

  if( .not. Green ) then
    do ia1 = 1,natome
      it1 = itypei(ia1)
      do ia2 = ia1+1,natome
        it2 = itypei(ia2)
        v(:) = posi(:,ia1) - posi(:,ia2)
        dist = sqrt( sum( v(:)**2 ) )
        if( dist < rmt(it1) + rmt(it2) - Adimp .and. mpirank0 == 0) then
          call write_error
          do ipr = 3,9,3
            if( ipr == 3 .and. icheck == 0 ) cycle
            write(ipr,280) ia1, Numat(itypei(ia1)), igroupi(ia1), ia2, Numat(itypei(ia2)), igroupi(ia2), dist*bohr, &
                   rmt(it1)*bohr, rmt(it2)*bohr, Adimp*bohr
          end do
          stop
        endif
      end do
    end do
  endif

  if( iaabsi == 0 .and. mpirank0 == 0 ) then
    call write_error
    do ipr = 3,9,3
      if( ipr == 3 .and. icheck == 0 ) cycle
      write(ipr,290)
    end do
    stop
  endif

  if( istop == 1 ) stop

  return
  110 format(/' ---- Atom_selec --',100('-'))
  120 format(/' The absorbing atom is not inside the area of calculation !',// &
              ' When the calculation is performed on a cluster of atoms,',/ &
              ' it can be due to the calculation radius which is too small.'/ &
              ' So try again increasing the radius foth both the SCF and the Xanes.',// &
              ' Another solution is too check in the list of selected atoms below,' / &
              ' which takes into account the ponctual group symmetry, if the absorbing atom is in the list.',// &
              ' - if not, choose another atom in the list equivalent by symmetry of the space group, or of the ponctual group.',/ &
              ' The equivalent atoms can be found under "Symsite" in the bav file.',/ &
              ' Then you can use the keyword "Absorber", to choose the equivalent atom as absorber.' ,// &
              ' - if yes or if the previous method does not work, just change the order of the atoms, under "Crystal",', / &
              '   or "molecule", putting first the selected atom or at least before the one giving the problem.' /)
  130 format(/' Atome',i4,', with working cluster sub-point group')
  140 format(/'  Rsort = ',f8.3,' A')
  150 format('  nx =',i4)
  160 format('  natome =',i4,', igrpt =',i4,', Cluster_comp =',l2,', Cluster_mag =',l2)
  165 format(/'   ia: atom index in the symmetrized cluster',/ &
              '   it: atom type index', / &
              '   igr: atom index in the unit cell (for periodical system) or in the molecule', / &
              '   ipr: non equivalent atom index in the unit cell or in the molecule', / &
              '   iap: atom index in the cluster', / &
              '   posx posy posz: position in angstroem in the cluster in orthonormal coordinates',/ &
              '   PtGrName: atom ponctual group in the cluster, and igrpt its index in the code', / &
              '   Comp (complex harmonics) Axe (atom on rotation axis)  Mag (magnetic atom), F (false), T (true)' )
  170 format(/'  ia   Z  it  igr ipr iap     posx      posy      posz   igrpt PtGrName Comp  Axe  Mag',9x,'Axe_atom')
  180 format(/'  ia   Z  it  igr ipr iap     posx      posy      posz   igrpt PtGrName Comp  Axe  Mag')
  190 format(i4,2i4,i5,2i4,3f10.5,i5,6x,a8,l1,2l5,3f10.5)
  200 format(/'  Atom :',4x,i4,3(21x,i3))
  210 format(4(3x,3f7.3))
  230 format(i4,3x,48(1x,2i4))
  240 format(/' ia_sym_eq (index of the representative atom)', /' Sym \ ia ',1x,48i4)
  250 format(i4,7x,48i4)
  270 format(i4,i5,3x,96i4)
  280 format(//' When using the FDM mode, the minimum distance between the atoms is the sum',/ &
               ' of their Rmt radius plus the interpoint distance.',// &
               '   The atoms',i4,' (Z =',i3,', igr =',i4,') and',i4, ' (Z =',i3,', igr =',i4,') are too close.',// &
               '   Their interatomic distance is',f8.5,' Angstroem.',/ &
               '   Their Rmt radius are ',f8.5,' and ',f8.5,' Angstroem.',/ &
               '   The interpoint distance is ',f8.5,' Angstroem.')
  290 format(//' The absorbing atom is outside the calculation sphere !' //)
end

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

! Calculation of the couples of atoms where one calculates the Crystal Orbital Overlap

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

  use declarations
  implicit none

  integer:: i, ia, icheck, ipr, iprabs_nonexc, j, n_atom_coop, nab_coop, nab_coop_ev, natome, neqm, n_atom_proto, ntype

  integer, dimension(0:ntype):: Numat
  integer, dimension(n_atom_coop):: ia_coop, igr_coop
  integer, dimension(natome):: iaprotoi, igroupi, itypei
  integer, dimension(0:n_atom_proto):: ngreq
  integer, dimension(0:n_atom_proto,neqm):: igreq

  character(len=Length_name):: nomfich_s

  logical:: COOP

  real(kind=db), dimension(2):: Dist_coop
  real(kind=db), dimension(0:n_atom_proto):: Rmtg
  real(kind=db), dimension(3,natome):: Posi

  nab_coop = 0
  if( .not. COOP ) return

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

  do j = 1,n_atom_coop
    boucle_ipr: do ipr = 1,n_atom_proto
      do i = 1,ngreq(ipr)
        if( igreq(ipr,i) == igr_coop(j) ) exit boucle_ipr
      end do
    end do boucle_ipr
    ia_coop(j) = 100000
    do i = 1,ngreq(ipr)
      do ia = 1,natome
        if( igroupi(ia) == igreq(ipr,i) ) then
          ia_coop(j) = min( ia_coop(j), ia )
          exit
        endif
      end do
    end do
    if( ia_coop(j) > natome ) ia_coop(j) = 0
  end do

  if( n_atom_coop > 0 .and. icheck > 0 ) then
    write(3,120)
    do i = 1,n_atom_coop
      if( ia_coop(i) == 0 ) cycle
      write(3,'(2i5,3f10.5)') igr_coop(i), ia_coop(i), Posi(:,ia_coop(i))*bohr
    end do
    write(3,130)
  endif

  nab_coop = nab_coop_ev(Dist_coop,ia_coop,iaprotoi,icheck,igroupi,iprabs_nonexc,itypei,n_atom_coop,n_atom_proto,natome, &
                         nomfich_s,ntype,Numat,Posi,Rmtg)

  return
  110 format(/' ---- Atom_coop_selec --',100('-'))
  120 format(/' Equivalence between COOP atom index in the indata file and index in the output file names:', // &
              '  igr   ia       Position in cluster')
  130 format(/'   igr: input index corresponding to the atom index in the unit cell as seen under Symsite', / &
              '   ia: ouput index corresponding to the atom index in the symmetrized cluster as seen under Atom_selec', / &
              '       an equivalent atom closer to the center of the cluster can have been chosen')
end

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

! Calculation of the number of couple of atoms where one calculate the Crystal Orbital Overlap

function nab_coop_ev(Dist_coop,ia_coop,iaprotoi,icheck,igroupi,iprabs_nonexc,itypei,n_atom_coop,n_atom_proto,natome, &
                     nomfich_s,ntype,Numat,Posi,Rmtg)

  use declarations
  implicit none

  integer:: ia, iab, ib, icheck, ipra, ipraa, iprabs_nonexc, iprb, iprbb, j, L, Length, n_atom_coop, nab_coop_ev, natome, &
            n_atom_proto, ntype

  integer, dimension(0:ntype):: Numat
  integer, dimension(n_atom_coop):: ia_coop
  integer, dimension(natome):: iaprotoi, igroupi, itypei

  character(len=1):: Mark_exc_a, Mark_exc_b
  character(len=Length_name):: File_coop_ext, nomfich_s

  real(kind=db):: Dist
  real(kind=db), dimension(2):: Dist_coop
  real(kind=db), dimension(0:n_atom_proto):: Rmtg
  real(kind=db), dimension(3,natome):: Posi

  if( icheck > 0 ) then
    if( Dist_coop(1) > eps10 ) &
      write(3,'(/a62,f10.5,a2)') ' The minimum interatomic distance for the COOP calculation is:', Dist_coop(1)*bohr,' A'
    if( Dist_coop(2) > eps10 ) then
      write(3,'(a62,f10.5,a2)') ' The maximum interatomic distance for the COOP calculation is:', Dist_coop(2)*bohr,' A'
    else
      write(3,'(A)') ' The maximum interatomic distance for the COOP calculation is the sum of the atomic radii'
    endif
  endif

  iab = 0

  do ia = 1,natome
    ipra = iaprotoi( ia )

    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 )
      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
      if( ipra == 0 ) then
        ipraa = iprabs_nonexc
        Mark_exc_a = '*'
      else
        ipraa = ipra
        Mark_exc_a = ' '
      endif
      if( iprb == 0 ) then
        iprbb = iprabs_nonexc
        Mark_exc_b = '*'
      else
        iprbb = iprb
        Mark_exc_b = ' '
      endif

      File_coop_ext = ' '
      Length = len_trim(nomfich_s)
      do L = Length,1,-1
        if( nomfich_s(L:L) == '/' .or. nomfich_s(L:L) == '\' ) exit
      end do
      L = L + 1
      File_coop_ext(1:Length-L+1) = nomfich_s(L:Length+1)
      Length = len_trim(File_coop_ext)
      File_coop_ext(Length+1:Length+5) = '_coop'
      Length = Length + 6
      File_coop_ext(Length:Length) = '_'
      call ad_number(ia,File_coop_ext,Length_name)
      Length = len_trim(File_coop_ext) + 1
      File_coop_ext(Length:Length) = '_'
      call ad_number(ib,File_coop_ext,Length_name)

      if( icheck > 0 ) then
        if( iab == 1 ) write(3,100)
        write(3,110) ia, igroupi(ia), ipraa, Numat(itypei(ia)), Mark_exc_a, Posi(:,ia)*bohr, &
                     ib, igroupi(ib), iprbb, Numat(itypei(ib)), Mark_exc_b, Posi(:,ib)*bohr, Dist*bohr, File_coop_ext
      endif
    end do
  end do

  nab_coop_ev = iab

  if( iab == 0 .and. icheck > 0 ) write(3,'(/A)') ' No couple of atoms found'

  return
  100 format(/' List of the couples of atoms:', // &
             '   ia  igr  ipr    Z        Position in cluster         ia  igr  ipr    Z        Position in cluster', &
             '        Distance      File_coop_name')
  110 format(4i5,a1,3f10.5,2x,4i5,a1,3f10.5,f12.5,3x,A)
end

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

! Search of the equivalent point inside the calculation area taking into account the symmetries of the cluster.

subroutine posequiv(mpirank0,pos,iopsym,isym,igrpt_nomag)

  use declarations
  implicit none

  integer:: ipr, is, igrpt_nomag, isym, isym_inv, k, k2, k3, mpirank0

  integer, dimension(nopsm):: iopsym

  logical:: d6, d6p, dpn12, dp13, d3p12, d3pn12, Found, gdiag, symok
  logical, dimension(3):: pnul, ppn, ppos
  logical, dimension(2):: p3nul, p3pn, p3pos

  real(kind=db):: a3, f, r3
  real(kind=db), dimension(3):: p, pos, v
  real(kind=db), dimension(3,3):: matopsym

  isym = 1

  do k = 1,3
    pnul(k) = abs(pos(k)) < epspos
  end do
  if( pnul(1) .and. pnul(2) .and. pnul(3) ) return

  boucle: do is = 1,nopsm
    if( iopsym(is) == 0 ) cycle

    call opsym(is,matopsym)
    v = matmul( matopsym, pos )
    do k = 1,3
      pnul(k) = abs(v(k)) < epspos
      ppos(k) = v(k) > epspos
      ppn(k) = ppos(k) .or. pnul(k)
    end do
    dpn12 = v(1) > v(2) - epspos
    dp13 = v(1) > v(3) + epspos
    gdiag = ppn(1) .and. ( abs(v(1)-v(2)) < epspos ) .and. ( abs(v(1)-v(3)) < epspos )

! Case of trigo and hexagonal groups

    d3p12 = .false.; d3pn12 = .false.; d6 = .false.; d6p = .false.
    if( igrpt_nomag > 15 .and. igrpt_nomag < 28 ) then
      r3 = sqrt(3._db)
      f = 1 / r3
      p(1) = v(1) + f * v(2)
      p(2) = 2 * f * v(2)
      p(3) = v(3)
      do k = 1,2
        p3nul(k) = abs(p(k)) < epspos
        p3pos(k) = p(k) > epspos
        p3pn(k) = p3pos(k) .or. p3nul(k)
      end do
      d3p12 = (p(1) > p(2) + epspos) .or. ( pnul(1) .and. pnul(2) )
      d3pn12 = p(1) > p(2) - epspos
      d6 = v(1) > abs( r3 * v(2) ) - epspos
      d6p = ( ( v(1) > - sqrt(3._db) * v(2) + epspos ) .and. (  v(1) > r3 * v(2) - epspos ) ) .or. &
             ( pnul(1) .and. pnul(2) )
    endif

    Found = .false.

    select case(igrpt_nomag)

      case(1)
        Found = .true.

      case(2)
        if( ppos(3) .or. ( pnul(3) .and.  ppos(1) ) .or. ( pnul(3) .and.  pnul(1) .and. ppn(2) ) ) Found = .true.

      case(3)
        if( ppn(3) ) Found = .true.

      case(4)
        if( ppos(1) .or. ( pnul(1) .and.  ppn(2) ) ) Found = .true.

      case(5)
        if( ppn(3) .and. ( ppos(1) .or. ( pnul(1) .and.  ppn(2) ) ) ) Found = .true.

      case(6)
        if( ppn(1) .and. ppn(2) ) Found = .true.

      case(7)
        if( ( ppos(1) .and. ppos(2) ) .or. ( pnul(1) .and. ppn(2) .and. ppn(3) ) .or. &
            ( pnul(2) .and. ppn(1) .and. ppn(3) ) ) Found = .true.

      case(8)
        if( ppn(1) .and. ppn(2) .and. ppn(3) ) Found = .true.

      case(9)
        if( ( ppos(1) .and. ppn(2) ) .or. ( pnul(1) .and. pnul(2) ) ) Found = .true.

      case(10)
        if( ( ppos(1) .and. ppn(2) ) .or. ( pnul(1) .and. pnul(2) .and. ppn(3) ) ) Found = .true.

      case(11)
        if( ( ppn(3) .and. ppos(1) .and. ppn(2) ) .or. ( ppn(3) .and. pnul(1) .and. pnul(2) ) ) Found = .true.

      case(12)
        if( ppn(2) .and. dpn12 ) Found = .true.

      case(13)
        if( ( ppos(2) .and. dpn12 ) .or. ( pnul(2) .and. ppn(1) .and. ppn(3) ) ) Found = .true.

      case(14)
        if( ( ppos(2) .and. dpn12 ) .or. ( pnul(2) .and. dpn12  .and. ppn(3) ) ) Found = .true.

      case(15)
        if( ppn(2) .and. dpn12  .and. ppn(3)) Found = .true.

      case(16)  ! C3
        if( ( p3pos(1) .and. p3pn(2) ) .or. ( p3nul(1) .and. p3nul(2) ) ) Found = .true.

      case(17)  ! S6
        if( ( p3pos(1) .and. p3pn(2) .and. ppos(3) ) .or. ( p3nul(1) .and. p3nul(2).and. ppn(3) ) .or. &
            ( d3p12 .and. p3pn(1) .and. p3pn(2) .and. pnul(3) ) ) Found = .true.

      case(18)  ! C3v
        if( d6 ) Found = .true.

      case(19)
        if( ( (  ( p3pos(1) .and. p3pn(2) ) .or. ( pnul(1) .and. pnul(2) )  ) .and. ppos(3) )  .or. &
           ( pnul(3) .and. p3pos(1) .and. d3pn12   )) Found = .true.

      case(20)
        if( d6p ) Found = .true.

      case(21)  ! C3h
        if( ( p3pos(1) .and. p3pn(2) .and. ppn(3) ) .or. ( p3nul(1) .and. p3nul(2).and. ppn(3) ) ) Found = .true.

      case(22)   ! C6
        if( p3pn(1) .and. p3pn(2) .and. d3p12 ) Found = .true.

      case(23)   ! C6h
        if( p3pn(1) .and. p3pn(2) .and. d3p12 .and. ppn(3) ) Found = .true.

      case(24)
        if( d6 .and. ppn(3) ) Found = .true.

      case(25)
        if( d6p .and. ppn(2) ) Found = .true.

      case(26)
        if( ( ppn(2) .and. d3p12 .and. ppos(3) ).or. ( d6 .and. ppn(2) .and. pnul(3) ) ) Found = .true.

      case(27)
        if( d6 .and. ppn(2) .and. ppn(3) ) Found = .true.

      case(28)
        a3 = abs( v(3) )
        if( ppn(2) .and. (( dpn12 .and. v(1) > a3+epspos ) .or. ( abs(v(1)-v(2)) < epspos .and. abs(v(1)-a3) < epspos ) )) &
                                                      Found = .true.

      case(29) ! m3
        if( ppn(2) .and. ppn(3) .and. ( ( dpn12 .and. dp13 ) .or. gdiag ) ) Found = .true.

      case(30) ! -43m
        a3 = abs( v(3) )
        if( dpn12 .and. v(2) > a3-epspos ) Found = .true.

      case(31) ! 432
        if( ( ppn(3) .and. ppos(2) .and. dpn12 .and. dp13 ) .or. ( ppn(1) .and. pnul(2) .and. pnul(3) ) &
             .or. gdiag ) Found = .true.

      case(32) ! m3m
        a3 = abs( v(3) )
        if( ppn(3) .and. ( dpn12 .and. v(2) > a3-epspos ) ) Found = .true.

      case(35)
        if( ppn(1) .and. ( ppos(3) .or. ( pnul(3) .and. ppn(2) ) ) ) Found = .true.

      case default

        symok = .false.

        select case(is)

          case(10)        ! Axe 2 diagonal (110)
            if( ppos(3) .or. (pnul(3) .and. dpn12) ) symok = .true.

          case(11)        ! Axe 2 diagonal (1-10)
            if( ppos(3) .or. ( pnul(3) .and. pos(2) < - pos(1) + epspos ) ) symok = .true.

          case(22,23,24)  ! Axes 2
            k = is - 21
            k2 = 1 + mod(k,3)
            k3 = 1 + mod(k+1,3)
            if( ppos(k2) .or. ( pnul(k2) .and. ppn(k3) ) ) symok = .true.

          case(25)        ! Centro-symmetry
            if( ppos(3) .or. ( pnul(3) .and.  ppos(1) ) .or. ( pnul(3) .and.  pnul(1) .and. ppn(2) ) ) symok = .true.

          case(40,41,42)  ! Main plane symmetries
            k = is - 39
            if( ppn(k) ) symok = .true.

          case(45)        ! Diagonal plane
            if( dpn12 ) symok = .true.

          case(48)        ! Diagonal plane
            if( pos(2) < -pos(1)+epspos ) symok = .true.

        end select

      if( symok ) pos = v

    end select

    if( Found ) exit boucle

  end do boucle

  if( is > nopsm .and. mpirank0 == 0 ) then
    call write_error
    do ipr = 6,9,3
      write(ipr,120) igrpt_nomag, pos(1:3)
      call write_iopsym(iopsym,ipr)
    end do
    stop
  endif

  pos = v

  isym = iopsym(is) * isym_inv(is)

  return
  120 format(/' Problem in posequiv : symmetry wrongly programmed !', / &
              ' igrpt_nomag =',i4,', pos =',3f7.3,//' iopsym =')
end

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

! Determination of the inverse symmetry operation

function isym_inv(is)

  implicit none

  integer:: is, isym_inv

  select case(is)
    case(2,4,6,8,32,34,36,38,49,51,53,55)
      isym_inv = is + 1
    case(3,5,7,9,33,35,37,39,50,52,54,56)
      isym_inv = is - 1
    case(16,17,18,26,27,28)
      isym_inv = is + 3
    case(19,20,21,29,30,31)
      isym_inv = is - 3
    case default
      isym_inv = is
  end select

  return
end

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

subroutine Point_group_atom(Ylm_comp,Atom_mag,Atom_with_axe,Nonsph,Axe_atom_clu,E_moment_axis, &
          iaabs,iap,icheck,igroup,igrpt,igrpt0,iopsym,iopsymr,itype,itypep,magnetic,mpirank0,natomp, &
          ngroup,ngroup_m,nlat,nlatm,nspin,ntype,Numat,popats,pos,posi,Rot_atom,Rot_atom_spin,Spinorbite,Symmol,Simplified)

  use declarations
  implicit none

  integer:: i, icheck, iaabs, iap, ib, igrpt, igrpt_nomag, igrpt0, mpirank0, natomp, ngroup, ngroup_m, nlatm, nspin, ntype

  integer, dimension(natomp):: igroup, itypep
  integer, dimension(nopsm):: iopsym, iopsymr, irotiops
  integer, dimension(ngroup):: itype
  integer, dimension(0:ntype):: nlat, Numat

  logical:: Atom_comp_cal, Atom_mag, Atom_mag_cal, Magnetic, Nonsph, Simplified, Spinorbite, Symmol, Ylm_comp
  logical, dimension(0:ngroup_m):: Atom_with_axe

  real(kind=db), dimension(3):: E_moment_axis, Posi, v
  real(kind=db), dimension(3,3):: Rot_atom, Rot_tem, Rot_un
  real(kind=db), dimension(3,natomp):: Axe_atom_clu, Axe_atom_clut, p, pos
  real(kind=db), dimension(3,3,natomp):: Rot_atom_spin
  real(kind=db), dimension(ngroup,nlatm,nspin):: popats

  Rot_un(:,:) = 0._db
  do i = 1,3
    Rot_un(i,i) = 1._db
  end do

  Rot_atom(:,:) = Rot_un(:,:)
  Axe_atom_clut(:,1:natomp) = Axe_atom_clu(:,1:natomp)

  if( abs( posi(1) ) < eps10 .and. abs( posi(2) ) < eps10 .and. abs( posi(3) ) < eps10 ) then

    iopsym(:) = iopsymr(:)
    igrpt = igrpt0

  else

    do ib = 1,natomp
      p(:,ib) = pos(:,ib) - posi(:)
    end do

! Determination of the symmetries of the atom site ponctual group (iopsymc)
    do i = 1,2

      call Sym_cluster( Atom_with_axe, Axe_atom_clu, E_moment_axis, iaabs, igroup, iopsym, itype, itypep, &
             natomp, ngroup, ngroup_m, nlat, nlatm, nspin, ntype, Numat, popats, p, Symmol )

! The atom site ponctual group must be a subgroup of the one of the cluster
      Rot_tem = Transpose( Rot_atom )
      call iop_rot(icheck,irotiops,Rot_tem)
      where( irotiops /= 0 ) irotiops = iopsymr(irotiops)
      where( irotiops == 0 ) iopsym = 0

      if( .not. Simplified ) call cluster_rot(iopsym,rot_tem)

      if( sum( abs( Rot_tem(:,:) - Rot_un(:,:) ) ) < eps10  ) exit

      Rot_atom(:,:) = matmul( Rot_tem, Rot_atom )

      do ib = 1,natomp
        v(:) = p(:,ib)
        v = matmul( Rot_tem, v )
        p(:,ib) = v(:)
      end do
      if( Magnetic .or. Nonsph ) then
        do ib = 1,natomp
          v(:) = Axe_atom_clut(:,ib)
          v = matmul( rot_tem, v )
          Axe_atom_clut(:,ib) = v(:)
        end do
      endif

    end do

    if( Simplified ) then
      call numgrpt_s(iopsym,igrpt,igrpt_nomag,mpirank0,.false.)
    else
      call numgrpt(iopsym,igrpt,igrpt_nomag,mpirank0,.false.)
    endif

  endif

  if( Magnetic ) then
    Atom_mag = Atom_mag_cal(igrpt)
  else
    Atom_mag = .false.
  endif

  if( Spinorbite .and. Magnetic ) then

    Rot_tem(:,:) = Rot_atom_spin(:,:,iap)

    call iop_rot(icheck,irotiops,rot_tem)
    where( irotiops /= 0 ) iopsym = iopsym(irotiops)

  endif

  Ylm_comp = Atom_comp_cal(igrpt)

  if( icheck > 1 ) then
    if( Atom_mag ) then
      write(3,110) igrpt
    else
      write(3,120) igrpt
    endif
    write(3,130)
    call write_iopsym(iopsym,3)
    write(3,150) rot_atom(:,:)
  endif

  return
  110 format(/' Local point group number',i3,', magnetic atom.')
  120 format(/' Local point group number',i3,', non-magnetic atom.')
  130 format(/' iopsym =')
  150 format(/' Atomic rotation matrix :',3(/,3f10.5))
end

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

! For some magnetic groups, the central atom cannot be magnetic

function Atom_mag_cal(igrpt)

  implicit none

  integer:: igrpt
  logical:: Atom_mag_cal

  select case(igrpt)
    case(1,2,3,4,5,9,10,11,16,17,21,22,23,35,39,40,41,44,45,46,48, 53,58,60,67,70,73,78,84)
      Atom_mag_cal = .true.
    case default
      Atom_mag_cal = .false.
  end select

  return
end

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

! Pour certains groupes magnetique, L'atome central ne peut pas etre magnetique

subroutine Axe_mag_cal(igrpt,Axe)

  use declarations
  implicit none

  integer:: igrpt

  real(kind=db), dimension(3):: Axe

  Axe(1:3) = 0._db

  select case(igrpt)
    case(34,35,41)
      Axe(2) = 1._db
    case default
      Axe(3) = 1._db
  end select

  return
end

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

! Define if the ponctual group needs complex Y(L,m)

function Atom_comp_cal(igrpt)

  integer:: igrpt

  logical:: Atom_comp_cal

  select case(igrpt)
    case(9,10,11,16,17,21,22,23,47,51,52,55,56,57,68,69,75,76,77)
      Atom_comp_cal = .true.
    case default
      Atom_comp_cal = .false.
  end select

  return
end

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

! Calculation of the number of points of the FDM grid

subroutine nbpoint( Adimp, Base_hexa, D_max_pot, Green, iaabs, igrpt_nomag, iopsymr, iord, Mag_axis_free, Moy_loc, &
               mpirank0, natomp, npoint, npso, nvois, nx, pos, Rot_Spinor, Rsort )

  use declarations
  implicit none

  integer:: ia, iaabs, igrpt_nomag, iord, isym, ix, iy, iz, mpirank0, natomp, npoint, npso, nvois, nx
  integer, dimension(nopsm):: iopsymr

  logical:: Base_hexa, Green, Mag_axis_free, Moy_loc

  real(kind=db):: Adimp, d, D_max_pot, Dist, Dist_max, Dista, dcour, f, Rmax, Rsort
  real(kind=db), dimension(3):: p, v, V1, w
  real(kind=db), dimension(3,3):: Rot_Spinor
  real(kind=db), dimension(3,natomp):: pos

  Dist_max = D_max_pot / Adimp + eps10
  f = sqrt(3._db) / 2

  if( Moy_loc ) then
    dcour = rsort
    do ia = 1,natomp
      if( ia == iaabs ) cycle
      p(:) = pos(:,ia) - pos(:,iaabs)
      d = sqrt( sum( p(:)**2 ) )
      dcour = min( dcour, d )
    end do
    rmax = min(dcour,rsort) / Adimp + epspos
  else
    rmax = rsort / Adimp + sqrt_2 * iord / 2 + epspos
  endif

  p(:) = pos(:,iaabs) / Adimp
  npoint = 0
  npso = 0
  do ix = -nx,nx
    do iy = -nx,nx
      if( Base_hexa ) then
        v(1) = ix - 0.5_db * iy
        v(2) = f * iy
      else
        v(1) = 1._db * ix
        v(2) = 1._db * iy
      endif
      do iz = -nx,nx

        v(3) = 1._db * iz
        if( Mag_axis_free ) then
          V1 = Matmul( Rot_Spinor, V )
        else
          V1(:) = V(:)
        endif

        if( Moy_loc ) then
          w(:) = V1(:) - p(:)
          dist = sqrt( sum( w(:)**2 ) )
        else
          dist = sqrt( sum( V1(:)**2 ) )
        endif
        if( dist > rmax ) cycle
        w(:) = V1(:)
        call posequiv(mpirank0,w,iopsymr,isym,igrpt_nomag)
        w(:) = abs( V1(:) - w(:) )
        if( w(1) > epspos .or. w(2) > epspos .or. w(3) > epspos ) cycle
        if( Green .and. .not. Moy_loc ) then
! Pour la moyenne du potentiel, on ne prend pas les points loin de tout atome
          do ia = 1,natomp
            w(:) = pos(:,ia) / Adimp - V1(:)
            dista = sqrt( sum( w(:)**2 ) )
            if( dista < Dist_max ) exit
          end do
          if( ia > natomp ) cycle
        endif
        npso = npso + 1
        if( dist*Adimp <= Rsort + epspos ) npoint = npoint + 1
     end do
    end do
  end do

  if( Base_hexa ) then
    nvois = 4 * iord
  else
    nvois = 3 * iord
  endif

  return
end

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

! Elaboration of the grid of points

subroutine FDM_grid( Adimp, Base_hexa, D_max_pot, Green, iaabs, icheck, &
               igrpt_nomag, indice, iopsymr, iord, itypei, Mag_axis_free, Moy_loc, mpirank0, mpres, natome, natomp, nim, &
               npoint, npr, npso, npsom, ntype, numia, nx, Rot_Spinor, pos, posi, Rmt, Rsort, rvol, xyz )

  use declarations
  implicit none

  integer:: i, ia, iaabs, icheck, igrpt_nomag, indi1, indi2, indi3, iord, ipr, istop, isym, it, ix, ix1, iy, iy1, iz, iz1, j, &
            mpirank0, natome, natomp, nim, npoint, npr, npso, npsom, ntype, nx

  integer, dimension(natome):: itypei
  integer, dimension(nopsm):: iopsymr
  integer, dimension(3,npsom):: indice
  integer, dimension(npsom):: numia
  integer, dimension(-nx:nx,-nx:nx,-nx:nx):: mpres

  logical:: Base_hexa, Green, Mag_axis_free, Moy_loc

  real(kind=db):: Adimp, d, D_max_pot, Dist, Dist_max, Dista, dcour, df3, dr, f, f3, Rmax, Rsort, Rvmax, xyzij

  real(kind=db), dimension(3):: p, x, v, V1, w, w1
  real(kind=db), dimension(3,3):: Rot_Spinor

  real(kind=db), dimension(nim):: rvol
  real(kind=db), dimension(0:ntype) :: rmt
  real(kind=db), dimension(3,natome):: posi
  real(kind=db), dimension(3,natomp):: pos
  real(kind=db), dimension(4,npsom):: xyz

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

  Dist_max = D_max_pot / Adimp + eps10

  mpres(:,:,:) = 0
  f = sqrt(3._db) / 2

  if( Moy_loc ) then
    dcour = rsort
    do ia = 1,natomp
      if( ia == iaabs ) cycle
      p(:) = pos(:,ia) - pos(:,iaabs)
      d = sqrt( sum( p(:)**2 ) )
      dcour = min( dcour, d )
    end do
    rmax = min(dcour,rsort) / Adimp + epspos
  else
    rmax = rsort / Adimp + sqrt_2 * iord / 2 + epspos
  endif

  p(:) = pos(:,iaabs) / Adimp
  i = 0

  do ix = -nx,nx
    do iy = -nx,nx
      if( Base_hexa ) then
        v(1) = ix - 0.5_db * iy
        v(2) = f * iy
      else
        v(1) = 1._db * ix
        v(2) = 1._db * iy
      endif

      do iz = -nx,nx
        V(3) = 1._db * iz

        if( Mag_axis_free ) then
          V1 = Matmul( Rot_Spinor, V )
        else
          V1(:) = V(:)
        endif
        if( Moy_loc ) then
          w(:) = V1(:) - p(:)
          dist = sqrt( sum( w(:)**2 ) )
        else
          dist = sqrt( sum( V1(:)**2 ) )
        endif

        if( dist > Rmax ) cycle

        w(:) = V1(:)
        call posequiv(mpirank0,w,iopsymr,isym,igrpt_nomag)
        if( abs(V1(1)-w(1)) > epspos .or. abs(V1(2)-w(2)) > epspos .or. abs(V1(3)-w(3)) > epspos ) cycle
        if( Green .and. .not. Moy_loc ) then
! Pour la moyenne du potentiel, on ne prend pas les points loin de tout atome
          do ia = 1,natomp
            w(:) = pos(:,ia) / Adimp - V1(:)
            dista = sqrt( sum( w(:)**2 ) )
            if( dista < Dist_max ) exit
          end do

          if( ia > natomp ) cycle
        endif
        i = i + 1
        indice(1,i) = ix
        indice(2,i) = iy
        indice(3,i) = iz
        xyz(4,i) = Adimp * Dist

      end do
    end do
  end do
  npso = i

! Ordering versus distance from the center of the cluster
  do i = 1,npso
    do j = i+1,npso
      if( xyz(4,i) < xyz(4,j) + epspos ) cycle
      xyzij = xyz(4,i)
      xyz(4,i) = xyz(4,j)
      xyz(4,j) = xyzij
      indi1 = indice(1,i)
      indi2 = indice(2,i)
      indi3 = indice(3,i)
      indice(1:3,i) = indice(1:3,j)
      indice(1,j) = indi1
      indice(2,j) = indi2
      indice(3,j) = indi3
    end do
  end do

  do i = 1,npso
    if( base_hexa ) then
      xyz(1,i) = ( indice(1,i) - 0.5_db * indice(2,i) ) * Adimp
      xyz(2,i) = f * indice(2,i) * Adimp
      xyz(3,i) = indice(3,i) * Adimp
    else
      xyz(1:3,i) = indice(1:3,i) * Adimp
    endif
  end do

  if( Mag_axis_free ) then
    do i = 1,npso
      V(1:3) = xyz(1:3,i)
      V = Matmul( Rot_Spinor, V )
      xyz(1:3,i) = V(1:3)
    end do
  endif

! Number of points inside the area of calculation
  do i = 1,npso
    if( xyz(4,i) > rsort + epspos ) exit
  end do
  npoint = i - 1

! We avoid a last point with Ylm = 0 (for mat routine and irregular solution calculation)

  i = npoint
  if( indice(1,i) == 0 .or. indice(2,i) == 0 .or. indice(3,i) == 0 &
    .or. indice(1,i) == indice(2,i) .or. indice(1,i) == indice(3,i) .or. indice(2,i) == indice(3,i) &
    .or. indice(1,i) == - indice(2,i) .or. indice(1,i) == - indice(3,i) .or. indice(2,i) == - indice(3,i) ) then

    do i = npoint-1,1,-1
      if( indice(1,i) == 0 .or. indice(2,i) == 0 .or. indice(3,i) == 0 &
        .or. indice(1,i) == indice(2,i) .or. indice(1,i) == indice(3,i) .or. indice(2,i) == indice(3,i) &
        .or. indice(1,i) == - indice(2,i) .or. indice(1,i) == - indice(3,i) .or. indice(2,i) == - indice(3,i) ) cycle

      do j = 1,4
        xyzij = xyz(j,i)
        xyz(j,i) = xyz(j,npoint)
        xyz(j,npoint) = xyzij
      end do
      do j = 1,3
        indi1 = indice(j,i)
        indice(j,i) = indice(j,npoint)
        indice(j,npoint) = indi1
      end do

      exit
    end do

  endif

  numia(1:npoint) = 0
  if( npoint < npso ) numia(npoint+1:npso) = -2

  do i = 1,npso
    mpres(indice(1,i),indice(2,i),indice(3,i)) = i
  end do

! List of points inside an atom
  do ia = 1,natome
    it = itypei(ia)
    p(1:3) = posi(1:3,ia)
    do i = 1,npoint
      x(1:3) = xyz(1:3,i)
      call posrel(iopsymr,x,p,v,dr,isym)
      if( dr < rmt(it) + epspos ) numia(i) = ia
    end do
  end do
  npr = npoint
  do i = 1,npoint
    if( numia(i) /= 0 ) npr = npr - 1
  end do

! FDM points volume

  f3 = 1 / sqrt(3._db)
  df3 = 2 * f3
  istop = 0
  p(:) = pos(:,iaabs) / Adimp
  rvol(:) = 0._db
  boucle_ix: do ix = -nx,nx
    do iy = -nx,nx
      if( base_hexa ) then
        v(1) = ix - 0.5_db * iy
        v(2) = f * iy
      else
        v(1) = 1._db * ix
        v(2) = 1._db * iy
      endif
      do iz = -nx,nx

        v(3) = 1._db * iz
        if( Mag_axis_free ) then
          V1 = Matmul( Rot_Spinor, V )
        else
          V1(:) = V(:)
        endif

        if( Moy_loc ) then
          w(:) = V1(:) - p(:)
          dist = sqrt( sum( w(:)**2 ) )
        else
          dist = sqrt( sum( V1(:)**2 ) )
        endif
        if( dist > Rmax ) cycle
        w(:) = V1(:)
        call posequiv(mpirank0,w,iopsymr,isym,igrpt_nomag)

        if( Green .and. .not. Moy_loc ) then
! Pour la moyenne du potentiel, on ne prend pas les points loin de tout atome
          do ia = 1,natomp
            w1(:) = pos(:,ia) / Adimp - w(:)
            dista = sqrt( sum( w1(:)**2 ) )
            if( Dista < Dist_max ) exit
          end do
          if( ia > natomp ) cycle
        endif

        if( Mag_axis_free ) W = Matmul( Transpose( Rot_Spinor ), W )

        if( base_hexa ) then
          ix1 = nint( w(1) + f3 * w(2) )
          iy1 = nint( df3 * w(2) )
        else
          ix1 = nint( w(1) )
          iy1 = nint( w(2) )
        endif
        iz1 = nint( w(3) )
        i = mpres(ix1,iy1,iz1)
        if( i > npoint ) cycle
        if( i == 0 .and. mpirank0 == 0 ) then
          call write_error
          do ipr = 3,9,3
            if( ipr == 3 .and. icheck == 0 ) cycle
            write(ipr,130) ix, iy, iz, ix1, iy1, iz1
          end do
          istop = 1
          exit boucle_ix
        endif
        rvol(i) = rvol(i) + 1
      end do
    end do
  end do boucle_ix

  if( istop == 0 ) then
    rvmax = 1._db
    do i = 1,npoint
      Rvmax = max(rvmax,rvol(i))
    end do
    rvol(1:npoint) = rvol(1:npoint) / Rvmax
  endif

  if( icheck > 0 ) then
    write(3,150) npr, npoint, npso
    write(3,160) natome
  endif
  if( icheck > 1 .or. istop == 1 ) then
    if( Base_hexa ) then
      write(3,170)
    else
      write(3,175)
    endif
    do i = 1,npoint
      write(3,180) i, indice(:,i), numia(i), xyz(1:4,i)*bohr, rvol(i)
    end do
    do i = npoint+1,npso
      write(3,180) i, indice(:,i), numia(i), xyz(1:4,i)*bohr
    end do
    if( istop == 1 ) stop
  endif

  return
  100 format(/' ---- FDM_grid -------',100('-'))
  130 format(//' For ix, iy, iz =',3i3,', equivalent point in ix1, iy1, iz1 =',3i3,/' not found in FDM_grid !'/ )
  150 format(/' npr =',i6,', npoint =',i6,', npso =',i6)
  160 format(' natome =',i4)
  170 format(/ ' Point index along hexagonal mesh',// '    i  ix  iy  iz  ia   xval    yval    zval    rval    rvol')
  175 format(/'    i  ix  iy  iz  ia    xval    yval    zval    rval    rvol')
  180 format(i5,4i4,5f8.4)
end

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

subroutine Posrel(iopsymr,x,a,u,dr,isym)

  use declarations
  implicit none

  integer:: is, isi, isym

  integer, dimension(nopsm):: iopsymr

  real(kind=db):: dr, dr1

  real(kind=db), dimension(3):: a, b, x, u, v, w
  real(kind=db), dimension(3,3):: matopsym

  u(:) = x(:) - a(:)
  dr = sqrt( sum( u(:)**2 ) )
  isym = 1

  do is = 2,nopsm
    select case(is)
      case(2,4,6,8,32,34,36,38,49,51,53,55)
        isi = is + 1
      case(3,5,7,9,33,35,37,39,50,52,54,56)
        isi = is - 1
      case(16,17,18,26,27,28)
        isi = is + 3
      case(19,20,21,29,30,31)
        isi = is - 3
      case default
        isi = is
    end select
    if( iopsymr(is) == 0 ) cycle
    call opsym(is,matopsym)
    b = matmul( matopsym, a )
    w(1:3) = x(1:3) - b(1:3)
    call opsym(isi,matopsym)
    v = matmul( matopsym, w )
    dr1 = sqrt( sum( v(:)**2 ) )
    if( dr1 < dr-epspos ) then
      u(:) = v(:)
      dr = dr1
      isym = is * iopsymr(is)   ! pour avoir le signe
    endif
  end do

  return
end

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

! Routine calculant les coefficients du laplacien.

subroutine Laplac(Adimp,Base_hexa,cgrad,clapl,icheck,igrpt_nomag,indice,iopsymr,iord,ivois,isvois, &
                  mpirank0,mpres,npso,npsom,nvois,nx)

  use declarations
  implicit none

  integer:: i, icheck, igrpt_nomag, io, iord, is, isym, iv, mpirank0, npso, npsom, nvois, nx

  integer, dimension(3):: la
  integer, dimension(3,0:nvois):: indpro
  integer, dimension(nopsm):: iopsymr
  integer, dimension(3,npsom):: indice
  integer, dimension(npsom,nvois):: ivois, isvois
  integer, dimension(-nx:nx,-nx:nx,-nx:nx):: mpres

  logical Base_hexa

  real(kind=db):: ad2, Adimp, cl, cd, d3, df3, f, f3

  real(kind=db), dimension(2):: coeford
  real(kind=db), dimension(3):: v
  real(kind=db), dimension(nvois):: cgrad
  real(kind=db), dimension(0:nvois):: clapl

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

! Coefficients du laplacien :

  indpro(:,:) = 0

  ad2 = Adimp**2
  coeford(1) = 1._db
  if( iord == 2 ) then
    cl = 1._db / ad2
  else
    cl = ( 4._db / 3._db ) / ad2
    coeford(2) = - 1._db / 16
  endif

  d3 = 2._db / 3
  iv = 0
  do io = 1,iord/2

    do i = 1,3
      do is = -1,1,2
        iv = iv + 1
        clapl(iv) = coeford(io) * cl
        if( base_hexa .and. ( i == 1 .or. i == 2 ) ) clapl(iv) = clapl(iv) * d3
        indpro(i,iv) = is * io
      end do
    end do

    if( Base_hexa ) then
      do is = -1,1,2
        iv = iv + 1
        clapl(iv) = coeford(io) * cl * d3
        indpro(1:2,iv) = is * io
      end do
    endif

  end do

  clapl(0) = - sum( clapl(1:nvois) )

! Coefficients du gradient

  coeford(1) = 1._db
  if( iord == 2 ) then
    cd = 1 / ( 2 * Adimp )
  else
    cd = (4._db/3._db) / ( 2 * Adimp )
    coeford(2) = - 1._db/8
  endif
  f = 1 /sqrt(3._db)

  iv = 0
  do io = 1,iord/2
    if( base_hexa ) then
      do i = 1,4
        do is = -1,1,2
          iv = iv + 1
          cgrad(iv) = is * coeford(io) * cd
! i = 4 correspond a la direction (110)
          if( i == 2 .or. i == 4 ) cgrad(iv) = cgrad(iv) * f
        end do
      end do
    else
      do i = 1,3
        do is = -1,1,2
          iv = iv + 1
          cgrad(iv) = is * coeford(io) * cd
        end do
      end do
    endif
  end do

  if( icheck > 0 ) then
    write(3,130) nvois
    write(3,140)
    do iv = 0,nvois
      write(3,150) iv, indpro(:,iv), clapl(iv) * ad2
    end do
    write(3,160)
    do iv = 1,nvois
      write(3,150) iv, indpro(:,iv), cgrad(iv) * Adimp
    end do
  endif

  f = sqrt(3._db) / 2
  f3 = 1 / sqrt(3._db)
  df3 = 2 * f3
  do i = 1,npso
    do  iv = 1,nvois

      La(:) = indice(:,i) + indpro(:,iv)
      if( Base_hexa ) then
        v(1) = La(1) - 0.5_db * La(2)
        v(2) = f * la(2)
        v(3) = real( La(3), db )
      else
        v(1:3) = real( La(1:3), db )
      endif

! Si le voisin tombe en dehors de la maille, on le ramene dedans par la symetrie eventuelle.
      call posequiv(mpirank0,v,iopsymr,isym,igrpt_nomag)
      if( base_hexa ) then
        la(1) = nint( v(1) + f3 * v(2) )
        la(2) = nint( df3 * v(2) )
        la(3) = nint( v(3) )
      else
        la(1:3) = nint( v(1:3) )
      endif

      if( abs(la(1)) <= nx .and. abs(la(2)) <= nx .and. abs(la(3)) <= nx ) then
        ivois(i,iv) = mpres(la(1),la(2),la(3))
        isvois(i,iv) = isym
      else
        ivois(i,iv) = 0
        isvois(i,iv) = 0
      endif

    end do
  end do

  if( icheck > 1 ) then
    write(3,170)
    do i = 1,npso
      write(3,180) i, ( ivois(i,iv), isvois(i,iv), iv = 1,nvois )
    end do
  endif

  return
  110 format(/' ---- Laplac -------',100('-'))
  130 format(/' nvois =',i3)
  140 format(/' iv  indpro  clapl * ad2')
  150 format(4i3,f12.6)
  160 format(/' iv  indpro  cgrad * Adimp')
  170 format(/'    i  ivois, isvois')
  180 format(i6,16(i6,i4))
end

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

! Routine selecting the points at the border of the muffin-tin sphere.
! Calculation of their distance from the atomic center

subroutine Bordure(Green,i_cycle,icheck,ibord,iopsymr,iord,isbord, &
              isrt,ivois,mpirank0,natome,nbm,nbord,nbordf,nbtm,nim,npoint,npso,npsom,nsort, &
              nsortf,numia,nvois,poidsa,poidso,posi,rvol,xyz)

  use declarations
  implicit none

  integer:: i, i_cycle, ia, ib, icheck, iord, ipr, iss, isym, iv, j, mpirank0, &
            natome, nbm, nbtm, nim, npoint, npso, npsom, nsort, nsortf, nv, nvois

  integer, dimension(natome):: ibp, nbord, nbordf
  integer, dimension(nopsm):: iopsymr
  integer, dimension(npsom):: numia
  integer, dimension(npsom,nvois):: ivois
  integer, dimension(nsort):: isrt
  integer, dimension(nbtm,natome):: ibord, isbord

  logical:: Green

  real(kind=db):: dr, fac, pdsort

  real(kind=db), dimension(3):: p, V, x
  real(kind=db), dimension(natome):: pdharm
  real(kind=db), dimension(nim):: rvol
  real(kind=db), dimension(3,natome):: posi
  real(kind=db), dimension(4,npsom):: xyz
  real(kind=db), dimension(nsortf):: Poidso
  real(kind=db), dimension(nbm,natome):: Poidsa

! De ib = 1 a nbordf, on stocke les points frontiere exterieurs,
! de ib = nbordf+1 a nbord, les points interieurs.
  ibp(:) = 0
  iss = 0

  nv = 2 * nvois / iord

  if( i_cycle == 1 ) then

    do i = 1,npoint
      if( numia(i) /= 0 ) cycle
      do iv = 1,nv
        j = ivois(i,iv)
        if( j == 0 ) cycle
        ia = numia(j)
        if( ia == -2 ) then
          if( iss /= i ) nsortf = nsortf + 1
          iss = i
        elseif( ia > 0 .and. .not. green ) then
          if( ibp(ia) /= i ) then
            nbordf(ia) = nbordf(ia) + 1
          endif
          ibp(ia) = i
        endif
      end do
    end do

    if( .not. Green ) then

      do ia = 1,natome
        ib = 0

        Loop_i: do i = 1,npoint
          if( numia(i) /= ia ) cycle

          do iv = 1,nvois
            j = ivois(i,iv)
            if( j == 0 .and. mpirank0 == 0 ) then
              call write_error
              do ipr = 3,9,3
                if( ipr == 3 .and. icheck == 0 ) cycle
                write(ipr,110) i, ia, iv, xyz(:,i)
              end do
              stop
            endif
            if( numia(j) /= ia ) then
              ib = ib + 1
              cycle Loop_i
            endif
          end do

        end do Loop_i

        nbord(ia) = nbordf(ia) + ib

      end do

    else

      nbord(:) = nbordf(:)

    endif

    nsort = nsortf
    do i = npoint+1,npso
      do iv = 1,nvois
        j = ivois(i,iv)
        if( j == 0 ) cycle
        if( numia(j) /= 0 ) cycle
        nsort = nsort + 1
        exit
      end do
    end do

    do ia = 1,natome
      nbtm = max( nbtm, nbord(ia) )
      nbm = max( nbm, nbordf(ia) )
    end do

    return
  endif

  nbordf(:) = 0
  nsortf = 0
  pdsort = 0._db
  pdharm(:) = 0._db
  ibp(:) = 0

! Les points en bordures sont seulement les points voisins dans les directions cristallographiques.
  do i = 1,npoint
    if( numia(i) /= 0 ) cycle
    do iv = 1,nv
      j = ivois(i,iv)
      if( j == 0 ) cycle
      ia = numia(j)
      if( ia == -2 ) then
        if( iss /= i ) then
          pdsort = pdsort + rvol(i)
          nsortf = nsortf + 1
          isrt(nsortf) = i
        endif
        iss = i
      elseif( ia > 0 .and. .not. Green ) then
        p(1:3) = posi(1:3,ia)
        x(1:3) = xyz(1:3,i)
        call posrel(iopsymr,x,p,V,dr,isym)
        if( ibp(ia) /= i ) then
          pdharm(ia) = pdharm(ia) + rvol(i)
          nbordf(ia) = nbordf(ia) + 1
          ibord(nbordf(ia),ia) = i
          isbord(nbordf(ia),ia) = isym
        endif
        ibp(ia) = i

      endif
    end do
  end do

  do ia = 1,natome
    ib = nbordf(ia)
    Loop_i2: do i = 1,npoint
      if( numia(i) /= ia ) cycle

      do iv = 1,nvois
        j = ivois(i,iv)
        if( j == 0 .and. mpirank0 == 0 ) then
          call write_error
          do ipr = 3,9,3
            if( ipr == 3 .and. icheck == 0 ) cycle
            write(ipr,110) i, ia, iv, xyz(:,i)
          end do
          stop
        endif
        if( numia(j) /= ia ) then
          ib = ib + 1
          p(1:3) = posi(1:3,ia)
          x(1:3) = xyz(1:3,i)
          call posrel(iopsymr,x,p,v,dr,isym)
          ibord(ib,ia) = i
          isbord(ib,ia) = isym
          cycle Loop_i2
        endif
      end do

    end do Loop_i2
  end do

  nsort = nsortf
  do i = npoint+1,npso
    do iv = 1,nvois
      j = ivois(i,iv)
      if( j == 0 ) cycle
      if( numia(j) /= 0 ) cycle
      nsort = nsort + 1
      isrt(nsort) = i
      exit
    end do
  end do

  do ia = 1,natome
    if( nbordf(ia) > 0 ) fac = quatre_pi / pdharm(ia)
    do ib = 1,nbordf(ia)
      poidsa(ib,ia) = fac * rvol( ibord(ib,ia) )
    end do
  end do

  if( nsortf > 0 ) then
    fac = quatre_pi / pdsort
    do ib = 1,nsortf
      poidso(ib) = fac * rvol( isrt(ib) )
    end do
  endif

  if( icheck > 0 ) then
    write(3,120)
    if( .not. green ) then
      do ia = 1,natome
        write(3,130) ia, nbordf(ia), nbord(ia)
        if( nbordf(ia) > 0 .and. icheck > 1 ) then
          write(3,140)
          do ib = 1,nbordf(ia)
            write(3,150) ibord(ib,ia), isbord(ib,ia), poidsa(ib,ia)
          end do
        endif
        if( nbord(ia) > nbordf(ia) .and. icheck > 1 ) then
          do ib = nbordf(ia)+1,nbord(ia)
            write(3,150) ibord(ib,ia), isbord(ib,ia)
          end do
        endif
      end do
    endif
    write(3,160) nsortf, nsort
    if( nsortf > 0 .and. icheck > 1 ) then
      write(3,165)
      write(3,170) (isrt(ib), poidso(ib), ib = 1,nsortf)
      if( nsort > nsortf ) write(3,180) (isrt(ib), ib = nsortf+1,nsort)
    endif

  endif

  return
  110 format(//' Error in bordure for mpirank, i, ia, iv =',4i6/,'   xyz =',1p,4e13.5/)
  120 format(/' ---- Bordure ------',100('-')/)
  130 format('     Atom',i4,', nbordf =',i5,', nbord =',i5)
  140 format('  ibord  isbord   poidsa')
  150 format(2i6,f12.5)
  160 format(' Outer sphere, nsortf =',i5,', nsort =',i5)
  165 format('   isrt  poidso')
  170 format(10(i6,f10.5))
  180 format(10(i6,10x))
  190 format(/' Points on the atomic radius, atom =',i3,', Pos =',3f9.5,', nb =',i4)
end

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

! Calculation of the energy of the core state

subroutine Energseuil(Core_energ_tot,Core_resolved,Delta_Epsii,Delta_Eseuil,E_Fermi,Emission,Epsii,Epsii_moy,Eseuil, &
              Exc_abs_i,icheck,is_g,Jseuil,Lseuil,m_g,mpirank0,nbseuil,ninit1,ninit,ninitr,nr,nrm,nseuil, &
              nspin,Numat,psii,r,Rmtg,Rmtsd,V_abs_i,V_intmax,Vc_abs_i,V0bd)

  use declarations
  implicit none

  integer, parameter:: nspino = 2
  integer, parameter:: nspinp = 2

  integer:: i, icheck, init, ipr, ir, isol, isp, Jseuil, lmax_pot_loc, L, Lseuil, m, mpirank0, n, nbseuil, &
    ninit1, ninit, ninitr, nlm_pot_loc, nm1, nm2, nr, nrm, nseuil, nsol, nspin, Numat, Z

  character(len=5):: mot5

  logical:: Core_energ_tot, Core_resolved, Emission, Failed, Relativiste, Spinorbite, Ylm_comp

  integer, dimension(ninit):: is_g
  integer, dimension(ninit,2):: m_g

  real(kind=db):: Charge, Delta, Delta_E_m, Delta_Epsii, Delta_Eseuil, E_elec, E_exc, E_Fermi, E_KS_Dirac, E_VXC, E_T, Ep_moy, &
     Epsii_moy, f_integr3, J, mj, psiHpsi, Rmtg, Rmtsd, V_intmax
  real(kind=db), dimension(nbseuil):: Delta_E, E_KS, Epsii_m, Eseuil
  real(kind=db), dimension(ninitr):: Epsii
  real(kind=db), dimension(ninit):: dEpsii, Epsi
  real(kind=db), dimension(nspin):: V0bd
  real(kind=db), dimension(nr):: fct, psi, r, rho
  real(kind=db), dimension(nrm,nbseuil):: psi_o, psii
  real(kind=db), dimension(nrm):: Exc_abs_i, Vc_abs_i
  real(kind=db), dimension(nrm,nspin):: V_abs_i
  real(kind=db), dimension(nr,1,nspin):: V_abs
  real(kind=db), dimension(nr,nspin):: Vrs

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

  Z = Numat

  if( Emission ) then
    mot5 = 'Epsif'
  else
    mot5 = 'Epsii'
  endif

! In the subroutine potential is in Hartree
  do isp = 1,nspin
    Vrs(1:nr,isp) = 0.5_db * r(1:nr) * V_abs_i(1:nr,isp)
  end do

  n = nseuil
  L = Lseuil

  do i = 1,nbseuil

    psi(1:nr) = psii(1:nr,i)

    if( Jseuil /= 2 * L ) then
      J = 0.5_db * Jseuil
    elseif( i == 1 ) then
      J = L - 0.5_db
    else
      J = L + 0.5_db
    endif

! We take these energies as positive
    Delta_E_m = 0.1_db
    Failed = .false.
    E_KS(i) = E_KS_Dirac(.true.,Delta_E_m,Failed,icheck,J,L,n,nr,nspin,Z,Vrs,psi,r,rho)
    if( Failed ) then
      call write_error
      do ipr = 6,9,3
        write(ipr,120) r(nr) * bohr
      end do
      stop
    endif

    fct(1:nr) = rho(1:nr) * Exc_abs_i(1:nr)
    E_exc = f_integr3(r,fct,1,nr,Rmtsd)

!  Hartree potential is the coulonmb potential of just the electrons, not the nucleus
    fct(1:nr) = rho(1:nr) * ( Vc_abs_i(1:nr) + 2 * Z / r(1:nr) )
    E_elec = 0.5_db * f_integr3(r,fct,1,nr,Rmtsd)

    E_Vxc = 0._db
    do isp = 1,nspin
      fct(1:nr) = rho(1:nr) * ( V_abs_i(1:nr,isp) - Vc_abs_i(1:nr) )
      E_Vxc = E_Vxc + f_integr3(r,fct,1,nr,Rmtsd) / nspin
    end do

    E_T = E_KS(i) - E_elec + E_exc - E_Vxc

    if( icheck > 1 ) write(3,130) E_T*rydb, E_KS(i)*rydb, E_elec*rydb, E_exc*rydb, E_Vxc*rydb
    if( icheck > 2 ) then
      write(3,140) Z, n, L, nint(2*J)
      do ir = 1,nr-1
        if( ir == 1 ) then
          Charge = 0.5_db * ( r(1) + r(2) ) * rho(ir)
        else
          Charge = Charge + 0.5_db * ( r(ir+1) - r(ir-1) ) * rho(ir)
        endif
        write(3,150) r(ir)*bohr, psi(ir), psii(ir,i), rho(ir), Charge
      end do
    end if

    if( Core_energ_tot ) then
      E_KS(i) = E_T
    else
      E_KS(i) = E_KS(i)
    endif
 ! For absorption we take it as positive because in order an increase of the level energy give a positive shift of the spectra
    if( .not. Emission ) E_KS(i) = - E_KS(i)

    if( nspin == 2 ) psi_o(:,i) = psi(:)
  end do

! Correction for the splitting due to magnetism
  if( nspin == 2 ) then

    if( Numat < 3 ) then
    ! Because, bad value with spinorbit for H and He
      Spinorbite = .false.
      Relativiste = .false.
    else
      Spinorbite = .true.
      Relativiste = .true.
    endif

! La contribution non diagonale du potentiel est negligee
    Ylm_comp = .false.
    lmax_pot_loc = 0
    nlm_pot_loc = 1
    V_abs(1:nr,1,:) = V_abs_i(1:nr,:)

! The calculation of the core levels is always with spin-orbit
    nm1 = - Lseuil - 1
    nm2 = Lseuil

    do init = 1,ninit

      if( init <= ninit1 ) then
        psi(:) = psi_o(:,1)
      else
        psi(:) = psi_o(:,2)
      endif
      if( .not. spinorbite ) then
    ! Corresponds to 1s of H and He
        m = 0
        nsol = 1
        isol = 1
      else
        if( m_g(init,1) == 1000 ) then
          m = nm1
          nsol = 1
          isol = 2
        elseif( m_g(init,2) == 1000 ) then
          m = nm2
          nsol = 1
          isol = 1
        else
          m = m_g(init,1)
          nsol = 2
          if( is_g(init) == 1 ) then
            isol = 1
          else
            isol = 2
          endif
        endif
      endif

      if( init == 1 .and. icheck > 0 ) write(3,*)

      Epsi(init) = psiHpsi(.true.,icheck,isol,L,lmax_pot_loc,m,n,nlm_pot_loc,nr,nr,nsol,nspin, &
                 nspino,nspinp,Numat,V0bd,V_abs,psi,r,Relativiste,Rmtg,Rmtsd,Spinorbite,V_intmax,Ylm_comp)
      if( .not. Emission ) Epsi(init) = - Epsi(init)

    end do

    Delta_E(1) = E_KS(1) - sum( Epsi(1:ninit1) ) / ninit1
    do init = 1,ninit1
      Epsi(init) = Epsi(init) + Delta_E(1)
    end do
    if( nbseuil == 2 ) then
      Delta_E(2) = E_KS(2) - sum( Epsi(ninit1+1:ninit) ) / ( ninit - ninit1 )
      do init = ninit1+1,ninit
        Epsi(init) = Epsi(init) + Delta_E(2)
      end do
    endif

    if( icheck > 1 ) then
      write(3,'(/A)') ' Difference between Dirac and internal KS energies'
      write(3,'(A)') '      E_KS_dirac    E_KS_int     Difference'
      do i = 1,nbseuil
        write(3,'(2x,3f13.3)') E_KS(i)*rydb, ( E_KS(i) + Delta_E(i) ) * rydb, Delta_E(i) * rydb
      end do
    endif

  else

    do init = 1,ninit1
      Epsi(init) = E_KS(1)
    end do
    do init = ninit1+1,ninit
      Epsi(init) = E_KS(2)
    end do

  endif

! Used to compensate the non equal Fermi level for the different absorbing atoms
! Fermi level being the zero, the wrong part of this value is supressed
! "+" is the goog sign !
! For Emission both core level are shifted in the same way, thus we do not mind.
  if( .not. Emission ) Epsi(:) = Epsi(:) + E_Fermi

  Epsii_m(1) = sum( Epsi(1:ninit1) ) / ninit1

  if( ninit1 < ninit ) then
    Epsii_m(2) = sum( Epsi(ninit1+1:ninit) ) / ( ninit - ninit1 )
    Delta = ( Eseuil(1) - Eseuil(2) ) - ( Epsii_m(1) - Epsii_m(2) )
    dEpsii(1:ninit1) = Epsi(1:ninit1)
    dEpsii(ninit1+1:ninit) = Epsi(ninit1+1:ninit)
  else
    dEpsii(1:ninit) = Epsi(1:ninit)
  endif

  if( Core_resolved ) then
    Epsii(1:ninit) = dEpsii(1:ninit)
  else
    Epsii(1:ninitr) = Epsii_m(1:ninitr)
  endif

  if( Core_resolved ) then
    if( ninit1 /= ninit ) then
      Epsii_moy = sum( Epsii(ninit1+1:ninit) ) / ( ninit - ninit1 )
      Ep_moy = sum( Epsii(1:ninit1) ) / ninit1
    else
      Epsii_moy = sum( Epsii(1:ninit) ) / ninit
      Ep_moy = Epsii_moy
    endif
  else
    Epsii_moy = Epsii(ninitr)
    Ep_moy = Epsii(1)
  endif
  Delta_Eseuil = Ep_moy - Epsii_moy

  if( Delta_Epsii < 100000._db .and. nbseuil > 1 ) then
    if( Core_resolved ) then
      Delta = Delta_Epsii - Delta_Eseuil
      Epsii(1:ninit1) = Epsii(1:ninit1) + Delta
    else
      Epsii(1) = Epsii(ninitr) + Delta_Epsii
    endif
    Delta_Eseuil = Delta_Epsii
  endif

  do ipr = 3,6,3

    if( L == 0 .or. ninit == 2*Lseuil + 2 ) then
      J = L + 0.5_db
    else
      J = L - 0.5_db
    endif

    if( ( ipr == 3 .and. icheck > 0 ) .or. ( ipr == 6 .and. Core_resolved .and. mpirank0 == 0 ) ) then
      if( ipr == 3 ) then
        if( Emission ) then
          write(ipr,'(/A/)') ' Kohn-Scham energy of the emission states:'
        else
          write(ipr,'(/A/)') ' Kohn-Scham energy of the core states:'
        endif
      endif
      if( ipr == 3 .and. ninit1 /= ninit ) then
        if( Emission ) then
          write(ipr,160) Delta * rydb
        else
          write(ipr,170) Delta * rydb
        endif
      endif
      mj = - j - 1
      do init = 1,ninit
        mj = mj + 1
        if( init == ninit1 + 1 ) then
          J = J + 1
          mj = - L - 0.5_db
        endif
        if( Delta_Epsii < 100000._db .and. nbseuil > 1 ) then
          write(ipr,180) mot5, dEpsii(init)*rydb, Epsi(init)*rydb, init, J, mj
        else
          write(ipr,190) mot5, dEpsii(init)*rydb, init, J, mj
        endif
      end do
    endif

    if( .not. Core_resolved .and. ( ( ipr == 3 .and. icheck > 0) .or. ( ipr == 6 .and. mpirank0 == 0 ) ) ) then
      if( ipr == 3 ) then
        if( ninitr == 1 ) then
          Write(ipr,200) mot5, Epsii(:) * Rydb
        else
          Write(ipr,210) mot5, Epsii(:) * Rydb
        endif
      else
        if( ninitr == 1 ) then
          Write(ipr,220) mot5, Epsii(:) * Rydb
        else
          Write(ipr,230) mot5, Epsii(:) * Rydb
        endif
      endif
    endif

  end do

  return
  110 format(/' ---- Energseuil ---',100('-'))
  120 format(//' Dirac subprogram, called by Energseuil:'//, &
              ' The turning point is beyond the atomic radius =',f9.5,' A',/ &
              ' Atomic potential probably out of standard values !'//)
  130 format(/' E_T =',f13.3,',  E_KS =',f13.3,', E_elec =',f13.3, / &
                          21x ,'E_exc =',f13.3,',  E_Vxc =',f13.3,' eV')
  140 format(/'  Z =',i4,', n =',i2,', L =',i2,', J =',i2,'/2',// &
              '     Radius      psi_new        psi          rho      integral')
  150 format(f13.7,1p,4e13.5)
  160 format(4x,'E_emis(1) - E_emis(2) + ( <E_KS(1)> - <E_KS(2)> ) =', f8.3,' eV',/)
  170 format(4x,'E_edge(1) - E_edge(2) - ( <E_KS(1)> - <E_KS(2)> ) =', f8.3,' eV',/)
  180 format(4x,a5,' =',f10.3,' eV,  E_KS =',f10.3, ' eV,  State',i3,', J =',f5.1,', Jz =',f5.1)
  190 format(4x,a5,' =',f10.3, ' eV,  State',i3,', J =',f5.1,', Jz =',f5.1)
  200 format(/7x,a5,' used =',f10.3,' eV')
  210 format(/7x,a5,' used =',f10.3,'  and',f10.3,' eV')
  220 format(a5,' used =',f10.3,' eV')
  230 format(a5,' used =',f10.3,'  and',f10.3,' eV')
end

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

! Calculation of the Kohhn-Sham energy of a core level by E = <psi|H|psi> / <psi|psi>
! When relativistic, one needs self-consistency because Hamiltonian depends on the calculated energy

function psiHpsi(Cal_psi,icheck,isol,L,lmax_pot,m,n,nlm_pot,nr,nrm,nsol,nspin, &
              nspino,nspinp,Numat,V0bd,Vrato,psi,r,Relativiste,Rmtg,Rmtsd,Spinorbite,V_intmax,Ylm_comp)

  use declarations
  implicit none

  integer:: icheck, ie_cycle, im, ip, ip_cycle, ir, isol, isp, L, l2, Lmax, lmax_pot, m, m_hubb, m1, m2, n, nie_cycle, &
    nip_cycle, nlm_pot, nlm_V, nodes, nr, nr_max, nr_pos, nrm, nrmtg, nrmtsd, nsol, nspin, nspino, nspinp, Numat

  parameter(m_hubb = 0)

  logical:: Cal_psi, Ecomp, Full_potential, Hubb_a, Hubb_d, Radial_comp, Relativiste, Renorm, Spinorbite, Ylm_comp

  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(2*L+1,nspin,2*L+1,nspin):: Tau
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb

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

  real(kind=db):: E, Eimag, Ep, Epp, fac, f_integr, f_so, Hpsi, &
    k_onde, php, pp, psiHpsi, Rmtg, Rmtsd, spp, td, V_intmax, vme
  real(kind=db), dimension(nspin)::  Ecinetic, V0bd
  real(kind=db), dimension(nrm):: dr, f2, psi, psi2, r
  real(kind=db), dimension(nrm,nspin):: g0, gm, gp, ur
  real(kind=db), dimension(nrm,nlm_pot,nspin):: Vrato
  real(kind=db), dimension(nrm,nspino):: gso

  real(kind=db), dimension(:,:,:,:,:), allocatable:: uis, urs

  if( icheck > 1 ) then
    if( Spinorbite ) then
      write(3,110) n, L, m
    else
      write(3,115) n, L
    endif
  endif

  Eimag = 0._db
  Ecomp = .false.
! For the core level orbital energy calculation, one neglects the  non-spherical aspect
  Full_potential = .false.
  Hubb_a = .false.
  Hubb_d = .true.
  m2 = 1
  m1 = 2 * L + 1
  Lmax = L
  Renorm = .false.
  Radial_comp = .false.

  if( Full_potential ) 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,nrm,nrmtg,nrmtsd,nspin,r,Rmtg,Rmtsd,V,V_intmax,V0bd,Vrato,Ylm_comp)

  dr(1) = 0.5_db * ( r(2) + r(1) )
  do ir = 2,nrmtg-1
    dr(ir) = 0.5_db * ( r(ir+1) - r(ir-1) )
  end do
  dr(nrmtg) = Rmtg - 0.5_db * ( r(nrmtg-2) + r(nrmtg-1) )

  nip_cycle = 200

  if( Relativiste .or. Spinorbite ) then
    nie_cycle = 10
  else
    nie_cycle = 1
  endif

  Epp = 0._db

  l2 = L**2 + L

  ur(:,:) = 0._db

  if( Spinorbite ) then
    if( m == -L-1 ) then
      isp = 2
      ur(:,2) = psi(:)
    elseif( m == L ) then
      isp = 1
      ur(:,1) = psi(:)
    else
      ur(:,1) = psi(:) * sqrt_1o2
      ur(:,2) = psi(:) * sqrt_1o2
    endif
    f_so = sqrt( (L - m) * ( L + m + 1._db) )
  else
    isp = 1
    ur(:,1) = psi(:)
  endif
  psi2(1:nrm) = psi(1:nrm)**2
  pp = f_integr(r,psi2,nrmtg,1,nrm,Rmtg)
  ur(:,:) = ur(:,:) / sqrt( pp )

  E = 0._db

! loop for the calculation of the wave function
  do ip_cycle = 1,nip_cycle

    do ie_cycle = 1,nie_cycle  ! loop for the energy calculation

      if( ip_cycle == 1 .and. ie_cycle == 1 ) then
        call Coef_sch_rad(E,f2,g0,gm,gp,gso,nlm_V,nr,nspin,nspino,Numat,r,.false.,.false.,V)
      elseif( Relativiste .or. Spinorbite ) then
        call Coef_sch_rad(E,f2,g0,gm,gp,gso,nlm_V,nr,nspin,nspino,Numat,r,Relativiste,Spinorbite,V)
      endif

      php = 0._db

      do isp = 1,nspin
        if( Spinorbite ) then
          if( m == -L-1 .and. isp == 1 ) cycle
          if( m == L .and. isp == 2 ) cycle
        endif
        do ir = 2,nrmtg
! one must add E because g0 contains V - E
          td = g0(ir,isp) + l2 * f2(ir) + E
          if( Spinorbite .and. ( ip_cycle > 1 .or. ie_cycle > 1 ) ) then
            if( isp == 1 ) then
              td = td + m * gso(ir,isp)
            else
              td = td - ( m + 1 ) * gso(ir,isp)
            endif
          endif

          Hpsi = gm(ir,isp) * ur(ir-1,isp) +  td * ur(ir,isp) + gp(ir,isp) * ur(ir+1,isp)
          if( nsol > 1 .and. (ip_cycle > 1 .or. ie_cycle >1) ) Hpsi = Hpsi + f_so * gso(ir,isp) * ur(ir,3-isp)
          php = php + ur(ir,isp) * Hpsi * dr(ir)
        end do
      end do

      Ep = E
      E =  php

      if( icheck > 1 ) write(3,120) ip_cycle, ie_cycle, E*Rydb, pp

      if( ie_cycle == 1 ) cycle

      if( abs( Ep - E ) < 0.001_db ) exit

    end do

    if( .not. cal_psi ) exit

    if( abs( Epp - E ) < 0.001_db ) exit

    Epp = E

    Ecinetic(:) = E - V0bd(:)

    do

! Konde is not useful, because one does not calulate the scattering amplitude Tau
      konde(:) = sqrt( cmplx(E - V0bd(:), Eimag,db) )

      allocate( urs(nr,m1,m2,nspin,nspino) )
      allocate( uis(nr,m1,m2,nspin,nspino) )
      call Sch_radial( Ecomp, Eimag, f2, Full_potential, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, L, Lmax, m_hubb, &
         m1, m2, nlm_V, nr, nrmtg, nspin ,nspino, nspinp, Numat, r, Radial_comp, Relativiste, Renorm, Rmtg, &
         Spinorbite, Tau, uis, urs, V, V_hubb )

      if( Spinorbite ) then
        if( m == -L-1 ) then
          ur(:,1) = 0._db
          ur(:,2) = urs(:,1,m2,2,nspino) * r(:)
        elseif( m == L ) then
          ur(:,1) = urs(:,m1,m2,1,1) * r(:)
          ur(:,2) = 0._db
        else
          ur(:,1) = urs(:,L+1+m,m2,1,isol) * r(:)
          ur(:,2) = urs(:,L+1+m+1,m2,2,isol) * r(:)
        endif
      else
        do isp = 1,nspin
          ur(:,isp) = urs(:,min(L+1+m,m1),m2,isp,1) * r(:)
        end do
      endif
      deallocate( urs, uis )

      do ir = nrmtg,1,-1
        if( real( V(ir,1,1,1), db ) < E .or. real( V(ir,1,1,nspin), db ) < E ) exit
      end do
      nr_pos = ir
      nr_pos = min(nr_pos,nr-2)

      nodes = 0
      if( m == -L-1 ) then
        isp = 2
      else
        isp = 1
      endif
      do ir = 2,min(nr_pos,nrmtg)
        if( ur(ir,isp)*ur(ir-1,isp) < 0._db ) nodes = nodes + 1
      end do
      if( nodes == n - L - 1 .or. E > real( V(nrmtg,1,1,1), db) ) exit

      if( nodes > n - L - 1 ) then
        E = E - 0.1_db * abs(E)
      else
        E = E + 0.1_db * abs(E)
      endif
      if( icheck > 1 ) write(3,125) nodes, n-L-1, E*Rydb
    end do

    if( E < real( V(nrmtg,1,1,1), db ) ) then

! Inward integration
      do ir = nr,1,-1
        if( ( real(V(ir,1,1,1), db) - E ) * r(ir)**2 < 625._db ) exit
      end do
      nr_max = ir

      do ir = nr_max+1,nr
        ur(ir,:) = 0._db
      end do

      do isp = 1,nspin
        if( Spinorbite ) then
          if( m == -L-1 .and. isp == 1 ) cycle
          if( m == L .and. isp == 2 ) cycle
        endif

        do ir = nr_max,nr_max-1,-1
          VmE = real( V(ir,1,1,isp), db ) - E
          VmE = Max( VmE, 0.000001_db )
          k_onde = sqrt( VmE )
          ur(ir,isp) = exp( - k_onde * r(ir) ) / r(ir)**(L+1)
        end do

        fac = ur(nr_pos+1,isp)
        do ir = nr_max-1,nr_pos+2,-1
          im = ir - 1
          ip = ir + 1
          td = g0(ir,isp) + l2 * f2(ir)
          if( Spinorbite ) then
            if( isp == 1 ) then
              td = td + m * gso(ir,isp)
            else
              td = td - ( m + 1 ) * gso(ir,isp)
            endif
          endif
          ur(im,isp) = - ( td * ur(ir,isp) + gp(ir,isp) * ur(ip,isp) ) / gm(ir,isp)
        end do
        fac = fac / ur(nr_pos+1,isp)
        do ir = nr_pos+1,nr_max
          ur(ir,isp) = fac * ur(ir,isp)
        end do

      end do

    else

      nr_max = nrmtg

    endif


    psi2(:) = 0._db
    do isp = 1,nspin
      psi2(1:nrm) = psi2(1:nrm) + ur(1:nrm,isp)**2
    end do

    pp = f_integr(r,psi2,nr,1,nrm,r(nr_max))
    spp = sqrt( pp )

    do isp = 1,nspin
      if( Spinorbite ) then
        if( m == -L-1 .and. isp == 1 ) cycle
        if( m == L .and. isp == 2 ) cycle
      endif
      ur(:,isp) = ur(:,isp) / spp
    end do

  end do

  if( icheck > 2 ) then
    if( nspin == 2 ) then
      write(3,130)
    else
      write(3,135)
    endif
    do ir = 1,nr
      write(3,140) r(ir)*bohr, psi(ir), ur(ir,:), real( V(ir,1,1,:), db )*Rydb
    end do
  endif

  psiHpsi =  E  ! Values, at this step are negative

  deallocate( V )

  return
  110 format(/' Core wave function : n =',i2,', L =',i2,', m =',i2/)
  115 format(/' Core wave function : n =',i2,', L =',i2/)
  120 format(' Cycle',2i4,',  E = ',f10.3,' eV,  <psi.psi> =',f10.7)
  125 format('   Nodes =',i2,' >',i2,' -->  E = ',f10.3,' eV')
  130 format('    rato        psi      psi_new(up)   psi_new(dn)       Vr_up       Vr_dn')
  135 format('    rato        psi        psi_new        V')
  140 format(f10.5,1p,5e13.5)
end

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

! Calculation of the Kohhn-Sham energy of a core level by E = <psi|H|psi> / <psi|psi>
! When relativistic, one needs self-consistency because Hamiltonian depends on the calculated energy

function psiHpsi_n(Cal_psi,icheck,isol,L,lmax_pot,m,n,nlm_pot,nr,nrm,nsol,nspin, &
              nspino,nspinp,Numat,V0bd,Vrato,psi,r,Relativiste,Rmtg,Rmtsd,Spinorbite,V_intmax,Ylm_comp)

  use declarations
  implicit none

  integer:: icheck, ie_cycle, im, ip, ip_cycle, ir, isol, is, isp, ispp, L, l2, Lmax, lmax_pot, m, m_hubb, m1, m2, n, nie_cycle, &
    nip_cycle, nlm_pot, nlm_V, nodes, nr, nr_max, nr_pos, nrm, nrmtg, nrmtsd, nsol, nspin, nspino, nspinp, Numat

  parameter(m_hubb = 0)

  logical:: Cal_psi, Ecomp, Full_potential, Hubb_a, Hubb_d, Radial_comp, Relativiste, Renorm, Spinorbite, Ylm_comp

  complex(kind=db), dimension(nspin):: konde
  complex(kind=db), dimension(2*L+1,nspin,2*L+1,nspin):: Tau
  complex(kind=db), dimension(-m_hubb:m_hubb,nspinp,-m_hubb:m_hubb,nspinp):: V_hubb

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

  real(kind=db):: E, Eimag, Ep, Epp, f_integr, f_so, Hpsi, &
    k_onde, php, pp, psiHpsi_n, Rmtg, Rmtsd, spp, td, V_intmax, vme
  real(kind=db), dimension(nspino):: fac
  real(kind=db), dimension(nspin)::  Ecinetic, V0bd
  real(kind=db), dimension(nrm):: dr, f2, psi, psi2, r
  real(kind=db), dimension(nrm,nspin):: g0, gm, gp
  real(kind=db), dimension(nrm,nspino):: ur
  real(kind=db), dimension(nrm,nlm_pot,nspin):: Vrato
  real(kind=db), dimension(nrm,nspino):: gso
  real(kind=db), dimension(:,:,:,:,:), allocatable:: uis, urs

  if( icheck > 1 ) then
    if( Spinorbite ) then
      write(3,110) n, L, m
    else
      write(3,115) n, L
    endif
  endif

  Eimag = 0._db
  Ecomp = .false.
! For the core level orbital energy calculation, one neglects the  non-spherical aspect
  Full_potential = .false.
  Hubb_a = .false.
  Hubb_d = .true.
  m2 = 1
  m1 = 2 * L + 1
  Lmax = L
  Renorm = .false.
  Radial_comp = .false.

  if( Full_potential ) 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,nrm,nrmtg,nrmtsd,nspin,r,Rmtg,Rmtsd,V,V_intmax,V0bd,Vrato,Ylm_comp)

  dr(1) = 0.5_db * ( r(2) + r(1) )
  do ir = 2,nrmtg-1
    dr(ir) = 0.5_db * ( r(ir+1) - r(ir-1) )
  end do
  dr(nrmtg) = Rmtg - 0.5_db * ( r(nrmtg-2) + r(nrmtg-1) )

  nip_cycle = 200

  if( Relativiste .or. Spinorbite ) then
    nie_cycle = 10
  else
    nie_cycle = 1
  endif

  Epp = 0._db

  l2 = L**2 + L

  ur(:,:) = 0._db

  if( Spinorbite ) then
    if( m == -L-1 ) then
      isp = 2
      ur(:,isp) = psi(:)
    elseif( m == L ) then
      isp = 1
      ur(:,isp) = psi(:)
    else
      ur(:,1) = psi(:) * sqrt_1o2
      ur(:,2) = ur(:,1)
    endif
    f_so = sqrt( (L - m) * ( L + m + 1._db) )
  else
    isp = 1
    ur(:,isp) = psi(:)
  endif
  psi2(1:nrm) = psi(1:nrm)**2
  pp = f_integr(r,psi2,nrmtg,1,nrm,Rmtg)
  ur(:,:) = ur(:,:) / sqrt( pp )

  E = 0._db

! loop for the calculation of the wave function
  do ip_cycle = 1,nip_cycle

    do ie_cycle = 1,nie_cycle  ! loop for the energy calculation

      if( ip_cycle == 1 .and. ie_cycle == 1 ) then
        call Coef_sch_rad(E,f2,g0,gm,gp,gso,nlm_V,nr,nspin,nspino,Numat,r,.false.,.false.,V)
      elseif( Relativiste .or. Spinorbite ) then
        call Coef_sch_rad(E,f2,g0,gm,gp,gso,nlm_V,nr,nspin,nspino,Numat,r,Relativiste,Spinorbite,V)
      endif

      php = 0._db

      do isp = 1,nspino
        ispp = min( isp, nspin )
        if( Spinorbite ) then
          if( m == -L-1 .and. isp == 1 ) cycle
          if( m == L .and. isp == 2 ) cycle
        endif
        do ir = 2,nrmtg
! one must add E because g0 contains V - E
          td = g0(ir,ispp) + l2 * f2(ir) + E
          if( Spinorbite .and. (ip_cycle > 1 .or. ie_cycle >1)) then
            if( isp == 1 ) then
              td = td + m * gso(ir,isp)
            else
              td = td - ( m + 1 ) * gso(ir,isp)
            endif
          endif

          Hpsi = gm(ir,ispp) * ur(ir-1,isp) +  td * ur(ir,isp) + gp(ir,ispp) * ur(ir+1,isp)
          if( nsol > 1 .and. (ip_cycle > 1 .or. ie_cycle >1) ) Hpsi = Hpsi + f_so * gso(ir,isp) * ur(ir,3-isp)
          php = php + ur(ir,isp) * Hpsi * dr(ir)
        end do
      end do

      Ep = E
      E =  php

      if( icheck > 1 ) write(3,120) ip_cycle, ie_cycle, E*Rydb, pp

      if( ie_cycle == 1 ) cycle

      if( abs( Ep - E ) < 0.001_db ) exit

    end do

    if( .not. cal_psi ) exit

    if( abs( Epp - E ) < 0.001_db ) exit

    Epp = E

    Ecinetic(:) = E - V0bd(:)

    do

! Konde is not useful, because one does not calculate the scattering amplitude Tau
      konde(:) = sqrt( cmplx(E - V0bd(:), Eimag,db) )

      allocate( urs(nr,m1,m2,nspinp,nspino) )
      allocate( uis(nr,m1,m2,nspinp,nspino) )
      call Sch_radial( Ecomp, Eimag, f2, Full_potential, g0, gm, gp, gso, Hubb_a, Hubb_d, icheck, konde, L, Lmax, m_hubb, &
         m1, m2, nlm_V, nr, nrmtg, nspin, nspino, nspinp, Numat, r, Radial_comp, Relativiste, Renorm, Rmtg, &
         Spinorbite, Tau, uis, urs, V, V_hubb )

      if( Spinorbite ) then
        if( m == -L-1 ) then
          ur(:,1) = 0._db
          ur(:,2) = urs(:,1,m2,2,nspino) * r(:)
        elseif( m == L ) then
          ur(:,1) = urs(:,m1,m2,1,1) * r(:)
          ur(:,2) = 0._db
        else
          ur(:,1) = urs(:,L+1+m,m2,1,isol) * r(:)
          ur(:,2) = urs(:,L+1+m+1,m2,2,isol) * r(:)
        endif
      else
        ur(:,1) = urs(:,min(L+1+m,m1),m2,isp,1) * r(:)
      endif
      deallocate( urs, uis )

      do ir = nrmtg,1,-1
        if( real( V(ir,1,1,1), db ) < E .or. real( V(ir,1,1,nspin), db ) < E ) exit
      end do
      nr_pos = ir
      nr_pos = min(nr_pos,nr-2)

      nodes = 0
      if( m == -L-1 ) then
        isp = 2
      else
        isp = 1
      endif
      do ir = 2,min(nr_pos,nrmtg)
        if( ur(ir,isp)*ur(ir-1,isp) < 0._db ) nodes = nodes + 1
      end do
      if( nodes == n - L - 1 .or. E > real( V(nrmtg,1,1,1), db ) ) exit

      if( nodes > n - L - 1 ) then
        E = E - 0.1_db * abs(E)
      else
        E = E + 0.1_db * abs(E)
      endif
      if( icheck > 1 ) write(3,125) nodes, n-L-1, E*Rydb
    end do

    if( E < real( V(nrmtg,1,1,1), db ) ) then

! Inward integration
      do ir = nr,1,-1
        if( ( real( V(ir,1,1,1), db ) - E ) * r(ir)**2 < 625._db ) exit
      end do
      nr_max = ir

      do ir = nr_max+1,nr
        ur(ir,:) = 0._db
      end do

! because dirac takes the other sign
      if( mod(n+L,2) == 1 ) then
        is = 1
      else
        is = -1
      endif
      do isp = 1,nspino ! it is anyway the spin
        ispp = min( isp, nspin )
        if( Spinorbite ) then
          if( m == -L-1 .and. isp == 1 ) cycle
          if( m == L .and. isp == 2 ) cycle
        endif

        do ir = nr_max,nr_max-1,-1
          VmE = real( V(ir,1,1,ispp), db ) - E
          VmE = Max( VmE, 0.000001_db )
          k_onde = sqrt( VmE )
          ur(ir,isp) = is * exp( - k_onde * r(ir) ) / r(ir)**(L+1)
        end do
      end do

      fac(:) = ur(nr_pos+1,:)

      do ir = nr_max-1,nr_pos+2,-1
        im = ir - 1
        ip = ir + 1
        do isp = 1,nspino ! it is anyway the spin
          ispp = min( isp,nspin)
          td = g0(ir,ispp) + l2 * f2(ir)
          if( Spinorbite ) then
            if( isp == 1 ) then
              td = td + m * gso(ir,isp)
            else
              td = td - ( m + 1 ) * gso(ir,isp)
            endif
          endif
          ur(im,isp) = - ( td * ur(ir,isp) + gp(ir,ispp) * ur(ip,isp) ) / gm(ir,ispp)
          if( nsol == 2 ) ur(im,isp) = ur(im,isp) - f_so * gso(ir,isp) * ur(ir,3-isp) / gm(ir,ispp)
        end do
      end do

      do isp = 1,nspino
        if( Spinorbite ) then
          if( m == -L-1 .and. isp == 1 ) cycle
          if( m == L .and. isp == 2 ) cycle
        endif
        fac(isp) = fac(isp) / ur(nr_pos+1,isp)
        do ir = nr_pos+1,nr_max
          ur(ir,:) = fac(isp) * ur(ir,isp)
        end do
      end do

    else

      nr_max = nrmtg

    endif

    psi2(:) = 0._db
    do isp = 1,nspino
      psi2(1:nrm) = psi2(1:nrm) + ur(1:nrm,isp)**2
    end do

    pp = f_integr(r,psi2,nr,1,nrm,r(nr_max))
    spp = sqrt( pp )

    do isp = 1,nspino
      if( Spinorbite ) then
        if( m == -L-1 .and. isp == 1 ) cycle
        if( m == L .and. isp == 2 ) cycle
      endif
      ur(:,isp) = ur(:,isp) / spp
    end do

  end do

  if( icheck > 2 ) then
    if( nspino == 2 ) then
      write(3,130)
    else
      write(3,135)
    endif
    do ir = 1,nr
      write(3,140) r(ir)*bohr, psi(ir), ur(ir,:), real( V(ir,1,1,:), db )*Rydb
    end do
  endif

  psiHpsi_n =  E  ! Values, at this step are negative

  if( Cal_psi ) psi(:) = ur(:,isol)

  deallocate( V )

  return
  110 format(/' Core wave function : n =',i2,', L =',i2,', m =',i2/)
  115 format(/' Core wave function : n =',i2,', L =',i2/)
  120 format(' Cycle',2i4,',  E = ',f10.3,' eV,  <psi.psi> =',f10.7)
  125 format('   Nodes =',i2,' >',i2,' -->  E = ',f10.3,' eV')
  130 format('    rato        psi      psi_new(up)   psi_new(dn)       Vr_up       Vr_dn')
  135 format('    rato        psi        psi_new        V')
  140 format(f10.5,1p,5e13.5)
end

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

! Calculation of the Kohhn-Sham energy of the core orbitals
! Delta_e_m = del in didif

function E_KS_Dirac(Cal_psi,Delta_E_m,Failed,icheck,J,L,n,nr,nspin,Z,Vrs,psi,r,rho)

  use declarations
  implicit none

  integer:: icheck, ir, L, n, npts, nr, nspin, Z

  logical:: Cal_psi, Failed

  real(kind=db):: Ch, Delta_E_m, deta, detb, detc, det, E, E_KS_Dirac, f_integr3, h, h_ray, h3, rn, eps, del, fj, &
                  J, ra, rb, rc, vbar, fk, cs, g, q11, q22, ta, tb, tc, tcs, v0, Zn
  real(kind=db), dimension(5):: da, dbb, voc
  real(kind=db), dimension(9):: ha
  real(kind=db), dimension(15):: a0, b0
  real(kind=db), dimension(nr):: a, b, psi, r, rho, Vr
  real(kind=db), dimension(nr,nspin):: Vrs

  do ir = 1,nr
    Vr(ir) = sum( Vrs(ir,:) ) / nspin   ! Vr in Hartree
  end do

  h_ray = nr * 54._db / 600  ! log step
  h = h_ray
  h = 1 / h
  h3 = h / 3
  ha(1) = 8 * h3
  ha(2) = 1.125_db * h3
  ha(3) = 2.375_db * h3
  ha(4) = 0.625_db * h3
  ha(5) = 0.125_db * h3
  ha(6) = h3 / 240
  ha(7) = h3 / 120
  ha(8) = h3 / 80
  ha(9) = h3 / 60

  rn = r(nr)
  eps = 2500._db
  del = min( 0.1_db, Delta_E_m )
  fj = J

  Zn = real( Z, db )

  ra = r(1)
  rb = r(2) / ra
  rc = r(3) / ra

  ta = vr(1) + Zn
  tb = (vr(2) + Zn) / rb
  tc = (vr(3) + Zn) / rc

  voc(1) = - Zn
  voc(2) = 0._db

  ra = 1._db
  deta = rb * rc * (rc - rb)
  detb = ra * rc * (ra - rc)
  detc = ra * rb * (rb - ra)
  det = deta + detb + detc
!     TEMPORARILY STORED IN VOC(5) UNTIL E CAN BE ADDED
  voc(5) = ( ta * deta + tb * detb + tc * detc ) / det

  deta = ra**2
  detb = rb**2
  detc = rc**2
  voc(3) = ( ta * (detb - detc) + tb * (detc - deta) + tc * (deta - detb) ) / det
  voc(4) = (ta * (rc - rb) + tb * (ra - rc) + tc * (rb - ra)) / det
  voc(1:5) = - voc(1:5) * alfa_sf

  vbar = 0._db
  fk = 0._db; cs = 0._db; g = 0._db; q11 = 0._db; q22 = 0._db; tcs = 0._db

  a(:) = psi(:)
  b(:) = 0._db
  E = 0._db

 ! subroutine in Dirac.f90
  Failed = .false.
  call didif(a,b,E,3,icheck,Failed,.true.,L,nr,n,r,Vr,rho,Zn,npts,ha,rn,h,eps,del,fj,v0,da,dbb,a0,b0,voc, &
                   vbar,fk,cs,g,q11,q22,tcs)
  if( Failed ) return

  if( Cal_psi ) psi(:) = a(:)

  E_KS_Dirac =  2 * E  ! Values, at this step are negative and convertion from Hartree to Rydberg

  Ch = f_integr3(r,rho,1,nr,r(nr))
  rho(:) = rho(:) / Ch

  return
  110 format(/' Core wave function : n =',i2,', L =',i2,', m =',i2/)
  115 format(/' Core wave function : n =',i2,', L =',i2/)
  120 format(' Cycle',2i4,',  E = ',f10.3,' eV,  <psi.psi> =',f10.7)
  125 format('   Nodes =',i2,' >',i2,' -->  E = ',f10.3,' eV')
  130 format('    rato        psi      psi_new(up)   psi_new(dn)       Vr_up       Vr_dn')
  135 format('    rato        psi        psi_new        V')
  140 format(f10.5,1p,5e13.5)
end

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

! Calculations of the (L,m) bellonging to each representations

subroutine Lmrep(Green,iaprotoi,iato,icheck,iopsym_atom,iopsymr,irep_util,iso,itypei,karact,lato, &
             lmaxat,lmaxso,lso,mato,mpirank0,mso,n_atom_proto,natome,nbordf,ngrph,nlmsa0,nlmsam,nlmso0, &
             nso1,nsortf,nspino,ntype,Numat,Orthmati,posi,rot_atom,Spin_axis_free)

  use declarations
  implicit none

  integer:: ia, icheck, igrph, ipr, irep, is, ispin, istop, js, k, L, Lm, Lmax, lmaxso, m, mpirank0, n_atom_proto, natome, ngrph, &
    nlmsam, nso1, nsortf, nsp, nspino, ntype

  integer, dimension(0:ntype) :: Numat
  integer, dimension(natome):: iaprotoi, itypei
  integer, dimension(ngrph):: nlmso0
  integer, dimension(0:n_atom_proto):: lmaxat
  integer, dimension(nopsm):: iopsyma, iopsymr, irotiops
  integer, dimension(nopsm,natome):: iopsym_atom
  integer, dimension(nrepm,2):: irep_util
  integer, dimension(natome,ngrph):: nlmsa0
  integer, dimension(natome):: nbordf
  integer, dimension(nso1,ngrph):: iso, lso, mso
  integer, dimension(nlmsam,natome,ngrph):: iato, lato, mato

  complex(kind=db), dimension(nopsm):: kopsymo
  complex(kind=db), dimension(nopsm,nrepm):: karact

  logical:: Green, Spin_axis_free

  real(kind=db), dimension(3):: p
  real(kind=db), dimension(3,natome):: posi
  real(kind=db), dimension(3,3):: Orthmati, rot_a, Rot_one
  real(kind=db), dimension(3,3,natome):: Rot_atom

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

  nlmso0(:) = 0
  nlmsa0(:,:) = 0
  Lso(:,:) = 10000
  Lato(:,:,:) = 10000
  Rot_one(:,:) = 0._db
  Rot_one(1,1) = 1._db;   Rot_one(2,2) = 1._db;   Rot_one(3,3) = 1._db

  do ia = 0,natome

    if( ia == 0 ) then

      if( green ) cycle
      Lmax = lmaxso
      iopsyma(:) = iopsymr(:)
      do is = 1,nopsm
        irotiops(is) = is
      end do

    else

      ipr = iaprotoi(ia)
      Lmax = lmaxat(ipr)
      if( icheck > 1 .or. (ia == 1 .and. icheck == 2) ) then
        do k = 1,3
          p(k) = sum( orthmati(k,1:3) * posi(1:3,ia) )
        end do
        write(3,130) ia, p(1:3)
      endif
      p(1:3) = posi(1:3,ia)
      iopsyma(:) = iopsym_atom(:,ia)
      if( Spin_axis_free ) then
        rot_a(:,:) = Rot_one(:,:)
      else
        rot_a(:,:) = rot_atom(:,:,ia)
      endif
      call iop_rot(icheck,irotiops,rot_a)
    endif

    do L = 0,Lmax
      do m = -L,L

        do ispin = 1,nspino

          call symorb(L,m,kopsymo)

! Search of the representation whom the orbital belongs
          boucle_irep: do igrph = 1,ngrph
            irep = abs( irep_util(igrph,ispin) )
            if( irep == 0 ) cycle
            do is = 1,nopsm
              js = irotiops(is)
              if( js == 0 ) cycle
              if( iopsymr(is) == 0 .or. iopsyma(js) == 0 ) cycle
              if( irep_util(igrph,ispin) > 0 ) then
                if( abs( karact(is,irep) - kopsymo(js) ) > eps10 ) cycle boucle_irep
              else
                if( abs( conjg(karact(is,irep)) - kopsymo(js) ) > eps10 ) cycle boucle_irep
              endif
            end do

            if( ia == 0 ) then
              nlmso0(igrph) = nlmso0(igrph) + 1
              iso( nlmso0(igrph), igrph ) = ispin
              lso( nlmso0(igrph), igrph ) = L
              mso( nlmso0(igrph), igrph ) = m
            else
              nlmsa0(ia,igrph) = nlmsa0(ia,igrph) + 1
              iato( nlmsa0(ia,igrph), ia, igrph ) = ispin
              lato( nlmsa0(ia,igrph), ia, igrph ) = L
              mato( nlmsa0(ia,igrph), ia, igrph ) = m
            endif

          end do boucle_irep

        end do
      end do
    end do

    if( icheck > 1 ) then

      if( ia == 0 ) then

        do igrph = 1,ngrph
          write(3,170) Lmax, nlmso0(igrph), igrph, irep_util(igrph,:)
          write(3,180)
          write(3,190) (Lm, lso(Lm,igrph), mso(Lm,igrph), iso(Lm,igrph), Lm = 1,nlmso0(igrph))
        end do

      else

        do igrph = 1,ngrph
          write(3,175) ia, Lmax, nlmsa0(ia,igrph), igrph, irep_util(igrph,:)
          write(3,180)
          write(3,190) (Lm, lato(Lm,ia,igrph), mato(Lm,ia,igrph), iato(Lm,ia,igrph), Lm = 1,nlmsa0(ia,igrph))
        end do

      endif

    endif

  end do

  if( .not. Green ) then

    istop = 0
    do igrph = 1,ngrph

      nsp = nspino * nsortf
      if( nlmso0(igrph) > nsp .and. mpirank0 == 0 ) then
        if( istop == 0 ) call write_error
        do ipr = 3,9,3
          if( ipr == 3 .and. icheck == 0 ) cycle
          write(ipr,200) nlmso0(igrph), nsp
        end do
        istop = 1
      endif

      do ia = 1,natome
        if( Numat( itypei(ia) ) == 0 ) cycle
        nsp = nspino * nbordf(ia)
        if( nlmsa0(ia,igrph) > nsp .and. mpirank0 == 0 ) then
          if( istop == 0 ) call write_error
          do ipr = 3,9,3
            if( ipr == 3 .and. icheck == 0 ) cycle
            write(ipr,210) ia, nlmsa0(ia,igrph), nsp
          end do
          istop = 1
        endif
      end do

    end do

    if( istop == 1 ) stop

  endif

  return
  110 format(/' ---- lmrep --------',100('-'))
  130 format(/' Atome ia =',i3,', position =',3f7.3)
  170 format(/' Outer sphere, Lmax =',i3,', nlm =',i3,', igrph =',i2,', irep(1:nspin) =',2i3)
  175 format(/'  ia = ',i3,', Lmax =',i3,', nlm =',i3,', igrph =',i2,', irep(1:nspin) =',2i3)
  180 format(/'   Lm    L    m   iso')
  190 format(4i5)
  200 format(///'   nlmso0 =',i4,' > nspino*nsortf =',i4, // &
                ' Solution :',/'  Reduce the maximum energy or ',/ &
                '  Reduce the outersphere Lmax using the lmaxso keyword or',/ &
                '  Reduce the interpoint distance using the keyword Adimp'//)
  210 format(///'   nlmsa0(ia=',i3,') =',i4,' > nspino*nbordf =',i4, // &
                ' Solution :',/'  Reduce the maximum energy or ',/ &
                '  Reduce the atomic Lmax using the Lmax keyword or',/ &
                '  Reduce the interpoint distance using the keyword Adimp'//)
end

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

! Reduction of the symmetry taking into account the atom position
! Rotation of the local basis such that Oz is not changed and Ox is the radial direction

subroutine iop_rot(icheck,irotiops,rot_atom)

  use declarations
  implicit none

  integer:: icheck, is, js

  integer, dimension(nopsm):: irotiops

  real(kind=db), dimension(3,3):: matopsym, rot_atom, rot_tem

  irotiops(:) = 0

  do is = 1,nopsm
    call opsym(is,matopsym)
    rot_tem = matmul( transpose(rot_atom), matmul( matopsym, rot_atom ) )
    do js = 1,nopsm
      call opsym(js,matopsym)
      if( sum( abs( matopsym(:,:) - rot_tem(:,:) ) ) > eps6 ) cycle
      irotiops(js) = is
      exit
    end do
  end do

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

  return
  110 format(/' irotiops =',/ 4(1x,5i3) )
end

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

! Calculation of the number of spherical harmonics at the energy
! From Lmax(Lmax-1) = ( k.R )^2

subroutine clmax(Energ,R,lmax0,Lmax,Z,lmaxfree)

  use declarations
  implicit none

  integer:: Lmax, lmax0, Z

  logical:: lmaxfree

  real(kind=db):: Energ, R, kR

  if( Energ > 0._db .and. R > eps10 ) then
    kR = sqrt( Energ ) * R
  else
    kR = 0._db
  endif

  if( lmax0 < 0 ) then
    Lmax = int( 0.5_db + 0.5_db * sqrt(1 + 4*kR**2) ) - lmax0
  elseif( Z < 0 ) then
    Lmax = Lmax0
  else
    Lmax = int( 0.5_db + 0.5_db * sqrt(1 + 4*kR**2) ) + 1
  endif

  if( Z < 0 ) then  ! outer sphere case
    Lmax = max( 1, Lmax )
  elseif( Z == 1 ) then
    Lmax = 2
  elseif( Z == 0 .or. ( Z > 1 .and. Z <= 54 ) ) then
    Lmax = max( 2, Lmax )
  elseif( Z > 54 ) then
    Lmax = max( 3, Lmax )
  endif

  if( .not. lmaxfree ) then
    if( Z > 0 .and. Z < 3 ) then
      Lmax = min(Lmax,3)
    elseif( Z < 19 ) then
      Lmax = min(Lmax,4)
    elseif( Z < 37 ) then
      Lmax = min(Lmax,5)
    elseif( Z < 55 ) then
      Lmax = min(Lmax,6)
    elseif( Z < 87 ) then
      Lmax = min(Lmax,7)
    elseif( Z >= 87 ) then
      Lmax = min(Lmax,8)
    endif
  endif

  if( lmax0 >= 0 ) Lmax = min( Lmax, lmax0 )

  return
end

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

! Calculation of the Ylm and of the distances from the atom center of each points.

subroutine Ylmpt(iaprotoi,ibord,icheck,iopsymr,isrt,lmaxat,lmaxso,n_atom_proto,natome, &
             nbord,nbtm,nlmmax,nlmomax,nsort,npsom,posi,rot_atom,Spin_axis_free,xyz,Ylmato,Ylmso)

  use declarations
  implicit none

  integer:: i, ia, ib, icheck, ipr, isym, L, Lm, Lmax, lmaxso, m, n_atom_proto, natome, nbtm, nlmc, nlmmax, &
            nlmomax, nlmr, np, nsort, npsom

  integer, dimension(0:n_atom_proto):: lmaxat
  integer, dimension(nopsm):: iopsymr
  integer, dimension(nsort):: isrt
  integer, dimension(natome):: iaprotoi, nbord
  integer, dimension(nbtm,natome):: ibord

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

  logical:: Spin_axis_free

  real(kind=db):: r
  real(kind=db), dimension(3):: p, v, w
  real(kind=db), dimension(3,3):: rot_a
  real(kind=db), dimension(3,3,natome):: rot_atom
  real(kind=db), dimension(3,natome):: posi
  real(kind=db), dimension(4,npsom):: xyz
  real(kind=db), dimension(nbtm,nlmmax,natome):: Ylmato
  real(kind=db), dimension(nsort,nlmomax):: Ylmso

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

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

  do ia = 0,natome

    if( ia > 0 ) then
      ipr = iaprotoi(ia)
      Lmax = lmaxat(ipr)
      np = nbord(ia)
      p(1:3) = posi(1:3,ia)
! Change of basis:
      if( Spin_axis_free ) then
        rot_a(:,:) = 0._db
        rot_a(1,1) = 1._db; rot_a(2,2) = 1._db; rot_a(3,3) = 1._db
      else
        rot_a(:,:) = Rot_atom(:,:,ia)
      endif
    else
      p(:) = 0._db
      Lmax = lmaxso
      np = nsort
    endif
    nlmr = ( Lmax + 1 )**2
    nlmc = ( ( Lmax + 1 ) * ( Lmax + 2 ) ) / 2
    allocate( Ylmc(nlmc) )
    allocate( Ylmr(nlmr) )

    do ib = 1,np
      if( ia == 0 ) then
        i = isrt(ib)
      else
        i = ibord(ib,ia)
      endif
      w(1:3) = xyz(1:3,i)
      call posrel(iopsymr,w,p,v,r,isym)
      if( ia > 0 ) w = matmul( rot_a, v )
      call cYlm(Lmax,w,r,Ylmc,nlmc)
! Conversion in real Ylm
      call Ylmcr(Lmax,nlmc,nlmr,Ylmc,Ylmr)
      if( ia == 0 ) then
        Ylmso(ib,1:nlmr) = Ylmr(1:nlmr)
      else
        Ylmato(ib,1:nlmr,ia) = Ylmr(1:nlmr)
      endif
    end do

    if( icheck > 2 ) then
      write(3,120) ia
      Lm = 0
      do L = 0,Lmax
        do m = -L,L
          write(3,130) L, m
          Lm = Lm + 1
          if( ia == 0 ) then
            write(3,140) Ylmso(1:np,Lm)
          else
            write(3,140) Ylmato(1:np,Lm,ia)
          endif
        end do
      end do
    endif

    deallocate( Ylmc )
    deallocate( Ylmr )

  end do

  return
  110 format(/' ---- Ylmpt --------',100('-'))
  120 format(/'    Ylm,  Atom',i3)
  130 format(/' L, m =',2i3)
  140 format(1p,10e13.5)
end

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

! Calculation of Plm
! Plm are the complex Ylm without the exp(i.m.phi)

subroutine Cal_Plm(Lmax,Plm,nlm,Theta)

  use declarations
  implicit none

  integer:: L, Lm, Lm0, Lm1, Lm2, Lmax, m, nlm

  real(kind=db):: Plm(nlm)

  real(kind=db):: Cos_t, Cot_t, f, g, Sin_t, Theta

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

! Calcul de Plm(0,0) :
  Plm(1) = 1._db / sqrt( quatre_pi )

! Calcul des Y(L,L) :
  do L = 1,Lmax
    Lm = ( L + 1 )**2
    Lm1 = L**2
    f = - sqrt( 1 + 0.5_db / L )
    Plm(Lm) = f * Sin_t * Plm(Lm1)
  end do

! Calcul de Plm(1,0)
  if( Lmax > 0 ) Plm(3) = sqrt( 3._db / quatre_pi ) * Cos_t

! Calcul des P(L,L-1)
  do L = 2,Lmax
    Lm = ( L + 1 )**2 - 1
    Lm1 = L**2 - 1
    f = - sqrt( (2*L + 1._db) / (2*L - 2) )
    Plm(Lm) = f * Sin_t * Plm(Lm1)
  end do

! Calcul des Plm(L,m)
  do L = 2,Lmax
    Lm0 = L**2 + L + 1
    do m = L-2,1,-1
      Lm = Lm0 + m
      f = - 2 * (m + 1._db) / sqrt( L*(L+1._db) - m*(m+1._db) )
      g = - sqrt( ( L*(L+1._db) - (m+1._db)*(m+2._db) ) / ( L*(L+1._db) - m*(m+1._db) ) )
      if( abs(Sin_t) > eps10 ) then
        Plm(Lm) = Cot_t * f * Plm(Lm+1) + g * Plm(Lm+2)
      else
        Plm(Lm) = ( 0._db, 0._db )
      endif
    end do
  end do

! Calcul of Plm(L,0) :
  do L = 2,Lmax
    Lm = L**2 + L + 1
    Lm1 = ( L - 1 )**2 + L
    Lm2 = ( L - 2 )**2 + L - 1
    f = sqrt( (2*L + 1._db) / (2*L - 1._db) ) * (2*L - 1._db) / L
    g = - sqrt( (2*L + 1._db) / (2*L - 3._db) ) * (L - 1._db) / L
    Plm(Lm) = f * Cos_t * Plm(Lm1) + g * Plm(Lm2)
  end do

  do L = 1,Lmax
    do m = -L,-1
      Lm = L**2 + L + 1 + m
      if( mod(abs(m),2) == 1 ) then
        Plm(Lm) = - Plm(Lm-2*m)
      else
        Plm(Lm) = Plm(Lm-2*m)
      endif
    end do
  end do

  return
end

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

! Calculation of complex Ylm
! Only m >= 0 are calculated
! The index of Ylm is Lm = L(L+1)/2 + 1 + m

subroutine cylm(Lmax,V,r,Ylmc,nlm)

  use declarations
  implicit none

  integer:: L, Lm, Lm0, Lm1, Lm2, Lmax, m, nlm

  complex(kind=db):: Ylmc(nlm), exphi, Sin_t_exp_phi

  real(kind=db):: Cos_t, Cot_t, den, f, g, r, Sin_t
  real(kind=db), dimension(3):: V

  if( r > eps6 ) then
    Cos_t = V(3) / r
  else
    Cos_t = 1._db
  endif

  den = sqrt( V(1)**2 + V(2)**2 )
  if( den > eps6 ) then
    exphi = cmplx( V(1), V(2), db ) / den
    Sin_t = sqrt( 1 - Cos_t**2 )  ! Theta is between 0 and pi
    Sin_t_exp_phi = cmplx( V(1), V(2), db ) / r
    Cot_t = Cos_t / Sin_t
  else
    exphi = (1._db,0._db)
    Sin_t = 0._db
    Sin_t_exp_phi = (0._db,0._db)
  endif

! Calcul de Y(0,0) :
  Ylmc(1) = 1._db / sqrt( quatre_pi )

! Calcul des Y(L,L) :
  do L = 1,Lmax
    Lm = ( ( L + 1 ) * ( L + 2 ) ) / 2
    Lm1 = ( L * ( L + 1 ) ) / 2
    f = - sqrt( 1 + 0.5_db / L )
    Ylmc(Lm) = f * Sin_t_exp_phi * Ylmc(Lm1)
  end do

! Calcul de Y(1,0) :
  if( Lmax > 0 ) Ylmc(2) = sqrt( 3._db / quatre_pi ) * Cos_t

! Calcul des Y(L,L-1) :
  do L = 2,Lmax
    Lm = ( ( L + 1 ) * ( L + 2 ) ) / 2 - 1
    Lm1 = ( L**2 + L ) / 2 - 1
    f = - sqrt( (2*L + 1._db) / (2*L - 2) )
    Ylmc(Lm) = f * Sin_t_exp_phi * Ylmc(Lm1)
  end do

! Calcul des Y(L,m) :
  exphi = conjg( exphi )

  do L = 2,Lmax
    Lm0 = ( L**2 + L ) / 2
    do m = L-2,1,-1
      Lm = Lm0 + m + 1
      f = - 2 * (m + 1._db) / sqrt( L*(L+1._db) - m*(m+1._db) )
      g = - sqrt( ( L*(L+1._db) - (m+1._db)*(m+2._db) ) / ( L*(L+1._db) - m*(m+1._db) ) )
      if( abs(Sin_t) > eps10 ) then
        Ylmc(Lm) = exphi*( Cot_t * f * Ylmc(Lm+1) + exphi * g * Ylmc(Lm+2) )
      else
        Ylmc(Lm) = ( 0._db, 0._db )
      endif
    end do
  end do

! Calcul des Y(L,0) :
  do L = 2,Lmax
    Lm = ( L * (L+1) ) / 2 + 1
    Lm1 = ( (L-1)*L ) / 2 + 1
    Lm2 = ( (L-2)*(L-1) ) / 2 + 1
    f = sqrt( (2*L + 1._db) / (2*L - 1._db) ) * (2*L - 1._db) / L
    g = - sqrt( (2*L + 1._db) / (2*L - 3._db) ) * (L - 1._db) / L
    Ylmc(Lm) = f * Cos_t * Ylmc(Lm1) + g * Ylmc(Lm2)
  end do

  return
end

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

! Calculation of complex Ylm but with classical ordering
! The index of Ylm is Lm = L**2 + L + 1 + m
! nlm = (Lmax+1)**2

subroutine Cal_Ylmc(Lmax,V,r,Ylmc,nlm)

  use declarations
  implicit none

  integer:: L, Lm, Lm0, Lm1, Lm2, Lmax, m, nlm

  complex(kind=db):: Ylmc(nlm), exphi, Sin_t_exp_phi

  real(kind=db):: Cos_t, Cot_t, den, f, g, r, Sin_t
  real(kind=db), dimension(3):: V

  if( r > eps6 ) then
    Cos_t = V(3) / r
  else
    Cos_t = 1._db
  endif

  den = sqrt( V(1)**2 + V(2)**2 )
  if( den > eps6 ) then
    exphi = cmplx( V(1), V(2), db ) / den
    Sin_t = sqrt( 1 - Cos_t**2 )  ! Theta is between 0 and pi
    Sin_t_exp_phi = cmplx( V(1), V(2), db ) / r
    Cot_t = Cos_t / Sin_t
  else
    exphi = (1._db,0._db)
    Sin_t = 0._db
    Sin_t_exp_phi = (0._db,0._db)
  endif

! Calcul de Y(0,0) :
  Ylmc(1) = 1._db / sqrt( quatre_pi )

! Calcul des Y(L,L) :
  do L = 1,Lmax
    Lm = ( L + 1 )**2
    Lm1 = L**2
    f = - sqrt( 1 + 0.5_db / L )
    Ylmc(Lm) = f * Sin_t_exp_phi * Ylmc(Lm1)
  end do

! Calcul de Y(1,0) :
  if( Lmax > 0 ) Ylmc(3) = sqrt( 3._db / quatre_pi ) * Cos_t

! Calcul des Y(L,L-1) :
  do L = 2,Lmax
    Lm = ( L + 1 )**2 - 1
    Lm1 = L**2 - 1
    f = - sqrt( (2*L + 1._db) / (2*L - 2) )
    Ylmc(Lm) = f * Sin_t_exp_phi * Ylmc(Lm1)
  end do

! Calculation of Y(L,m)
  exphi = conjg( exphi )

  do L = 2,Lmax
    Lm0 = L**2 + L + 1
    do m = L-2,1,-1
      Lm = Lm0 + m
      f = - 2 * (m + 1._db) / sqrt( L*(L+1._db) - m*(m+1._db) )
      g = - sqrt( ( L*(L+1._db) - (m+1._db)*(m+2._db) ) / ( L*(L+1._db) - m*(m+1._db) ) )
      if( abs(Sin_t) > eps10 ) then
        Ylmc(Lm) = exphi*( Cot_t * f * Ylmc(Lm+1) + exphi * g * Ylmc(Lm+2) )
      else
        Ylmc(Lm) = ( 0._db, 0._db )
      endif
    end do
  end do

! Calculation of Y(L,0)
  do L = 2,Lmax
    Lm = L**2 + L + 1
    Lm1 = ( L - 1 )**2 + L
    Lm2 = ( L - 2 )**2 + L - 1
    f = sqrt( (2*L + 1._db) / (2*L - 1._db) ) * (2*L - 1._db) / L
    g = - sqrt( (2*L + 1._db) / (2*L - 3._db) ) * (L - 1._db) / L
    Ylmc(Lm) = f * Cos_t * Ylmc(Lm1) + g * Ylmc(Lm2)
  end do

  do L = 1,Lmax
    Lm0 = L**2 + L + 1
    do m = -L,-1
      Lm = Lm0 + m
      if( mod(abs(m),2) == 1 ) then
        Ylmc(Lm) = - conjg( Ylmc(Lm-2*m) )
      else
        Ylmc(Lm) = conjg( Ylmc(Lm-2*m) )
      endif
    end do
  end do

  return
end

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

! Convertion from complex Ylm to real Ylm

subroutine ylmcr(Lmax,nlmc,nlmr,ylmc,ylmr)

  use declarations
  implicit none

  integer:: L, l2, Lm, Lm0, Lmax, m, nlmc, nlmr

  complex(kind=db), dimension(nlmc):: ylmc

  real(kind=db), dimension(nlmr):: ylmr

  Lm = 0
  do L = 0,Lmax

    l2 = ( L**2 + L ) / 2 + 1

    do m = -L,L

      Lm = Lm + 1
      Lm0 = l2 + abs(m)

      if( m < 0 ) then
        ylmr(Lm) = (-1)**m * sqrt_2 * aimag( ylmc(Lm0) )
      elseif( m == 0 ) then
        ylmr(Lm) = real( ylmc(Lm0), db )
      else
        ylmr(Lm) = (-1)**m * sqrt_2 * real( ylmc(Lm0), db )
      endif

    end do
  end do

  return
end

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

! Calculation of real Ylm

subroutine Cal_Ylmr(Lmax,V,r,Ylmr,nlm)

  use declarations
  implicit none

  integer:: L, L2, Lm, Lm0, Lm1, Lm2, Lmax, m, nlm, nlmc

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

  real(kind=db):: Cos_t, Cot_t, den, f, g, r, Sin_t
  real(kind=db), dimension(3):: V
  real(kind=db), dimension(nlm):: Ylmr

  nlmc = ( ( Lmax + 1 ) * ( Lmax + 2 ) ) / 2
  allocate( Ylmc( nlmc ) )
! The index of Ylmc is Lm = L(L+1)/2 + 1 + m

  if( r > eps6 ) then
    Cos_t = V(3) / r
  else
    Cos_t = 1._db
  endif

  den = sqrt( V(1)**2 + V(2)**2 )
  if( den > eps6 ) then
    exphi = cmplx( V(1), V(2), db ) / den
    Sin_t = sqrt( 1 - Cos_t**2 )  ! Theta is between 0 and pi
    Sin_t_exp_phi = cmplx( V(1), V(2), db ) / r
    Cot_t = Cos_t / Sin_t
  else
    exphi = (1._db,0._db)
    Sin_t = 0._db
    Sin_t_exp_phi = (0._db,0._db)
  endif

! Y(0,0)
  Ylmc(1) = 1._db / sqrt( quatre_pi )

! Calculation of Y(L,L)
  do L = 1,Lmax
    Lm = ( ( L + 1 ) * ( L + 2 ) ) / 2
    Lm1 = ( L * ( L + 1 ) ) / 2
    f = - sqrt( 1 + 0.5_db / L )
    Ylmc(Lm) = f * Sin_t_exp_phi * Ylmc(Lm1)
  end do

! Y(1,0)
  if( Lmax > 0 ) Ylmc(2) = sqrt( 3._db / quatre_pi ) * Cos_t

! Calculation of Y(L,L-1)
  do L = 2,Lmax
    Lm = ( ( L + 1 ) * ( L + 2 ) ) / 2 - 1
    Lm1 = ( L**2 + L ) / 2 - 1
    f = - sqrt( (2*L + 1._db) / (2*L - 2) )
    Ylmc(Lm) = f * Sin_t_exp_phi * Ylmc(Lm1)
  end do

! Calculation of Y(L,m)
  exphi = conjg( exphi )

  do L = 2,Lmax
    Lm0 = ( L**2 + L ) / 2
    do m = L-2,1,-1
      Lm = Lm0 + m + 1
      f = - 2 * (m + 1._db) / sqrt( L*(L+1._db) - m*(m+1._db) )
      g = - sqrt( ( L*(L+1._db) - (m+1._db)*(m+2._db) ) / ( L*(L+1._db) - m*(m+1._db) ) )
      if( abs(Sin_t) > eps10 ) then
        Ylmc(Lm) = exphi*( Cot_t * f * Ylmc(Lm+1) + exphi * g * Ylmc(Lm+2) )
      else
        Ylmc(Lm) = ( 0._db, 0._db )
      endif
    end do
  end do

! Calculation of Y(L,0)
  do L = 2,Lmax
    Lm = ( L * (L+1) ) / 2 + 1
    Lm1 = ( (L-1)*L ) / 2 + 1
    Lm2 = ( (L-2)*(L-1) ) / 2 + 1
    f = sqrt( (2*L + 1._db) / (2*L - 1._db) ) * (2*L - 1._db) / L
    g = - sqrt( (2*L + 1._db) / (2*L - 3._db) ) * (L - 1._db) / L
    Ylmc(Lm) = f * Cos_t * Ylmc(Lm1) + g * Ylmc(Lm2)
  end do

  Lm = 0
  do L = 0,Lmax

    L2 = ( L**2 + L ) / 2 + 1

    do m = -L,L

      Lm = Lm + 1
      Lm0 = L2 + abs(m)

      if( m < 0 ) then
        Ylmr(Lm) = (-1)**m * sqrt_2 * aimag( Ylmc(Lm0) )
      elseif( m == 0 ) then
        Ylmr(Lm) = real( Ylmc(Lm0), db )
      else
        Ylmr(Lm) = (-1)**m * sqrt_2 * real( Ylmc(Lm0), db )
      endif

    end do
  end do

  deallocate( Ylmc )

  return
end

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

! Convertion from complex Ylm to real Ylm

subroutine Ylm_ZtoK(Lmax,nlmr,Ylm)

  use declarations
  implicit none

  integer:: i, L, lm_K, Lm0, Lmax, m, m_K, n, nlmr

  real(kind=db):: c_cubic

  real(kind=db), dimension(nlmr):: Ylm, Rlm

  Rlm(:) = Ylm(:)

  Ylm(:) = 0._db
  lm_K = 0

  do L = 0,Lmax

    Lm0 = L**2 + L + 1

    do m_K = -L,L

      lm_K = lm_K + 1

      if( L /= 3 .or. ( m_K == -3 .or. m_K == 0 .or. m_K == 3 ) ) then
        n = 1
      else
        n = 2
      endif

      do i = 1,n
        call Trans_TtoK(c_cubic,.true.,i,l,m_K,m)
        Ylm(lm_K) = Ylm(lm_K) + c_cubic * Rlm( Lm0 + m )
      end do

    end do
  end do

  return
end

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

! Selection des harmoniques spheriques compte tenu des symetries

subroutine Ylmsym(iopsym,Lmax,lv,mpirank0,mv,nlms,nlmtot)

  use declarations
  implicit none

  integer:: ipr, irot, L, Lm, Lmax, m, m2, m4, ml, mpirank0, mr, nlms, nlmtot

  integer, dimension(nopsm):: iops, iopsym
  integer, dimension(nlms):: lv, mv

  logical:: imparite, parite, parrot, parsym

  iops(:) = abs( iopsym(:) )
  parsym = .false.

  Lm = 0

  do L = 0,Lmax
    do m = -L,L

! Centrosymetrie
      if( iops(25) == 1 ) then
        parsym = iopsym(25) == 1
        parite = mod(L+2*abs(m),2) == 0
        if( (parsym .and. .not. parite) .or. (.not. parsym .and. parite)  ) cycle
      endif

! Plan Ox
      if( iops(40) == 1 ) then
        parsym = iopsym(40) == 1
        m2 = mod(abs(m),2)
        parite = (m >= 0 .and. m2 == 0) .or. (m < 0 .and. m2 == 1)
        if( (parsym .and. .not. parite) .or. (.not. parsym .and. parite)  ) cycle
      endif

! Plan Oy
      if( iops(41) == 1 ) then
        parsym = iopsym(41) == 1
        parite = m >= 0
        if( (parsym .and. .not. parite) .or. (.not. parsym .and. parite)  ) cycle
      endif

! Plan Oz
      if( iops(42) == 1 ) then
        parsym = iopsym(42) == 1
        parite = mod(L+abs(m),2) == 0
        if( (parsym .and. .not. parite) .or. (.not. parsym .and. parite)  ) cycle
      endif

! Plan diagonal 0z
      if( iops(44) == 1 .or. iops(45) == 1 ) then
        parsym = ( iopsym(44) == 1 .or. iopsym(45) == 1 )
        m4 = mod(abs(m),4)
        parite = (m4 == 0 .and. m >= 0) .or. (m4 == 2 .and. m < 0)
        imparite = (m4 == 2 .and. m >= 0) .or. (m4 == 0 .and. m < 0)
        if( ( (parsym .and. .not. parite) .or. (.not. parsym .and. .not. imparite) ) &
             .and. .not. ( (m4 == 1 .or. m4 == 3) .and. (m > 0) .and. iops(18) /= 1 ) ) cycle
      endif

! Axes de rotation selon Oz
      if( iops(51) == 1 ) then
        irot = 6
        parsym = iopsym(51) == 1
      elseif( iops(55) == 1 ) then
        irot = 6
        parsym = iopsym(55) == 1
      elseif( iops(18) == 1 ) then
        irot = 4
        parsym = iopsym(18) == 1
      elseif( iops(28) == 1 ) then
        irot = 4
        parsym = iopsym(28) == 1
      elseif( iops(49) == 1 ) then
        irot = 3
        parsym = iopsym(49) == 1
      elseif( iops(53) == 1 ) then
        irot = 3
        parsym = iopsym(53) == 1
      elseif( iops(24) == 1 ) then
        irot = 2
        parsym = iopsym(24) == 1
      else
        irot = 1
      endif

      if( irot > 1) then
        mr = mod(abs(m),irot)
        ml = mod(L+abs(m),2)
        parrot = mod(irot,2) == 0
        if( abs(iopsym(28)) == 1 .and. iopsym(18) == 0 ) then
          parite = ( mr == 0 .and. ml == 0 ) .or. ( mr == 2 .and. ml == 1 )
          imparite = ( mr == 2 .and. ml == 0 ).or. ( mr == 0 .and. ml == 1 )
        else
          parite = mr == 0
          imparite = parrot .and. mr == irot/2
        endif
        if( (parsym .and. .not. parite) .or. (.not. parsym .and. .not. imparite)  ) cycle
      endif

! Axe 2 selon 0x
      if( iops(22) == 1 ) then
        parsym = iopsym(22) > 0
        parite = (m >= 0 .and. mod(L+m,2) == 0) .or. (m < 0 .and. mod(L-m,2) == 1)
        if( (parsym .and. .not. parite) .or. (.not. parsym .and. parite)  ) cycle
      endif

! Axe 2 selon 0y
      if( iops(23) == 1 ) then
        parsym = iopsym(23) > 0
        parite = (m >= 0 .and. mod(L+2*m,2) == 0) .or. (m < 0 .and. mod(L-2*m,2) == 1)
        if( (parsym .and. .not. parite) .or. (.not. parsym .and. parite)  ) cycle
      endif

! Axes 4 selon 0x ou 0y
      if( mpirank0 == 0 .and. ( iops(16) == 1 .or. iops(17) == 1 .or. iops(26) == 1 .or. iops(27) == 1 ) ) then
        call write_error
        do ipr = 6,9,3
          write(ipr,110)
        end do
        stop
      endif

      Lm = Lm + 1
      if( Lm > nlms .and. mpirank0 == 0 ) then
        call write_error
        do ipr = 6,9,3
          write(ipr,120) Lm, nlms
        end do
        stop
      endif
      lv(Lm) = L
      mv(Lm) = m

    end do
  end do

  nlmtot = Lm

  return
  110 format(/' Les axes 4 selon Ox et Oy ne sont pas programmes !')
  120 format(/' Lm =',i4,' > nlms =',i4)
end

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

! Calcul de la racine de la densite d'etats avec energie complexe.
! Prise comme la convolution par une lorenzienne de la densite d'etats du vide.

function Cal_norm(Energ,Eimag)

  use declarations
  implicit none

  integer:: je, je1, je2

  real(kind=db):: Cal_norm, de_int, Delta_E, e, E1, E2, Eimag, Eimag2, Energ, fac, k, rho, rint

  Eimag2 = Eimag**2
  de_int = abs( Eimag ) / 20
  Delta_E = 500 * abs( Eimag )
  E1 = Energ - Delta_E
  E2 = Energ + Delta_E
  je1 = nint( E1 / de_int )
  je1 = max( 1, je1 )
  je2 = nint( E2 / de_int )
  je2 = max( je2, 10 )

  rint = 0._db
  rho = 0._db

  do je = je1,je2
    e = ( je - 0.5_db ) * de_int
    k = sqrt( e )
    fac = de_int / ( ( Energ - e )**2 + Eimag2 )
    rho = rho + k * fac
    rint = rint + fac
  end do
  rho = rho * abs(Eimag) / pi**2

  rint = rint * abs(Eimag) / pi

  Cal_norm = sqrt( rho )

end

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

subroutine cnlmmax(Lmax,Lv,nlmam,nlm)

  implicit none

  integer:: Lm, Lmax, nlm, nlmam

  integer, dimension(nlmam):: Lv

  do Lm = nlmam,1,-1
    if( Lv(Lm) <= Lmax ) exit
  end do
  nlm = Lm

  return
end

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

subroutine irep_comp(Atom_comp0,Green,iopsymr,irep_util,karact,ngrph,nspino,Repres_comp)

  use declarations
  implicit none

  integer, intent(in):: ngrph, nspino
  logical, intent(in):: Atom_comp0, Green

  integer, dimension(nopsm), intent(in):: iopsymr
  integer, dimension(nrepm,2), intent(in):: irep_util

  complex(kind=db), dimension(nopsm,nrepm), intent(in):: karact
  logical, dimension(ngrph), intent(out):: Repres_comp

  integer igrph, irep, is, isp

  Repres_comp(:) = .false.

  do igrph = 1, ngrph
    do isp = 1,nspino
      irep = abs( irep_util(igrph,isp) )
      if( green ) then
        if( irep == 0 ) cycle
      else
! Il n'y a pas de couplage up-down dans le cas suivant
        if( irep == 0 ) irep = abs( irep_util(igrph,3-isp) )
        if( .not. Atom_comp0 ) cycle
      end if
      do is = 1,nopsm
        if( green .and. iopsymr(is) == 0 ) cycle
        if( abs( aimag(karact(is,irep)) ) > eps10 ) Repres_comp(igrph) = .true.
      end do
    end do
  end do

  return
end

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

! Calculation of the unit cell volume

function Cal_Volume_maille(axyz,angxyz)

  use declarations
  implicit none

  real(kind=db):: Cal_Volume_maille, cosa, cosb, cosc
  real(kind=db), dimension(3):: angxyz, axyz

  cosa = cos( angxyz(1) )
  cosb = cos( angxyz(2) )
  cosc = cos( angxyz(3) )
  Cal_Volume_maille = axyz(1) * axyz(2) * axyz(3) * sqrt( 1 - cosa**2 - cosb**2 - cosc**2 + 2*cosa*cosb*cosc )

  return
end

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

! Wigner Matrix for j=1/2

Subroutine Wigner_one_half_cal(icheck,natome,Rot_atom,Wigner_one_half)

  use declarations
  implicit none

  integer:: ia, icheck, natome

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

  real(kind=db):: alfa, beta, gamma

  real(kind=db), dimension(3,3):: Mat
  real(kind=db), dimension(3,3,natome):: Rot_atom

  do ia = 1,natome
    Mat(:,:) = Rot_atom(:,:,ia)
    Mat = transpose( Mat )

    call Euler_mat(icheck,Mat,alfa,beta,gamma)
    call WignerMat_J_One_half(alfa,beta,gamma,DJ_One_half)
    Wigner_one_half(:,:,ia) = DJ_One_half(:,:)
  end do

  return
end

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

! Wigner Matrix for j=1/2

Subroutine WignerMat_J_One_half(alfa,beta,gamma,DJ_One_half)

  use declarations
  implicit none

  complex(kind=db), dimension(2,2):: DJ_One_half

  real(kind=db):: alfa, beta, cos_b, gamma, sin_b

  cos_b = cos( beta / 2 )
  sin_b = sin( beta / 2 )

  DJ_One_half(1,1) = cos_b * exp( - img * 0.5_db * ( alfa + gamma ) )
  DJ_One_half(1,2) = - sin_b * exp( - img * 0.5_db * ( alfa - gamma ) )
  DJ_One_half(2,1) = sin_b * exp( - img * 0.5_db * ( - alfa + gamma ) )
  DJ_One_half(2,2) = cos_b * exp( - img * 0.5_db * ( - alfa - gamma ) )

  return
end




