******************************************************************************
C                         SUBROUTINE PERMID.F
******************************************************************************
C Calculates only the identity permutation.
C Uses periodic BC in (x,y) plane, open BC on z axis.
******************************************************************************
      subroutine perm(x,y,z,t,matoms,iatom,iatomp,sum,con,
     x                islice,iptot)
      include 'pimc_sqr3sc.dcl'
      dimension x(2*m,nat),y(2*m,nat),z(2*m,nat)
      dimension t(nperm),f(nfact+nat),sum(0:nperm)
      integer matoms(nperm),ind(nat,nat),iatom(nperm,4),iatomp(nperm,4)

      cutoff=exp(-argcut)

*//////////////////////////////////////////////////////////////////////////////
C                         ONE- AND TWO-BODY FACTORS
C Here we calculate the two-particle factors f(ip), whose products will be
C used to construct two-,three-, and four-particle permutations.  See equation
C (49).  There are np2 values of f(ip), where np2=nat*(nat-1).  
*//////////////////////////////////////////////////////////////////////////////

      ip=0
      prod1b=1.0
      iarg1=islice
      iarg2=islice+nbis
      do 1 i=1,nat
         call dstpbc(x(iarg1,i),x(iarg2,i),xdim,xd1,sgn)
         call dstpbc(y(iarg1,i),y(iarg2,i),ydim,yd1,sgn)
         zd1=z(iarg1,i)-z(iarg2,i)
c         call dstpbc(z(iarg1,i),z(iarg2,i),zdim,zd1,sgn)
         arg=con*(xd1**2+yd1**2+zd1**2)
         ip=ip+1
         ind(i,i)=ip
         f(ip)=exp(-arg)
         prod1b=prod1b*exp(-arg)
 1    continue
      np2=ip

*////////////////////////////////////////////////////////////////////////////
C                           IDENTITY PERMUTATION
*////////////////////////////////////////////////////////////////////////////
      iperm=0
      sum(iperm)=0.0
      do i=1,nat
         i1=ind(i,i)
         prod=f(i1)
         if(prod.ge.cutoff) then
            iperm=iperm+1
            t(iperm)=prod
            sum(iperm)=sum(iperm-1)+t(iperm)
            matoms(iperm)=1
            iatom(iperm,1)=i
            iatomp(iperm,1)=i
         end if
      end do
      iptot=iperm
      return
      end 

