source: setmvs.f@ e40e335

Last change on this file since e40e335 was e40e335, checked in by baerbaer <baerbaer@…>, 16 years ago

Initial import to BerliOS corresponding to 3.0.4

git-svn-id: svn+ssh://svn.berlios.de/svnroot/repos/smmp/trunk@1 26dc1dd8-5c4e-0410-9ffe-d298b4865968

  • Property mode set to 100644
File size: 15.1 KB
Line 
1c**************************************************************
2c
3c This file contains the subroutines: setmvs,fndbrn
4c
5c Copyright 2003-2005 Frank Eisenmenger, U.H.E. Hansmann,
6c Shura Hayryan, Chin-Ku
7c Copyright 2007 Frank Eisenmenger, U.H.E. Hansmann,
8c Jan H. Meinke, Sandipan Mohanty
9c
10c **************************************************************
11
12
13 subroutine setmvs(nml)
14
15c ......................................................................
16c PURPOSE: 1. ORDER variables according to rules:
17c variables with same base: 1st comes TORSION (can be only
18c one with this base, since PHASE a. assumed to be FIXED),
19c after this, for atoms branching from this base:
20c for a b.angle & b.length with common primary moving
21c atom=branch atom - b.angle comes 1st
22c
23c iorvr(i), i=i_fivr_ml,i_lavr_ml -> indices of ordered var.
24c
25c 2. define NON-OVERLAPPING moving sets of atoms in molecule
26c 'nml' related to local variables
27c
28c nmsml(i_ml) - number of moving sets per molecule
29c imsvr1(i_vr),imsvr2() - indices of 1st/last m.s for var. 'i_vr'
30c in 'latms1' & 'latms2'
31c latms1(i_ms),latms2() - range of atoms of i-th m.s
32c
33c 3. define indices of next-following variables for each var.,
34c which complete its physical moving set ('added' variables)
35c
36c nadml(i_ml) - number of 'added' var.s per molecule
37c iadvr1(i_vr),iadvr2() - indices of 1st/last 'added' var. for
38c var. 'i_vr' in 'ladvr'
39c ladvr() - indices of 'added' variables
40c
41c 4. define index of corresponding variable for each atom
42c
43c ! routine must be called successively for molecules 1 -> ntlml
44c
45c CALLS: fndbrn, nursvr
46c ......................................................................
47
48 include 'INCL.H'
49
50 logical bb
51
52 parameter (mxh=10)
53 dimension lvw1h(mxh),lvw2h(mxh),l1h(mxh),l2h(mxh)
54
55
56 ntlvr=nvrml(nml)
57
58 if (nml.eq.1) then
59 imsml1(1)=1
60 nms=0
61 iadml1(1)=1
62 nad=0
63 else
64 imsml1(nml)=imsml1(nml-1)+nmsml(nml-1)
65 nms=imsml1(nml)-1
66 iadml1(nml)=iadml1(nml-1)+nadml(nml-1)
67 nad=iadml1(nml)-1
68 endif
69
70 if (ntlvr.eq.0) then
71 write (*,'(a,i4)')
72 # ' setmvs> No variables defined in molecule #',nml
73 nmsml(nml)=0
74 nadml(nml)=0
75 return
76 endif
77c _________________ Take index of primary atom for each variable
78c (i.e. index of atom moved by variable) to
79c sort variables, handling variables with same base:
80c modify indices to obtain appropriate order
81
82 ifirs=irsml1(nml)
83 ilars=irsml2(nml)
84
85 ifivr=ivrml1(nml)
86 ilavr=ifivr+ntlvr-1
87 ifiat=iatrs1(ifirs)
88 ilaat=iatrs2(ilars)
89
90 do n=ifirs,ilars ! ______________________ Residues
91 ib=ivrrs1(n)
92 do i=ib,ib+nvrrs(n)-1 ! _________________ Variables
93 ia=iatvr(i)
94 io=iowat(ia) ! ('ia' cannot be 1st atom of 'nml')
95 it=ityvr(i)
96 if (it.eq.3) then ! torsion
97 do j=1,nbdat(io)
98 ii=ibdat(j,io)
99 if (iowat(ii).eq.io) ia=min(ia,ii)
100 enddo
101 iadvr1(i)=ia*10
102 elseif (it.eq.2) then ! bond angle
103 iadvr1(i)=ia*10+1
104 elseif (it.eq.1) then ! bond length
105 iadvr1(i)=ia*10+2
106 endif
107 iorvr(i)=i ! (initialize for sorting)
108 enddo ! ... Variables
109 enddo ! ... Residues
110c ___________________________________ Sort variables in ascending order
111c (i.e. from start of molecule/base of branches)
112c array 'iorvr' gives indices of (1st,2nd, ... ,n-th) variables;
113c as can be found in arrays for variables (example: ityvr(iorvr())
114 k=ilavr
115 l=ifivr+ntlvr/2
116 ii=ifivr-1
117 1 if (l.gt.ifivr) then
118 l=l-1
119 io=iorvr(l)
120 n=iadvr1(io)
121 else
122 io=iorvr(k)
123 n=iadvr1(io)
124 iorvr(k)=iorvr(ifivr)
125 k=k-1
126 if (k.eq.ifivr) then
127 iorvr(k)=io
128 goto 2
129 endif
130 endif
131 i=l
132 j=l+l-ii
133 do while (j.le.k)
134 if (j.lt.k.and.iadvr1(iorvr(j)).lt.iadvr1(iorvr(j+1))) j=j+1
135 if (n.lt.iadvr1(iorvr(j))) then
136 iorvr(i)=iorvr(j)
137 i=j
138 j=j+j-ii
139 else
140 j=k+1
141 endif
142 enddo
143 iorvr(i)=io
144 goto 1
145c ______________________________ Find non-overlapping ranges of atoms (moving
146c sets) for each variable
147 2 nms=imsml1(nml)-1
148
149 do io=ifivr,ilavr ! _____ Loop over variables in 'ascendent' order
150 iv=iorvr(io)
151 ir=nursvr(iv) ! residue for variable 'iv'
152 ia=iatvr(iv) ! primary mov. atom
153 ib=iowat(ia) ! base
154c __________________________ First, determine complete mov. set for 'iv'
155 it=ityvr(iv)
156 if (it.eq.3) then ! torsion
157 i1=0
158 do i=1,nbdat(ib)
159 j=ibdat(i,ib)
160 if (iowat(j).eq.ib) then ! excl. ring
161 call fndbrn(nml,ir,j,k,irg1,irg2,bb)
162 if (bb) k=ilaat
163 if (i1.ne.0) then ! combine ranges
164 if (j.gt.(i2+1).or.k.lt.(i1-1)) then
165 write (*,'(3a,/,2a,i4,a,i3)')
166 # ' setmvs> Cannot combine disjunct ranges of atom',
167 # ' indices for torsion ',nmvr(iv),' in residue ',
168 # seq(ir),ir,' of molecule # ',nml
169 stop
170 else
171 if (j.lt.i1) i1=j
172 if (k.gt.i2) i2=k
173 endif
174 else
175 i1=j
176 i2=k
177 endif
178 endif
179 enddo
180 elseif (it.eq.2.or.it.eq.1) then ! b. angle, b. length
181 i1=ia
182 call fndbrn(nml,ir,i1,i2,irg1,irg2,bb)
183 if (bb) i2=ilaat
184 endif
185
186 if ((nms+1).gt.mxms) then
187 write (*,'(a,i4,a,i5)') ' setmvs> Molecule # ',nml,
188 # ': Number of moving sets > ',mxms
189 stop
190 endif
191
192 imsvr1(iv)=nms+1 ! index of 1st
193 imsvr2(iv)=nms+1 ! & last m.s for var. 'iv'
194
195c ______________ Next, exclude overlaps between mov. set for 'iv' and the
196c m.s. for 'previous' variables by reducing/splitting those
197
198 do jo=ifivr,io-1 ! prev. variables ...
199 jv=iorvr(jo)
200
201 j1s=imsvr1(jv) ! index of 1st m.s. for 'jv'
202 jns=imsvr2(jv)-j1s+1 ! # of m.s. for 'jv'
203
204 j=j1s
205 do while (j.lt.(j1s+jns)) ! while there are m.s. for 'jv'
206 j1=latms1(j) ! 1st &
207 j2=latms2(j) ! last atom of m.s. 'j'
208 if (i1.le.j2.and.i2.ge.j1) then ! Overlap
209 ja=0
210 if (i1.gt.j1) then
211 if (i2.gt.j2) goto 6
212 ja=1
213 latms2(j)=i1-1
214 endif
215 if (i2.lt.j2) then
216 if (i1.lt.j1) goto 6
217 if (ja.gt.0) then ! +1 moving set
218 nms=nms+1
219 if (nms.gt.mxms) then
220 write (*,'(a,i4,a,i5)') ' setmvs> Molecule # ',
221 # nml,': Number of moving sets > ',mxms
222 stop
223 endif
224 jns=jns+1
225 do k=nms,j+2,-1 ! shift ranges of m.s.
226 latms1(k)=latms1(k-1)
227 latms2(k)=latms2(k-1)
228 enddo
229 do ko=jo+1,io
230 k=iorvr(ko)
231 imsvr1(k)=imsvr1(k)+1
232 imsvr2(k)=imsvr2(k)+1
233 enddo
234 latms2(j+1)=j2
235 endif
236 latms1(j+ja)=i2+1
237 ja=ja+1
238 endif
239 if (ja.eq.0) then ! -1 moving set
240 nms=nms-1
241 jns=jns-1
242 do k=j,nms
243 latms1(k)=latms1(k+1)
244 latms2(k)=latms2(k+1)
245 enddo
246 do ko=jo+1,io
247 k=iorvr(ko)
248 imsvr1(k)=imsvr1(k)-1
249 imsvr2(k)=imsvr2(k)-1
250 enddo
251 else
252 j=j+ja
253 endif
254 else ! No overlap
255 j=j+1
256 endif
257 enddo ! mov. sets for 'jv'
258 imsvr2(jv)=j1s+jns-1
259
260 enddo ! prev. variables
261c _______________________________ Finally, add moving set for 'iv'
262 nms=nms+1
263 latms1(nms)=i1
264 latms2(nms)=i2
265 enddo ! variables
266 nmsml(nml)=nms-imsml1(nml)+1
267c _____________________________ Determine index of moving set for each atom
268 do ia=ifiat,ilaat
269 ixmsat(ia)=0
270 enddo
271 do is=imsml1(nml),nms
272 do ia=latms1(is),latms2(is)
273 ixmsat(ia)=is
274 enddo
275 enddo
276c _____________________________ Determine indices of variables which moving
277c set sets have to be added (=are related) to
278c those of a given variable
279
280 i=iorvr(ifivr) ! initialize index of CURRENT var.
281 ii=imsvr1(i) ! -"- index of its 1st m.s
282
283 do io=ifivr,ilavr-1 ! ________ loop over variables
284
285 ic=i ! save index of CURRENT var.
286 ia=iatvr(i) ! ist primar.mv.atom
287 ib=iowat(ia) ! its base
288 it=ityvr(i) ! its type
289 is=ii ! index of its 1st m.s
290
291 n=nad+1
292 iadvr1(i)=n ! # of its 1st 'added' var.
293
294 i=iorvr(io+1) ! index of next-in-order var.
295 ii=imsvr1(i) ! index of its 1st m.s
296
297 do jo=io+1,ilavr ! ______ over following-in-order var.
298 j=iorvr(jo) ! index of var.
299 ja=iatvr(j) ! its prim.mv.at
300 jb=iowat(ja) ! its base
301
302c _______________ current var. is torsion & shares base with var. 'j'
303 if (it.eq.3.and.jb.eq.ib) then
304 do k=n,nad ! ? has this branch been registered before ?
305 if (iatvr(ladvr(k)).eq.ja) goto 3
306 enddo
307 nad=nad+1
308 if (nad.gt.mxvr) then
309 write (*,'(a,i4,a,i5)') ' setmvs> Molecule # ',nml,
310 # ': Number of added variables > ',mxvr
311 stop
312 endif
313 ladvr(nad)=j ! save index of 'added' variable
314 endif
315
316 3 if (is.lt.ii) then ! _____ current var. has any m.s:
317 do k=is,ii-1 ! ? base of var. 'j' within m.s ?
318 if (latms1(k).le.jb.and.jb.le.latms2(k)) then
319 do l=n,nad
320 if (iatvr(ladvr(l)).eq.ja) goto 4
321 enddo
322 nad=nad+1
323 if (nad.gt.mxvr) then
324 write (*,'(a,i4,a,i5)') ' setmvs> Molecule # ',nml,
325 # ': Number of added variables > ',mxvr
326 stop
327 endif
328 ladvr(nad)=j
329 endif
330 4 enddo
331 else ! _____ current var. has no m.s:
332 if (ja.eq.ia) then ! ? share prim.mv.at with var. 'j' ?
333 do k=n,nad
334 if (iatvr(ladvr(k)).eq.ja) goto 5
335 enddo
336 nad=nad+1
337 if (nad.gt.mxvr) then
338 write (*,'(a,i4,a,i5)') ' setmvs> Molecule # ',nml,
339 # ': Number of added variables > ',mxvr
340 stop
341 endif
342 ladvr(nad)=j
343 endif
344 endif
345 5 enddo ! ... following-in-order variables
346 iadvr2(ic)=nad ! last 'added' var. for current var.
347 enddo ! ... variables
348
349 iadvr1(i)=nad+1 ! don't forget last variable
350 iadvr2(i)=nad
351
352 nadml(nml)=nad-iadml1(nml)+1
353c _____________________________________ Summary
354c do io=ilavr,ifivr,-1
355c iv=iorvr(io)
356c ib=iowat(iatvr(iv))
357c i1s=imsvr1(iv)
358c i2s=imsvr2(iv)
359c if (i1s.le.i2s) then
360c do i=i1s,i2s
361c i1=latms1(i)
362c i2=latms2(i)
363c if (i.eq.i1s) then
364c write (*,'(a,i3,7a,i4,3a,i4,a)') 'res # ',nursvr(iv),
365c # ' var: ',nmvr(iv),' base:',nmat(ib),' atoms= ',
366c # nmat(i1),'(',i1,') - ',nmat(i2),'(',i2,')'
367c else
368c write (*,'(39x,2a,i4,3a,i4,a)')
369c # nmat(i1),'(',i1,') - ',nmat(i2),'(',i2,')'
370c endif
371c enddo
372c else
373c write (*,'(a,i3,5a)') 'res # ',nursvr(iv),
374c # ' var: ',nmvr(iv),' base:',nmat(ib),' No atoms'
375c endif
376c i1a=iadvr1(iv)
377c i2a=iadvr2(iv)
378c if (i1a.le.i2a) then
379c write (*,'(a,30(1x,a))') ' Depending variables:',
380c # (nmvr(ladvr(i)),i=i1a,i2a)
381c else
382c write (*,'(a)') ' No dep. variables'
383c endif
384c enddo
385c _____________________________________ Summary - End
386
387 return
388
389 6 write (*,'(a,i4,/,2(a,i5),a)')
390 # ' setmvs> Error in atom numbering of molecule # ',nml,
391 # ': atom ranges for variables # ',iv,' and # ',jv,
392 # ' overlap only PARTLY'
393 stop
394
395 end
396c *******************************************************
397 subroutine fndbrn(nml,nrs,ifirg,ilarg,irg1,irg2,bb)
398
399c .........................................................
400c PURPOSE: determine range [ifirg,ilarg] of atom indices
401c for branch starting from atom 'ifirg' of residue
402c 'nrs' in molecule 'nml'
403c OUTPUT: BB - .t. if 'ifirg' is a backbone atom
404c IRG1 & IRG2 - atom indices of ring-closing bond,
405c if 'ifirg' is INSIDE a ring, but NOT
406c its 1st atom ( in 'multiple' rings
407c only LAST closing bond is given !)
408c
409c CALLS: none
410c
411c .........................................................
412
413 include 'INCL.H'
414
415 logical bb
416 dimension ibd(4)
417
418 ilarg=ifirg
419
420 bb=.false.
421 irg1=0
422
423 ifi=iatrs1(nrs)
424 ila=iatrs2(nrs)
425 ixt=ixatrs(nrs)
426
427 if (ifirg.eq.ifi) then ! = 1st mainchain atom
428 bb=.true.
429 if (nrs.ne.irsml1(nml)) then
430 ilarg=ila
431 else ! 1st residue of 'nml'
432
433 ibd(1)=iowat(ifirg)
434 ibd(2)=ibdat(1,ifirg)
435 ibd(3)=ibdat(2,ifirg)
436 ibd(4)=ibdat(3,ifirg)
437
438 il=0
439 do i=1,nbdat(ifirg)+1
440 ib=ibd(i)
441 if (ib.gt.il.and.iowat(ib).eq.ifirg) il=ib
442 enddo
443 if (il.gt.0) ilarg=il-1
444 endif
445 else
446 if (ifirg.eq.ixt) bb=.true.
447 do i=1,nbdat(ifirg) ! ______________ check bonds
448 ib=ibdat(i,ifirg)
449 if (iowat(ib).eq.ifirg) then ! branch
450 do j=ib,ila
451 if (j.gt.ib.and.iowat(j).lt.ib) goto 1
452 if (j.eq.ixt) bb=.true.
453 do k=1,nbdat(j)
454 jb=ibdat(k,j)
455 if (jb.lt.ifirg) then ! ring
456 irg1=j
457 irg2=jb
458 endif
459 enddo
460 ilarg=j
461 enddo ! ... branch atoms
462 elseif (ib.lt.ifirg) then ! ring
463 irg1=ifirg
464 irg2=ib
465 endif
466 1 enddo ! ... bonds
467 endif
468
469 return
470 end
471
Note: See TracBrowser for help on using the repository browser.