update.f

Go to the documentation of this file.

      SUBROUTINE update(IPAIR)
*
*
*       List modifications after KS termination.
*       ----------------------------------------
*
      include 'common6.h'
      DATA iw /0/
      SAVE iw
*
*
*       Adjust neighbour lists to new sequence (skip last or only pair).
      icm = n + ipair
      IF (ipair.GT.npairs) go to 60
*
*       Set largest index of any regularized member.
      ilast = 2*npairs + 2
*
*       Rename lists containing single regularized components.
      DO 50 j = 1,ntot
*       Skip renaming if first neighbour exceeds regularized components.
          IF (list(2,j).GT.ilast.OR.body(j).EQ.0.0d0) go to 50
          nnb = list(1,j)
          IF (nnb.EQ.0) go to 50
          l = 2
*       Determine list index and new location of any regularized component.
          inew = 0
   10     IF (list(l,j).EQ.2*ipair-1) THEN
              i = 2*ipair - 1
              inew = 2*npairs + 1
          ELSE IF (list(l,j).EQ.2*ipair) THEN
              i = 2*ipair
              inew = 2*npairs + 2
          ELSE IF (inew.EQ.0) THEN
*       Define as zero for single body test below (at least one < ILAST).
              i = 0
*       Note that L = 2 may be single body and L = 3 current KS component.
          END IF
          l = l + 1
          IF (l.LE.nnb+1.AND.list(l,j).LT.ilast) go to 10
*
*       Rename regularized components > 2*IPAIR and reduce by 2 if <= ILAST.
          DO 20 k = 2,l
*       Note that L determined above is list index of standard particle.
              IF (list(k,j).EQ.i) THEN
                  list(k,j) = inew
              ELSE IF (list(k,j).LE.ilast.AND.
     &                 list(k,j).GT.2*ipair) THEN
                  list(k,j) = list(k,j) - 2
              END IF
   20     CONTINUE
*
*       Check that list of single KS components is sequential (up to ILAST).
          l = 2
   30     IF (list(l+1,j).LT.list(l,j).AND.l.LE.nnb) THEN
              jl = list(l,j)
              list(l,j) = list(l+1,j)
              list(l+1,j) = jl
          END IF
          l = l + 1
          IF (list(l,j).LE.ilast.AND.l.LE.nnb+1) go to 30
   50 CONTINUE
*
*       Replace c.m. by components and reduce subsequent members by one.
   60 DO 80 j = 1,ntot
          IF (body(j).EQ.0.0d0) go to 80
          nnb = list(1,j)
          l = nnb + 1
          move = 0
*       Check for removal of current c.m. and reduce by one if > N + IPAIR.
   70     IF (l.EQ.1.OR.list(l,j).LT.icm) go to 80
*       See whether ICM is on neighbour list (otherwise skip splitting).
          IF (list(l,j).EQ.icm) move = 1
          IF (list(l,j).NE.icm) THEN
              list(l,j) = list(l,j) - 1
              l = l - 1
              go to 70
          END IF
*
*       Skip on zero ID or remove c.m. name by moving up subsequent members.
          IF (move.EQ.0) go to 80
   72     IF (l.LE.nnb) THEN
              list(l,j) = list(l+1,j) 
              l = l + 1
              go to 72
          END IF
*
          nnb = nnb - 1
*       Expand the list to include both components since c.m. was deleted.
          kcase = 2
*       Only move neighbours down by one if the list has too many members.
          IF (nnb.GT.lmax-5) kcase = 1
          IF (nnb.EQ.0) go to 76
*       In this special case L = 2 already.
          l = nnb + 1
*       Take special precaution if last neighbour is a regularized body.
          IF (list(l,j).LE.jcomp) THEN
              l = l + 1
              go to 76
          END IF
*
*       Move members down by two (or one) to make room for components.
   74     list(l+kcase,j) = list(l,j)
          IF (l.GT.2.AND.list(l-1,j).GE.icomp) THEN
              l = l - 1
              go to 74
          END IF
*
*       Rename deleted c.m. appropriately and increase membership by 2 or 1.
   76     list(l,j) = icomp
*       Do not over-write the list if NNB > LMAX-3 after removal of c.m.
          IF (kcase.EQ.2) list(l+1,j) = jcomp
          list(1,j) = nnb + kcase
          IF (kcase.EQ.1.AND.iw.LT.10) THEN
              WRITE (6,78)  nnb, j, jcomp
   78         FORMAT (5x,'WARNING!    UPDATE    NNB J JCOMP ',3i6)
              iw = iw + 1
          END IF
   80 CONTINUE
*
*       Modify the list of previously regularized binaries.
      nnb = listr(1) - 1
      l = 0
   91 l = l + 2
   92 IF (l.GT.nnb + 1) go to 96
      j = listr(l)
      k = listr(l+1)
*       First check the current two-body separation of any old pairs.
      rjk2 = (x(1,j) - x(1,k))**2 + (x(2,j) - x(2,k))**2 +
     &                              (x(3,j) - x(3,k))**2
*       Remove pair if RJK > 4*RMIN when special procedure not needed.
      IF (rjk2.LT.16.0*rmin**2) go to 91
      DO 94 k = l,nnb
          listr(k) = listr(k+2)
   94 CONTINUE
      nnb = nnb - 2
      go to 92
*
*       Add ICOMP & JCOMP to LISTR (maximum of MLR/2 - 1 pairs).
   96 IF (nnb.GT.mlr - 4) THEN
*       Note that NNB is one less than the actual membership.
          DO 98 k = 2,nnb
              listr(k) = listr(k+2)
   98     CONTINUE
          nnb = nnb - 2
*       Removal of the oldest KS pair.
      END IF
      listr(nnb+3) = icomp
      listr(nnb+4) = jcomp
      listr(1) = nnb + 3
*
*       Copy flag index of disrupted pair (set in KSTERM).
      iflag = jlist(3)
*       Add primordial pairs to LISTD (skip new KS pairs or primordials).
      IF (iflag.EQ.0.OR.iabs(jlist(1) - jlist(2)).EQ.1) go to 110
*
*       Check list of disrupted component names.
      nnb = listd(1) - 1
      kcomp = 0
      DO 100 k = 2,nnb+1,2
          IF (listd(k).EQ.jlist(1).AND.listd(k+1).EQ.jlist(2)) kcomp = 1
  100 CONTINUE
*
*       Include both components unless already members.
      IF (kcomp.EQ.0) THEN
          IF (nnb.GT.mld - 4) THEN
              DO 102 k = 2,nnb
                 listd(k) = listd(k+2)
  102         CONTINUE
              nnb = nnb - 2
          END IF
*       Add most recent names at the end (limit is MLD/2 - 1 pairs).
          listd(nnb+3) = jlist(1)
          listd(nnb+4) = jlist(2)
          listd(1) = nnb + 3
      END IF
      IF (iflag.NE.-1) WRITE (8,104)  ipair, iflag, jlist(1), jlist(2)
  104 FORMAT (' LISTD INCONSISTENCY!!  IPAIR IFLAG NAMES ',2i5,2i8)
*
*       Update list of high velocity particles containing c.m. members.
  110 nnb = listv(1)
      DO 130 l = 2,nnb+1
          IF (listv(l).EQ.icm) THEN
*       Remove old c.m. and reduce the membership.
              DO 125 k = l,nnb
                  listv(k) = listv(k+1)
  125         CONTINUE
              listv(1) = listv(1) - 1
          END IF
*       Reduce higher particle locations by one.
          IF (listv(l).GT.icm) THEN
              listv(l) = listv(l) - 1
          END IF
  130 CONTINUE
*
      RETURN
*
      END