permit.f

Go to the documentation of this file.

      SUBROUTINE permit(PERIM,IGO)
*
*
*       Check on existing multiple regularization.
*       ------------------------------------------
*
      include 'common6.h'
      parameter(nmx=10,nmx3=3*nmx,nmxm=nmx*(nmx-1)/2)
      REAL*8  m,mass,mc,mij,mkk
      common/clump/   bodys(ncmax,5),t0s(5),ts(5),steps(5),rmaxs(5),
     &                names(ncmax,5),isys(5)
      common/chain1/  xch(nmx3),vch(nmx3),m(nmx),
     &                zz(nmx3),wc(nmx3),mc(nmx),
     &                xi(nmx3),pi(nmx3),mass,rinv(nmxm),rsum,mkk(nmx),
     &                mij(nmx,nmx),tkk(nmx),tk1(nmx),iname(nmx),nn
*
*
*       Search any existing subsystem.
      isub = 0
      ichsub = 1
      DO 10 l = 1,nsub
*       Identify chain pointer for possible reduction of STEPS.
          IF (isys(l).EQ.3) ichsub = isys(l)
*       Distinguish between triple & quad case (denoted ISUB = 1 or 2).
          IF (jcomp.LE.n.AND.names(4,l).EQ.0) THEN
              isub = 1
      ELSE IF (jcomp.GT.n.AND.names(4,l).GT.0) THEN
              isub = 2
          END IF
   10 CONTINUE
*
*       Do not allow a second regularization of the same type.
      IF (isub.GT.0) THEN
*       See whether the case ISUB = 1 or 2 is used already.
          DO 20 l = 1,nsub
              IF (isub.EQ.isys(l)) igo = 1
   20     CONTINUE
*       Enforce chain termination at next extension if new system < RSUM/2.
          IF (perim.LT.0.5*rsum.AND.igo.GT.0) THEN
              steps(ichsub) = 0.0
          END IF
      END IF
*
      RETURN
*
      END