subroutine contact(lprint,ncont,icont,co) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.INTERACT' include 'COMMON.FFIELD' include 'COMMON.NAMES' real*8 facont /1.569D0/ ! facont = (2/(1-sqrt(1-1/4)))**(1/6) integer ncont,icont(2,maxcont) logical lprint ncont=0 kkk=3 do i=nnt+kkk,nct iti=iabs(itype(i)) do j=nnt,i-kkk itj=iabs(itype(j)) if (ipot.ne.4) then c rcomp=sigmaii(iti,itj)+1.0D0 rcomp=facont*sigmaii(iti,itj) else c rcomp=sigma(iti,itj)+1.0D0 rcomp=facont*sigma(iti,itj) endif c rcomp=6.5D0 c print *,'rcomp=',rcomp,' dist=',dist(nres+i,nres+j) if (dist(nres+i,nres+j).lt.rcomp) then ncont=ncont+1 icont(1,ncont)=i icont(2,ncont)=j endif enddo enddo if (lprint) then write (iout,'(a)') 'Contact map:' do i=1,ncont i1=icont(1,i) i2=icont(2,i) it1=itype(i1) it2=itype(i2) write (iout,'(i3,2x,a,i4,2x,a,i4)') & i,restyp(it1),i1,restyp(it2),i2 enddo endif co = 0.0d0 do i=1,ncont co = co + dfloat(iabs(icont(1,i)-icont(2,i))) enddo co = co / (nres*ncont) return end c---------------------------------------------------------------------------- double precision function contact_fract(ncont,ncont_ref, & icont,icont_ref) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.IOUNITS' integer ncont,ncont_ref,icont(2,maxcont),icont_ref(2,maxcont) nmatch=0 c print *,'ncont=',ncont,' ncont_ref=',ncont_ref c write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) c write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) c write (iout,'(20i4)') (icont(1,i),i=1,ncont) c write (iout,'(20i4)') (icont(2,i),i=1,ncont) do i=1,ncont do j=1,ncont_ref if (icont(1,i).eq.icont_ref(1,j) .and. & icont(2,i).eq.icont_ref(2,j)) nmatch=nmatch+1 enddo enddo c print *,' nmatch=',nmatch c contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) contact_fract=dfloat(nmatch)/dfloat(ncont_ref) return end c---------------------------------------------------------------------------- double precision function contact_fract_nn(ncont,ncont_ref, & icont,icont_ref) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.IOUNITS' integer ncont,ncont_ref,icont(2,maxcont),icont_ref(2,maxcont) nmatch=0 c print *,'ncont=',ncont,' ncont_ref=',ncont_ref c write (iout,'(20i4)') (icont_ref(1,i),i=1,ncont_ref) c write (iout,'(20i4)') (icont_ref(2,i),i=1,ncont_ref) c write (iout,'(20i4)') (icont(1,i),i=1,ncont) c write (iout,'(20i4)') (icont(2,i),i=1,ncont) do i=1,ncont do j=1,ncont_ref if (icont(1,i).eq.icont_ref(1,j) .and. & icont(2,i).eq.icont_ref(2,j)) nmatch=nmatch+1 enddo enddo c print *,' nmatch=',nmatch c contact_fract=dfloat(nmatch)/dfloat(max0(ncont,ncont_ref)) contact_fract_nn=dfloat(ncont-nmatch)/dfloat(ncont) return end c---------------------------------------------------------------------------- subroutine hairpin(lprint,nharp,iharp) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.INTERACT' include 'COMMON.FFIELD' include 'COMMON.NAMES' integer ncont,icont(2,maxcont) integer nharp,iharp(4,maxres/3) logical lprint,not_done real*8 rcomp /6.0d0/ ncont=0 kkk=0 c print *,'nnt=',nnt,' nct=',nct do i=nnt,nct-3 do k=1,3 c(k,2*nres+1)=0.5d0*(c(k,i)+c(k,i+1)) enddo do j=i+2,nct-1 do k=1,3 c(k,2*nres+2)=0.5d0*(c(k,j)+c(k,j+1)) enddo if (dist(2*nres+1,2*nres+2).lt.rcomp) then ncont=ncont+1 icont(1,ncont)=i icont(2,ncont)=j endif enddo enddo if (lprint) then write (iout,'(a)') 'PP contact map:' do i=1,ncont i1=icont(1,i) i2=icont(2,i) it1=itype(i1) it2=itype(i2) write (iout,'(i3,2x,a,i4,2x,a,i4)') & i,restyp(it1),i1,restyp(it2),i2 enddo endif c finding hairpins nharp=0 do i=1,ncont i1=icont(1,i) j1=icont(2,i) if (j1.eq.i1+2 .and. i1.gt.nnt .and. j1.lt.nct) then c write (iout,*) "found turn at ",i1,j1 ii1=i1 jj1=j1 not_done=.true. do while (not_done) i1=i1-1 j1=j1+1 do j=1,ncont if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 enddo not_done=.false. 10 continue c write (iout,*) i1,j1,not_done enddo i1=i1+1 j1=j1-1 if (j1-i1.gt.4) then nharp=nharp+1 iharp(1,nharp)=i1 iharp(2,nharp)=j1 iharp(3,nharp)=ii1 iharp(4,nharp)=jj1 c write (iout,*)'nharp',nharp,' iharp',(iharp(k,nharp),k=1,4) endif endif enddo c do i=1,nharp c write (iout,*)'i',i,' iharp',(iharp(k,i),k=1,4) c enddo if (lprint) then write (iout,*) "Hairpins:",nharp do i=1,nharp i1=iharp(1,i) j1=iharp(2,i) ii1=iharp(3,i) jj1=iharp(4,i) write (iout,*) write (iout,'(20(a,i3,1x))') (restyp(itype(k)),k,k=i1,ii1) write (iout,'(20(a,i3,1x))') (restyp(itype(k)),k,k=j1,jj1,-1) c do k=jj1,j1,-1 c write (iout,'(a,i3,$)') restyp(itype(k)),k c enddo enddo endif return end c----------------------------------------------------------------------------