!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! J'ai change  character(4) en  character(5) pour atom at1 ...
! Ne pas s'etonner si ca ne marche pas !

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine atomliens(ilpair1)
      use mod_lirorb
      use mod_script
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      parameter(maxat=1000)
      character(5) atom(maxat)
      character(50000) namel,namel2
      character(4) namel3
      character(80) namel1
      character(18),allocatable :: orb(:)
      character(5) at1,at2,at3
      integer :: isym1(8)
      logical,allocatable :: y(:),yy(:,:)
      logical(1),allocatable,dimension(:,:) :: yll
      dimension ilpair1(2,noc*nvirt)
      real(8),allocatable,dimension(:,:) :: coor
      yw=.false.
      !
      !
      ! relecture de la file Info
      !
      open(99)
      open(45,file=info1,status='old')
      call LECNAM('&COST_MO',namel,45,ierr,0)
      call nameli(namel,FROZEN,'FROZEN',4)
      call nameli(namel,DELETE,'DELETE',4)
      print*,'Atomes ',atom0(1:natom)
      allocate(yll(noc,noc+1:norb))
      allocate(coor(3,natom))
      !print*,'natom',natom
      call nameld(namel,COOR,'COOR',8)
      
      yll=.false.
!
      
      close(45)
      !
      ! lecture des labels 
      !
      close(71,status='delete')
      close(73,status='delete')
      close(74,status='delete')
      nlc=0
      nlco=0
!      call lirorb('ORB_IJKLOC',norb1,nsymbid,isym1,71,72,ifiloc=73
!     *,ifillab=74)
      allocate(orb(norb),y(norb))
      !
      ! Lecture de la file ORB_AT_CORRESP
      !
      open(98,file='ORB_AT_CORRESP',status='old',form='unformatted')
      read(98) natom,atom(1:natom)
      read(98) 
      read(98) orb(1:norb)
      close(98)
      if(yw) then
         print*, natom,atom(1:natom)
         print*, orb(1:norb)
         print*,'orbitales'
         do k=1,norb
            print*,k,'   ',orb(k)
         enddo
      endif
!
!     Traitement des atomes multiples
!

      rewind 93
      call titre('CAS/orb#',20)
      !
      ! Liaisons entre CAS et orb sur un atome du CAS
      !
      print*,' '
      print*,'---------------------------------------------'
      print*,'Liaisons entre CAS et orb sur un atome du CAS'
      print*,'---------------------------------------------'
      y=.false.
      do i=1,natom
         namel=' '
         ifin=0
         ii=0
         if(i>1) then
            if(atom(i)==atom(i-1)) cycle
         endif
         jj=0
         do j=1,norb
            if(orb(j)(1:1)=='A') then
               !print*,'atom',atom(1:natom)
               !print*,orb(j)(3:12),' ',trim(atom(i))
!               jj=index3(orb(j)(3:12),trim(atom(i)),
!     *         atom,natom)
               l=len_trim(atom(i))
               jj=index(orb(j)(3:12),atom(i)(1:l-1))
               !print*,'jj',jj
               if(jj/=0) exit
            endif
         enddo
         if(jj/=0) then
            print*,' '
            print*,'=========Atome actif  ',trim(atom(i))
            print*,'         ---> sont liees au CAS :'
            call ecrichar(namel,' ',-80)
            ! L'Atome i apparait dans le CAS
            do j=1,norb
               if(y(j)) cycle
               if(orb(j)(1:1)=='A') cycle
               jjj=index3(orb(j)(3:12),trim(atom(i)),
     *         atom,natom)
               if(jjj/=0) then
                  nlc=nlc+1
                  if(j<=noc) nlco=nlco+1
                  write(99,*) j
                  if(index(namel,trim(orb(j)))==0)
     *            call ecrichar(namel,trim(orb(j)),1)
                  y(j)=.true.
               endif
            enddo
         endif
         call ecrichar(namel,' ',0)
      enddo
      
      !
      ! Lecture des donnees de liaisons entre atomes et CAS
      !
      print*,' '
      print*,'----------------------------'
      print*,'liaisons entre atomes et CAS'
      print*,'----------------------------'
      print*, ' '
      rewind 93
      do
         read(93,'(a80)',end=1) namel1
         namel1=adjustl(namel1)
         call maj(namel1,80)
         if(namel1(1:3)/='CAS') cycle
         ii=1
         namel=' '
         do
            read(93,'(a80)') namel(ii:ii+79)
            namel(ii:ii+79)=adjustl(namel(ii:ii+79))
            call maj(namel(ii:ii+79),80)
            l=len_trim(namel)
            if(namel(ii:ii+2)=='FIN'.or.namel(ii:ii+2)=='END'.or.
     *      namel(ii:ii+2)=='ATO') then
               namel(ii:ii+3)=' '
               exit
            endif
            print*,'En donnee :   ',namel(ii:l)
            print*,' '
            ii=l+2
         enddo
         exit
      enddo
 1    continue
      !print*,'CAS-AT ',trim(namel)
      l=len_trim(namel)
      call suppdb(namel,l)
      l=len_trim(namel)
      !print*,'CAS-AT ',trim(namel)
      !
      ! liaisons orbitales/cas
      !
      m=1
      do
         ib=index(namel(m:l+1),' ')+m-1
         if(ib<=1) exit
         at1=' '
         read(namel(m:ib-1),'(a)') at1
         m=ib+1
         print'(a,a6)','========liaison CAS ',at1
         print*,'         ---> sont liees au CAS :'
         call ecrichar(namel2,' ',-80)
         !print*,'at1 ',at1
         do i=1,norb
            if(orb(i)(1:1)=='A') cycle
            if(y(i)) cycle
            if(index3(orb(i)(3:12),trim(at1),atom0,natom)/=0) then
               call ecrichar(namel2,trim(orb(i)),1)
               y(i)=.true.
               nlc=nlc+1
               if(i<=noc) nlco=nlco+1
               write(99,*) i
            endif
         enddo
         call ecrichar(namel2,' ',0)
         if(m>l) exit
      enddo
      allocate(ilc(nlc))
      rewind 99
      do k=1,nlc
         read(99,*) ilc(k)
      enddo
      call reor(nlc,ilc,idum)
      nlcv=nlc-nlco
!
      call titre('orb/orb#',20)
      !
      ! Liaisons entre orbitales contenant le meme atome
      !
      print*, ' '
      print*,'Liaisons entre orbitales contenant le meme atome'
      print*, ' '
      nlpairp=0
      allocate(yy(noc,ninac+noac+1:norb))
      yy=.false.
      do i=1,natom
         yaecrire=.true.
         do j=1,noc
         call ecrichar(namel2,' ',-80)
            yaecrire2=.true.
            if(orb(j)(1:1)=='A') cycle
            do k=noc+1,norb
               if(orb(k)(1:1)=='A') cycle
               if(yy(j,k)) cycle
               jj=index3(orb(j)(3:12),trim(atom(i)),atom,natom)
               if(jj/=0) then
                  kk=index3(orb(k)(3:12),trim(atom(i)),
     *            atom,natom)
                  if(kk/=0) then
                     if(yy(j,k)) cycle
                     !write(75,*)i,j,k,jj,kk,atom(i),orb(j),orb(k),'$'
                     !call scril
                     nlpairp=nlpairp+1
                     ilpair1(1,nlpairp)=j
                     ilpair1(2,nlpairp)=k
                     yll(j,k)=.true.
                     if(yaecrire) then
                        print*,' '
                        print*,'========Atome ',trim(atom(i))
                        yaecrire=.false.
                     endif
                     if(yaecrire2) then
                        print*,' '
                        print*,'====liaison ',trim(orb(j))
                        yaecrire2=.false.
                     endif
                     if(yw)print'(a5,a10,a1,a12,a1,a12,2i4,i6)',
     *               'lien ',trim(atom(i)),' ',trim(orb(j)),' ',
     *               trim(orb(k)),j,k,nlpairp
                     call ecrichar(namel2,trim(orb(k)),1)
                  endif
               endif
            enddo
         call ecrichar(namel2,' ',0)
         enddo
      enddo
      !
      ! Lecture des donnees de liaisons entre atomes
      !
      print*,' '
      print*,'liaisons entre atomes'
      print*,' '
      do k=1,natom
         print'(a4,3f10.6)',atom(k),coor(:,k)
      enddo
      call atomliens2(atom,coor)
      rewind 97
      call ecrichar(namel2,' ',-80)
      do
         ! on lit les liaisons entre atomes
         ! on les ecrit dans le caractere namel2
         read(97,'(a80)',end=2) namel(ii:ii+79)
         print*,namel(ii:ii+79)
         namel(ii:ii+79)=adjustl(namel(ii:ii+79))
         l=len_trim(namel)
         !print*,'lu',namel(ii:l)
         call ecrichar(namel2,namel(ii:l),1)
      enddo
      call ecrichar(namel2,' ',0)
 2    continue
      !
      ! Recherche des liens
      !
      ll=0
      l=len_trim(namel2)
      namel2(2:l+1)=namel2(1:l)
      namel2(1:1)=' '
      namel(1:l+1)=namel2(1:l+1)
      do
         k=index(namel,'-')
      !print*,'namel',trim(namel)
      !   print*,'place - ',k
         if(k==0) exit
         do j=k-1,k-4,-1
            if(namel(j:j)==' ') then
               at1=namel(j+1:k-1)
               exit
            endif
         enddo
         do j=k+1,k+4
            if(namel(j:j)==' ') then
               at2=namel(k+1:j-1)
               exit
            endif
         enddo
         namel(k:k)=' '
         ll=ll+1
         print*,' '
         print*,'====liaison   ',at1,' ',at2
!
! Double boucle sur les orbitales
!
         call ecrichar(namel2,' ',-80)
         do icas=1,2
            do j=1,noc
               if(orb(j)(1:1)=='A') cycle
            !print*,'j0',j,trim(orb(j))
               if(index3(orb(j),at1,atom,natom)/=0) then
            !print*,'j',j,trim(orb(j))
                  do k=noc+1,norb
                     if(orb(k)(1:1)=='A') cycle
                     if(index3(orb(k),at2,atom,natom)/=0) then
                    !print*,'j,k',j,k,trim(orb(j)),' ',trim(orb(k))
                        if(yll(j,k)) cycle
                        nlpairp=nlpairp+1
                        ilpair1(1,nlpairp)=j
                        ilpair1(2,nlpairp)=k
                        yll(j,k)=.true.
                        call ecrichar(namel2,trim(orb(j))//' '//
     *                  trim(orb(k))//' ;  ',1)
                     endif
                  enddo
            !      print*,'icas',icas
               endif
            enddo
            at3=at1
            at1=at2
            at2=at3
         enddo
         call ecrichar(namel2,' ',0)
      enddo
      close(98,status='delete')
      return
      end
       function index3(orb,at,atom,natom)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Fonction index modifiee
! index3=index si at apparait dans orb ET...
! si il n'ya a pas d'autre atome dont le nom contient le nom de at
! et dont le nom est inclus dans orb
!
! ex orb=C12C3
! at=C1
! index('C12C3','C1')==1, index3('C12C3','C1')==0
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(*) orb,at
      character(5) atom(natom)
      if(index(trim(orb),trim(at))==0) then
        !print*,'coucou1',trim(orb),' ',trim(at)
         index3=0
         return
      else
        !print*,'coucou2',trim(orb),' ',trim(at)
         l=len_trim(at)
         do k=1,natom
            ll=len_trim(atom(k))
            if(ll<=l) cycle
            if(index(atom(k),trim(at))/=0) then
               !print*,'coucou3'
               if(index(orb,trim(atom(k)))==0) then
                  !print*,'coucou4'
                  index3=0
                  return
               endif
            endif
         enddo
         index3=index(orb,trim(at))
      endif
      return
      end
       subroutine atomliens2(atom,coor)
      use mod_script
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      parameter(maxat=1000)
      character(5) atom(maxat)
      character(10000) namel1
      character(4) namel3
      dimension coor(3,natom)
      yw=.false.
      ! On met une donnee par ligne
      rewind 93
      if(yw)print*,'entree atomliens2'
      open(98)
      call LECNAM('&LOC_AT',namel1,93,ierr,0)
      if(ierr==1) then
         print*,'liens=''ATOM'', &LOC_AT absente'
         stop
      endif
!      do
!         namel1=' '
!         read(93,'(a80)') namel1
!         !call maj(namel1,80)
!         namel1=adjustl(namel1)
!         namel3=namel1(1:4)
!         yder=namel3(1:3)=='FIN'.or.namel3(1:3)=='END'
!         call ligne_ligne(98,namel1(1:80))
!         if(yder) exit
!      enddo
!
!  Donnees de liaison atome/atome
!  Gestion des donnees multiples
!
!     Ecriture sur 97 des donnees 'ATOM'
!
      do 
         read(93,'(a80)') namel1
         namel1=adjustl(namel1)
         if(yw)print*,trim(namel1)
         namel3=namel1(1:4)
         call maj(namel3,4)
         if(yw.and.namel3=='ATOM') print*,'exit ATOM'
         if(namel3=='ATOM') exit
      enddo
      nlec=0
      do 
         read(93,'(a80)') namel1
         namel1=adjustl(namel1)
         if(yw)print*,trim(namel1)
         namel3=namel1(1:4)
         call maj(namel3,4)
         if(yw)print*,'exit'
         if(namel3(1:3)=='FIN'.or.namel3(1:3)=='END'
     *   .or.namel3(1:3)=='CAS') exit
         write(98,'(a80)') namel1
         nlec=nlec+1
      enddo
!
! Traitement des donnees ecrites sur 98
! On va les traiter 2 fois, car il peut y avoir jusqu'a 2 "*" 
! dans chaque ligne (icas=1,2)
!
      ifilr=98
      ifilw=97
      do icas=1,2
         rewind ifilr
         rewind ifilw
         nlec2=0
         ! boucle sur les lignes a lire
         do ilec=1,nlec
            namel1=' '
            read(ifilr,'(a80)') namel1
            l=len_trim(namel1)
            i=index(namel1,'*')
            if(i>0) l1=i+index(namel1(i:l),' ')-1
            !
            ! C*-C1b dist=1.6 ANGSTROM
            !  |    |                |
            !  i    l1               l
            !
            if(yw)print*,'lu ',trim(namel1),l,i
            if(i==0) then
               ! pas de "*", on recopie la ligne sur ifilw
               write(ifilw,'(a)') trim(namel1)
               if(yw)print*,'ecrit',ifilw,trim(namel1)
               if(yder) exit
            else
               j=index(namel1,'-')
               if(j>i) then
                  ! * sur 1er atome : on remplace l'*
                  if(yw)print*,'1er atome'
                  do k=1,natom
                     if(index(atom(k),namel1(1:i-1))/=0) then
                        write(ifilw,'(a)') 
     *                  trim(atom(k))//namel1(j:l)
                        if(yw)print*,'Ecrit',ifilw,
     *                  trim(atom(k))//namel1(j:l)
                        nlec2=nlec2+1
                     endif
                  enddo
               else
                  ! * sur 2eme atome : on remplace l'*
                  if(yw)print*,'2eme atome'
                  do k=1,natom
                     if(yw)print*,atom(k),namel1(j+1:l1-2)
                if(yw)print*,index(atom(k),namel1(j+1:l1-2))
                     if(index(atom(k),namel1(j+1:l1-2))/=0) then
                        write(ifilw,'(a)') 
     *                  namel1(1:j)//trim(atom(k))//namel1(l1:l)
                        if(yw)print*,'Ecrit',ifilw,
     *                  namel1(1:j)//trim(atom(k))//namel1(l1:l)
                        nlec2=nlec2+1
                     endif
                  enddo
               endif
            endif
         enddo
         ifilr=97
         ifilw=98
         nlec=nlec2
      enddo
!
! distances
!
      ! boucle sur les lignes de liaisons
      rewind 98
      rewind 97
      if(yw)print*,'nlec2',nlec2
      do
         read(98,'(a)',end=1) namel1
         if(yw)print*,'DIST ',trim(namel1)
         l=len_trim(namel1)
         j=index(namel1,'-')
         l1=j+index(namel1(j:l),' ')-1
         ! On cherche iat1,iat2, numeros des atomes de la liaison
         do k=1,natom
            if(atom(k)==namel1(1:j-1)) then
               iat1=k
               exit
            endif
         enddo
         do k=1,natom
            if(atom(k)==namel1(j+1:l1-1)) then
               iat2=k
               exit
            endif
         enddo
         if(yw)print*,'iat1,iat2',iat1,iat2
         if(iat1==iat2) cycle
         ! lecture distance max
         call maj(namel1(l1:l),l-l1+1)
         namel1(l+2:l+2)='/'
         ind=index(namel1,'DIST=')
         ydist=ind/=0
         if(ydist) then
            ind=index(namel1(ind:l),' ')+ind-1
            namel1(ind:ind)=','
            if(yw)print*,'DIST ',trim(namel1)
            call nameld(namel1,distmax,'DIST',8)
            if(yw)print*,'distmax',distmax
            if(index(namel1,'ANGS')/=0) distmax=distmax/0.51929
            if(yw)print*,'distmax',distmax
            ! calcul distance
            dist=(coor(1,iat1)-coor(1,iat2))**2+
     *      (coor(2,iat1)-coor(2,iat2))**2+
     *      (coor(3,iat1)-coor(3,iat2))**2
            dist=dsqrt(dist)
            if(yw)print*,trim(namel1),'  ',atom(iat1),atom(iat2),
     *      iat1,iat2,dist
            if(dist>distmax) cycle
         endif
         write(97,'(a)') namel1(1:l1-1)
      enddo
 1    continue
      if(yw) then
         do k=1,natom
            print'(a4,3f10.6)',atom(k),coor(:,k)
         enddo
      endif

      if(yw)print*,'sortie atomliens2'
      return
      end
