      subroutine orb_at_corresp(info1)
      use mod_lirorb
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(50000) namel
      character(*) info1
      character(18),allocatable,dimension(:) :: tipo
      character(18) tipotmp
      character(5),allocatable,dimension(:) :: atom,atomtmp,atom0
      character(5) atomref
      character(8),allocatable,dimension(:) :: label
      character(9),allocatable,dimension(:) :: labeltmp,label2
      double precision,allocatable,dimension(:) :: occup
      double precision,allocatable,dimension(:,:) :: orb
      integer,allocatable,dimension(:) :: multat,numat
      logical(1),allocatable,dimension(:) :: yy
      dimension isym(8),poids(8),loc(1)
      character,dimension(8)  :: suffix=(/'a','b','c','d','e','f'
     *,'g','h'/)
      yw=.false.
!
! Lecture Info
!
      open(99,file=INFO1,status='old')
      call LECNAM('&COST_AO',namel,99,ierr,0)
      call nameli(namel,NATOM,'NATOM',4)
      allocate(atom(natom),atomtmp(natom),atom0(natom))
      allocate(multat(natom))
      atom=' '
      call namela(namel,ATOM,'ATOM')
      atom0=atom
      if(yw) then
         do k=1,natom
            print*,'atom',atom(k),k
         enddo
      endif
      call nameli(namel,noa,'NORB',4)
      if(yw)print*,'noa',noa
      allocate(label(noa))
      allocate(label2(noa))
      allocate(labeltmp(noa))
      allocate(yy(noa))
      call namela(namel,label,'LABEL')
      if(yw) then
         do k=1,noa
            print*,'label  ',label(k),k
         enddo
      endif
      call LECNAM('&COST_MO',namel,99,ierr,0)
      call nameli(namel,norb,'NORB',4)
      call nameli(namel,ngel,'FROZEN',4)
      close(99)
!
! Calcul multat
! Ajout d'un suffixe a atom
!
      multat=0
      do k=1,natom
         if(multat(k)/=0) cycle
         m=1
         do l=k+1,natom
            ll=l
            if(atom(k)==atom(l)) then
               m=m+1
            else
               multat(k:l-1)=m
               ii=0
               do i=k,l-1
                  ii=ii+1
                  lt=len_trim(atom(i))+1
                  atom(i)(lt:lt)=suffix(ii)
                  if(yw)print*,'I',i,ii,atom(i),'  ',suffix(ii)
               enddo
               exit
            endif
         enddo
         if(k==natom) then
                 if(yw)print*,'k==natom, modif',atom(k)
            multat(natom)=1
            lt=len_trim(atom(k))+1
            atom(k)(lt:lt)='a'
         endif
         if(ll==natom.and.atom(ll)==atom(ll-1)) then
            multat(k:natom)=m
            ii=0
            do i=k,natom
               ii=ii+1
               lt=len_trim(atom(i))+1
               atom(i)(lt:lt)=suffix(ii)
            enddo
         endif
      enddo
      if(yw) then
         do k=1,natom
            print*,'multat  ',atom(k),multat(k),k
         enddo
      endif
!
! Lecture Orbitales et labels d'OL
!
      call lirorb('ORB_IJKLOC',noa,nsym,isym,98,99,ifiloc=97,ifillab=96)
      rewind 97
      allocate(orb(noa,noa))
      read(98) orb
      allocate(tipo(noa))
      read(96) tipo
      if(yw) then
         do k=1,noa
            print*,'tipo  ',tipo(k),k
         enddo
      endif
      close(97,status='delete')
      close(96,status='delete')
      close(98,status='delete')
      close(99)
!
! Appartenance des atomes aux labels d'OA
! ajout du suffixe aux labels d'OA
!
      allocate(numat(noa))
      do i=1,natom
         l=len_trim(atom(i))-1
         m=0
         do j=1,noa
            if(label(j)(1:l)==atom(i)(1:l)) m=m+1
         enddo
         nb=m/multat(i)
         if(yw)print*,'nb ',atom(i),nb
         m=0
         do j=1,noa
            if(label(j)(1:l)==atom(i)(1:l)) then
               m=m+1
               numat(j)=(m-1)/nb+1
            endif
         enddo
      enddo
      do k=1,noa
         l=len_trim(label(k)(1:4))
         label2(k)=label(k)(1:4)//' '//label(k)(5:8)
         label2(k)(l+1:l+1)=suffix(numat(k))
      enddo
      if(yw) then
         do k=1,noa
            print*,'label2,numat  ',label2(k),numat(k),k
         enddo
      endif
      !call mscript(orb)
!
! Correspondance OL atomes
!
! Methode : 1. prendre une OL iol
!           2. rechercher un atome iat dedans
!           3. noter cet atome
!           4. lui ajouter le suffixe a, calculer le poids des
!              OA contenant l'atome//a
!           5. Recommencer avec b,c...
!           6. prendre le plus gros poids, corriger le nom de l'OL
      if(yw)print*,'========================'
! 1. prendre une OL iol
      ! boucle sur les OL
      open(99)
      do iol=1,noa
         if(tipo(iol)(1:1)=='A') cycle
         if(tipo(iol)(1:1)=='G') cycle
         atomtmp=atom
         labeltmp=label2
         rewind 99
         yy=.false.
         if(yw)print*,'************* OL  ',tipo(iol),iol
         tipotmp=tipo(iol)
         atomref=' '
         !  boucle sur les atomes qu'on peut trouver dans cette OL
         do
            if(yw) then
            !do k=1,natom ; print*,k,atomtmp(k) ; enddo
            endif
            ! 2. rechercher un atome iat dedans
            ytrouve=.false.
            do iat=1,natom
               l=len_trim(atomtmp(iat))
               ii=index4(tipotmp,atomtmp(iat)(1:l-1),atom0,natom)
               if(ii/=0) then
                  ! 3.  noter cet atome
                  atomref=atomtmp(iat)(1:l-1)
                  if(yw)
     *            print*,'------ on a trouve l''atome ',iat,atomref
                  iatref=iat
                  ytrouve=.true.
                  exit
               endif
            enddo
            if(.not.ytrouve) exit
            ! 4. lui ajouter le suffixe a, calculer le poids des
            !    OA contenant l'atome//a
            ! 5. Recommencer avec b,c...
            poids=0.d0
            do k=1,multat(iatref)
               atomref(l:l)=suffix(k)
               if(yw)print*,'ajout suffixe ',atomref
               do ioa=1,noa
                  jj=index(labeltmp(ioa)(1:5),atomref)
                  if(jj/=0) poids(k)
     *            =poids(k)+orb(ioa,iol)*orb(ioa,iol)
                  if(yw.and.jj/=0)print*,'indice',
     *            ioa,labeltmp(ioa),orb(ioa,iol)
               enddo
            enddo
            ! Ici, poids(:) contient le poids des atomes a,b,c...
            ! dans l'OL
            loc=maxloc(poids(1:multat(iatref)))
            ! loc donne la place du plus grand poids, donc a,b, ou c...
            ! correction de labeltmp : on met a '????' l'atome deja
            ! utilise
            do ioa=1,noa
               jj=index(labeltmp(ioa)(1:5),
     *         atomref(1:l-1)//suffix(loc(1)))
               if(jj/=0) labeltmp(ioa)(1:5)='?????'
            enddo
            if(yw)
     *      print*,'poids ',k,atomref,poids(1:multat(iatref)),loc(1)
            tipotmp(ii:ii+l-2)=' '
            write(99,'(2i4,a)') ii,ii+l-2,trim(atomtmp(iat)(1:l-1)//
     *      suffix(loc(1)))
!           on ne recherchera plus cet atome, on le met a '????'
            do k=1,natom
               if(atomtmp(k)==trim(atomtmp(iat)(1:l-1)//
     *         suffix(loc(1)))) then
                  atomtmp(k)='????'
                  exit
               endif
            enddo
            if(yw)
     *      print*,'ecrit sur 99',ii,ii+l-2,trim(atom(iat)(1:l-1)//
     *      suffix(loc(1)))
         enddo
         rewind 99
         kk=0
         do
            read(99,'(2i4,a)',end=1) i,j,atomref
            if(yw)print*,'lu sur 99', i,j,atomref
            i=i+kk
            j=j+kk
            kk=kk+1
            ll=len_trim(tipo(iol))
            tipo(iol)(j+2:ll+1)=tipo(iol)(j+1:ll)
            tipo(iol)(i:j+1)=atomref
         enddo
 1       continue
         if(yw)print*,'tipo',iol,tipo(iol)
      enddo
      close(99,status='delete')
      if(yw) then
         do iol=1,noa
            print*,'tipo',iol,tipo(iol)
         enddo
      endif
      open(99,form='unformatted',file='ORB_AT_CORRESP',status='unknown')
      write(99) natom,atom(1:natom)
      write(99) noa,label(1:noa)
      write(99) tipo(ngel+1:ngel+norb)
      if(yw)print*,'fin orb_at_corresp. Ecriture sur ORB_AT_CORRESP'
      if(yw)write(6,*) natom,atom(1:natom)
      if(yw)write(6,*) noa,label(1:noa)
      if(yw)write(6,*) tipo(ngel+1:ngel+norb)
      return
      end
