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