1      subroutine argos_cafe_collapse(ncoll,fcoll,nums,numw,ismol,issgm,
2     + xs,xsm,mst,tsm,fs,xwm,xw,fw)
3c
4      implicit none
5c
6#include "argos_cafe_common.fh"
7#include "mafdecls.fh"
8c
9      integer ncoll,numw,nums,mst
10      integer ismol(msa),issgm(msa)
11      real*8 fcoll
12      real*8 xsm(msm,3),xs(msa,3),fs(msa,3),tsm(mst,4)
13      real*8 xwm(mwm,3),xw(mwm,3,mwa),fw(mwm,3,mwa)
14c
15      integer i,j,k,ki,kf
16      real*8 d
17c
18      ki=1
19      kf=3
20      if(ncoll.eq.1.or.ncoll.eq.4) ki=3
21      if(ncoll.eq.2.or.ncoll.eq.5) kf=2
22c
23      if(ncoll.le.3) then
24c
25      do 5 i=1,msm
26      if(ncoll.eq.1) then
27      d=one/sqrt(xsm(i,1)**2+xsm(i,2)**2+xsm(i,3)**2)
28      else
29      d=one/sqrt(xsm(i,1)**2+xsm(i,2)**2)
30      endif
31      tsm(i,1)=xsm(i,1)*d
32      tsm(i,2)=xsm(i,2)*d
33      tsm(i,3)=xsm(i,3)*d
34    5 continue
35c
36      do 1 k=ki,kf
37      do 2 i=1,nums
38      fs(i,k)=fs(i,k)-fcoll*tsm(ismol(i),k)
39    2 continue
40    1 continue
41      do 4 i=1,numw
42      if(ncoll.eq.1) then
43      d=one/sqrt(xwm(i,1)**2+xwm(i,2)**2+xwm(i,3)**2)
44      else
45      d=one/sqrt(xwm(i,1)**2+xwm(i,2)**2)
46      endif
47      do 3 j=1,nwa
48      do 6 k=ki,kf
49      fw(i,k,j)=fw(i,k,j)-fcoll*d*xwm(i,k)
50    6 continue
51    3 continue
52    4 continue
53c
54      else
55c
56      do 7 i=1,mst
57      tsm(i,1)=0.0d0
58      tsm(i,2)=0.0d0
59      tsm(i,3)=0.0d0
60      tsm(i,4)=0.0d0
61    7 continue
62      do 8 i=1,nums
63      tsm(issgm(i),1)=tsm(issgm(i),1)+xs(i,1)
64      tsm(issgm(i),2)=tsm(issgm(i),2)+xs(i,2)
65      tsm(issgm(i),3)=tsm(issgm(i),3)+xs(i,3)
66      tsm(issgm(i),4)=tsm(issgm(i),4)+1.0d0
67    8 continue
68      do 9 k=ki,kf
69      do 10 i=1,nums
70      fs(i,k)=fs(i,k)-fcoll*tsm(issgm(i),k)/tsm(issgm(i),4)
71   10 continue
72    9 continue
73c
74      endif
75c
76      return
77      end
78c $Id$
79