source: rmsdfun.f@ 32289cd

Last change on this file since 32289cd was 32289cd, checked in by baerbaer <baerbaer@…>, 14 years ago

Explicitly declare variables.

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

  • Property mode set to 100644
File size: 11.4 KB
Line 
1! **************************************************************
2!
3! This file contains the subroutines: rmsdfun,rmsdopt,fitmol,
4! jacobi,rmsinit
5!
6! Copyright 2003-2005 Frank Eisenmenger, U.H.E. Hansmann,
7! Shura Hayryan, Chin-Ku
8! Copyright 2007 Frank Eisenmenger, U.H.E. Hansmann,
9! Jan H. Meinke, Sandipan Mohanty
10!
11! **************************************************************
12
13 real*8 function rmsdfun(nml,ir1,ir2,ixat,xrf,yrf,zrf,isl)
14!
15! --------------------------------------------------------------
16! Wrapping function for calculating rmsd
17!
18! LIMITATION: requires call of rmsinit BEFORE calling this function
19!
20! CALLS: rmsdopt
21!
22! ---------------------------------------------------------------
23!
24 include 'INCL.H'
25 include 'INCP.H'
26!
27! Input
28 double precision xrf, yrf, zrf, rm, av1, av2, rssd
29
30 integer nml, ir1, ir2, ixat, isl
31
32 dimension ixat(mxat),xrf(mxatp),yrf(mxatp),zrf(mxatp)
33! Local
34 dimension rm(3,3),av1(3),av2(3)
35 call rmsdopt(nml,ir1,ir2,ixat,xrf,yrf,zrf,isl,rm,av1,av2,rssd)
36
37 rmsdfun = rssd
38
39 return
40
41 end
42
43!*******************************************************************
44 subroutine rmsdopt(nml,ir1,ir2,ixat,xrf,yrf,zrf,isl,
45 & rm,av1,av2,rmsd)
46
47! ---------------------------------------------------------------
48! PURPOSE: root mean square deviation (rmsd) between current SMMP
49! structure and reference atom coordinates 'x,y,zrf()'
50! for range of SMMP residues [ir1,ir2] in molecule 'nml'
51!
52! ixat(i) - points to the atom in ref. coords., which is
53! equivalent to atom i of SMMP structure
54! (=0 if no equivalent in ref. structure exists)
55!
56! isl = 0 : select all heavy atoms
57! isl = 1 : backbone atoms n,ca,c
58! isl = 2 : only ca atoms
59!
60! CALLS: fitmol [S.K.Kearsley, Acta Cryst. 1989, A45, 208-210]
61!
62! NB uncomment last lines in 'fitmol' to return coordinates
63! in 'x2' after fitting the ref. str. onto SMMP structure
64! ----------------------------------------------------------------
65
66 include 'INCL.H'
67 include 'INCP.H'
68
69 double precision x1, x2, xrf, yrf, zrf, rm, av1, av2, rmsd
70
71 integer nml, nr, na, n, im, ir, ia, ir1, ir2, ix, ixat, isl
72
73
74!-------------------------------------------------------- input
75 dimension ixat(mxat),xrf(mxatp),yrf(mxatp),zrf(mxatp)
76!-------------------------------------------------------- output
77 dimension rm(3,3),av1(3),av2(3)
78!-------------------------------------------------------- local
79 dimension x1(3,mxat),x2(3,mxat)
80 character*4 atnm
81
82
83 if (nml.lt.1.or.nml.gt.ntlml) then
84 write(*,*) ' rmsdopt> Sorry, there is no molecule #',nml
85 stop
86 endif
87
88
89 nr=0
90 na=0
91 n=0
92
93 do im=1,ntlml
94 do ir=irsml1(im),irsml2(im)
95 if (im.eq.nml) nr=nr+1
96
97 do ia=iatrs1(ir),iatrs2(ir)
98
99 na=na+1
100
101 if (im.eq.nml.and.nr.ge.ir1.and.nr.le.ir2) then ! range of res. for 'nml'
102
103 ix=ixat(na)
104 atnm=nmat(ia)
105
106 if (ix.gt.0.and.atnm(1:1).ne.'h') then
107
108 if ( isl.eq.0
109
110 & .or.
111
112 & (isl.eq.1.and.(index(atnm,'n ').gt.0 .or.
113 & index(atnm,'ca ').gt.0 .or.
114 & index(atnm,'c ').gt.0 ))
115 & .or.
116
117 & (isl.eq.2.and.index(atnm,'ca ').gt.0)
118
119 & ) then
120
121 n=n+1
122 x1(1,n)=xat(ia)
123 x1(2,n)=yat(ia)
124 x1(3,n)=zat(ia)
125 x2(1,n)=xrf(ix)
126 x2(2,n)=yrf(ix)
127 x2(3,n)=zrf(ix)
128
129 endif ! atom selection
130 endif ! ix>0 & not 'h'
131
132 endif ! res. range in mol. 'nml'
133
134 enddo ! atoms
135 enddo ! residues
136 enddo ! molecules
137
138 if (n.lt.3) then
139 write(*,*) ' rmsdopt> <3 atoms selected !'
140 stop
141 endif
142
143 call fitmol(n,x1,x2, rm,av1,av2,rmsd)
144
145 return
146 end
147! *********************************************
148 subroutine fitmol(n,x1,x2, rm,a1,a2,rmsd)
149! real*8 function fitmol(n,x1,x2)
150
151! .......................................................
152! PURPOSE: compute RMSD of n positions in x1(3,) & x2(3,)
153! [S.K.Kearsley Acta Cryst. 1989,A45,208-210]
154!
155! CALLS: jacobi
156! .......................................................
157!f2py intent(out) rmsd
158
159 include 'INCL.H'
160! implicit real*8 (a-h,o-z)
161! implicit integer*4 (i-n)
162
163! ------------------------------------------- input/output
164 double precision dn, a1, a2, x1, x2, q, dm, dp, dxm, dym, dzm, dxp
165 double precision dyp, dzp, e, v, em, rmsd, rm
166
167 integer n, i, j, ndim4, im
168
169 dimension x1(3,mxat),x2(3,mxat)
170! -------------------------------------------------- local
171 dimension e(4),q(4,4),v(4,4),dm(3),dp(3),a1(3),a2(3),rm(3,3)
172
173 dn=dble(n)
174! ------------------- average of coordinates
175 do i=1,3
176 a1(i) = 0.d0
177 a2(i) = 0.d0
178 do j=1,n
179 a1(i) = a1(i) + x1(i,j)
180 a2(i) = a2(i) + x2(i,j)
181 enddo
182 a1(i) = a1(i)/dn
183 a2(i) = a2(i)/dn
184 enddo
185! ------------------------- compile quaternion
186 do i=1,4
187 do j=1,4
188 q(i,j)=0.d0
189 enddo
190 enddo
191
192 do i=1,n
193
194 do j=1,3
195 dm(j) = x1(j,i)-a1(j)
196 dp(j) = x2(j,i)-a2(j)
197 enddo
198
199 dxm = dp(1) - dm(1)
200 dym = dp(2) - dm(2)
201 dzm = dp(3) - dm(3)
202 dxp = dp(1) + dm(1)
203 dyp = dp(2) + dm(2)
204 dzp = dp(3) + dm(3)
205
206 q(1,1) = q(1,1) + dxm * dxm + dym * dym + dzm * dzm
207 q(1,2) = q(1,2) + dyp * dzm - dym * dzp
208 q(1,3) = q(1,3) + dxm * dzp - dxp * dzm
209 q(1,4) = q(1,4) + dxp * dym - dxm * dyp
210 q(2,2) = q(2,2) + dyp * dyp + dzp * dzp + dxm * dxm
211 q(2,3) = q(2,3) + dxm * dym - dxp * dyp
212 q(2,4) = q(2,4) + dxm * dzm - dxp * dzp
213 q(3,3) = q(3,3) + dxp * dxp + dzp * dzp + dym * dym
214 q(3,4) = q(3,4) + dym * dzm - dyp * dzp
215 q(4,4) = q(4,4) + dxp * dxp + dyp * dyp + dzm * dzm
216
217 enddo
218
219 do i=1,3
220 do j=i+1,4
221 q(j,i)=q(i,j)
222 enddo
223 enddo
224! ------------------------------ eigenvalues & -vectors
225 ndim4=4
226 call jacobi(q,ndim4,e,v)
227! --------------------------- lowest eigenvalue
228 im=1
229 em=e(1)
230 do i=2,4
231 if (e(i).lt.em) then
232 em=e(i)
233 im=i
234 endif
235 enddo
236
237 rmsd = sqrt(em/dn)
238
239! ================= uncomment following lines to fit molecule 2 onto 1
240
241! ---------------------------------------------------rotation matrix
242 rm(1,1) = v(1,im)**2+v(2,im)**2-v(3,im)**2-v(4,im)**2
243 rm(1,2) = 2.d0*( v(2,im)*v(3,im)-v(1,im)*v(4,im) )
244 rm(1,3) = 2.d0*( v(2,im)*v(4,im)+v(1,im)*v(3,im) )
245 rm(2,1) = 2.d0*( v(2,im)*v(3,im)+v(1,im)*v(4,im) )
246 rm(2,2) = v(1,im)**2+v(3,im)**2-v(2,im)**2-v(4,im)**2
247 rm(2,3) = 2.d0*( v(3,im)*v(4,im)-v(1,im)*v(2,im) )
248 rm(3,1) = 2.d0*( v(2,im)*v(4,im)-v(1,im)*v(3,im) )
249 rm(3,2) = 2.d0*( v(3,im)*v(4,im)+v(1,im)*v(2,im) )
250 rm(3,3) = v(1,im)**2+v(4,im)**2-v(2,im)**2-v(3,im)**2
251
252! do i=1,n
253! do j=1,3
254! dm(j) = x2(j,i) - a2(j)
255! enddo
256! do j=1,3
257! dp(j) = a1(j)
258! do k=1,3
259! dp(j) = dp(j) + rm(j,k) * dm(k)
260! enddo
261! x2(j,i) = dp(j)
262! enddo
263! enddo
264
265! fitmol=rmsd
266
267 return
268 end
269! ******************************
270 subroutine jacobi(a,n,d,v)
271
272! ......................................................
273! PURPOSE: for given symmetric matrix 'a(n,n)
274! compute eigenvalues 'd' & eigenvectors 'v(,)'
275!
276! [W.H.Press,S.A.Teukolsky,W.T.Vetterling,
277! B.P.Flannery, Numerical Recipes in FORTRAN,
278! Cambridge Univ. Press, 2nd Ed. 1992, 456-462]
279!
280! CALLS: none
281!
282! ......................................................
283
284!f2py intent(out) d
285!f2py intent(out) v
286 integer nmax
287
288 parameter (NMAX=500)
289
290 integer n,nrot,i,ip,iq,j
291
292
293 real*8 a(n,n),d(n),v(n,n),
294 & c,g,h,s,sm,t,tau,theta,tresh,b(NMAX),z(NMAX),smeps
295
296 smeps=1.0d-6
297
298
299 do ip=1,n
300 b(ip)=a(ip,ip)
301 d(ip)=b(ip)
302 z(ip)=0.d0
303 do iq=1,n
304 v(ip,iq)=0.d0
305 enddo
306 v(ip,ip)=1.d0
307 enddo
308
309 nrot=0
310
311 do i=1,500
312
313 sm=0.d0
314
315 do ip=1,n-1
316 do iq=ip+1,n
317 sm=sm+abs(a(ip,iq))
318 enddo
319 enddo
320
321 if (sm.le.smeps) return ! normal end
322
323 if (i.lt.4) then
324 tresh=0.2d0*sm/n**2
325 else
326 tresh=0.d0
327 endif
328
329 do ip=1,n-1
330 do iq=ip+1,n
331
332 g=100.d0*abs(a(ip,iq))
333
334 if((i.gt.4).and.(abs(d(ip))+
335
336 &g.eq.abs(d(ip))).and.(abs(d(iq))+g.eq.abs(d(iq))))then
337 a(ip,iq)=0.d0
338
339 else if(abs(a(ip,iq)).gt.tresh)then
340
341 h=d(iq)-d(ip)
342
343 if (abs(h)+g.eq.abs(h)) then
344
345 t=a(ip,iq)/h
346
347 else
348
349 theta=0.5d0*h/a(ip,iq)
350 t=1.d0/(abs(theta)+sqrt(1.d0+theta**2))
351 if (theta.lt.0.d0) t=-t
352
353 endif
354
355 c=1.d0/sqrt(1.d0+t**2)
356 s=t*c
357 tau=s/(1.d0+c)
358 h=t*a(ip,iq)
359 z(ip)=z(ip)-h
360 z(iq)=z(iq)+h
361 d(ip)=d(ip)-h
362 d(iq)=d(iq)+h
363 a(ip,iq)=0.d0
364
365 do j=1,ip-1
366 g=a(j,ip)
367 h=a(j,iq)
368 a(j,ip)=g-s*(h+g*tau)
369 a(j,iq)=h+s*(g-h*tau)
370 enddo
371
372 do j=ip+1,iq-1
373 g=a(ip,j)
374 h=a(j,iq)
375 a(ip,j)=g-s*(h+g*tau)
376 a(j,iq)=h+s*(g-h*tau)
377 enddo
378 do j=iq+1,n
379 g=a(ip,j)
380 h=a(iq,j)
381 a(ip,j)=g-s*(h+g*tau)
382 a(iq,j)=h+s*(g-h*tau)
383 enddo
384 do j=1,n
385 g=v(j,ip)
386 h=v(j,iq)
387 v(j,ip)=g-s*(h+g*tau)
388 v(j,iq)=h+s*(g-h*tau)
389 enddo
390 nrot=nrot+1
391
392 endif
393
394 enddo
395 enddo
396
397 do ip=1,n
398 b(ip)=b(ip)+z(ip)
399 d(ip)=b(ip)
400 z(ip)=0.d0
401 enddo
402
403 enddo
404
405 write(*,*) ' jacobi> too many iterations'
406 stop
407
408 return
409 end
410
411! ***********************************************************
412
413 subroutine rmsinit(nml,string)
414!
415!------------------------------------------------------------------------------
416! Reads in pdb-file 'string' into INCP.H and initalizes
417! the files that 'rmdsopt' needs to calculate the rmsd
418! of a configuration with the pdb-configuration
419!
420! CALLS: pdbread,atixpdb
421!
422! ----------------------------------------------------------------------------
423!
424 include 'INCL.H'
425 include 'INCP.H'
426
427 integer i, nml, ier
428
429 character string*(*)
430
431 if(string.eq.'smmp') then
432!
433! Compare with a smmp-structure
434!
435 do i=iatrs1(irsml1(nml)),iatrs2(irsml2(nml))
436 if(nmat(i)(1:1).ne.'h') then
437 ixatp(i)=i
438 else
439 ixatp(i) = 0
440 end if
441 enddo
442!
443 else
444!
445! Reference structure is read in from pdb-file
446!
447 call pdbread(string,ier)
448 if(ier.ne.0) stop
449 call atixpdb(nml)
450!
451 end if
452 print *,'RMSD initialized with ',string
453 return
454
455 end
456
Note: See TracBrowser for help on using the repository browser.