      subroutine frag
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxorb=1024,nsymz=8)
      parameter(maxorbcas=16)
      character*1280 namel
      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
     *,numt(maxorb),nump(maxorb),ntac,nutac(maxorbcas),ms2
      common/fr/nfrag,iorbfr(maxorbcas,maxorbcas),norbfr(maxorbcas)
     *,lie(maxorbcas,maxorbcas),ion,iondis,ivois(3,maxorbcas,maxorbcas)
     *,nbvois(3,maxorbcas)
      dimension ifr(maxorbcas),kfinfr(0:maxorbcas),nelfr(maxorbcas)
      dimension iappfr(maxorbcas)
      dimension l(maxorb)
      ion=1
      iondis=1
      print*,' '
      print*,'----------------------------- '
      print*,'           FRAGMENTS          '
      print*,'----------------------------- '
      do k=1,noac
         ifr(k)=0
         nelfr(k)=0
      enddo
      call LECNAM('&FR',namel,94,ierr,1)
      call nameli(namel,IFR(1),'IFR',4)
      call nameli(namel,NELFR(1),'NELFR',4)
      call nameli(namel,ION,'ION',4)
      call nameli(namel,IONDIS,'IONDIS',4)
      kk=0
      do k=1,nfrag
         kk=kk+nelfr(k)
      enddo
      if(kk.ne.nelac) then
         print*,'le total d''electrons des fragments n''est pas egal'
     *   ,'a nelac'
         print*,kk,' electrons dans les fragments, noac=',noac
         stop
      endif
      if(ifr(1).ne.0) then
         do k=1,nfrag
            if(ifr(k).eq.0) then
               write(75,*) k-1,' fragments donnes, nfrag=',nfrag,'$'
               call scril
               stop
            endif
         enddo
         mfrag=0
         kfinfr(0)=0
         do k=1,nfrag
            kfinfr(k)=kfinfr(k-1)+ifr(k)
         enddo
         do k=1,nfrag
            do i=1,noac
               iorbfr(k,i)=0
            enddo
         enddo
         kk=0
         do k=1,nfrag
            norbfr(k)=kfinfr(k)-kfinfr(k-1)
            do i=1,norbfr(k)
               kk=kk+1
               iorbfr(k,i)=kk
            enddo
         enddo
         print*,'norbfr',(norbfr(k),k=1,nfrag)
         print*,'iorbfr'
         do k=1,nfrag
            print*,k,' : ',(iorbfr(k,kk),kk=1,noac)
         enddo
         do k=1,nfrag
            write(75,*)'fragment',k,' : orbitales',(numac(ll),ll=
     *      kfinfr(k-1)+1,kfinfr(k)),' - nombre d''electrons : ',
     *      nelfr(k),'$'
            call scril
         enddo
      endif
c
c        lecture des liaisons
c
      do k=1,nfrag
         do kk=1,nfrag
            lie(kk,k)=0
         enddo
      enddo
      lu=0
 10   continue
      call LECNAM('&LINK',namel,94,ierr,0)
      n=2
      l(1)=0
      call nameli(namel,n,'N',4)
      call nameli(namel,L(1),'L',4)
      if(l(1).ne.0) then
         do k=1,n
            do kk=k+1,n
               lie(l(k),l(kk))=1
               lie(l(kk),l(k))=1
               lu=1
            enddo
         enddo
         goto 10
      endif
c        liaisons lointaines :
      if(lu.eq.1) then
         do i=1,nfrag
            do j=i+1,nfrag
               if(lie(i,j).eq.0) then
                  lie(i,j)=nfrag
                  lie(j,i)=nfrag
               endif
            enddo
         enddo
         do ii=1,nfrag
            do i=1,nfrag
               do j=i+1,nfrag
                  if(lie(i,j).eq.nfrag) then
                     do k=1,nfrag
                        if(k.ne.i.and.k.ne.j) then
                           lie(i,j)=min(lie(i,j),lie(i,k)+lie(j,k))
                           lie(j,i)=lie(i,j)
                        endif
                     enddo
                  endif
               enddo
            enddo
         enddo
      endif
      if(lu.eq.0) then
         do k=1,nfrag
            do kk=k+1,nfrag
               lie(kk,k)=1
               lie(k,kk)=1
            enddo
         enddo
      endif
      print*,'liaisons des fragments'
      do k=1,nfrag
         print*,(lie(k,kk),kk=1,nfrag)
      enddo
      print*,'cout d''un fragment ionique',ion
      print*,'cout d''un saut par liaison',iondis
c
c     liste des voisins de chaque fragment
c
      do i=1,nfrag
         do j=1,3
            nbvois(j,i)=0
         enddo
      enddo
      do i=1,nfrag
         do j=1,nfrag
            do k=1,3
               ivois(k,j,i)=0
            enddo
         enddo
      enddo
      do i=1,nfrag
         do j=1,nfrag
            if(i.ne.j) then
            k=lie(j,i)
            if(k.le.3) then
               nbvois(k,i)=nbvois(k,i)+1
               ivois(k,nbvois(k,i),i)=j
            endif
            endif
         enddo
      enddo
      do i=1,nfrag
         print*,'voisins du fragment',i
         do j=1,3
            print*,'voisins d''ordre',j,' : ',(ivois(j,
     *      k,i),k=1,nbvois(j,i))
         enddo
      enddo
            
            
            
      
      return
      end
