Merge branch 'devel' of mmka.chem.univ.gda.pl:unres into devel
[unres.git] / source / wham / src-M / read_dist_constr.F
1       subroutine read_dist_constr
2       implicit real*8 (a-h,o-z)
3       include 'DIMENSIONS'
4 #ifdef MPI
5       include 'mpif.h'
6 #endif
7       include 'COMMON.CONTROL'
8       include 'COMMON.CHAIN'
9       include 'COMMON.IOUNITS'
10       include 'COMMON.SBRIDGE'
11       integer ifrag_(2,100),ipair_(2,100)
12       double precision wfrag_(100),wpair_(100)
13       character*500 controlcard
14       logical lprn /.true./
15       write (iout,*) "Calling read_dist_constr"
16       write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup
17       call flush(iout)
18       call card_concat(controlcard)
19       call readi(controlcard,"NFRAG",nfrag_,0)
20       call readi(controlcard,"NPAIR",npair_,0)
21       call readi(controlcard,"NDIST",ndist_,0)
22       call reada(controlcard,'DIST_CUT',dist_cut,5.0d0)
23       call multreadi(controlcard,"IFRAG",ifrag_(1,1),2*nfrag_,0)
24       call multreadi(controlcard,"IPAIR",ipair_(1,1),2*npair_,0)
25       call multreada(controlcard,"WFRAG",wfrag_(1),nfrag_,0.0d0)
26       call multreada(controlcard,"WPAIR",wpair_(1),npair_,0.0d0)
27       write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_
28       write (iout,*) "IFRAG"
29       do i=1,nfrag_
30         write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i)
31       enddo
32       write (iout,*) "IPAIR"
33       do i=1,npair_
34         write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i)
35       enddo
36       call flush(iout)
37       do i=1,nfrag_
38         if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup
39         if (ifrag_(2,i).gt.nstart_sup+nsup-1)
40      &    ifrag_(2,i)=nstart_sup+nsup-1
41 c        write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i)
42         call flush(iout)
43         if (wfrag_(i).gt.0.0d0) then
44         do j=ifrag_(1,i),ifrag_(2,i)-1
45           do k=j+1,ifrag_(2,i)
46             write (iout,*) "j",j," k",k
47             ddjk=dist(j,k)
48             if (constr_dist.eq.1) then
49               nhpb=nhpb+1
50               ihpb(nhpb)=j
51               jhpb(nhpb)=k
52               dhpb(nhpb)=ddjk
53               forcon(nhpb)=wfrag_(i) 
54             else if (constr_dist.eq.2) then
55               if (ddjk.le.dist_cut) then
56                 nhpb=nhpb+1
57                 ihpb(nhpb)=j
58                 jhpb(nhpb)=k
59                 dhpb(nhpb)=ddjk
60                 forcon(nhpb)=wfrag_(i) 
61               endif
62             else
63               nhpb=nhpb+1
64               ihpb(nhpb)=j
65               jhpb(nhpb)=k
66               dhpb(nhpb)=ddjk
67               forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2)
68             endif
69             if (lprn)
70      &      write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ",
71      &       nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
72           enddo
73         enddo
74         endif
75       enddo
76       do i=1,npair_
77         if (wpair_(i).gt.0.0d0) then
78         ii = ipair_(1,i)
79         jj = ipair_(2,i)
80         if (ii.gt.jj) then
81           itemp=ii
82           ii=jj
83           jj=itemp
84         endif
85         do j=ifrag_(1,ii),ifrag_(2,ii)
86           do k=ifrag_(1,jj),ifrag_(2,jj)
87             nhpb=nhpb+1
88             ihpb(nhpb)=j
89             jhpb(nhpb)=k
90             forcon(nhpb)=wpair_(i)
91             dhpb(nhpb)=dist(j,k)
92             write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",
93      &       nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
94           enddo
95         enddo
96         endif
97       enddo 
98       do i=1,ndist_
99         read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1)
100         if (forcon(nhpb+1).gt.0.0d0) then
101           nhpb=nhpb+1
102           dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb))
103           write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ",
104      &     nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb)
105         endif
106       enddo
107       call flush(iout)
108       return
109       end