1      subroutine argos_cafe_vs
2     + (xs,ys,vs,vst,esk,nums,isat,ismol,isfrc,ishop,wsm,wgt,vsm)
3c
4      implicit none
5c
6#include "argos_cafe_common.fh"
7#include "global.fh"
8#include "msgids.fh"
9c
10      integer nums
11      integer isat(msa),ismol(msa),isfrc(msa),ishop(msa)
12      real*8 xs(msa,3),ys(msa,3),vs(msa,3),vst(msa,3)
13      real*8 wgt(mat,mset),vsm(msm,3)
14      real*8 wsm(msm)
15      real*8 esk(msf)
16c
17      integer i,j,k
18      real*8 w
19c
20      do 11 i=1,msf
21      esk(i)=zero
22   11 continue
23      if(nums.gt.0) then
24      do 1 j=1,3
25      if(mdalgo.eq.1) then
26      do 2 i=1,nums
27      vst(i,j)=half*(vs(i,j)+vst(i,j))
28      if(iand(ishop(i),1).ne.1) esk(isfrc(i))=
29     + esk(isfrc(i))+half*wgt(isat(i),iset)*vst(i,j)*vst(i,j)
30    2 continue
31      else
32      do 3 i=1,nums
33      if(iand(ishop(i),1).ne.1) esk(isfrc(i))=
34     + esk(isfrc(i))+half*wgt(isat(i),iset)*vs(i,j)*vs(i,j)
35    3 continue
36      endif
37    1 continue
38      endif
39c
40      eskc(1,1)=zero
41      eskc(2,1)=zero
42      eskc(3,1)=zero
43      eskc(1,2)=zero
44      eskc(2,2)=zero
45      eskc(3,2)=zero
46      eskc(1,3)=zero
47      eskc(2,3)=zero
48      eskc(3,3)=zero
49      do 5 i=1,msm
50      vsm(i,1)=zero
51      vsm(i,2)=zero
52      vsm(i,3)=zero
53    5 continue
54      do 4 i=1,nums
55      if(iand(ishop(i),1).ne.1) then
56      k=ismol(i)
57      w=wgt(isat(i),iset)
58      if(mdalgo.eq.1) then
59      do 6 j=1,3
60      vsm(k,j)=vsm(k,j)+w*vst(i,j)
61    6 continue
62      else
63      do 7 j=1,3
64      vsm(k,j)=vsm(k,j)+w*vs(i,j)
65    7 continue
66      endif
67      endif
68    4 continue
69      if(np.gt.1) call ga_dgop(mcf_43,vsm,3*msm,'+')
70      if(me.eq.0) then
71      do 8 i=1,nsm
72      w=half/wsm(i)
73      eskc(1,1)=eskc(1,1)+w*vsm(i,1)*vsm(i,1)
74      eskc(2,1)=eskc(2,1)+w*vsm(i,2)*vsm(i,1)
75      eskc(3,1)=eskc(3,1)+w*vsm(i,3)*vsm(i,1)
76      eskc(1,2)=eskc(1,2)+w*vsm(i,1)*vsm(i,2)
77      eskc(2,2)=eskc(2,2)+w*vsm(i,2)*vsm(i,2)
78      eskc(3,2)=eskc(3,2)+w*vsm(i,3)*vsm(i,2)
79      eskc(1,3)=eskc(1,3)+w*vsm(i,1)*vsm(i,3)
80      eskc(2,3)=eskc(2,3)+w*vsm(i,2)*vsm(i,3)
81      eskc(3,3)=eskc(3,3)+w*vsm(i,3)*vsm(i,3)
82    8 continue
83      endif
84c
85      return
86      end
87c $Id$
88