Nbody6
 All Files Functions Variables
ksreg.f
Go to the documentation of this file.
1  SUBROUTINE ksreg
2 *
3 *
4 * New KS regularization.
5 * ----------------------
6 *
7  include 'common6.h'
8  REAL*8 SAVE(15)
9  EXTERNAL rename
10 *
11 *
12 * Replace #JCOMP by arbitrary body in case it is the only neighbour.
13  nnb = list(1,icomp)
14  IF (nnb.EQ.1.AND.list(2,icomp).EQ.jcomp) THEN
15  list(2,icomp) = jcomp + 1
16  IF (jcomp + 1.GT.ntot) THEN
17  list(2,icomp) = max(icomp-1,ifirst+2)
18  END IF
19  END IF
20 *
21 * Copy neighbour list of #ICOMP without JCOMP.
22  nnb1 = 1
23  DO 1 l = 1,nnb
24  IF (list(l+1,icomp).EQ.jcomp) go to 1
25  nnb1 = nnb1 + 1
26  ilist(nnb1) = list(l+1,icomp)
27  1 CONTINUE
28  ilist(1) = nnb1 - 1
29 *
30 * Save basic variables for components unless in correct location.
31  DO 10 kcomp = 1,2
32 * Treat the first & second component in turn.
33  IF (kcomp.EQ.1) THEN
34  i = icomp
35  ELSE
36  i = jcomp
37  END IF
38  j = 2*npairs + kcomp
39  IF (i.EQ.j) go to 10
40 *
41  DO 2 k = 1,3
42  save(k) = x(k,i)
43  save(k+3) = x0dot(k,i)
44  2 CONTINUE
45  save(7) = body(i)
46  save(8) = rs(i)
47  save(9) = radius(i)
48  save(10) = tev(i)
49  save(11) = body0(i)
50  save(12) = tev0(i)
51  save(13) = epoch(i)
52  save(14) = spin(i)
53  save(15) = zlmsty(i)
54  namei = name(i)
55  ksi = kstar(i)
56 *
57 * Exchange first & second single particle with ICOMP & JCOMP.
58  DO 4 k = 1,3
59  x(k,i) = x(k,j)
60  x0(k,i) = x0(k,j)
61  x0dot(k,i) = x0dot(k,j)
62  xdot(k,i) = xdot(k,j)
63  f(k,i) = f(k,j)
64  fdot(k,i) = fdot(k,j)
65  fi(k,i) = fi(k,j)
66  fidot(k,i) = fidot(k,j)
67  d0(k,i) = d0(k,j)
68  d1(k,i) = d1(k,j)
69  d2(k,i) = d2(k,j)
70  d3(k,i) = d3(k,j)
71  fr(k,i) = fr(k,j)
72  frdot(k,i) = frdot(k,j)
73  d0r(k,i) = d0r(k,j)
74  d1r(k,i) = d1r(k,j)
75  d2r(k,i) = d2r(k,j)
76  d3r(k,i) = d3r(k,j)
77  x(k,j) = save(k)
78  x0dot(k,j) = save(k+3)
79  4 CONTINUE
80 *
81  body(i) = body(j)
82  rs(i) = rs(j)
83  radius(i) = radius(j)
84  tev(i) = tev(j)
85  tev0(i) = tev0(j)
86  body0(i) = body0(j)
87  epoch(i) = epoch(j)
88  spin(i) = spin(j)
89  zlmsty(i) = zlmsty(j)
90  name(i) = name(j)
91  kstar(i) = kstar(j)
92  step(i) = step(j)
93  stepr(i) = stepr(j)
94  t0(i) = t0(j)
95  t0r(i) = t0r(j)
96  k = list(1,j) + 1
97  DO 5 l = 1,k
98  list(l,i) = list(l,j)
99  5 CONTINUE
100  body(j) = save(7)
101  rs(j) = save(8)
102  radius(j) = save(9)
103  tev(j) = save(10)
104  body0(j) = save(11)
105  tev0(j) = save(12)
106  epoch(j) = save(13)
107  spin(j) = save(14)
108  zlmsty(j) = save(15)
109  name(j) = namei
110  kstar(j) = ksi
111  10 CONTINUE
112 *
113 * Save neighbour list of first component for RENAME & FPOLY.
114  DO 15 l = 1,nnb1
115  list(l,ifirst) = ilist(l)
116  15 CONTINUE
117 *
118 * Increase pair index, total number & single particle index.
119  npairs = npairs + 1
120  ntot = n + npairs
121  ifirst = 2*npairs + 1
122 *
123 * Update all relevant COMMON list arrays.
124  CALL rename
125 *
126 * Check replacing of single KS component by corresponding c.m.
127  DO 30 i = ifirst-2,ntot-1
128  20 IF (list(1,i).GT.0.AND.list(2,i).LT.ifirst) THEN
129  j2 = list(2,i)
130  j = kvec(j2) + n
131  nnb = list(1,i)
132  DO 25 l = 2,nnb+1
133  IF (l.LE.nnb.AND.list(l+1,i).LT.j) THEN
134  list(l,i) = list(l+1,i)
135  ELSE
136  list(l,i) = j
137 * Check again until first neighbour > 2*NPAIRS.
138  go to 20
139  END IF
140  25 CONTINUE
141  END IF
142  30 CONTINUE
143 *
144 * Copy neighbour list for second component & c.m. (NNB1 = LIST(1,I)+1).
145  i = 2*npairs - 1
146  DO 40 l = 1,nnb1
147  list(l,i+1) = list(l,i)
148  list(l,ntot) = list(l,i)
149  40 CONTINUE
150 *
151 * Initialize the regularized solution.
152  CALL ksinit
153 *
154 * Check optional binary analysis after merger or multiple collision.
155  IF (kz(4).GT.0.AND.iphase.GT.3) THEN
156  CALL evolve(npairs,-1)
157  END IF
158 *
159 * Check updating of global index for chain c.m.
160  IF (nch.GT.0) THEN
161  CALL chfind
162  END IF
163 *
164  RETURN
165 *
166  END