rename.f

Go to the documentation of this file.

      SUBROUTINE rename
*
*
*       Renaming of list arrays.
*       ------------------------
*
      include 'common6.h'
*
*
*       Old & new names are shown explicitly for three different cases.
*
*       Standard sequence     ICOMP = 2*NPAIRS-1     ICOMP = 2*NPAIRS
*       -------------------------------------------------------------------
*       2*NPAIRS-1 ICOMP       2*NPAIRS-1 ICOMP       2*NPAIRS-1 JCOMP
*       2*NPAIRS   JCOMP       ICOMP      2*NPAIRS-1  ICOMP      2*NPAIRS-1
*       ICOMP      2*NPAIRS-1  2*NPAIRS   JCOMP       2*NPAIRS   2*NPAIRS-1
*       JCOMP      2*NPAIRS    JCOMP      2*NPAIRS    JCOMP      2*NPAIRS
*       -------------------------------------------------------------------
*
*       Form the sequential names of exchanged & regularized bodies.
      ilist(1) = 2*npairs - 1
      ilist(2) = 2*npairs
      ilist(3) = icomp
      ilist(4) = jcomp
*       Save the corresponding new names for the renaming procedure.
      ilist(5) = ilist(3)
      ilist(6) = ilist(4)
      ilist(7) = ilist(1)
      ilist(8) = ilist(2)
*       Ensure consecutive search list and modify renaming list accordingly.
      IF (icomp.LE.ilist(2)) THEN
          ilist(3) = ilist(2)
          ilist(2) = icomp
*       Note that all the new names are affected by the rearrangement.
          ilist(5) = ilist(2)
          ilist(6) = ilist(1)
          ilist(7) = ilist(4)
          ilist(8) = ilist(3)
          IF (icomp.NE.ilist(1)) THEN
*       First single particle is exchanged twice if ICOMP = 2*NPAIRS.
              ilist(5) = jcomp
              ilist(7) = ilist(1)
*       New name of 2*NPAIRS is not really needed because of duplicity.
          END IF
      END IF
*
*       Rename neighbour lists with exchanged or regularized components.
      DO 40 j = 1,ntot-1
*       Skip modification if first neighbour comes after second component.
          IF (list(2,j).GT.jcomp) go to 40
*       No special precaution needed for case of no neighbours.
          nnb = list(1,j)
          nnb1 = 0
          nij = 0
*
*       See whether any neighbours need to be renamed.
          k1 = 1
          DO 25 l = 2,nnb+1
              IF (list(l,j).GT.jcomp) go to 30
*       Start search loop above last identified value (bug fix 10/07).
              DO 20 k = k1,4
                  IF (list(l,j).EQ.ilist(k)) THEN
                      k1 = k + 1
                      nnb1 = nnb1 + 1
*       Save corresponding list location for the modification loop.
                      jlist(nnb1) = k
                      jlist(nnb1+4) = l
*       Count number of identified KS components.
                      IF (ilist(k).EQ.icomp.OR.ilist(k).EQ.jcomp)
     &                                                     nij = nij + 1
*       Advance neighbour list after each identification (note duplicity).
                      go to 25
                  END IF
   20         CONTINUE
   25     CONTINUE
*
*       Skip modification if no neighbours need to be renamed.
   30     IF (nnb1.EQ.0) go to 40
*
*       Include c.m. renaming procedure if both components are neighbours.
          DO 38 k = 1,nnb1
              ktime = jlist(k)
*       Indicator for identified members of search list.
              inew = ilist(ktime+4)
*       Replace identified components (or single perturber) by c.m.
              IF (inew.LT.ifirst) THEN
                  IF (nij.EQ.2.OR.j.LT.ifirst - 3) inew = ntot
              END IF
*       Start with the saved list index (may differ by one either way).
              ls = jlist(k+4)
*       See if index needs adjusting after previous modification. 
              IF (list(ls,j).LT.ilist(ktime)) ls = ls + 1
              IF (list(ls,j).GT.ilist(ktime)) ls = ls - 1
*
*       Move list members up or down unless new name is identical to old.
              IF (ls.LE.0) ls = 2
              ll = ls
              IF (inew.LT.ilist(ktime)) THEN
*       Move list members down by one until location for new name is vacated.
                  DO 32 l = ll,3,-1
                      IF (list(l-1,j).GT.inew) THEN
                          list(l,j) = list(l-1,j)
                          ls = l - 1
                      ELSE
                          go to 36
                      END IF
   32             CONTINUE
              ELSE IF (inew.GT.ilist(ktime)) THEN
*       Move list members up by one until sequential location is reached.
                  DO 34 l = ll,nnb
                      IF (list(l+1,j).LT.inew) THEN
                          list(l,j) = list(l+1,j)
                          ls = l + 1
                      ELSE
                          go to 36
                      END IF
   34             CONTINUE
              END IF
*       Set renamed neighbour in sequential location.
   36         list(ls,j) = inew
   38     CONTINUE
*
*       Reduce membership by one if c.m. set in last two locations.
          IF (nij.EQ.2) list(1,j) = nnb - 1
   40 CONTINUE
*
*       Update the list of recently regularized particles.
   41 nnb = listr(1)
      DO 44 l = 2,nnb+1
*       First see whether either component has been regularized before.
          IF (listr(l).EQ.icomp.OR.listr(l).EQ.jcomp) THEN 
*       Remove corresponding pair even if only one component is present.
              j = 2*kvec(l-1)
*       Move up the subsequent pairs and reduce membership by two.
              DO 42 k = j,nnb-1
                  listr(k) = listr(k+2)
   42         CONTINUE
              listr(1) = listr(1) - 2
*       Make a new search otherwise LISTR -> -2 if NNB = 2.
              go to 41
          END IF
   44 CONTINUE
*
*       Rename exchanged components if present in the list.
      DO 48 kcomp = 1,2
          DO 46 l = 2,nnb+1
              IF (listr(l).EQ.2*npairs - 2 + kcomp) THEN
                  IF (kcomp.EQ.1) listr(l) = icomp
                  IF (kcomp.EQ.2) listr(l) = jcomp
              END IF
   46     CONTINUE
   48 CONTINUE
*
*       Update the list of high velocity particles.
      IF (listv(1).EQ.0) go to 70
      nnb = listv(1)
      l = 1
   50 l = l + 1
*       Check for removal of regularized component.
      IF (listv(l).EQ.icomp.OR.listv(l).EQ.jcomp) THEN
          DO 52 k = l,nnb
              listv(k) = listv(k+1)
   52     CONTINUE
          listv(1) = listv(1) - 1
          nnb = nnb - 1
*       Consider the same location again.
          l = l - 1
      END IF
      IF (l.LE.nnb) go to 50
*
*       Rename exchanged components.
      DO 58 kcomp = 1,2
          DO 56 l = 2,nnb+1
              IF (listv(l).EQ.2*npairs - 2 + kcomp) THEN
                  IF (kcomp.EQ.1) listv(l) = icomp
                  IF (kcomp.EQ.2) listv(l) = jcomp
              END IF
   56     CONTINUE
   58 CONTINUE
*
*       Remove any fast particles which have slowed down or are outside 2<R>.
      l = 1
   60 l = l + 1
      IF (listv(1).EQ.0) go to 70
      j = listv(l)
      a0 = xdot(1,j)**2 + xdot(2,j)**2 + xdot(3,j)**2
      a2 = (x(1,j) - rdens(1))**2 + (x(2,j) - rdens(2))**2 +
     &                              (x(3,j) - rdens(3))**2
      IF (a0.LT.16.0*eclose.OR.a2.GT.4.0*rscale**2) THEN 
          DO 65 k = l,nnb
              listv(k) = listv(k+1)
   65     CONTINUE
          listv(1) = listv(1) - 1
          nnb = nnb - 1
*       Consider the same location again.
          l = l - 1
      END IF
      IF (l.LE.nnb) go to 60
*
   70 RETURN
*
      END