program cevp
c     deletes far molecules from tinker geometry
      implicit none
      integer*4 nat,i,ix,ntree,ia,iaa,ib,im,ii,nat0,imt
      real*8 cm(3),dl
      character*80 s80
      character*11,allocatable::s(:)
      real*8,allocatable::r(:)
      integer*4 ,allocatable::it(:),bt(:,:),ioff(:),tree(:),nn(:),
     1dli(:,:),tt(:)
      call getarg(1,s80)
      read(s80,*)dl
      open(9,file='IN')
      read(9,*)nat
      nat0=nat
      allocate(r(3*nat),it(nat),bt(nat,4),s(nat),ioff(nat),tree(nat),
     1nn(nat),dli(nat,nat),tt(nat))
      do 1 i=1,nat
      read(9,900)s(i),(r(ix+3*(i-1)),ix=1,3),it(i),(bt(i,ix),ix=1,4)
      tt(i)=0
      do 1 ix=1,4
1     if(bt(i,ix).ne.0)tt(i)=ix
900   format(a11,3f12.6,5i6)
      close(9)
c     identify molecules
      im=0
      imt=0
      ioff=1
333   do 2 i=1,nat
      if(ioff(i).ne.0)then
c      initiate new:
       ntree=0
       call addta(ntree,tree,i,ioff)
c      atoms hanging on ntree atoms:
222    do 4 ia=1,ntree
       do 5 ix=1,tt(tree(ia))
       ib=bt(tree(ia),ix)
c      is the atom already in:
       do 9 iaa=1,ntree
9      if(ib.eq.tree(iaa))goto 5
c      add atom ib and start over
       call addta(ntree,tree,ib,ioff)
       goto 222
5      continue
4      continue
       im=im+1
       imt=imt+1
c      write(6,601)im,(tree(ia),ia=1,ntree)
c01    format(' Molecule',i6,': ',60i6)
       cm=0.0d0
       do 6 ix=1,3
       do 7 ia=1,ntree
7      cm(ix)=cm(ix)+r(ix+3*(tree(ia)-1))
6      cm(ix)=cm(ix)/dble(ntree)
       if(cm(1)**2+cm(2)**2+cm(3)**2.lt.dl**2)then
c       keep this molecule
        im=im-1
       else
c       add to delete list
        nn(im)=ntree
        do 8 ia=1,ntree
8       dli(im,ia)=tree(ia)
        write(6,602)im,imt,(tree(ia),ia=1,ntree)
602     format(' Delete Molecule',2i6,': ',60i6)
       endif
       goto 333
      endif
2     continue
      write(6,603)im,imt
603   format(' Delete',i6,' molecules of',i6)

      do 12 ii=1,im
      do 12 ia=1,nn(ii)
      i=dli(ii,ia)
12    call delat(nat0,i,nat,r,it,bt,tt,dli,im,nn,s)

      open(9,file='OUT')
      write(9,901)nat
901   format(i6)
      do 10 i=1,nat
10    write(9,902)i,s(i)(7:len(s(i))),(r(ix+3*(i-1)),ix=1,3),it(i),
     1(bt(i,ix),ix=1,tt(i))
902   format(i6,a5,3f12.6,5i6)
      close(9)

      end

      subroutine delat(nat0,i,nat,r,it,bt,tt,dli,im,nn,s)
      implicit none
      integer*4 nat0,i,nat,tt(*),it(*),ix,j,bt(nat0,4),dli(nat0,nat0),
     1nn(*),im
      real*8 r(*)
      character*11 s(*)
      do 1 j=i,nat-1
      s(j)=s(j+1)
      it(j)=it(j+1)
      tt(j)=tt(j+1)
      do 2 ix=1,4
2     bt(j,ix)=bt(j+1,ix)
      do 1 ix=1,3
1     r(ix+3*(j-1))=r(ix+3*(j+1-1))
      do 3 j=1,nat-1
      do 3 ix=1,tt(j)
3     if(bt(j,ix).ge.i)bt(j,ix)=bt(j,ix)-1
      do 4 j=1,im
      do 4 ix=1,nn(im)
4     if(dli(j,ix).ge.i)dli(j,ix)=dli(j,ix)-1
      nat=nat-1
      return
      end


      subroutine addta(ntree,tree,i1,ioff)
      implicit none
      integer*4 ntree,tree(*),i1,ioff(*)
      ntree=ntree+1
      tree(ntree)=i1
      ioff(i1)=0
      return
      end