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