1 logical function argos_prep_fix(lfnout,ifix,jfix,rfix,cfix, 2 + iwmr,xw,mwm,mwa,nwm,nwa,iwmrc,xwc,mwmc,nwmc, 3 + isar,isgm,csa,xs,msa,nsa) 4c 5c $Id$ 6c 7 implicit none 8c 9#include "util.fh" 10c 11 integer lfnout 12 integer mwm,mwa,nwm,nwa,msa,nsa,mwmc,nwmc 13 integer ifix,jfix 14 real*8 rfix 15 character*80 cfix 16c 17 real*8 xw(3,mwa,mwm),xs(3,msa),xwc(3,mwa,mwmc) 18 integer iwmrc(mwmc),iwmr(mwm),isar(msa),isgm(msa) 19 character*16 csa(msa) 20c 21 integer iatom,isgmnt,jsgmnt,ndx,ndy 22 integer i,j,ifrst,ilast,jfrst 23 character*6 aname 24 logical lsin 25 real*8 dx,dy,dz,d2,rfix2 26 character*4 csgmnt,string 27c 28 rfix2=rfix*rfix 29c 30c determine center 31c 32 isgmnt=0 33 aname=' ' 34 ndx=index(cfix,':') 35 ndy=index(cfix,' ') 36 if(ndx.gt.0) then 37 csgmnt=' ' 38 read(cfix(1:ndx-1),*,err=99) isgmnt 39 goto 999 40 99 continue 41 isgmnt=0 42 if(ndx.le.4) then 43 csgmnt(1:ndx-1)=cfix(1:ndx-1) 44 else 45 csgmnt=cfix(1:4) 46 endif 47 999 continue 48 if(ndy-ndx.gt.5) 49 + call md_abort('argos_prep_fix: atom name problem',9999) 50 aname(1:ndy-ndx)=cfix(ndx+1:ndy) 51 else 52 if(ndy.gt.5) 53 + call md_abort('argos_prep_modify: atom name problem',9999) 54 aname(1:ndy-1)=cfix(1:ndy-1) 55 endif 56 do 1 i=1,index(aname,' ')-1 57 if(aname(i:i).eq.'_') aname(i:i)=' ' 58 1 continue 59c 60 100 continue 61c 62 if(csgmnt.ne.' ') then 63 do 101 i=1,nsa 64 string=csa(i)(1:4) 65 if(csgmnt.eq.string.and.isgmnt.lt.isgm(i)) then 66 isgmnt=isgm(i) 67 goto 102 68 endif 69 101 continue 70 goto 199 71 endif 72 102 continue 73c 74c determine iatom : atom number of specified atom 75c ifrst : number first atom of the segment 76c ilast : number last atom of the segment 77c 78 iatom=0 79 ifrst=0 80 ilast=0 81 do 2 i=1,nsa 82 if(isgm(i).eq.isgmnt) then 83 if(csa(i)(11:16).eq.aname) iatom=i 84 if(ifrst.eq.0) ifrst=i 85 ilast=i 86 endif 87 2 continue 88c 89 if(iatom.eq.0.or.ifrst.eq.0.or.ilast.eq.0) then 90 if(util_print('restart',print_low)) then 91 write(lfnout,'(a,i8,a,a)') 'Unable to find ',isgmnt,':',aname 92 endif 93 call md_abort('argos_prep_fix: center not found',9999) 94 endif 95c 96 if(util_print('restart',print_high)) then 97 write(lfnout,1000) ifix,jfix,rfix,isgmnt,aname,ifrst,ilast 98 1000 format(' fixed ',2i5,f12.6,1x,i5,':',a,5x,2i7) 99 endif 100c 101c fix solvent molecules 102c --------------------- 103c 104 do 3 i=1,nwm 105 do 4 j=1,nwa 106 dx=abs(xw(1,j,i)-xs(1,iatom)) 107 dy=abs(xw(2,j,i)-xs(2,iatom)) 108 dz=abs(xw(3,j,i)-xs(3,iatom)) 109 d2=dx*dx+dy*dy+dz*dz 110 if(ifix.eq.1) then 111 if(d2.ge.rfix2) iwmr(i)=2 112 else 113 if(d2.le.rfix2) iwmr(i)=2 114 endif 115 4 continue 116 3 continue 117 do 5 i=1,nwmc 118 do 6 j=1,nwa 119 dx=abs(xwc(1,j,i)-xs(1,iatom)) 120 dy=abs(xwc(2,j,i)-xs(2,iatom)) 121 dz=abs(xwc(3,j,i)-xs(3,iatom)) 122 d2=dx*dx+dy*dy+dz*dz 123 if(ifix.eq.1) then 124 if(d2.ge.rfix2) iwmrc(i)=2 125 else 126 if(d2.le.rfix2) iwmrc(i)=2 127 endif 128 6 continue 129 5 continue 130c 131c fix atoms 132c --------- 133c 134 if(jfix.eq.1) then 135 do 7 i=1,nsa 136 dx=abs(xs(1,i)-xs(1,iatom)) 137 dy=abs(xs(2,i)-xs(2,iatom)) 138 dz=abs(xs(3,i)-xs(3,iatom)) 139 d2=dx*dx+dy*dy+dz*dz 140 if(ifix.eq.1) then 141 if(d2.ge.rfix2) isar(i)=2 142 else 143 if(d2.le.rfix2) isar(i)=2 144 endif 145 7 continue 146 else 147c 148c fix segments 149c ------------ 150c 151 jfrst=1 152 do 8 i=1,nsa 153 if(i.eq.nsa) then 154 jsgmnt=0 155 else 156 jsgmnt=isgm(i+1) 157 endif 158c 159 if(jsgmnt.ne.isgm(i)) then 160 lsin=.false. 161 do 9 j=jfrst,i 162 dx=abs(xs(1,j)-xs(1,iatom)) 163 dy=abs(xs(2,j)-xs(2,iatom)) 164 dz=abs(xs(3,j)-xs(3,iatom)) 165 d2=dx*dx+dy*dy+dz*dz 166 if(d2.le.rfix2) lsin=.true. 167 9 continue 168 if((lsin.and.ifix.eq.-1).or.(.not.lsin.and.ifix.eq.1)) then 169 do 10 j=jfrst,i 170 isar(j)=2 171 10 continue 172 endif 173 jfrst=i+1 174 endif 175 8 continue 176c 177 endif 178c 179 if(csgmnt.ne.' ') goto 100 180 199 continue 181c 182 argos_prep_fix=.true. 183 return 184c 185 9999 continue 186 argos_prep_fix=.false. 187 return 188 end 189