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