1      subroutine argos_space_wtrst(lfnrst,filrst,lveloc,pres,
2     + temp,tempw,temps,
3     + iwl,iwlp,xw,vw,fw,xwcr,isl,islp,xs,vs,fs,xscr,
4     + ipl,nb,ibw,bxw,bvw,bfw,brw,ibs,bxs,bvs,bfs,lseq)
5c
6      implicit none
7c
8#include "argos_space_common.fh"
9#include "mafdecls.fh"
10#include "global.fh"
11c
12      integer lfnrst,nb
13      character*255 filrst
14      logical lveloc
15      real*8 pres,temp,tempw,temps
16      integer iwl(mwm,miw2),isl(msa,mis2),lseq(mseq)
17      integer iwlp(mwm,npackw),islp(msa,npack)
18      real*8 xw(mwm,3,mwa),vw(mwm,3,mwa),fw(mwm,3,mwa),xwcr(mwm,3)
19      real*8 xs(msa,3),vs(msa,3),fs(msa,3),xscr(msm,3)
20      integer ipl(mbox,mip2),ibw(nb),ibs(nb,2)
21      real*8 bxw(nb,3,mwa),bvw(nb,3,mwa),bfw(nb,3,mwa),brw(nb,3)
22      real*8 bxs(nb,3),bvs(nb,3),bfs(nb,3)
23c
24      integer i,j,k,node,ncyc,icyc,numw,nums,number,nwmn,nsan
25      integer ilp,ihp,jlp,jhp,ili,ihi,jli,jhi,ilw,ihw,jlw,jhw
26      integer ils,ihs,jls,jhs
27      character*10 rdate,rtime
28      character*18 user
29#ifdef USE_POSIXF
30      integer ilen,ierror
31#endif
32      integer idyn,idynp,ihop
33      logical lforces
34c
35      lforces=iguide.ne.0
36c
37      if(ga_nodeid().eq.0) then
38c
39      call swatch(rdate,rtime)
40#ifdef USE_POSIXF
41      call pxfgetlogin(user, ilen, ierror)
42#else
43      call getlog(user)
44#endif
45      if(user(18:18).ne.' ') user='                  '
46c
47      rewind(lfnrst)
48      write(lfnrst,1000)
49 1000 format('Restart file',/,' ',/,' ')
50      write(lfnrst,1001) 4.2,rdate,rtime,nhist,lforces
51 1001 format(f12.6,2a10,i5,4x,l1)
52      hist(nhist)(1:18)=user
53      hist(nhist)(19:28)=rdate
54      hist(nhist)(29:48)=rtime
55      hist(nhist)(49:108)=project(1:60)
56      do 10 i=1,nhist
57      write(lfnrst,1009) hist(i)
58 1009 format(a)
59   10 continue
60      write(lfnrst,1002) npbtyp,nbxtyp,rsgm,((vlat(i,j),j=1,3),i=1,3)
61 1002 format(2i5,f12.6,/,(3f12.6))
62      write(lfnrst,1003) pres
63 1003 format(1pe12.5)
64      write(lfnrst,1004) temp,tempw,temps
65 1004 format(3f12.6)
66      write(lfnrst,1005) nwm,nwa,nsm,nsa,nwmc,nsf,nseq,0,0
67 1005 format(7i10,2i5)
68c
69      if(nwm.gt.0) then
70      number=0
71      ncyc=nwm/nb+1
72      numw=nb
73      do 1 icyc=1,ncyc
74      if(nwm-number.lt.numw) numw=nwm-number
75c
76c     begin test code 10/31/2001
77c     initialize ibw to check that all atoms have been received
78c
79      do 1112 i=1,nb
80      ibw(i)=-1
81 1112 continue
82c
83c     end test code
84c
85      do 2 node=np-1,0,-1
86      call ga_distribution(ga_ip,node,ilp,ihp,jlp,jhp)
87      call ga_get(ga_ip,ilp,ihp,jlp,jhp,ipl,mbox)
88      nwmn=ipl(1,2)
89      if(nwmn.gt.0) then
90      call ga_distribution(ga_iw,node,ili,ihi,jli,jhi)
91      if(npackw.eq.0) then
92      call ga_get(ga_iw,ili,ili+nwmn-1,jli,jli+lwdyn-1,iwl,mwm)
93      else
94      call ga_get(ga_iw,ili,ili+nwmn-1,jli,jli+npackw-1,iwlp,mwm)
95      call argos_space_unpackw(nwmn,iwl,iwlp)
96      endif
97      call ga_distribution(ga_w,node,ilw,ihw,jlw,jhw)
98      call ga_get(ga_w,ilw,ilw+nwmn-1,jlw,jlw+3*mwa-1,xw,mwm)
99      if(lveloc)
100     + call ga_get(ga_w,ilw,ilw+nwmn-1,jlw+3*mwa,jlw+6*mwa-1,vw,mwm)
101      if(lforces)
102     + call ga_get(ga_w,ilw,ilw+nwmn-1,jlw+6*mwa+3,jlw+9*mwa+2,fw,mwm)
103      call ga_get(ga_w,ilw,ilw+nwmn-1,jlw+6*mwa,jlw+6*mwa+2,xwcr,mwm)
104      do 3 i=1,nwmn
105      j=iwl(i,lwgmn)-number
106      if(j.gt.0.and.j.le.numw) then
107      do 4 k=1,nwa
108      bxw(j,1,k)=xw(i,1,k)
109      bxw(j,2,k)=xw(i,2,k)
110      bxw(j,3,k)=xw(i,3,k)
111      bvw(j,1,k)=vw(i,1,k)
112      bvw(j,2,k)=vw(i,2,k)
113      bvw(j,3,k)=vw(i,3,k)
114      if(lforces) then
115      bfw(j,1,k)=fw(i,1,k)
116      bfw(j,2,k)=fw(i,2,k)
117      bfw(j,3,k)=fw(i,3,k)
118      endif
119    4 continue
120      brw(j,1)=xwcr(i,1)
121      brw(j,2)=xwcr(i,2)
122      brw(j,3)=xwcr(i,3)
123      ibw(j)=iwl(i,lwdyn)
124      endif
125    3 continue
126      endif
127    2 continue
128      do 5 i=1,numw
129      if(lveloc) then
130      write(lfnrst,1006) ((bxw(i,j,k),j=1,3),(bvw(i,j,k),j=1,3),k=1,nwa)
131      else
132      write(lfnrst,1006) ((bxw(i,j,k),j=1,3),(zero,j=1,3),k=1,nwa)
133      endif
134 1006 format(2x,6f13.8)
135      if(lforces) write(lfnrst,1106) ((bfw(i,j,k),j=1,3),k=1,nwa)
136 1106 format(2x,6e13.6)
137      idyn=iand(ibw(i),12)/4
138      idynp=iand(ibw(i),3)
139      write(lfnrst,1007) idynp,idyn,(brw(i,k),k=1,3)
140 1007 format(2i1,3f13.8)
141c
142c     begin test code 10/31/2001
143c     check if al atoms have been received
144c
145      if(ibw(i).lt.0)
146     + call md_abort('Missing solvent in wtrst',i)
147c
148c     end test code
149c
150    5 continue
151      number=number+numw
152    1 continue
153      endif
154c
155      if(nsa.gt.0) then
156      number=0
157      ncyc=nsa/nb+1
158      nums=nb
159      do 6 icyc=1,ncyc
160      if(nsa-number.lt.nums) nums=nsa-number
161c
162c     begin test code 10/31/2001
163c     initialize ibw to check that all atoms have been received
164c
165      do 1117 i=1,nb
166      ibs(i,1)=-1
167      ibs(i,2)=0
168 1117 continue
169c
170c     end test code
171c
172      do 7 node=np-1,0,-1
173      call ga_distribution(ga_ip,node,ilp,ihp,jlp,jhp)
174      call ga_get(ga_ip,ilp,ihp,jlp,jhp,ipl,mbox)
175      nsan=ipl(2,2)
176      if(nsan.gt.0) then
177      call ga_distribution(ga_is,node,ili,ihi,jli,jhi)
178      if(npack.eq.0) then
179      call ga_get(ga_is,ili,ili+nsan-1,jli,jli+lsdyn-1,isl,msa)
180      else
181      call ga_get(ga_is,ili,ili+nsan-1,jli,jli+npack-1,islp,msa)
182      call argos_space_unpack(nsan,isl,islp)
183      endif
184      call ga_distribution(ga_s,node,ils,ihs,jls,jhs)
185      call ga_get(ga_s,ils,ils+nsan-1,jls,jls+2,xs,msa)
186      if(lveloc) call ga_get(ga_s,ils,ils+nsan-1,jls+3,jls+5,vs,msa)
187      if(lforces) call ga_get(ga_s,ils,ils+nsan-1,jls+6,jls+8,fs,msa)
188      do 8 i=1,nsan
189      j=isl(i,lsgan)-number
190      if(j.gt.0.and.j.le.nums) then
191      bxs(j,1)=xs(i,1)
192      bxs(j,2)=xs(i,2)
193      bxs(j,3)=xs(i,3)
194      bvs(j,1)=vs(i,1)
195      bvs(j,2)=vs(i,2)
196      bvs(j,3)=vs(i,3)
197      if(lforces) then
198      bfs(j,1)=fs(i,1)
199      bfs(j,2)=fs(i,2)
200      bfs(j,3)=fs(i,3)
201      endif
202      ibs(j,1)=isl(i,lsdyn)
203      ibs(j,2)=isl(i,lshop)
204      endif
205    8 continue
206      endif
207    7 continue
208      do 9 i=1,nums
209      idyn=iand(ibs(i,1),12)/4
210      idynp=iand(ibs(i,1),3)
211      ihop=ibs(i,2)
212      if(iand(ihop,1).eq.1) then
213      ihop=-(ihop/2)
214      else
215      ihop=ihop/2
216      endif
217      if(lveloc) then
218      write(lfnrst,1008) idynp,idyn,(bxs(i,j),j=1,3),(bvs(i,j),j=1,3),
219     + ihop
220      else
221      write(lfnrst,1008) idynp,idyn,(bxs(i,j),j=1,3),(zero,j=1,3),ihop
222      endif
223 1008 format(2i1,6f13.8,i5)
224      if(lforces) write(lfnrst,1108) (bfs(i,j),j=1,3)
225 1108 format(2x,3e13.6)
226c
227c     begin test code 10/31/2001
228c     check if al atoms have been received
229c
230      if(ibs(i,1).lt.0)
231     + call md_abort('Missing solute atom in wtrst',i)
232c
233c     end test code
234c
235    9 continue
236      number=number+nums
237    6 continue
238      endif
239c
240      if(nsm.gt.0) then
241      do 21 i=1,nsm
242      write(lfnrst,1109) (xscr(i,j),j=1,3)
243 1109 format(2x,3f13.8)
244   21 continue
245      endif
246c
247      if(nseq.gt.0) then
248      write(lfnrst,1013) (lseq(i),i=1,nseq)
249 1013 format(20i3)
250      endif
251c
252      endif
253c
254      return
255 9999 continue
256      call md_abort('Failed to open restart file',me)
257      return
258      end
259c $Id$
260