subroutine etotal(energia) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' #ifndef ISNAN external proc_proc #endif #ifdef WINPGI cMS$ATTRIBUTES C :: proc_proc #endif include 'COMMON.IOUNITS' double precision energia(0:max_ene),energia1(0:max_ene+1) include 'COMMON.FFIELD' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.SBRIDGE' include 'COMMON.CHAIN' include 'COMMON.SHIELD' include 'COMMON.CONTROL' include 'COMMON.TORCNSTR' include 'COMMON.WEIGHTS' include 'COMMON.WEIGHTDER' c write(iout, '(a,i2)')'Calling etotal ipot=',ipot c call flush(iout) cd print *,'nnt=',nnt,' nct=',nct C C Compute the side-chain and electrostatic interaction energy C goto (101,102,103,104,105,106) ipot C Lennard-Jones potential. 101 call elj(evdw) cd print '(a)','Exit ELJ' goto 107 C Lennard-Jones-Kihara potential (shifted). 102 call eljk(evdw) goto 107 C Berne-Pechukas potential (dilated LJ, angular dependence). 103 call ebp(evdw) goto 107 C Gay-Berne potential (shifted LJ, angular dependence). 104 call egb(evdw) goto 107 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). 105 call egbv(evdw) goto 107 C New SC-SC potential 106 call emomo(evdw,evdw_p,evdw_m) C C Calculate electrostatic (H-bonding) energy of the main chain. C 107 continue call vec_and_deriv if (shield_mode.eq.1) then call set_shield_fac else if (shield_mode.eq.2) then call set_shield_fac2 endif call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) C write(iout,*) 'po eelec' C Calculate excluded-volume interaction energy between peptide groups C and side chains. C call escp(evdw2,evdw2_14) c c Calculate the bond-stretching energy c call ebond(estr) C write (iout,*) "estr",estr C C Calculate the disulfide-bridge and other energy and the contributions C from other distance constraints. cd print *,'Calling EHPB' call edis(ehpb) cd print *,'EHPB exitted succesfully.' C C Calculate the virtual-bond-angle energy. C C print *,'Bend energy finished.' if (wang.gt.0d0) then if (tor_mode.eq.0) then call ebend(ebe) else C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the C energy function call ebend_kcc(ebe) endif else ebe=0.0d0 endif ethetacnstr=0.0d0 if (with_theta_constr) call etheta_constr(ethetacnstr) c call ebend(ebe,ethetacnstr) cd print *,'Bend energy finished.' C C Calculate the SC local energy. C call esc(escloc) C print *,'SCLOC energy finished.' C C Calculate the virtual-bond torsional energy. C if (wtor.gt.0.0d0) then if (tor_mode.eq.0) then call etor(etors) else C etor kcc is Kubo cumulant clustered rigorous attemp to derive the C energy function call etor_kcc(etors) endif else etors=0.0d0 endif edihcnstr=0.0d0 if (ndih_constr.gt.0) call etor_constr(edihcnstr) c print *,"Processor",myrank," computed Utor" C C 6/23/01 Calculate double-torsional energy C if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then call etor_d(etors_d) else etors_d=0 endif c print *,"Processor",myrank," computed Utord" C call eback_sc_corr(esccor) eliptran=0.0d0 if (wliptran.gt.0) then call Eliptransfer(eliptran) endif C C 12/1/95 Multi-body terms C n_corr=0 n_corr1=0 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 & .or. wturn6.gt.0.0d0) then c write(iout,*)"calling multibody_eello" call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) c write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1 c write (iout,*) ecorr,ecorr5,ecorr6,eturn6 else ecorr=0.0d0 ecorr5=0.0d0 ecorr6=0.0d0 eturn6=0.0d0 endif if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then c write (iout,*) "Calling multibody_hbond" call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) endif #ifdef SPLITELE if (shield_mode.gt.0) then etot=wsc*(evdw+evdw_t)+wscp*evdw2 & +welec*ees & +wvdwpp*evdw1 & +wang*ebe+wtor*etors+wscloc*escloc & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 & +wcorr6*ecorr6+wturn4*eello_turn4 & +wturn3*eello_turn3+wturn6*eturn6 & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d & +wbond*estr+wsccor*esccor+ethetacnstr & +wliptran*eliptran else etot=wsc*(evdw+evdw_t)+wscp*evdw2+welec*ees & +wvdwpp*evdw1 & +wang*ebe+wtor*etors+wscloc*escloc & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 & +wcorr6*ecorr6+wturn4*eello_turn4 & +wturn3*eello_turn3+wturn6*eturn6 & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d & +wbond*estr+wsccor*esccor+ethetacnstr & +wliptran*eliptran endif #else if (shield_mode.gt.0) then etot=wsc*(evdw+evdw_t)+wscp*evdw2 & +welec*(ees+evdw1) & +wang*ebe+wtor*etors+wscloc*escloc & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 & +wcorr6*ecorr6+wturn4*eello_turn4 & +wturn3*eello_turn3+wturn6*eturn6 & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d & +wbond*estr+wsccor*esccor+ethetacnstr & +wliptran*eliptran else etot=wsc*(evdw+evdw_t)+wscp*evdw2 & +welec*(ees+evdw1) & +wang*ebe+wtor*etors+wscloc*escloc & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 & +wcorr6*ecorr6+wturn4*eello_turn4 & +wturn3*eello_turn3+wturn6*eturn6 & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d & +wbond*estr+wsccor*esccor+ethetacnstr & +wliptran*eliptran endif #endif energia(0)=etot energia(1)=evdw #ifdef SCP14 energia(2)=evdw2-evdw2_14 energia(17)=evdw2_14 #else energia(2)=evdw2 energia(17)=0.0d0 #endif #ifdef SPLITELE energia(3)=ees energia(16)=evdw1 #else energia(3)=ees+evdw1 energia(16)=0.0d0 #endif energia(4)=ecorr energia(5)=ecorr5 energia(6)=ecorr6 energia(7)=eel_loc energia(8)=eello_turn3 energia(9)=eello_turn4 energia(10)=eturn6 energia(11)=ebe energia(12)=escloc energia(13)=etors energia(14)=etors_d energia(15)=ehpb energia(17)=estr energia(19)=esccor energia(20)=edihcnstr energia(21)=evdw_t energia(24)=ethetacnstr energia(22)=eliptran c detecting NaNQ #ifdef ISNAN #ifdef AIX if (isnan(etot).ne.0) energia(0)=1.0d+99 #else if (isnan(etot)) energia(0)=1.0d+99 #endif #else i=0 #ifdef WINPGI idumm=proc_proc(etot,i) #else call proc_proc(etot,i) #endif if(i.eq.1)energia(0)=1.0d+99 #endif #ifdef MPL c endif #endif #ifdef DEBUG call enerprint(energia) #endif if (calc_grad) then C C Sum up the components of the Cartesian gradient. C #ifdef SPLITELE do i=1,nct do j=1,3 if (shield_mode.eq.0) then gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ & welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+ & wbond*gradb(j,i)+ & wstrain*ghpbc(j,i)+ & wcorr*gradcorr(j,i)+ & wel_loc*gel_loc(j,i)+ & wturn3*gcorr3_turn(j,i)+ & wturn4*gcorr4_turn(j,i)+ & wcorr5*gradcorr5(j,i)+ & wcorr6*gradcorr6(j,i)+ & wturn6*gcorr6_turn(j,i)+ & wsccor*gsccorc(j,i) & +wliptran*gliptranc(j,i) gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ & wbond*gradbx(j,i)+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ & wsccor*gsccorx(j,i) & +wliptran*gliptranx(j,i) else gradc(j,i,icg)=wsc*gvdwc(j,i) & +wscp*gvdwc_scp(j,i)+ & welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+ & wbond*gradb(j,i)+ & wstrain*ghpbc(j,i)+ & wcorr*gradcorr(j,i)+ & wel_loc*gel_loc(j,i)+ & wturn3*gcorr3_turn(j,i)+ & wturn4*gcorr4_turn(j,i)+ & wcorr5*gradcorr5(j,i)+ & wcorr6*gradcorr6(j,i)+ & wturn6*gcorr6_turn(j,i)+ & wsccor*gsccorc(j,i) & +wliptran*gliptranc(j,i) & +welec*gshieldc(j,i) & +welec*gshieldc_loc(j,i) & +wcorr*gshieldc_ec(j,i) & +wcorr*gshieldc_loc_ec(j,i) & +wturn3*gshieldc_t3(j,i) & +wturn3*gshieldc_loc_t3(j,i) & +wturn4*gshieldc_t4(j,i) & +wturn4*gshieldc_loc_t4(j,i) & +wel_loc*gshieldc_ll(j,i) & +wel_loc*gshieldc_loc_ll(j,i) gradx(j,i,icg)=wsc*gvdwx(j,i) & +wscp*gradx_scp(j,i)+ & wbond*gradbx(j,i)+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ & wsccor*gsccorx(j,i) & +wliptran*gliptranx(j,i) & +welec*gshieldx(j,i) & +wcorr*gshieldx_ec(j,i) & +wturn3*gshieldx_t3(j,i) & +wturn4*gshieldx_t4(j,i) & +wel_loc*gshieldx_ll(j,i) endif enddo #else do i=1,nct do j=1,3 if (shield_mode.eq.0) then gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ & welec*gelc(j,i)+wstrain*ghpbc(j,i)+ & wbond*gradb(j,i)+ & wcorr*gradcorr(j,i)+ & wel_loc*gel_loc(j,i)+ & wturn3*gcorr3_turn(j,i)+ & wturn4*gcorr4_turn(j,i)+ & wcorr5*gradcorr5(j,i)+ & wcorr6*gradcorr6(j,i)+ & wturn6*gcorr6_turn(j,i)+ & wsccor*gsccorc(j,i) & +wliptran*gliptranc(j,i) gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ & wbond*gradbx(j,i)+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ & wsccor*gsccorx(j,i) & +wliptran*gliptranx(j,i) else gradc(j,i,icg)=wsc*gvdwc(j,i)+ & wscp*gvdwc_scp(j,i)+ & welec*gelc(j,i)+wstrain*ghpbc(j,i)+ & wbond*gradb(j,i)+ & wcorr*gradcorr(j,i)+ & wel_loc*gel_loc(j,i)+ & wturn3*gcorr3_turn(j,i)+ & wturn4*gcorr4_turn(j,i)+ & wcorr5*gradcorr5(j,i)+ & wcorr6*gradcorr6(j,i)+ & wturn6*gcorr6_turn(j,i)+ & wsccor*gsccorc(j,i) & +wliptran*gliptranc(j,i) & +welec*gshieldc(j,i) & +welec*gshieldc_loc(j,i) & +wcorr*gshieldc_ec(j,i) & +wcorr*gshieldc_loc_ec(j,i) & +wturn3*gshieldc_t3(j,i) & +wturn3*gshieldc_loc_t3(j,i) & +wturn4*gshieldc_t4(j,i) & +wturn4*gshieldc_loc_t4(j,i) & +wel_loc*gshieldc_ll(j,i) & +wel_loc*gshieldc_loc_ll(j,i) gradx(j,i,icg)=wsc*gvdwx(j,i)+ & wscp*gradx_scp(j,i)+ & wbond*gradbx(j,i)+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ & wsccor*gsccorx(j,i) & +wliptran*gliptranx(j,i) & +welec*gshieldx(j,i) & +wcorr*gshieldx_ec(j,i) & +wturn3*gshieldx_t3(j,i) & +wturn4*gshieldx_t4(j,i) & +wel_loc*gshieldx_ll(j,i) endif enddo #endif enddo do i=1,nres-3 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) & +wcorr5*g_corr5_loc(i) & +wcorr6*g_corr6_loc(i) & +wturn4*gel_loc_turn4(i) & +wturn3*gel_loc_turn3(i) & +wturn6*gel_loc_turn6(i) & +wel_loc*gel_loc_loc(i) c & +wsccor*gsccor_loc(i) c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA enddo endif c if (dyn_ss) call dyn_set_nss return end C------------------------------------------------------------------------ subroutine enerprint(energia) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.SBRIDGE' double precision energia(0:max_ene) etot=energia(0) evdw=energia(1)+energia(21) #ifdef SCP14 evdw2=energia(2)+energia(17) #else evdw2=energia(2) #endif ees=energia(3) #ifdef SPLITELE evdw1=energia(16) #endif ecorr=energia(4) ecorr5=energia(5) ecorr6=energia(6) eel_loc=energia(7) eello_turn3=energia(8) eello_turn4=energia(9) eello_turn6=energia(10) ebe=energia(11) escloc=energia(12) etors=energia(13) etors_d=energia(14) ehpb=energia(15) esccor=energia(19) edihcnstr=energia(20) estr=energia(17) ethetacnstr=energia(24) eliptran=energia(22) #ifdef SPLITELE write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1, & wvdwpp, & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor, & etors_d,wtor_d,ehpb,wstrain, & ecorr,wcorr,ecorr5,wcorr5,ecorr6,wcorr6, & eel_loc,wel_loc,eello_turn3,wturn3, & eello_turn4,wturn4,eello_turn6,wturn6, & esccor,wsccor,edihcnstr,ethetacnstr,ebr*nss, & eliptran,wliptran,etot 10 format (/'Virtual-chain energies:'// & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/ & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, & ' (SS bridges & dist. cnstr.)'/ & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ & 'ETOT= ',1pE16.6,' (total)') #else write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,estr,wbond, & ebe,wang,escloc,wscloc,etors,wtor,etors_d,wtor_d, & ehpb,wstrain,ecorr,wcorr,ecorr5,wcorr5, & ecorr6,wcorr6,eel_loc,wel_loc, & eello_turn3,wturn3,eello_turn4,wturn4, & eello_turn6,wturn6,esccor,wsccor, & edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot 10 format (/'Virtual-chain energies:'// & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, & ' (SS bridges & dist. cnstr.)'/ & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ & 'ETOT= ',1pE16.6,' (total)') #endif return end C----------------------------------------------------------------------- subroutine elj(evdw) C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the LJ potential of interaction. C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' parameter (accur=1.0d-10) include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.TORSION' include 'COMMON.WEIGHTDER' include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' include 'COMMON.CONTACTS' dimension gg(3) integer icant external icant cd print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon do i=1,nntyp do j=1,2 eneps_temp(j,i)=0.0d0 enddo enddo evdw=0.0D0 do i=iatsc_s,iatsc_e itypi=itype(i) itypi1=itype(i+1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) C Change 12/1/95 num_conti=0 C C Calculate SC interaction energy. C do iint=1,nint_gr(i) cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), cd & 'iend=',iend(i,iint) do j=istart(i,iint),iend(i,iint) itypj=itype(j) xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi C Change 12/1/95 to calculate four-body interactions rij=xj*xj+yj*yj+zj*zj rrij=1.0D0/rij c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj eps0ij=eps(itypi,itypj) fac=rrij**expon2 e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) evdwij=e1+e2 ij=icant(itypi,itypj) eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij) eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, cd & (c(k,i),k=1,3),(c(k,j),k=1,3) evdw=evdw+evdwij if (calc_grad) then C C Calculate the components of the gradient in DC and X C fac=-rrij*(e1+evdwij) gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) gvdwx(k,j)=gvdwx(k,j)+gg(k) enddo do k=i,j-1 do l=1,3 gvdwc(l,k)=gvdwc(l,k)+gg(l) enddo enddo endif C C 12/1/95, revised on 5/20/97 C C Calculate the contact function. The ith column of the array JCONT will C contain the numbers of atoms that make contacts with the atom I (of numbers C greater than I). The arrays FACONT and GACONT will contain the values of C the contact function and its derivative. C C Uncomment next line, if the correlation interactions include EVDW explicitly. c if (j.gt.i+1 .and. evdwij.le.0.0D0) then C Uncomment next line, if the correlation interactions are contact function only if (j.gt.i+1.and. eps0ij.gt.0.0D0) then rij=dsqrt(rij) sigij=sigma(itypi,itypj) r0ij=rs0(itypi,itypj) C C Check whether the SC's are not too far to make a contact. C rcut=1.5d0*r0ij call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) C Add a new contact, if the SC's are close enough, but not too close (r.< c! om = omega, sqom = om^2 sqom1 = om1 * om1 sqom2 = om2 * om2 sqom12 = om12 * om12 c! now we calculate EGB - Gey-Berne c! It will be summed up in evdwij and saved in evdw sigsq = 1.0D0 / sigsq sig = sig0ij * dsqrt(sigsq) c! rij_shift = 1.0D0 / rij - sig + sig0ij rij_shift = Rtail - sig + sig0ij IF (rij_shift.le.0.0D0) THEN evdw = 1.0D20 RETURN END IF sigder = -sig * sigsq rij_shift = 1.0D0 / rij_shift fac = rij_shift**expon c1 = fac * fac * aa(itypi,itypj) c! c1 = 0.0d0 c2 = fac * bb(itypi,itypj) c! c2 = 0.0d0 evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) eps2der = eps3rt * evdwij eps3der = eps2rt * evdwij c! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij evdwij = eps2rt * eps3rt * evdwij c! evdwij = 0.0d0 c! write (*,*) "Gey Berne = ", evdwij #ifdef TSCSC IF (bb(itypi,itypj).gt.0) THEN evdw_p = evdw_p + evdwij ELSE evdw_m = evdw_m + evdwij END IF #else evdw = evdw & + evdwij #endif c!------------------------------------------------------------------- c! Calculate some components of GGB c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 fac = -expon * (c1 + evdwij) * rij_shift sigder = fac * sigder c! fac = rij * fac c! Calculate distance derivative c! gg(1) = xj * fac c! gg(2) = yj * fac c! gg(3) = zj * fac gg(1) = fac gg(2) = fac gg(3) = fac c! write (*,*) "gg(1) = ", gg(1) c! write (*,*) "gg(2) = ", gg(2) c! write (*,*) "gg(3) = ", gg(3) c! The angular derivatives of GGB are brought together in sc_grad c!------------------------------------------------------------------- c! Fcav c! c! Catch gly-gly interactions to skip calculation of something that c! does not exist IF (itypi.eq.10.and.itypj.eq.10) THEN Fcav = 0.0d0 dFdR = 0.0d0 dCAVdOM1 = 0.0d0 dCAVdOM2 = 0.0d0 dCAVdOM12 = 0.0d0 ELSE c! we are not 2 glycines, so we calculate Fcav (and maybe more) fac = chis1 * sqom1 + chis2 * sqom2 & - 2.0d0 * chis12 * om1 * om2 * om12 c! we will use pom later in Gcav, so dont mess with it! pom = 1.0d0 - chis1 * chis2 * sqom12 Lambf = (1.0d0 - (fac / pom)) Lambf = dsqrt(Lambf) sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0) c! write (*,*) "sparrow = ", sparrow Chif = Rtail * sparrow ChiLambf = Chif * Lambf eagle = dsqrt(ChiLambf) bat = ChiLambf ** 11.0d0 top = b1 * ( eagle + b2 * ChiLambf - b3 ) bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0) botsq = bot * bot c! write (*,*) "sig1 = ",sig1 c! write (*,*) "sig2 = ",sig2 c! write (*,*) "Rtail = ",Rtail c! write (*,*) "sparrow = ",sparrow c! write (*,*) "Chis1 = ", chis1 c! write (*,*) "Chis2 = ", chis2 c! write (*,*) "Chis12 = ", chis12 c! write (*,*) "om1 = ", om1 c! write (*,*) "om2 = ", om2 c! write (*,*) "om12 = ", om12 c! write (*,*) "sqom1 = ", sqom1 c! write (*,*) "sqom2 = ", sqom2 c! write (*,*) "sqom12 = ", sqom12 c! write (*,*) "Lambf = ",Lambf c! write (*,*) "b1 = ",b1 c! write (*,*) "b2 = ",b2 c! write (*,*) "b3 = ",b3 c! write (*,*) "b4 = ",b4 c! write (*,*) "top = ",top c! write (*,*) "bot = ",bot Fcav = top / bot c! Fcav = 0.0d0 c! write (*,*) "Fcav = ", Fcav c!------------------------------------------------------------------- c! derivative of Fcav is Gcav... c!--------------------------------------------------- dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf)) dbot = 12.0d0 * b4 * bat * Lambf dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow c! dFdR = 0.0d0 c! write (*,*) "dFcav/dR = ", dFdR dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif)) dbot = 12.0d0 * b4 * bat * Chif eagle = Lambf * pom dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle) dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle) dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) & * (chis2 * om2 * om12 - om1) / (eagle * pom) dFdL = ((dtop * bot - top * dbot) / botsq) c! dFdL = 0.0d0 dCAVdOM1 = dFdL * ( dFdOM1 ) dCAVdOM2 = dFdL * ( dFdOM2 ) dCAVdOM12 = dFdL * ( dFdOM12 ) c! write (*,*) "dFcav/dOM1 = ", dCAVdOM1 c! write (*,*) "dFcav/dOM2 = ", dCAVdOM2 c! write (*,*) "dFcav/dOM12 = ", dCAVdOM12 c! write (*,*) "" c!------------------------------------------------------------------- c! Finally, add the distance derivatives of GB and Fcav to gvdwc c! Pom is used here to project the gradient vector into c! cartesian coordinates and at the same time contains c! dXhb/dXsc derivative (for charged amino acids c! location of hydrophobic centre of interaction is not c! the same as geometric centre of side chain, this c! derivative takes that into account) c! derivatives of omega angles will be added in sc_grad DO k= 1, 3 ertail(k) = Rtail_distance(k)/Rtail END DO erdxi = scalar( ertail(1), dC_norm(1,i+nres) ) erdxj = scalar( ertail(1), dC_norm(1,j+nres) ) facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres) facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) gvdwx(k,i) = gvdwx(k,i) & - (( dFdR + gg(k) ) * pom) c! & - ( dFdR * pom ) pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres)) gvdwx(k,j) = gvdwx(k,j) & + (( dFdR + gg(k) ) * pom) c! & + ( dFdR * pom ) gvdwc(k,i) = gvdwc(k,i) & - (( dFdR + gg(k) ) * ertail(k)) c! & - ( dFdR * ertail(k)) gvdwc(k,j) = gvdwc(k,j) & + (( dFdR + gg(k) ) * ertail(k)) c! & + ( dFdR * ertail(k)) gg(k) = 0.0d0 c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) END DO c!------------------------------------------------------------------- c! Compute head-head and head-tail energies for each state isel = iabs(Qi) + iabs(Qj) IF (isel.eq.0) THEN c! No charges - do nothing eheadtail = 0.0d0 ELSE IF (isel.eq.4) THEN c! Calculate dipole-dipole interactions CALL edd(ecl) eheadtail = ECL ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN c! Charge-nonpolar interactions CALL eqn(epol) eheadtail = epol ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN c! Nonpolar-charge interactions CALL enq(epol) eheadtail = epol ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN c! Charge-dipole interactions CALL eqd(ecl, elj, epol) eheadtail = ECL + elj + epol ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN c! Dipole-charge interactions CALL edq(ecl, elj, epol) eheadtail = ECL + elj + epol ELSE IF ((isel.eq.2.and. & iabs(Qi).eq.1).and. & nstate(itypi,itypj).eq.1) THEN c! Same charge-charge interaction ( +/+ or -/- ) CALL eqq(Ecl,Egb,Epol,Fisocav,Elj) eheadtail = ECL + Egb + Epol + Fisocav + Elj ELSE IF ((isel.eq.2.and. & iabs(Qi).eq.1).and. & nstate(itypi,itypj).ne.1) THEN c! Different charge-charge interaction ( +/- or -/+ ) CALL energy_quad & (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) END IF END IF ! this endif ends the "catch the gly-gly" at the beggining of Fcav c! write (*,*) "evdw = ", evdw c! write (*,*) "Fcav = ", Fcav c! write (*,*) "eheadtail = ", eheadtail evdw = evdw & + Fcav & + eheadtail ij=icant(itypi,itypj) eneps_temp(1,ij)=eneps_temp(1,ij)+evdwij eneps_temp(2,ij)=eneps_temp(2,ij)+Fcav eneps_temp(3,ij)=eheadtail IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)') & restyp(itype(i)),i,restyp(itype(j)),j, & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, & Equad,evdw IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)') & restyp(itype(i)),i,restyp(itype(j)),j, & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, & Equad,evdw #ifdef CHECK_MOMO evdw = 0.0d0 END DO ! troll #endif c!------------------------------------------------------------------- c! As all angular derivatives are done, now we sum them up, c! then transform and project into cartesian vectors and add to gvdwc c! We call sc_grad always, with the exception of +/- interaction. c! This is because energy_quad subroutine needs to handle c! this job in his own way. c! This IS probably not very efficient and SHOULD be optimised c! but it will require major restructurization of emomo c! so it will be left as it is for now c! write (*,*) 'troll1, nstate =', nstate (itypi,itypj) IF (nstate(itypi,itypj).eq.1) THEN #ifdef TSCSC IF (bb(itypi,itypj).gt.0) THEN CALL sc_grad ELSE CALL sc_grad_T END IF #else CALL sc_grad #endif END IF c!------------------------------------------------------------------- c! NAPISY KONCOWE END DO ! j END DO ! iint END DO ! i c write (iout,*) "Number of loop steps in EGB:",ind c energy_dec=.false. RETURN END SUBROUTINE emomo c! END OF MOMO C----------------------------------------------------------------------------- SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj) IMPLICIT NONE INCLUDE 'DIMENSIONS' INCLUDE 'DIMENSIONS.ZSCOPT' INCLUDE 'COMMON.CALC' INCLUDE 'COMMON.CHAIN' INCLUDE 'COMMON.CONTROL' INCLUDE 'COMMON.DERIV' INCLUDE 'COMMON.EMP' INCLUDE 'COMMON.GEO' INCLUDE 'COMMON.INTERACT' INCLUDE 'COMMON.IOUNITS' INCLUDE 'COMMON.LOCAL' INCLUDE 'COMMON.NAMES' INCLUDE 'COMMON.VAR' double precision scalar, facd3, facd4, federmaus, adler c! Epol and Gpol analytical parameters alphapol1 = alphapol(itypi,itypj) alphapol2 = alphapol(itypj,itypi) c! Fisocav and Gisocav analytical parameters al1 = alphiso(1,itypi,itypj) al2 = alphiso(2,itypi,itypj) al3 = alphiso(3,itypi,itypj) al4 = alphiso(4,itypi,itypj) csig = (1.0d0 & / dsqrt(sigiso1(itypi, itypj)**2.0d0 & + sigiso2(itypi,itypj)**2.0d0)) c! pis = sig0head(itypi,itypj) eps_head = epshead(itypi,itypj) Rhead_sq = Rhead * Rhead c! R1 - distance between head of ith side chain and tail of jth sidechain c! R2 - distance between head of jth side chain and tail of ith sidechain R1 = 0.0d0 R2 = 0.0d0 DO k = 1, 3 c! Calculate head-to-tail distances needed by Epol R1=R1+(ctail(k,2)-chead(k,1))**2 R2=R2+(chead(k,2)-ctail(k,1))**2 END DO c! Pitagoras R1 = dsqrt(R1) R2 = dsqrt(R2) c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) c! & +dhead(1,1,itypi,itypj))**2)) c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) c! & +dhead(2,1,itypi,itypj))**2)) c!------------------------------------------------------------------- c! Coulomb electrostatic interaction Ecl = (332.0d0 * Qij) / Rhead c! derivative of Ecl is Gcl... dGCLdR = (-332.0d0 * Qij ) / Rhead_sq dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 c!------------------------------------------------------------------- c! Generalised Born Solvent Polarization c! Charged head polarizes the solvent ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) Fgb = sqrt( ( Rhead_sq ) + a12sq * ee) Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb c! Derivative of Egb is Ggb... dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb) dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) ) & / ( 2.0d0 * Fgb ) dGGBdR = dGGBdFGB * dFGBdR c!------------------------------------------------------------------- c! Fisocav - isotropic cavity creation term c! or "how much energy it costs to put charged head in water" pom = Rhead * csig top = al1 * (dsqrt(pom) + al2 * pom - al3) bot = (1.0d0 + al4 * pom**12.0d0) botsq = bot * bot FisoCav = top / bot c! write (*,*) "Rhead = ",Rhead c! write (*,*) "csig = ",csig c! write (*,*) "pom = ",pom c! write (*,*) "al1 = ",al1 c! write (*,*) "al2 = ",al2 c! write (*,*) "al3 = ",al3 c! write (*,*) "al4 = ",al4 c! write (*,*) "top = ",top c! write (*,*) "bot = ",bot c! Derivative of Fisocav is GCV... dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) dbot = 12.0d0 * al4 * pom ** 11.0d0 dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig c!------------------------------------------------------------------- c! Epol c! Polarization energy - charged heads polarize hydrophobic "neck" MomoFac1 = (1.0d0 - chi1 * sqom2) MomoFac2 = (1.0d0 - chi2 * sqom1) RR1 = ( R1 * R1 ) / MomoFac1 RR2 = ( R2 * R2 ) / MomoFac2 ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) fgb1 = sqrt( RR1 + a12sq * ee1 ) fgb2 = sqrt( RR2 + a12sq * ee2 ) epol = 332.0d0 * eps_inout_fac * ( & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) c! epol = 0.0d0 c write (*,*) "eps_inout_fac = ",eps_inout_fac c write (*,*) "alphapol1 = ", alphapol1 c write (*,*) "alphapol2 = ", alphapol2 c write (*,*) "fgb1 = ", fgb1 c write (*,*) "fgb2 = ", fgb2 c write (*,*) "epol = ", epol c! derivative of Epol is Gpol... dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) & / (fgb1 ** 5.0d0) dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) & / (fgb2 ** 5.0d0) dFGBdR1 = ( (R1 / MomoFac1) & * ( 2.0d0 - (0.5d0 * ee1) ) ) & / ( 2.0d0 * fgb1 ) dFGBdR2 = ( (R2 / MomoFac2) & * ( 2.0d0 - (0.5d0 * ee2) ) ) & / ( 2.0d0 * fgb2 ) dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) & * ( 2.0d0 - 0.5d0 * ee1) ) & / ( 2.0d0 * fgb1 ) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) & * ( 2.0d0 - 0.5d0 * ee2) ) & / ( 2.0d0 * fgb2 ) dPOLdR1 = dPOLdFGB1 * dFGBdR1 c! dPOLdR1 = 0.0d0 dPOLdR2 = dPOLdFGB2 * dFGBdR2 c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 c! dPOLdOM1 = 0.0d0 dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 c! dPOLdOM2 = 0.0d0 c!------------------------------------------------------------------- c! Elj c! Lennard-Jones 6-12 interaction between heads pom = (pis / Rhead)**6.0d0 Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) c! derivative of Elj is Glj dGLJdR = 4.0d0 * eps_head & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) c!------------------------------------------------------------------- c! Return the results c! These things do the dRdX derivatives, that is c! allow us to change what we see from function that changes with c! distance to function that changes with LOCATION (of the interaction c! site) DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j+nres) facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) c! Now we add appropriate partial derivatives (one in each dimension) DO k = 1, 3 hawk = (erhead_tail(k,1) + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) condor = (erhead_tail(k,2) + & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gvdwx(k,i) = gvdwx(k,i) & - dGCLdR * pom & - dGGBdR * pom & - dGCVdR * pom & - dPOLdR1 * hawk & - dPOLdR2 * (erhead_tail(k,2) & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) & - dGLJdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) gvdwx(k,j) = gvdwx(k,j) & + dGCLdR * pom & + dGGBdR * pom & + dGCVdR * pom & + dPOLdR1 * (erhead_tail(k,1) & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) & + dPOLdR2 * condor & + dGLJdR * pom gvdwc(k,i) = gvdwc(k,i) & - dGCLdR * erhead(k) & - dGGBdR * erhead(k) & - dGCVdR * erhead(k) & - dPOLdR1 * erhead_tail(k,1) & - dPOLdR2 * erhead_tail(k,2) & - dGLJdR * erhead(k) gvdwc(k,j) = gvdwc(k,j) & + dGCLdR * erhead(k) & + dGGBdR * erhead(k) & + dGCVdR * erhead(k) & + dPOLdR1 * erhead_tail(k,1) & + dPOLdR2 * erhead_tail(k,2) & + dGLJdR * erhead(k) END DO RETURN END SUBROUTINE eqq c!------------------------------------------------------------------- SUBROUTINE energy_quad &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) IMPLICIT NONE INCLUDE 'DIMENSIONS' INCLUDE 'DIMENSIONS.ZSCOPT' INCLUDE 'COMMON.CALC' INCLUDE 'COMMON.CHAIN' INCLUDE 'COMMON.CONTROL' INCLUDE 'COMMON.DERIV' INCLUDE 'COMMON.EMP' INCLUDE 'COMMON.GEO' INCLUDE 'COMMON.INTERACT' INCLUDE 'COMMON.IOUNITS' INCLUDE 'COMMON.LOCAL' INCLUDE 'COMMON.NAMES' INCLUDE 'COMMON.VAR' double precision scalar double precision ener(4) double precision dcosom1(3),dcosom2(3) c! used in Epol derivatives double precision facd3, facd4 double precision federmaus, adler c! Epol and Gpol analytical parameters alphapol1 = alphapol(itypi,itypj) alphapol2 = alphapol(itypj,itypi) c! Fisocav and Gisocav analytical parameters al1 = alphiso(1,itypi,itypj) al2 = alphiso(2,itypi,itypj) al3 = alphiso(3,itypi,itypj) al4 = alphiso(4,itypi,itypj) csig = (1.0d0 & / dsqrt(sigiso1(itypi, itypj)**2.0d0 & + sigiso2(itypi,itypj)**2.0d0)) c! w1 = wqdip(1,itypi,itypj) w2 = wqdip(2,itypi,itypj) pis = sig0head(itypi,itypj) eps_head = epshead(itypi,itypj) c! First things first: c! We need to do sc_grad's job with GB and Fcav eom1 = & eps2der * eps2rt_om1 & - 2.0D0 * alf1 * eps3der & + sigder * sigsq_om1 & + dCAVdOM1 eom2 = & eps2der * eps2rt_om2 & + 2.0D0 * alf2 * eps3der & + sigder * sigsq_om2 & + dCAVdOM2 eom12 = & evdwij * eps1_om12 & + eps2der * eps2rt_om12 & - 2.0D0 * alf12 * eps3der & + sigder *sigsq_om12 & + dCAVdOM12 c! now some magical transformations to project gradient into c! three cartesian vectors DO k = 1, 3 dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k)) dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k) c! this acts on hydrophobic center of interaction gvdwx(k,i)= gvdwx(k,i) - gg(k) & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv gvdwx(k,j)= gvdwx(k,j) + gg(k) & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv c! this acts on Calpha gvdwc(k,i)=gvdwc(k,i)-gg(k) gvdwc(k,j)=gvdwc(k,j)+gg(k) END DO c! sc_grad is done, now we will compute eheadtail = 0.0d0 eom1 = 0.0d0 eom2 = 0.0d0 eom12 = 0.0d0 c! ENERGY DEBUG c! ii = 1 c! jj = 1 c! d1 = dhead(1, 1, itypi, itypj) c! d2 = dhead(2, 1, itypi, itypj) c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) c! & +dhead(1,ii,itypi,itypj))**2)) c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) c! & +dhead(2,jj,itypi,itypj))**2)) c! Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2)) c! END OF ENERGY DEBUG c************************************************************* DO istate = 1, nstate(itypi,itypj) c************************************************************* IF (istate.ne.1) THEN IF (istate.lt.3) THEN ii = 1 ELSE ii = 2 END IF jj = istate/ii d1 = dhead(1,ii,itypi,itypj) d2 = dhead(2,jj,itypi,itypj) DO k = 1,3 chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) Rhead_distance(k) = chead(k,2) - chead(k,1) END DO c! pitagoras (root of sum of squares) Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) END IF Rhead_sq = Rhead * Rhead c! R1 - distance between head of ith side chain and tail of jth sidechain c! R2 - distance between head of jth side chain and tail of ith sidechain R1 = 0.0d0 R2 = 0.0d0 DO k = 1, 3 c! Calculate head-to-tail distances R1=R1+(ctail(k,2)-chead(k,1))**2 R2=R2+(chead(k,2)-ctail(k,1))**2 END DO c! Pitagoras R1 = dsqrt(R1) R2 = dsqrt(R2) c! ENERGY DEBUG c! write (*,*) "istate = ", istate c! write (*,*) "ii = ", ii c! write (*,*) "jj = ", jj c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) c! & +dhead(1,ii,itypi,itypj))**2)) c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) c! & +dhead(2,jj,itypi,itypj))**2)) c! Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2)) c! Rhead_sq = Rhead * Rhead c! write (*,*) "d1 = ",d1 c! write (*,*) "d2 = ",d2 c! write (*,*) "R1 = ",R1 c! write (*,*) "R2 = ",R2 c! write (*,*) "Rhead = ",Rhead c! END OF ENERGY DEBUG c!------------------------------------------------------------------- c! Coulomb electrostatic interaction Ecl = (332.0d0 * Qij) / (Rhead * eps_in) c! Ecl = 0.0d0 c! write (*,*) "Ecl = ", Ecl c! derivative of Ecl is Gcl... dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in) c! dGCLdR = 0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 c!------------------------------------------------------------------- c! Generalised Born Solvent Polarization ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) Fgb = sqrt( ( Rhead_sq ) + a12sq * ee) Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb c! Egb = 0.0d0 c! write (*,*) "a1*a2 = ", a12sq c! write (*,*) "Rhead = ", Rhead c! write (*,*) "Rhead_sq = ", Rhead_sq c! write (*,*) "ee = ", ee c! write (*,*) "Fgb = ", Fgb c! write (*,*) "fac = ", eps_inout_fac c! write (*,*) "Qij = ", Qij c! write (*,*) "Egb = ", Egb c! Derivative of Egb is Ggb... c! dFGBdR is used by Quad's later... dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb) dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) ) & / ( 2.0d0 * Fgb ) dGGBdR = dGGBdFGB * dFGBdR c! dGGBdR = 0.0d0 c!------------------------------------------------------------------- c! Fisocav - isotropic cavity creation term pom = Rhead * csig top = al1 * (dsqrt(pom) + al2 * pom - al3) bot = (1.0d0 + al4 * pom**12.0d0) botsq = bot * bot FisoCav = top / bot c! FisoCav = 0.0d0 c! write (*,*) "pom = ",pom c! write (*,*) "al1 = ",al1 c! write (*,*) "al2 = ",al2 c! write (*,*) "al3 = ",al3 c! write (*,*) "al4 = ",al4 c! write (*,*) "top = ",top c! write (*,*) "bot = ",bot c! write (*,*) "Fisocav = ", Fisocav c! Derivative of Fisocav is GCV... dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) dbot = 12.0d0 * al4 * pom ** 11.0d0 dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig c! dGCVdR = 0.0d0 c!------------------------------------------------------------------- c! Polarization energy c! Epol MomoFac1 = (1.0d0 - chi1 * sqom2) MomoFac2 = (1.0d0 - chi2 * sqom1) RR1 = ( R1 * R1 ) / MomoFac1 RR2 = ( R2 * R2 ) / MomoFac2 ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) fgb1 = sqrt( RR1 + a12sq * ee1 ) fgb2 = sqrt( RR2 + a12sq * ee2 ) epol = 332.0d0 * eps_inout_fac * ( & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) c! epol = 0.0d0 c! derivative of Epol is Gpol... dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) & / (fgb1 ** 5.0d0) dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) & / (fgb2 ** 5.0d0) dFGBdR1 = ( (R1 / MomoFac1) & * ( 2.0d0 - (0.5d0 * ee1) ) ) & / ( 2.0d0 * fgb1 ) dFGBdR2 = ( (R2 / MomoFac2) & * ( 2.0d0 - (0.5d0 * ee2) ) ) & / ( 2.0d0 * fgb2 ) dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) & * ( 2.0d0 - 0.5d0 * ee1) ) & / ( 2.0d0 * fgb1 ) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) & * ( 2.0d0 - 0.5d0 * ee2) ) & / ( 2.0d0 * fgb2 ) dPOLdR1 = dPOLdFGB1 * dFGBdR1 c! dPOLdR1 = 0.0d0 dPOLdR2 = dPOLdFGB2 * dFGBdR2 c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 c! dPOLdOM1 = 0.0d0 dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 c! dPOLdOM2 = 0.0d0 c!------------------------------------------------------------------- c! Elj pom = (pis / Rhead)**6.0d0 Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) c! Elj = 0.0d0 c! derivative of Elj is Glj dGLJdR = 4.0d0 * eps_head & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) c! dGLJdR = 0.0d0 c!------------------------------------------------------------------- c! Equad IF (Wqd.ne.0.0d0) THEN Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) & - 37.5d0 * ( sqom1 + sqom2 ) & + 157.5d0 * ( sqom1 * sqom2 ) & - 45.0d0 * om1*om2*om12 fac = -( Wqd / (2.0d0 * Fgb**5.0d0) ) Equad = fac * Beta1 c! Equad = 0.0d0 c! derivative of Equad... dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR c! dQUADdR = 0.0d0 dQUADdOM1 = fac & * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12) c! dQUADdOM1 = 0.0d0 dQUADdOM2 = fac & * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12) c! dQUADdOM2 = 0.0d0 dQUADdOM12 = fac & * ( 6.0d0*om12 - 45.0d0*om1*om2 ) c! dQUADdOM12 = 0.0d0 ELSE Beta1 = 0.0d0 Equad = 0.0d0 END IF c!------------------------------------------------------------------- c! Return the results c! Angular stuff eom1 = dPOLdOM1 + dQUADdOM1 eom2 = dPOLdOM2 + dQUADdOM2 eom12 = dQUADdOM12 c! now some magical transformations to project gradient into c! three cartesian vectors DO k = 1, 3 dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k)) dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k) END DO c! Radial stuff DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j+nres) facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) c! Throw the results into gheadtail which holds gradients c! for each micro-state DO k = 1, 3 hawk = erhead_tail(k,1) + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)) condor = erhead_tail(k,2) + & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) c! this acts on hydrophobic center of interaction gheadtail(k,1,1) = gheadtail(k,1,1) & - dGCLdR * pom & - dGGBdR * pom & - dGCVdR * pom & - dPOLdR1 * hawk & - dPOLdR2 * (erhead_tail(k,2) & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) & - dGLJdR * pom & - dQUADdR * pom & - tuna(k) & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) c! this acts on hydrophobic center of interaction gheadtail(k,2,1) = gheadtail(k,2,1) & + dGCLdR * pom & + dGGBdR * pom & + dGCVdR * pom & + dPOLdR1 * (erhead_tail(k,1) & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) & + dPOLdR2 * condor & + dGLJdR * pom & + dQUADdR * pom & + tuna(k) & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv c! this acts on Calpha gheadtail(k,3,1) = gheadtail(k,3,1) & - dGCLdR * erhead(k) & - dGGBdR * erhead(k) & - dGCVdR * erhead(k) & - dPOLdR1 * erhead_tail(k,1) & - dPOLdR2 * erhead_tail(k,2) & - dGLJdR * erhead(k) & - dQUADdR * erhead(k) & - tuna(k) c! this acts on Calpha gheadtail(k,4,1) = gheadtail(k,4,1) & + dGCLdR * erhead(k) & + dGGBdR * erhead(k) & + dGCVdR * erhead(k) & + dPOLdR1 * erhead_tail(k,1) & + dPOLdR2 * erhead_tail(k,2) & + dGLJdR * erhead(k) & + dQUADdR * erhead(k) & + tuna(k) END DO c! write(*,*) "ECL = ", Ecl c! write(*,*) "Egb = ", Egb c! write(*,*) "Epol = ", Epol c! write(*,*) "Fisocav = ", Fisocav c! write(*,*) "Elj = ", Elj c! write(*,*) "Equad = ", Equad c! write(*,*) "wstate = ", wstate(istate,itypi,itypj) c! write(*,*) "eheadtail = ", eheadtail c! write(*,*) "TROLL = ", dexp(-betaT * ener(istate)) c! write(*,*) "dGCLdR = ", dGCLdR c! write(*,*) "dGGBdR = ", dGGBdR c! write(*,*) "dGCVdR = ", dGCVdR c! write(*,*) "dPOLdR1 = ", dPOLdR1 c! write(*,*) "dPOLdR2 = ", dPOLdR2 c! write(*,*) "dGLJdR = ", dGLJdR c! write(*,*) "dQUADdR = ", dQUADdR c! write(*,*) "tuna(",k,") = ", tuna(k) ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad eheadtail = eheadtail & + wstate(istate, itypi, itypj) & * dexp(-betaT * ener(istate)) c! foreach cartesian dimension DO k = 1, 3 c! foreach of two gvdwx and gvdwc DO l = 1, 4 gheadtail(k,l,2) = gheadtail(k,l,2) & + wstate( istate, itypi, itypj ) & * dexp(-betaT * ener(istate)) & * gheadtail(k,l,1) gheadtail(k,l,1) = 0.0d0 END DO END DO END DO c! Here ended the gigantic DO istate = 1, 4, which starts c! at the beggining of the subroutine DO k = 1, 3 DO l = 1, 4 gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail END DO gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2) gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2) gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2) gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2) DO l = 1, 4 gheadtail(k,l,1) = 0.0d0 gheadtail(k,l,2) = 0.0d0 END DO END DO eheadtail = (-dlog(eheadtail)) / betaT dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 dQUADdOM1 = 0.0d0 dQUADdOM2 = 0.0d0 dQUADdOM12 = 0.0d0 RETURN END SUBROUTINE energy_quad c!------------------------------------------------------------------- SUBROUTINE eqn(Epol) IMPLICIT NONE INCLUDE 'DIMENSIONS' INCLUDE 'DIMENSIONS.ZSCOPT' INCLUDE 'COMMON.CALC' INCLUDE 'COMMON.CHAIN' INCLUDE 'COMMON.CONTROL' INCLUDE 'COMMON.DERIV' INCLUDE 'COMMON.EMP' INCLUDE 'COMMON.GEO' INCLUDE 'COMMON.INTERACT' INCLUDE 'COMMON.IOUNITS' INCLUDE 'COMMON.LOCAL' INCLUDE 'COMMON.NAMES' INCLUDE 'COMMON.VAR' double precision scalar, facd4, federmaus alphapol1 = alphapol(itypi,itypj) c! R1 - distance between head of ith side chain and tail of jth sidechain R1 = 0.0d0 DO k = 1, 3 c! Calculate head-to-tail distances R1=R1+(ctail(k,2)-chead(k,1))**2 END DO c! Pitagoras R1 = dsqrt(R1) c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) c! & +dhead(1,1,itypi,itypj))**2)) c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) c! & +dhead(2,1,itypi,itypj))**2)) c-------------------------------------------------------------------- c Polarization energy c Epol MomoFac1 = (1.0d0 - chi1 * sqom2) RR1 = R1 * R1 / MomoFac1 ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) fgb1 = sqrt( RR1 + a12sq * ee1) epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) c! epol = 0.0d0 c!------------------------------------------------------------------ c! derivative of Epol is Gpol... dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) & / (fgb1 ** 5.0d0) dFGBdR1 = ( (R1 / MomoFac1) & * ( 2.0d0 - (0.5d0 * ee1) ) ) & / ( 2.0d0 * fgb1 ) dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) & * (2.0d0 - 0.5d0 * ee1) ) & / (2.0d0 * fgb1) dPOLdR1 = dPOLdFGB1 * dFGBdR1 c! dPOLdR1 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 c! dPOLdOM2 = 0.0d0 c!------------------------------------------------------------------- c! Return the results c! (see comments in Eqq) DO k = 1, 3 erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) END DO bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) facd1 = d1 * vbld_inv(i+nres) facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 hawk = (erhead_tail(k,1) + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) gvdwx(k,i) = gvdwx(k,i) & - dPOLdR1 * hawk gvdwx(k,j) = gvdwx(k,j) & + dPOLdR1 * (erhead_tail(k,1) & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) gvdwc(k,i) = gvdwc(k,i) & - dPOLdR1 * erhead_tail(k,1) gvdwc(k,j) = gvdwc(k,j) & + dPOLdR1 * erhead_tail(k,1) END DO RETURN END SUBROUTINE eqn c!------------------------------------------------------------------- SUBROUTINE enq(Epol) IMPLICIT NONE INCLUDE 'DIMENSIONS' INCLUDE 'DIMENSIONS.ZSCOPT' INCLUDE 'COMMON.CALC' INCLUDE 'COMMON.CHAIN' INCLUDE 'COMMON.CONTROL' INCLUDE 'COMMON.DERIV' INCLUDE 'COMMON.EMP' INCLUDE 'COMMON.GEO' INCLUDE 'COMMON.INTERACT' INCLUDE 'COMMON.IOUNITS' INCLUDE 'COMMON.LOCAL' INCLUDE 'COMMON.NAMES' INCLUDE 'COMMON.VAR' double precision scalar, facd3, adler alphapol2 = alphapol(itypj,itypi) c! R2 - distance between head of jth side chain and tail of ith sidechain R2 = 0.0d0 DO k = 1, 3 c! Calculate head-to-tail distances R2=R2+(chead(k,2)-ctail(k,1))**2 END DO c! Pitagoras R2 = dsqrt(R2) c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) c! & +dhead(1,1,itypi,itypj))**2)) c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) c! & +dhead(2,1,itypi,itypj))**2)) c------------------------------------------------------------------------ c Polarization energy MomoFac2 = (1.0d0 - chi2 * sqom1) RR2 = R2 * R2 / MomoFac2 ee2 = exp(-(RR2 / (4.0d0 * a12sq))) fgb2 = sqrt(RR2 + a12sq * ee2) epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) c! epol = 0.0d0 c!------------------------------------------------------------------- c! derivative of Epol is Gpol... dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) & / (fgb2 ** 5.0d0) dFGBdR2 = ( (R2 / MomoFac2) & * ( 2.0d0 - (0.5d0 * ee2) ) ) & / (2.0d0 * fgb2) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) & * (2.0d0 - 0.5d0 * ee2) ) & / (2.0d0 * fgb2) dPOLdR2 = dPOLdFGB2 * dFGBdR2 c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 c! dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 c!------------------------------------------------------------------- c! Return the results c! (See comments in Eqq) DO k = 1, 3 erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) facd2 = d2 * vbld_inv(j+nres) facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) DO k = 1, 3 condor = (erhead_tail(k,2) & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) gvdwx(k,i) = gvdwx(k,i) & - dPOLdR2 * (erhead_tail(k,2) & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) gvdwx(k,j) = gvdwx(k,j) & + dPOLdR2 * condor gvdwc(k,i) = gvdwc(k,i) & - dPOLdR2 * erhead_tail(k,2) gvdwc(k,j) = gvdwc(k,j) & + dPOLdR2 * erhead_tail(k,2) END DO RETURN END SUBROUTINE enq c!------------------------------------------------------------------- SUBROUTINE eqd(Ecl,Elj,Epol) IMPLICIT NONE INCLUDE 'DIMENSIONS' INCLUDE 'DIMENSIONS.ZSCOPT' INCLUDE 'COMMON.CALC' INCLUDE 'COMMON.CHAIN' INCLUDE 'COMMON.CONTROL' INCLUDE 'COMMON.DERIV' INCLUDE 'COMMON.EMP' INCLUDE 'COMMON.GEO' INCLUDE 'COMMON.INTERACT' INCLUDE 'COMMON.IOUNITS' INCLUDE 'COMMON.LOCAL' INCLUDE 'COMMON.NAMES' INCLUDE 'COMMON.VAR' double precision scalar, facd4, federmaus alphapol1 = alphapol(itypi,itypj) w1 = wqdip(1,itypi,itypj) w2 = wqdip(2,itypi,itypj) pis = sig0head(itypi,itypj) eps_head = epshead(itypi,itypj) c!------------------------------------------------------------------- c! R1 - distance between head of ith side chain and tail of jth sidechain R1 = 0.0d0 DO k = 1, 3 c! Calculate head-to-tail distances R1=R1+(ctail(k,2)-chead(k,1))**2 END DO c! Pitagoras R1 = dsqrt(R1) c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) c! & +dhead(1,1,itypi,itypj))**2)) c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) c! & +dhead(2,1,itypi,itypj))**2)) c!------------------------------------------------------------------- c! ecl sparrow = w1 * Qi * om1 hawk = w2 * Qi * Qi * (1.0d0 - sqom2) Ecl = sparrow / Rhead**2.0d0 & - hawk / Rhead**4.0d0 c!------------------------------------------------------------------- c! derivative of ecl is Gcl c! dF/dr part dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 & + 4.0d0 * hawk / Rhead**5.0d0 c! dF/dom1 dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) c! dF/dom2 dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) c-------------------------------------------------------------------- c Polarization energy c Epol MomoFac1 = (1.0d0 - chi1 * sqom2) RR1 = R1 * R1 / MomoFac1 ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) fgb1 = sqrt( RR1 + a12sq * ee1) epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) c! epol = 0.0d0 c!------------------------------------------------------------------ c! derivative of Epol is Gpol... dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) & / (fgb1 ** 5.0d0) dFGBdR1 = ( (R1 / MomoFac1) & * ( 2.0d0 - (0.5d0 * ee1) ) ) & / ( 2.0d0 * fgb1 ) dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) & * (2.0d0 - 0.5d0 * ee1) ) & / (2.0d0 * fgb1) dPOLdR1 = dPOLdFGB1 * dFGBdR1 c! dPOLdR1 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 c! dPOLdOM2 = 0.0d0 c!------------------------------------------------------------------- c! Elj pom = (pis / Rhead)**6.0d0 Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) c! derivative of Elj is Glj dGLJdR = 4.0d0 * eps_head & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) c!------------------------------------------------------------------- c! Return the results DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j+nres) facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 hawk = (erhead_tail(k,1) + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gvdwx(k,i) = gvdwx(k,i) & - dGCLdR * pom & - dPOLdR1 * hawk & - dGLJdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) gvdwx(k,j) = gvdwx(k,j) & + dGCLdR * pom & + dPOLdR1 * (erhead_tail(k,1) & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) & + dGLJdR * pom gvdwc(k,i) = gvdwc(k,i) & - dGCLdR * erhead(k) & - dPOLdR1 * erhead_tail(k,1) & - dGLJdR * erhead(k) gvdwc(k,j) = gvdwc(k,j) & + dGCLdR * erhead(k) & + dPOLdR1 * erhead_tail(k,1) & + dGLJdR * erhead(k) END DO RETURN END SUBROUTINE eqd c!------------------------------------------------------------------- SUBROUTINE edq(Ecl,Elj,Epol) IMPLICIT NONE INCLUDE 'DIMENSIONS' INCLUDE 'DIMENSIONS.ZSCOPT' INCLUDE 'COMMON.CALC' INCLUDE 'COMMON.CHAIN' INCLUDE 'COMMON.CONTROL' INCLUDE 'COMMON.DERIV' INCLUDE 'COMMON.EMP' INCLUDE 'COMMON.GEO' INCLUDE 'COMMON.INTERACT' INCLUDE 'COMMON.IOUNITS' INCLUDE 'COMMON.LOCAL' INCLUDE 'COMMON.NAMES' INCLUDE 'COMMON.VAR' double precision scalar, facd3, adler alphapol2 = alphapol(itypj,itypi) w1 = wqdip(1,itypi,itypj) w2 = wqdip(2,itypi,itypj) pis = sig0head(itypi,itypj) eps_head = epshead(itypi,itypj) c!------------------------------------------------------------------- c! R2 - distance between head of jth side chain and tail of ith sidechain R2 = 0.0d0 DO k = 1, 3 c! Calculate head-to-tail distances R2=R2+(chead(k,2)-ctail(k,1))**2 END DO c! Pitagoras R2 = dsqrt(R2) c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) c! & +dhead(1,1,itypi,itypj))**2)) c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) c! & +dhead(2,1,itypi,itypj))**2)) c!------------------------------------------------------------------- c! ecl sparrow = w1 * Qi * om1 hawk = w2 * Qi * Qi * (1.0d0 - sqom2) ECL = sparrow / Rhead**2.0d0 & - hawk / Rhead**4.0d0 c!------------------------------------------------------------------- c! derivative of ecl is Gcl c! dF/dr part dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 & + 4.0d0 * hawk / Rhead**5.0d0 c! dF/dom1 dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) c! dF/dom2 dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) c-------------------------------------------------------------------- c Polarization energy c Epol MomoFac2 = (1.0d0 - chi2 * sqom1) RR2 = R2 * R2 / MomoFac2 ee2 = exp(-(RR2 / (4.0d0 * a12sq))) fgb2 = sqrt(RR2 + a12sq * ee2) epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) c! epol = 0.0d0 c! derivative of Epol is Gpol... dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) & / (fgb2 ** 5.0d0) dFGBdR2 = ( (R2 / MomoFac2) & * ( 2.0d0 - (0.5d0 * ee2) ) ) & / (2.0d0 * fgb2) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) & * (2.0d0 - 0.5d0 * ee2) ) & / (2.0d0 * fgb2) dPOLdR2 = dPOLdFGB2 * dFGBdR2 c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 c! dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 c!------------------------------------------------------------------- c! Elj pom = (pis / Rhead)**6.0d0 Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) c! derivative of Elj is Glj dGLJdR = 4.0d0 * eps_head & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) c!------------------------------------------------------------------- c! Return the results c! (see comments in Eqq) DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j+nres) facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) DO k = 1, 3 condor = (erhead_tail(k,2) & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gvdwx(k,i) = gvdwx(k,i) & - dGCLdR * pom & - dPOLdR2 * (erhead_tail(k,2) & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) & - dGLJdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) gvdwx(k,j) = gvdwx(k,j) & + dGCLdR * pom & + dPOLdR2 * condor & + dGLJdR * pom gvdwc(k,i) = gvdwc(k,i) & - dGCLdR * erhead(k) & - dPOLdR2 * erhead_tail(k,2) & - dGLJdR * erhead(k) gvdwc(k,j) = gvdwc(k,j) & + dGCLdR * erhead(k) & + dPOLdR2 * erhead_tail(k,2) & + dGLJdR * erhead(k) END DO RETURN END SUBROUTINE edq C-------------------------------------------------------------------- SUBROUTINE edd(ECL) IMPLICIT NONE INCLUDE 'DIMENSIONS' INCLUDE 'DIMENSIONS.ZSCOPT' INCLUDE 'COMMON.CALC' INCLUDE 'COMMON.CHAIN' INCLUDE 'COMMON.CONTROL' INCLUDE 'COMMON.DERIV' INCLUDE 'COMMON.EMP' INCLUDE 'COMMON.GEO' INCLUDE 'COMMON.INTERACT' INCLUDE 'COMMON.IOUNITS' INCLUDE 'COMMON.LOCAL' INCLUDE 'COMMON.NAMES' INCLUDE 'COMMON.VAR' double precision scalar c! csig = sigiso(itypi,itypj) w1 = wqdip(1,itypi,itypj) w2 = wqdip(2,itypi,itypj) c!------------------------------------------------------------------- c! ECL fac = (om12 - 3.0d0 * om1 * om2) c1 = (w1 / (Rhead**3.0d0)) * fac c2 = (w2 / Rhead ** 6.0d0) & * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) ECL = c1 - c2 c! write (*,*) "w1 = ", w1 c! write (*,*) "w2 = ", w2 c! write (*,*) "om1 = ", om1 c! write (*,*) "om2 = ", om2 c! write (*,*) "om12 = ", om12 c! write (*,*) "fac = ", fac c! write (*,*) "c1 = ", c1 c! write (*,*) "c2 = ", c2 c! write (*,*) "Ecl = ", Ecl c! write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0) c! write (*,*) "c2_2 = ", c! & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) c!------------------------------------------------------------------- c! dervative of ECL is GCL... c! dECL/dr c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0) c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) & * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2)) dGCLdR = c1 - c2 c! dECL/dom1 c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0) c2 = (-6.0d0 * w2) / (Rhead**6.0d0) & * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 ) dGCLdOM1 = c1 - c2 c! dECL/dom2 c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0) c2 = (-6.0d0 * w2) / (Rhead**6.0d0) & * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 ) dGCLdOM2 = c1 - c2 c! dECL/dom12 c1 = w1 / (Rhead ** 3.0d0) c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 dGCLdOM12 = c1 - c2 c!------------------------------------------------------------------- c! Return the results c! (see comments in Eqq) DO k= 1, 3 erhead(k) = Rhead_distance(k)/Rhead END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j+nres) DO k = 1, 3 pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gvdwx(k,i) = gvdwx(k,i) & - dGCLdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) gvdwx(k,j) = gvdwx(k,j) & + dGCLdR * pom gvdwc(k,i) = gvdwc(k,i) & - dGCLdR * erhead(k) gvdwc(k,j) = gvdwc(k,j) & + dGCLdR * erhead(k) END DO RETURN END SUBROUTINE edd c!------------------------------------------------------------------- SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol) IMPLICIT NONE c! maxres INCLUDE 'DIMENSIONS' INCLUDE 'DIMENSIONS.ZSCOPT' c! itypi, itypj, i, j, k, l, chead, INCLUDE 'COMMON.CALC' c! c, nres, dc_norm INCLUDE 'COMMON.CHAIN' c! gradc, gradx INCLUDE 'COMMON.DERIV' c! electrostatic gradients-specific variables INCLUDE 'COMMON.EMP' c! wquad, dhead, alphiso, alphasur, rborn, epsintab INCLUDE 'COMMON.INTERACT' c! t_bath, Rb c INCLUDE 'COMMON.MD' c! io for debug, disable it in final builds INCLUDE 'COMMON.IOUNITS' double precision Rb /1.987D-3/ c!------------------------------------------------------------------- c! Variable Init c! what amino acid is the aminoacid j'th? itypj = itype(j) c! 1/(Gas Constant * Thermostate temperature) = BetaT c! ENABLE THIS LINE WHEN USING CHECKGRAD!!! c! t_bath = 300 c! BetaT = 1.0d0 / (t_bath * Rb) BetaT = 1.0d0 / (298.0d0 * Rb) c! Gay-berne var's sig0ij = sigma( itypi,itypj ) chi1 = chi( itypi, itypj ) chi2 = chi( itypj, itypi ) chi12 = chi1 * chi2 chip1 = chipp( itypi, itypj ) chip2 = chipp( itypj, itypi ) chip12 = chip1 * chip2 c! not used by momo potential, but needed by sc_angular which is shared c! by all energy_potential subroutines alf1 = 0.0d0 alf2 = 0.0d0 alf12 = 0.0d0 c! location, location, location xj = c( 1, nres+j ) - xi yj = c( 2, nres+j ) - yi zj = c( 3, nres+j ) - zi dxj = dc_norm( 1, nres+j ) dyj = dc_norm( 2, nres+j ) dzj = dc_norm( 3, nres+j ) c! distance from center of chain(?) to polar/charged head c! write (*,*) "istate = ", 1 c! write (*,*) "ii = ", 1 c! write (*,*) "jj = ", 1 d1 = dhead(1, 1, itypi, itypj) d2 = dhead(2, 1, itypi, itypj) c! ai*aj from Fgb a12sq = rborn(itypi,itypj) * rborn(itypj,itypi) c! a12sq = a12sq * a12sq c! charge of amino acid itypi is... Qi = icharge(itypi) Qj = icharge(itypj) Qij = Qi * Qj c! chis1,2,12 chis1 = chis(itypi,itypj) chis2 = chis(itypj,itypi) chis12 = chis1 * chis2 sig1 = sigmap1(itypi,itypj) sig2 = sigmap2(itypi,itypj) c! write (*,*) "sig1 = ", sig1 c! write (*,*) "sig2 = ", sig2 c! alpha factors from Fcav/Gcav b1 = alphasur(1,itypi,itypj) b2 = alphasur(2,itypi,itypj) b3 = alphasur(3,itypi,itypj) b4 = alphasur(4,itypi,itypj) c! used to determine whether we want to do quadrupole calculations wqd = wquad(itypi, itypj) c! used by Fgb eps_in = epsintab(itypi,itypj) eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) c! write (*,*) "eps_inout_fac = ", eps_inout_fac c!------------------------------------------------------------------- c! tail location and distance calculations Rtail = 0.0d0 DO k = 1, 3 ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i) ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j) END DO c! tail distances will be themselves usefull elswhere c1 (in Gcav, for example) Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 ) Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 ) Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 ) Rtail = dsqrt( & (Rtail_distance(1)*Rtail_distance(1)) & + (Rtail_distance(2)*Rtail_distance(2)) & + (Rtail_distance(3)*Rtail_distance(3))) c!------------------------------------------------------------------- c! Calculate location and distance between polar heads c! distance between heads c! for each one of our three dimensional space... DO k = 1,3 c! location of polar head is computed by taking hydrophobic centre c! and moving by a d1 * dc_norm vector c! see unres publications for very informative images chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) c! distance c! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) c! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) Rhead_distance(k) = chead(k,2) - chead(k,1) END DO c! pitagoras (root of sum of squares) Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) c!------------------------------------------------------------------- c! zero everything that should be zero'ed Egb = 0.0d0 ECL = 0.0d0 Elj = 0.0d0 Equad = 0.0d0 Epol = 0.0d0 eheadtail = 0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 RETURN END SUBROUTINE elgrad_init C----------------------------------------------------------------------------- subroutine sc_angular C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2, C om12. Called by ebp, egb, and egbv. implicit none include 'COMMON.CALC' erij(1)=xj*rij erij(2)=yj*rij erij(3)=zj*rij om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) om12=dxi*dxj+dyi*dyj+dzi*dzj chiom12=chi12*om12 C Calculate eps1(om12) and its derivative in om12 faceps1=1.0D0-om12*chiom12 faceps1_inv=1.0D0/faceps1 eps1=dsqrt(faceps1_inv) C Following variable is eps1*deps1/dom12 eps1_om12=faceps1_inv*chiom12 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2, C and om12. om1om2=om1*om2 chiom1=chi1*om1 chiom2=chi2*om2 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12 sigsq=1.0D0-facsig*faceps1_inv sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2 C Calculate eps2 and its derivatives in om1, om2, and om12. chipom1=chip1*om1 chipom2=chip2*om2 chipom12=chip12*om12 facp=1.0D0-om12*chipom12 facp_inv=1.0D0/facp facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12 C Following variable is the square root of eps2 eps2rt=1.0D0-facp1*facp_inv C Following three variables are the derivatives of the square root of eps C in om1, om2, and om12. eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2 C Evaluate the "asymmetric" factor in the VDW constant, eps3 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12 C Calculate whole angle-dependent part of epsilon and contributions C to its derivatives return end C---------------------------------------------------------------------------- subroutine sc_grad implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.CALC' double precision dcosom1(3),dcosom2(3) eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 & -2.0D0*alf12*eps3der+sigder*sigsq_om12 do k=1,3 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) enddo do k=1,3 gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k) enddo do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv gvdwx(k,j)=gvdwx(k,j)+gg(k) & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv enddo C C Calculate the components of the gradient in DC and X C do k=i,j-1 do l=1,3 gvdwc(l,k)=gvdwc(l,k)+gg(l) enddo enddo return end c------------------------------------------------------------------------------ subroutine vec_and_deriv implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' include 'COMMON.CHAIN' include 'COMMON.VECTORS' include 'COMMON.DERIV' include 'COMMON.INTERACT' dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2) C Compute the local reference systems. For reference system (i), the C X-axis points from CA(i) to CA(i+1), the Y axis is in the C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane. do i=1,nres-1 c if (i.eq.nres-1 .or. itel(i+1).eq.0) then if (i.eq.nres-1) then C Case of the last full residue C Compute the Z-axis call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i)) costh=dcos(pi-theta(nres)) fac=1.0d0/dsqrt(1.0d0-costh*costh) do k=1,3 uz(k,i)=fac*uz(k,i) enddo if (calc_grad) then C Compute the derivatives of uz uzder(1,1,1)= 0.0d0 uzder(2,1,1)=-dc_norm(3,i-1) uzder(3,1,1)= dc_norm(2,i-1) uzder(1,2,1)= dc_norm(3,i-1) uzder(2,2,1)= 0.0d0 uzder(3,2,1)=-dc_norm(1,i-1) uzder(1,3,1)=-dc_norm(2,i-1) uzder(2,3,1)= dc_norm(1,i-1) uzder(3,3,1)= 0.0d0 uzder(1,1,2)= 0.0d0 uzder(2,1,2)= dc_norm(3,i) uzder(3,1,2)=-dc_norm(2,i) uzder(1,2,2)=-dc_norm(3,i) uzder(2,2,2)= 0.0d0 uzder(3,2,2)= dc_norm(1,i) uzder(1,3,2)= dc_norm(2,i) uzder(2,3,2)=-dc_norm(1,i) uzder(3,3,2)= 0.0d0 endif C Compute the Y-axis facy=fac do k=1,3 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i)) enddo if (calc_grad) then C Compute the derivatives of uy do j=1,3 do k=1,3 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) & -dc_norm(k,i)*dc_norm(j,i-1) uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) enddo uyder(j,j,1)=uyder(j,j,1)-costh uyder(j,j,2)=1.0d0+uyder(j,j,2) enddo do j=1,2 do k=1,3 do l=1,3 uygrad(l,k,j,i)=uyder(l,k,j) uzgrad(l,k,j,i)=uzder(l,k,j) enddo enddo enddo call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) endif else C Other residues C Compute the Z-axis call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i)) costh=dcos(pi-theta(i+2)) fac=1.0d0/dsqrt(1.0d0-costh*costh) do k=1,3 uz(k,i)=fac*uz(k,i) enddo if (calc_grad) then C Compute the derivatives of uz uzder(1,1,1)= 0.0d0 uzder(2,1,1)=-dc_norm(3,i+1) uzder(3,1,1)= dc_norm(2,i+1) uzder(1,2,1)= dc_norm(3,i+1) uzder(2,2,1)= 0.0d0 uzder(3,2,1)=-dc_norm(1,i+1) uzder(1,3,1)=-dc_norm(2,i+1) uzder(2,3,1)= dc_norm(1,i+1) uzder(3,3,1)= 0.0d0 uzder(1,1,2)= 0.0d0 uzder(2,1,2)= dc_norm(3,i) uzder(3,1,2)=-dc_norm(2,i) uzder(1,2,2)=-dc_norm(3,i) uzder(2,2,2)= 0.0d0 uzder(3,2,2)= dc_norm(1,i) uzder(1,3,2)= dc_norm(2,i) uzder(2,3,2)=-dc_norm(1,i) uzder(3,3,2)= 0.0d0 endif C Compute the Y-axis facy=fac do k=1,3 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) enddo if (calc_grad) then C Compute the derivatives of uy do j=1,3 do k=1,3 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) & -dc_norm(k,i)*dc_norm(j,i+1) uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) enddo uyder(j,j,1)=uyder(j,j,1)-costh uyder(j,j,2)=1.0d0+uyder(j,j,2) enddo do j=1,2 do k=1,3 do l=1,3 uygrad(l,k,j,i)=uyder(l,k,j) uzgrad(l,k,j,i)=uzder(l,k,j) enddo enddo enddo call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) endif endif enddo if (calc_grad) then do i=1,nres-1 vbld_inv_temp(1)=vbld_inv(i+1) if (i.lt.nres-1) then vbld_inv_temp(2)=vbld_inv(i+2) else vbld_inv_temp(2)=vbld_inv(i) endif do j=1,2 do k=1,3 do l=1,3 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i) uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i) enddo enddo enddo enddo endif return end c------------------------------------------------------------------------------ subroutine set_matrices implicit real*8 (a-h,o-z) include 'DIMENSIONS' #ifdef MPI include "mpif.h" integer IERR integer status(MPI_STATUS_SIZE) #endif include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' double precision auxvec(2),auxmat(2,2) C C Compute the virtual-bond-torsional-angle dependent quantities needed C to calculate the el-loc multibody terms of various order. C c write(iout,*) 'SET_MATRICES nphi=',nphi,nres do i=3,nres+1 if (i.gt. nnt+2 .and. i.lt.nct+2) then iti = itype2loc(itype(i-2)) else iti=nloctyp endif c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then if (i.gt. nnt+1 .and. i.lt.nct+1) then iti1 = itype2loc(itype(i-1)) else iti1=nloctyp endif #ifdef NEWCORR cost1=dcos(theta(i-1)) sint1=dsin(theta(i-1)) sint1sq=sint1*sint1 sint1cub=sint1sq*sint1 sint1cost1=2*sint1*cost1 #ifdef DEBUG write (iout,*) "bnew1",i,iti write (iout,*) (bnew1(k,1,iti),k=1,3) write (iout,*) (bnew1(k,2,iti),k=1,3) write (iout,*) "bnew2",i,iti write (iout,*) (bnew2(k,1,iti),k=1,3) write (iout,*) (bnew2(k,2,iti),k=1,3) #endif do k=1,2 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1 b1(k,i-2)=sint1*b1k gtb1(k,i-2)=cost1*b1k-sint1sq* & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1) b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1 b2(k,i-2)=sint1*b2k if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq* & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1) enddo do k=1,2 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1 cc(1,k,i-2)=sint1sq*aux if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub* & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1) aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1 dd(1,k,i-2)=sint1sq*aux if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub* & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1) enddo cc(2,1,i-2)=cc(1,2,i-2) cc(2,2,i-2)=-cc(1,1,i-2) gtcc(2,1,i-2)=gtcc(1,2,i-2) gtcc(2,2,i-2)=-gtcc(1,1,i-2) dd(2,1,i-2)=dd(1,2,i-2) dd(2,2,i-2)=-dd(1,1,i-2) gtdd(2,1,i-2)=gtdd(1,2,i-2) gtdd(2,2,i-2)=-gtdd(1,1,i-2) do k=1,2 do l=1,2 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1 EE(l,k,i-2)=sint1sq*aux if (calc_grad) & gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti) enddo enddo EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti) EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti) if (calc_grad) then gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1 endif c b1tilde(1,i-2)=b1(1,i-2) c b1tilde(2,i-2)=-b1(2,i-2) c b2tilde(1,i-2)=b2(1,i-2) c b2tilde(2,i-2)=-b2(2,i-2) #ifdef DEBUG write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2) write(iout,*) 'b1=',(b1(k,i-2),k=1,2) write(iout,*) 'b2=',(b2(k,i-2),k=1,2) write (iout,*) 'theta=', theta(i-1) #endif #else if (i.gt. nnt+2 .and. i.lt.nct+2) then iti = itype2loc(itype(i-2)) else iti=nloctyp endif c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then if (i.gt. nnt+1 .and. i.lt.nct+1) then iti1 = itype2loc(itype(i-1)) else iti1=nloctyp endif b1(1,i-2)=b(3,iti) b1(2,i-2)=b(5,iti) b2(1,i-2)=b(2,iti) b2(2,i-2)=b(4,iti) do k=1,2 do l=1,2 CC(k,l,i-2)=ccold(k,l,iti) DD(k,l,i-2)=ddold(k,l,iti) EE(k,l,i-2)=eeold(k,l,iti) enddo enddo #endif b1tilde(1,i-2)= b1(1,i-2) b1tilde(2,i-2)=-b1(2,i-2) b2tilde(1,i-2)= b2(1,i-2) b2tilde(2,i-2)=-b2(2,i-2) c Ctilde(1,1,i-2)= CC(1,1,i-2) Ctilde(1,2,i-2)= CC(1,2,i-2) Ctilde(2,1,i-2)=-CC(2,1,i-2) Ctilde(2,2,i-2)=-CC(2,2,i-2) c Dtilde(1,1,i-2)= DD(1,1,i-2) Dtilde(1,2,i-2)= DD(1,2,i-2) Dtilde(2,1,i-2)=-DD(2,1,i-2) Dtilde(2,2,i-2)=-DD(2,2,i-2) c write(iout,*) "i",i," iti",iti c write(iout,*) 'b1=',(b1(k,i-2),k=1,2) c write(iout,*) 'b2=',(b2(k,i-2),k=1,2) enddo do i=3,nres+1 if (i .lt. nres+1) then sin1=dsin(phi(i)) cos1=dcos(phi(i)) sintab(i-2)=sin1 costab(i-2)=cos1 obrot(1,i-2)=cos1 obrot(2,i-2)=sin1 sin2=dsin(2*phi(i)) cos2=dcos(2*phi(i)) sintab2(i-2)=sin2 costab2(i-2)=cos2 obrot2(1,i-2)=cos2 obrot2(2,i-2)=sin2 Ug(1,1,i-2)=-cos1 Ug(1,2,i-2)=-sin1 Ug(2,1,i-2)=-sin1 Ug(2,2,i-2)= cos1 Ug2(1,1,i-2)=-cos2 Ug2(1,2,i-2)=-sin2 Ug2(2,1,i-2)=-sin2 Ug2(2,2,i-2)= cos2 else costab(i-2)=1.0d0 sintab(i-2)=0.0d0 obrot(1,i-2)=1.0d0 obrot(2,i-2)=0.0d0 obrot2(1,i-2)=0.0d0 obrot2(2,i-2)=0.0d0 Ug(1,1,i-2)=1.0d0 Ug(1,2,i-2)=0.0d0 Ug(2,1,i-2)=0.0d0 Ug(2,2,i-2)=1.0d0 Ug2(1,1,i-2)=0.0d0 Ug2(1,2,i-2)=0.0d0 Ug2(2,1,i-2)=0.0d0 Ug2(2,2,i-2)=0.0d0 endif if (i .gt. 3 .and. i .lt. nres+1) then obrot_der(1,i-2)=-sin1 obrot_der(2,i-2)= cos1 Ugder(1,1,i-2)= sin1 Ugder(1,2,i-2)=-cos1 Ugder(2,1,i-2)=-cos1 Ugder(2,2,i-2)=-sin1 dwacos2=cos2+cos2 dwasin2=sin2+sin2 obrot2_der(1,i-2)=-dwasin2 obrot2_der(2,i-2)= dwacos2 Ug2der(1,1,i-2)= dwasin2 Ug2der(1,2,i-2)=-dwacos2 Ug2der(2,1,i-2)=-dwacos2 Ug2der(2,2,i-2)=-dwasin2 else obrot_der(1,i-2)=0.0d0 obrot_der(2,i-2)=0.0d0 Ugder(1,1,i-2)=0.0d0 Ugder(1,2,i-2)=0.0d0 Ugder(2,1,i-2)=0.0d0 Ugder(2,2,i-2)=0.0d0 obrot2_der(1,i-2)=0.0d0 obrot2_der(2,i-2)=0.0d0 Ug2der(1,1,i-2)=0.0d0 Ug2der(1,2,i-2)=0.0d0 Ug2der(2,1,i-2)=0.0d0 Ug2der(2,2,i-2)=0.0d0 endif c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then if (i.gt. nnt+2 .and. i.lt.nct+2) then iti = itype2loc(itype(i-2)) else iti=nloctyp endif c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then if (i.gt. nnt+1 .and. i.lt.nct+1) then iti1 = itype2loc(itype(i-1)) else iti1=nloctyp endif cd write (iout,*) '*******i',i,' iti1',iti cd write (iout,*) 'b1',b1(:,iti) cd write (iout,*) 'b2',b2(:,iti) cd write (iout,*) 'Ug',Ug(:,:,i-2) c if (i .gt. iatel_s+2) then if (i .gt. nnt+2) then call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2)) #ifdef NEWCORR call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2)) c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj" #endif c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i), c & EE(1,2,iti),EE(2,2,i) call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2)) call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2)) c write(iout,*) "Macierz EUG", c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2), c & eug(2,2,i-2) if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2)) call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2)) call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2)) call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2)) call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2)) endif else do k=1,2 Ub2(k,i-2)=0.0d0 Ctobr(k,i-2)=0.0d0 Dtobr2(k,i-2)=0.0d0 do l=1,2 EUg(l,k,i-2)=0.0d0 CUg(l,k,i-2)=0.0d0 DUg(l,k,i-2)=0.0d0 DtUg2(l,k,i-2)=0.0d0 enddo enddo endif call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2)) call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2)) do k=1,2 muder(k,i-2)=Ub2der(k,i-2) enddo c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then if (i.gt. nnt+1 .and. i.lt.nct+1) then if (itype(i-1).le.ntyp) then iti1 = itype2loc(itype(i-1)) else iti1=nloctyp endif else iti1=nloctyp endif do k=1,2 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1) enddo #ifdef MUOUT write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1), & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2), & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2), & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2) & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2), & ((ee(l,k,i-2),l=1,2),k=1,2) #endif cd write (iout,*) 'mu1',mu1(:,i-2) cd write (iout,*) 'mu2',mu2(:,i-2) if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) & then if (calc_grad) then call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2)) call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2)) call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2)) call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2)) call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2)) endif C Vectors and matrices dependent on a single virtual-bond dihedral. call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1)) call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2)) call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2)) call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2)) call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2)) if (calc_grad) then call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2)) call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2)) call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2)) call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2)) endif endif enddo C Matrices dependent on two consecutive virtual-bond dihedrals. C The order of matrices is from left to right. if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &then do i=2,nres-1 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i)) if (calc_grad) then call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i)) call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i)) endif call transpose2(DtUg2(1,1,i-1),auxmat(1,1)) call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i)) if (calc_grad) then call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i)) call transpose2(DtUg2der(1,1,i-1),auxmat(1,1)) call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i)) endif enddo endif return end C-------------------------------------------------------------------------- subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) C C This subroutine calculates the average interaction energy and its gradient C in the virtual-bond vectors between non-adjacent peptide groups, based on C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. C The potential depends both on the distance of peptide-group centers and on C the orientation of the CA-CA virtual bonds. C implicit real*8 (a-h,o-z) #ifdef MPI include 'mpif.h' #endif include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.CONTROL' include 'COMMON.IOUNITS' include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' include 'COMMON.TIME1' include 'COMMON.SPLITELE' dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4) common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, & num_conti,j1,j2 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions #ifdef MOMENT double precision scal_el /1.0d0/ #else double precision scal_el /0.5d0/ #endif C 12/13/98 C 13-go grudnia roku pamietnego... double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, & 0.0d0,1.0d0,0.0d0, & 0.0d0,0.0d0,1.0d0/ cd write(iout,*) 'In EELEC' cd do i=1,nloctyp cd write(iout,*) 'Type',i cd write(iout,*) 'B1',B1(:,i) cd write(iout,*) 'B2',B2(:,i) cd write(iout,*) 'CC',CC(:,:,i) cd write(iout,*) 'DD',DD(:,:,i) cd write(iout,*) 'EE',EE(:,:,i) cd enddo cd call check_vecgrad cd stop if (icheckgrad.eq.1) then do i=1,nres-1 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) do k=1,3 dc_norm(k,i)=dc(k,i)*fac enddo c write (iout,*) 'i',i,' fac',fac enddo endif if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then c call vec_and_deriv #ifdef TIMING time01=MPI_Wtime() #endif call set_matrices #ifdef TIMING time_mat=time_mat+MPI_Wtime()-time01 #endif endif cd do i=1,nres-1 cd write (iout,*) 'i=',i cd do k=1,3 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) cd enddo cd do k=1,3 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) cd enddo cd enddo t_eelecij=0.0d0 ees=0.0D0 evdw1=0.0D0 eel_loc=0.0d0 eello_turn3=0.0d0 eello_turn4=0.0d0 ind=0 do i=1,nres num_cont_hb(i)=0 enddo cd print '(a)','Enter EELEC' cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e do i=1,nres gel_loc_loc(i)=0.0d0 gcorr_loc(i)=0.0d0 enddo c c c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms C C Loop over i,i+2 and i,i+3 pairs of the peptide groups C C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition do i=iturn3_start,iturn3_end c if (i.le.1) cycle C write(iout,*) "tu jest i",i if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 C changes suggested by Ana to avoid out of bounds C Adam: Unnecessary: handled by iturn3_end and iturn3_start c & .or.((i+4).gt.nres) c & .or.((i-1).le.0) C end of changes by Ana C dobra zmiana wycofana & .or. itype(i+2).eq.ntyp1 & .or. itype(i+3).eq.ntyp1) cycle C Adam: Instructions below will switch off existing interactions c if(i.gt.1)then c if(itype(i-1).eq.ntyp1)cycle c end if c if(i.LT.nres-3)then c if (itype(i+4).eq.ntyp1) cycle c end if dxi=dc(1,i) dyi=dc(2,i) dzi=dc(3,i) dx_normi=dc_norm(1,i) dy_normi=dc_norm(2,i) dz_normi=dc_norm(3,i) xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi xmedi=mod(xmedi,boxxsize) if (xmedi.lt.0) xmedi=xmedi+boxxsize ymedi=mod(ymedi,boxysize) if (ymedi.lt.0) ymedi=ymedi+boxysize zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize num_conti=0 call eelecij(i,i+2,ees,evdw1,eel_loc) if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) num_cont_hb(i)=num_conti enddo do i=iturn4_start,iturn4_end if (i.lt.1) cycle if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 C changes suggested by Ana to avoid out of bounds c & .or.((i+5).gt.nres) c & .or.((i-1).le.0) C end of changes suggested by Ana & .or. itype(i+3).eq.ntyp1 & .or. itype(i+4).eq.ntyp1 c & .or. itype(i+5).eq.ntyp1 c & .or. itype(i).eq.ntyp1 c & .or. itype(i-1).eq.ntyp1 & ) cycle dxi=dc(1,i) dyi=dc(2,i) dzi=dc(3,i) dx_normi=dc_norm(1,i) dy_normi=dc_norm(2,i) dz_normi=dc_norm(3,i) xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi C Return atom into box, boxxsize is size of box in x dimension c 194 continue c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize C Condition for being inside the proper box c if ((xmedi.gt.((0.5d0)*boxxsize)).or. c & (xmedi.lt.((-0.5d0)*boxxsize))) then c go to 194 c endif c 195 continue c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize C Condition for being inside the proper box c if ((ymedi.gt.((0.5d0)*boxysize)).or. c & (ymedi.lt.((-0.5d0)*boxysize))) then c go to 195 c endif c 196 continue c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize C Condition for being inside the proper box c if ((zmedi.gt.((0.5d0)*boxzsize)).or. c & (zmedi.lt.((-0.5d0)*boxzsize))) then c go to 196 c endif xmedi=mod(xmedi,boxxsize) if (xmedi.lt.0) xmedi=xmedi+boxxsize ymedi=mod(ymedi,boxysize) if (ymedi.lt.0) ymedi=ymedi+boxysize zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize num_conti=num_cont_hb(i) c write(iout,*) "JESTEM W PETLI" call eelecij(i,i+3,ees,evdw1,eel_loc) if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) & call eturn4(i,eello_turn4) num_cont_hb(i)=num_conti enddo ! i C Loop over all neighbouring boxes C do xshift=-1,1 C do yshift=-1,1 C do zshift=-1,1 c c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 c CTU KURWA do i=iatel_s,iatel_e C do i=75,75 c if (i.le.1) cycle if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 C changes suggested by Ana to avoid out of bounds c & .or.((i+2).gt.nres) c & .or.((i-1).le.0) C end of changes by Ana c & .or. itype(i+2).eq.ntyp1 c & .or. itype(i-1).eq.ntyp1 & ) cycle dxi=dc(1,i) dyi=dc(2,i) dzi=dc(3,i) dx_normi=dc_norm(1,i) dy_normi=dc_norm(2,i) dz_normi=dc_norm(3,i) xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi xmedi=mod(xmedi,boxxsize) if (xmedi.lt.0) xmedi=xmedi+boxxsize ymedi=mod(ymedi,boxysize) if (ymedi.lt.0) ymedi=ymedi+boxysize zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize C xmedi=xmedi+xshift*boxxsize C ymedi=ymedi+yshift*boxysize C zmedi=zmedi+zshift*boxzsize C Return tom into box, boxxsize is size of box in x dimension c 164 continue c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize C Condition for being inside the proper box c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or. c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then c go to 164 c endif c 165 continue c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize C Condition for being inside the proper box c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or. c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then c go to 165 c endif c 166 continue c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize cC Condition for being inside the proper box c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or. c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then c go to 166 c endif c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) num_conti=num_cont_hb(i) C I TU KURWA do j=ielstart(i),ielend(i) C do j=16,17 C write (iout,*) i,j C if (j.le.1) cycle if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1 C changes suggested by Ana to avoid out of bounds c & .or.((j+2).gt.nres) c & .or.((j-1).le.0) C end of changes by Ana c & .or.itype(j+2).eq.ntyp1 c & .or.itype(j-1).eq.ntyp1 &) cycle call eelecij(i,j,ees,evdw1,eel_loc) enddo ! j num_cont_hb(i)=num_conti enddo ! i C enddo ! zshift C enddo ! yshift C enddo ! xshift c write (iout,*) "Number of loop steps in EELEC:",ind cd do i=1,nres cd write (iout,'(i3,3f10.5,5x,3f10.5)') cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) cd enddo c 12/7/99 Adam eello_turn3 will be considered as a separate energy term ccc eel_loc=eel_loc+eello_turn3 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij return end C------------------------------------------------------------------------------- subroutine eelecij(i,j,ees,evdw1,eel_loc) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' #ifdef MPI include "mpif.h" #endif include 'COMMON.CONTROL' include 'COMMON.IOUNITS' include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' include 'COMMON.TIME1' include 'COMMON.SPLITELE' include 'COMMON.SHIELD' dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4), & gmuij2(4),gmuji2(4) common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, & num_conti,j1,j2 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions #ifdef MOMENT double precision scal_el /1.0d0/ #else double precision scal_el /0.5d0/ #endif C 12/13/98 C 13-go grudnia roku pamietnego... double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, & 0.0d0,1.0d0,0.0d0, & 0.0d0,0.0d0,1.0d0/ integer xshift,yshift,zshift c time00=MPI_Wtime() cd write (iout,*) "eelecij",i,j c ind=ind+1 iteli=itel(i) itelj=itel(j) if (j.eq.i+2 .and. itelj.eq.2) iteli=2 aaa=app(iteli,itelj) bbb=bpp(iteli,itelj) ael6i=ael6(iteli,itelj) ael3i=ael3(iteli,itelj) dxj=dc(1,j) dyj=dc(2,j) dzj=dc(3,j) dx_normj=dc_norm(1,j) dy_normj=dc_norm(2,j) dz_normj=dc_norm(3,j) C xj=c(1,j)+0.5D0*dxj-xmedi C yj=c(2,j)+0.5D0*dyj-ymedi C zj=c(3,j)+0.5D0*dzj-zmedi xj=c(1,j)+0.5D0*dxj yj=c(2,j)+0.5D0*dyj zj=c(3,j)+0.5D0*dzj xj=mod(xj,boxxsize) if (xj.lt.0) xj=xj+boxxsize yj=mod(yj,boxysize) if (yj.lt.0) yj=yj+boxysize zj=mod(zj,boxzsize) if (zj.lt.0) zj=zj+boxzsize if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ" dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 xj_safe=xj yj_safe=yj zj_safe=zj isubchap=0 do xshift=-1,1 do yshift=-1,1 do zshift=-1,1 xj=xj_safe+xshift*boxxsize yj=yj_safe+yshift*boxysize zj=zj_safe+zshift*boxzsize dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 if(dist_temp.lt.dist_init) then dist_init=dist_temp xj_temp=xj yj_temp=yj zj_temp=zj isubchap=1 endif enddo enddo enddo if (isubchap.eq.1) then xj=xj_temp-xmedi yj=yj_temp-ymedi zj=zj_temp-zmedi else xj=xj_safe-xmedi yj=yj_safe-ymedi zj=zj_safe-zmedi endif C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC c 174 continue c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize C Condition for being inside the proper box c if ((xj.gt.((0.5d0)*boxxsize)).or. c & (xj.lt.((-0.5d0)*boxxsize))) then c go to 174 c endif c 175 continue c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize C Condition for being inside the proper box c if ((yj.gt.((0.5d0)*boxysize)).or. c & (yj.lt.((-0.5d0)*boxysize))) then c go to 175 c endif c 176 continue c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize C Condition for being inside the proper box c if ((zj.gt.((0.5d0)*boxzsize)).or. c & (zj.lt.((-0.5d0)*boxzsize))) then c go to 176 c endif C endif !endPBC condintion C xj=xj-xmedi C yj=yj-ymedi C zj=zj-zmedi rij=xj*xj+yj*yj+zj*zj sss=sscale(sqrt(rij)) sssgrad=sscagrad(sqrt(rij)) c write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut, c & " rlamb",rlamb," sss",sss c if (sss.gt.0.0d0) then rrmij=1.0D0/rij rij=dsqrt(rij) rmij=1.0D0/rij r3ij=rrmij*rmij r6ij=r3ij*r3ij cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij fac=cosa-3.0D0*cosb*cosg ev1=aaa*r6ij*r6ij c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions if (j.eq.i+2) ev1=scal_el*ev1 ev2=bbb*r6ij fac3=ael6i*r6ij fac4=ael3i*r3ij evdwij=(ev1+ev2) el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) el2=fac4*fac C MARYSIA C eesij=(el1+el2) C 12/26/95 - for the evaluation of multi-body H-bonding interactions ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) if (shield_mode.gt.0) then C fac_shield(i)=0.4 C fac_shield(j)=0.6 el1=el1*fac_shield(i)**2*fac_shield(j)**2 el2=el2*fac_shield(i)**2*fac_shield(j)**2 eesij=(el1+el2) ees=ees+eesij else fac_shield(i)=1.0 fac_shield(j)=1.0 eesij=(el1+el2) ees=ees+eesij endif evdw1=evdw1+evdwij*sss cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, cd & xmedi,ymedi,zmedi,xj,yj,zj if (energy_dec) then write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)') &'evdw1',i,j,evdwij &,iteli,itelj,aaa,evdw1,sss write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij, &fac_shield(i),fac_shield(j) endif C C Calculate contributions to the Cartesian gradient. C #ifdef SPLITELE facvdw=-6*rrmij*(ev1+evdwij)*sss facel=-3*rrmij*(el1+eesij) fac1=fac erij(1)=xj*rmij erij(2)=yj*rmij erij(3)=zj*rmij * * Radial derivatives. First process both termini of the fragment (i,j) * if (calc_grad) then ggg(1)=facel*xj ggg(2)=facel*yj ggg(3)=facel*zj if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (shield_mode.gt.0)) then C print *,i,j do ilist=1,ishield_list(i) iresshield=shield_list(ilist,i) do k=1,3 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i) & *2.0 gshieldx(k,iresshield)=gshieldx(k,iresshield)+ & rlocshield & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield) C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i) C if (iresshield.gt.i) then C do ishi=i+1,iresshield-1 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i) C C enddo C else C do ishi=iresshield,i C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i) C C enddo C endif enddo enddo do ilist=1,ishield_list(j) iresshield=shield_list(ilist,j) do k=1,3 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) & *2.0 gshieldx(k,iresshield)=gshieldx(k,iresshield)+ & rlocshield & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j) C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield) C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j) C if (iresshield.gt.j) then C do ishi=j+1,iresshield-1 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j) C C enddo C else C do ishi=iresshield,j C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j) C enddo C endif enddo enddo do k=1,3 gshieldc(k,i)=gshieldc(k,i)+ & grad_shield(k,i)*eesij/fac_shield(i)*2.0 gshieldc(k,j)=gshieldc(k,j)+ & grad_shield(k,j)*eesij/fac_shield(j)*2.0 gshieldc(k,i-1)=gshieldc(k,i-1)+ & grad_shield(k,i)*eesij/fac_shield(i)*2.0 gshieldc(k,j-1)=gshieldc(k,j-1)+ & grad_shield(k,j)*eesij/fac_shield(j)*2.0 enddo endif c do k=1,3 c ghalf=0.5D0*ggg(k) c gelc(k,i)=gelc(k,i)+ghalf c gelc(k,j)=gelc(k,j)+ghalf c enddo c 9/28/08 AL Gradient compotents will be summed only at the end C print *,"before", gelc_long(1,i), gelc_long(1,j) do k=1,3 gelc_long(k,j)=gelc_long(k,j)+ggg(k) C & +grad_shield(k,j)*eesij/fac_shield(j) gelc_long(k,i)=gelc_long(k,i)-ggg(k) C & +grad_shield(k,i)*eesij/fac_shield(i) C gelc_long(k,i-1)=gelc_long(k,i-1) C & +grad_shield(k,i)*eesij/fac_shield(i) C gelc_long(k,j-1)=gelc_long(k,j-1) C & +grad_shield(k,j)*eesij/fac_shield(j) enddo C print *,"bafter", gelc_long(1,i), gelc_long(1,j) * * Loop over residues i+1 thru j-1. * cgrad do k=i+1,j-1 cgrad do l=1,3 cgrad gelc(l,k)=gelc(l,k)+ggg(l) cgrad enddo cgrad enddo if (sss.gt.0.0) then ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj else ggg(1)=0.0 ggg(2)=0.0 ggg(3)=0.0 endif c do k=1,3 c ghalf=0.5D0*ggg(k) c gvdwpp(k,i)=gvdwpp(k,i)+ghalf c gvdwpp(k,j)=gvdwpp(k,j)+ghalf c enddo c 9/28/08 AL Gradient compotents will be summed only at the end do k=1,3 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) enddo * * Loop over residues i+1 thru j-1. * cgrad do k=i+1,j-1 cgrad do l=1,3 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) cgrad enddo cgrad enddo endif ! calc_grad #else C MARYSIA facvdw=(ev1+evdwij)*sss facel=(el1+eesij) fac1=fac fac=-3*rrmij*(facvdw+facvdw+facel) erij(1)=xj*rmij erij(2)=yj*rmij erij(3)=zj*rmij * * Radial derivatives. First process both termini of the fragment (i,j) * if (calc_grad) then ggg(1)=fac*xj C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j) ggg(2)=fac*yj C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j) ggg(3)=fac*zj C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j) c do k=1,3 c ghalf=0.5D0*ggg(k) c gelc(k,i)=gelc(k,i)+ghalf c gelc(k,j)=gelc(k,j)+ghalf c enddo c 9/28/08 AL Gradient compotents will be summed only at the end do k=1,3 gelc_long(k,j)=gelc(k,j)+ggg(k) gelc_long(k,i)=gelc(k,i)-ggg(k) enddo * * Loop over residues i+1 thru j-1. * cgrad do k=i+1,j-1 cgrad do l=1,3 cgrad gelc(l,k)=gelc(l,k)+ggg(l) cgrad enddo cgrad enddo c 9/28/08 AL Gradient compotents will be summed only at the end ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj do k=1,3 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) enddo endif ! calc_grad #endif * * Angular part * if (calc_grad) then ecosa=2.0D0*fac3*fac1+fac4 fac4=-3.0D0*fac4 fac3=-6.0D0*fac3 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) do k=1,3 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) enddo cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), cd & (dcosg(k),k=1,3) do k=1,3 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))* & fac_shield(i)**2*fac_shield(j)**2 enddo c do k=1,3 c ghalf=0.5D0*ggg(k) c gelc(k,i)=gelc(k,i)+ghalf c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) c gelc(k,j)=gelc(k,j)+ghalf c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) c enddo cgrad do k=i+1,j-1 cgrad do l=1,3 cgrad gelc(l,k)=gelc(l,k)+ggg(l) cgrad enddo cgrad enddo C print *,"before22", gelc_long(1,i), gelc_long(1,j) do k=1,3 gelc(k,i)=gelc(k,i) & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)) & *fac_shield(i)**2*fac_shield(j)**2 gelc(k,j)=gelc(k,j) & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)) & *fac_shield(i)**2*fac_shield(j)**2 gelc_long(k,j)=gelc_long(k,j)+ggg(k) gelc_long(k,i)=gelc_long(k,i)-ggg(k) enddo C print *,"before33", gelc_long(1,i), gelc_long(1,j) C MARYSIA c endif !sscale endif ! calc_grad IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN C C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction C energy of a peptide unit is assumed in the form of a second-order C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms C are computed for EVERY pair of non-contiguous peptide groups. C if (j.lt.nres-1) then j1=j+1 j2=j-1 else j1=j-1 j2=j-2 endif kkk=0 lll=0 do k=1,2 do l=1,2 kkk=kkk+1 muij(kkk)=mu(k,i)*mu(l,j) c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l #ifdef NEWCORR if (calc_grad) then gmuij1(kkk)=gtb1(k,i+1)*mu(l,j) c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j) gmuij2(kkk)=gUb2(k,i)*mu(l,j) gmuji1(kkk)=mu(k,i)*gtb1(l,j+1) c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i) gmuji2(kkk)=mu(k,i)*gUb2(l,j) endif #endif enddo enddo #ifdef DEBUG write (iout,*) 'EELEC: i',i,' j',j write (iout,*) 'j',j,' j1',j1,' j2',j2 write(iout,*) 'muij',muij write (iout,*) "uy",uy(:,i) write (iout,*) "uz",uz(:,j) write (iout,*) "erij",erij #endif ury=scalar(uy(1,i),erij) urz=scalar(uz(1,i),erij) vry=scalar(uy(1,j),erij) vrz=scalar(uz(1,j),erij) a22=scalar(uy(1,i),uy(1,j))-3*ury*vry a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz a32=scalar(uz(1,i),uy(1,j))-3*urz*vry a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz fac=dsqrt(-ael6i)*r3ij a22=a22*fac a23=a23*fac a32=a32*fac a33=a33*fac cd write (iout,'(4i5,4f10.5)') cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i), cd & uy(:,j),uz(:,j) cd write (iout,'(4f10.5)') cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) cd write (iout,'(4f10.5)') ury,urz,vry,vrz cd write (iout,'(9f10.5/)') cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij C Derivatives of the elements of A in virtual-bond vectors if (calc_grad) then call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) do k=1,3 uryg(k,1)=scalar(erder(1,k),uy(1,i)) uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) urzg(k,1)=scalar(erder(1,k),uz(1,i)) urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) vryg(k,1)=scalar(erder(1,k),uy(1,j)) vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) vrzg(k,1)=scalar(erder(1,k),uz(1,j)) vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) enddo C Compute radial contributions to the gradient facr=-3.0d0*rrmij a22der=a22*facr a23der=a23*facr a32der=a32*facr a33der=a33*facr agg(1,1)=a22der*xj agg(2,1)=a22der*yj agg(3,1)=a22der*zj agg(1,2)=a23der*xj agg(2,2)=a23der*yj agg(3,2)=a23der*zj agg(1,3)=a32der*xj agg(2,3)=a32der*yj agg(3,3)=a32der*zj agg(1,4)=a33der*xj agg(2,4)=a33der*yj agg(3,4)=a33der*zj C Add the contributions coming from er fac3=-3.0d0*fac do k=1,3 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) enddo do k=1,3 C Derivatives in DC(i) cgrad ghalf1=0.5d0*agg(k,1) cgrad ghalf2=0.5d0*agg(k,2) cgrad ghalf3=0.5d0*agg(k,3) cgrad ghalf4=0.5d0*agg(k,4) aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) & -3.0d0*uryg(k,2)*vry)!+ghalf1 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) & -3.0d0*uryg(k,2)*vrz)!+ghalf2 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) & -3.0d0*urzg(k,2)*vry)!+ghalf3 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) & -3.0d0*urzg(k,2)*vrz)!+ghalf4 C Derivatives in DC(i+1) aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) & -3.0d0*uryg(k,3)*vry)!+agg(k,1) aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) & -3.0d0*uryg(k,3)*vrz)!+agg(k,2) aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) & -3.0d0*urzg(k,3)*vry)!+agg(k,3) aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) & -3.0d0*urzg(k,3)*vrz)!+agg(k,4) C Derivatives in DC(j) aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) & -3.0d0*vryg(k,2)*ury)!+ghalf1 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) & -3.0d0*vrzg(k,2)*ury)!+ghalf2 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) & -3.0d0*vryg(k,2)*urz)!+ghalf3 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) & -3.0d0*vrzg(k,2)*urz)!+ghalf4 C Derivatives in DC(j+1) or DC(nres-1) aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) & -3.0d0*vryg(k,3)*ury) aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) & -3.0d0*vrzg(k,3)*ury) aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) & -3.0d0*vryg(k,3)*urz) aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) & -3.0d0*vrzg(k,3)*urz) cgrad if (j.eq.nres-1 .and. i.lt.j-2) then cgrad do l=1,4 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l) cgrad enddo cgrad endif enddo endif ! calc_grad acipa(1,1)=a22 acipa(1,2)=a23 acipa(2,1)=a32 acipa(2,2)=a33 a22=-a22 a23=-a23 if (calc_grad) then do l=1,2 do k=1,3 agg(k,l)=-agg(k,l) aggi(k,l)=-aggi(k,l) aggi1(k,l)=-aggi1(k,l) aggj(k,l)=-aggj(k,l) aggj1(k,l)=-aggj1(k,l) enddo enddo endif ! calc_grad if (j.lt.nres-1) then a22=-a22 a32=-a32 do l=1,3,2 do k=1,3 agg(k,l)=-agg(k,l) aggi(k,l)=-aggi(k,l) aggi1(k,l)=-aggi1(k,l) aggj(k,l)=-aggj(k,l) aggj1(k,l)=-aggj1(k,l) enddo enddo else a22=-a22 a23=-a23 a32=-a32 a33=-a33 do l=1,4 do k=1,3 agg(k,l)=-agg(k,l) aggi(k,l)=-aggi(k,l) aggi1(k,l)=-aggi1(k,l) aggj(k,l)=-aggj(k,l) aggj1(k,l)=-aggj1(k,l) enddo enddo endif ENDIF ! WCORR IF (wel_loc.gt.0.0d0) THEN C Contribution to the local-electrostatic energy coming from the i-j pair eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) & +a33*muij(4) #ifdef DEBUG write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32, & " a33",a33 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij, & " wel_loc",wel_loc #endif if (shield_mode.eq.0) then fac_shield(i)=1.0 fac_shield(j)=1.0 C else C fac_shield(i)=0.4 C fac_shield(j)=0.6 endif eel_loc_ij=eel_loc_ij & *fac_shield(i)*fac_shield(j) if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & 'eelloc',i,j,eel_loc_ij c if (eel_loc_ij.ne.0) c & write (iout,'(a4,2i4,8f9.5)')'chuj', c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4) eel_loc=eel_loc+eel_loc_ij C Now derivative over eel_loc if (calc_grad) then if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (shield_mode.gt.0)) then C print *,i,j do ilist=1,ishield_list(i) iresshield=shield_list(ilist,i) do k=1,3 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij & /fac_shield(i) C & *2.0 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ & rlocshield & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i) gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1) & +rlocshield enddo enddo do ilist=1,ishield_list(j) iresshield=shield_list(ilist,j) do k=1,3 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij & /fac_shield(j) C & *2.0 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ & rlocshield & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j) gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1) & +rlocshield enddo enddo do k=1,3 gshieldc_ll(k,i)=gshieldc_ll(k,i)+ & grad_shield(k,i)*eel_loc_ij/fac_shield(i) gshieldc_ll(k,j)=gshieldc_ll(k,j)+ & grad_shield(k,j)*eel_loc_ij/fac_shield(j) gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ & grad_shield(k,i)*eel_loc_ij/fac_shield(i) gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ & grad_shield(k,j)*eel_loc_ij/fac_shield(j) enddo endif c write (iout,*) 'i',i,' j',j,itype(i),itype(j), c & ' eel_loc_ij',eel_loc_ij C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4) C Calculate patrial derivative for theta angle #ifdef NEWCORR geel_loc_ij=(a22*gmuij1(1) & +a23*gmuij1(2) & +a32*gmuij1(3) & +a33*gmuij1(4)) & *fac_shield(i)*fac_shield(j) c write(iout,*) "derivative over thatai" c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3), c & a33*gmuij1(4) gloc(nphi+i,icg)=gloc(nphi+i,icg)+ & geel_loc_ij*wel_loc c write(iout,*) "derivative over thatai-1" c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3), c & a33*gmuij2(4) geel_loc_ij= & a22*gmuij2(1) & +a23*gmuij2(2) & +a32*gmuij2(3) & +a33*gmuij2(4) gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ & geel_loc_ij*wel_loc & *fac_shield(i)*fac_shield(j) c Derivative over j residue geel_loc_ji=a22*gmuji1(1) & +a23*gmuji1(2) & +a32*gmuji1(3) & +a33*gmuji1(4) c write(iout,*) "derivative over thataj" c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3), c & a33*gmuji1(4) gloc(nphi+j,icg)=gloc(nphi+j,icg)+ & geel_loc_ji*wel_loc & *fac_shield(i)*fac_shield(j) geel_loc_ji= & +a22*gmuji2(1) & +a23*gmuji2(2) & +a32*gmuji2(3) & +a33*gmuji2(4) c write(iout,*) "derivative over thataj-1" c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3), c & a33*gmuji2(4) gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+ & geel_loc_ji*wel_loc & *fac_shield(i)*fac_shield(j) #endif cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij C Partial derivatives in virtual-bond dihedral angles gamma if (i.gt.1) & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) & *fac_shield(i)*fac_shield(j) gel_loc_loc(j-1)=gel_loc_loc(j-1)+ & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) & *fac_shield(i)*fac_shield(j) C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) do l=1,3 ggg(l)=(agg(l,1)*muij(1)+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)) & *fac_shield(i)*fac_shield(j) gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) cgrad ghalf=0.5d0*ggg(l) cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf enddo cgrad do k=i+1,j2 cgrad do l=1,3 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l) cgrad enddo cgrad enddo C Remaining derivatives of eello do l=1,3 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)) & *fac_shield(i)*fac_shield(j) gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)) & *fac_shield(i)*fac_shield(j) gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)) & *fac_shield(i)*fac_shield(j) gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)) & *fac_shield(i)*fac_shield(j) enddo endif ! calc_grad ENDIF C Change 12/26/95 to calculate four-body contributions to H-bonding energy c if (j.gt.i+1 .and. num_conti.le.maxconts) then if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 & .and. num_conti.le.maxconts) then c write (iout,*) i,j," entered corr" C C Calculate the contact function. The ith column of the array JCONT will C contain the numbers of atoms that make contacts with the atom I (of numbers C greater than I). The arrays FACONT and GACONT will contain the values of C the contact function and its derivative. c r0ij=1.02D0*rpp(iteli,itelj) c r0ij=1.11D0*rpp(iteli,itelj) r0ij=2.20D0*rpp(iteli,itelj) c r0ij=1.55D0*rpp(iteli,itelj) call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) if (fcont.gt.0.0D0) then num_conti=num_conti+1 if (num_conti.gt.maxconts) then write (iout,*) 'WARNING - max. # of contacts exceeded;', & ' will skip next contacts for this conf.' else jcont_hb(num_conti,i)=j cd write (iout,*) "i",i," j",j," num_conti",num_conti, cd & " jcont_hb",jcont_hb(num_conti,i) IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el C terms. d_cont(num_conti,i)=rij cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij C --- Electrostatic-interaction matrix --- a_chuj(1,1,num_conti,i)=a22 a_chuj(1,2,num_conti,i)=a23 a_chuj(2,1,num_conti,i)=a32 a_chuj(2,2,num_conti,i)=a33 C --- Gradient of rij if (calc_grad) then do kkk=1,3 grij_hb_cont(kkk,num_conti,i)=erij(kkk) enddo kkll=0 do k=1,2 do l=1,2 kkll=kkll+1 do m=1,3 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) enddo enddo enddo endif ! calc_grad ENDIF IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN C Calculate contact energies cosa4=4.0D0*cosa wij=cosa-3.0D0*cosb*cosg cosbg1=cosb+cosg cosbg2=cosb-cosg c fac3=dsqrt(-ael6i)/r0ij**3 fac3=dsqrt(-ael6i)*r3ij c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 if (ees0tmp.gt.0) then ees0pij=dsqrt(ees0tmp) else ees0pij=0 endif c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 if (ees0tmp.gt.0) then ees0mij=dsqrt(ees0tmp) else ees0mij=0 endif c ees0mij=0.0D0 if (shield_mode.eq.0) then fac_shield(i)=1.0d0 fac_shield(j)=1.0d0 else ees0plist(num_conti,i)=j C fac_shield(i)=0.4d0 C fac_shield(j)=0.6d0 endif ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) & *fac_shield(i)*fac_shield(j) ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) & *fac_shield(i)*fac_shield(j) C Diagnostics. Comment out or remove after debugging! c ees0p(num_conti,i)=0.5D0*fac3*ees0pij c ees0m(num_conti,i)=0.5D0*fac3*ees0mij c ees0m(num_conti,i)=0.0D0 C End diagnostics. c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont C Angular derivatives of the contact function ees0pij1=fac3/ees0pij ees0mij1=fac3/ees0mij fac3p=-3.0D0*fac3*rrmij ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) c ees0mij1=0.0D0 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) ecosap=ecosa1+ecosa2 ecosbp=ecosb1+ecosb2 ecosgp=ecosg1+ecosg2 ecosam=ecosa1-ecosa2 ecosbm=ecosb1-ecosb2 ecosgm=ecosg1-ecosg2 C Diagnostics c ecosap=ecosa1 c ecosbp=ecosb1 c ecosgp=ecosg1 c ecosam=0.0D0 c ecosbm=0.0D0 c ecosgm=0.0D0 C End diagnostics facont_hb(num_conti,i)=fcont if (calc_grad) then fprimcont=fprimcont/rij cd facont_hb(num_conti,i)=1.0D0 C Following line is for diagnostics. cd fprimcont=0.0D0 do k=1,3 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) enddo do k=1,3 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) enddo gggp(1)=gggp(1)+ees0pijp*xj gggp(2)=gggp(2)+ees0pijp*yj gggp(3)=gggp(3)+ees0pijp*zj gggm(1)=gggm(1)+ees0mijp*xj gggm(2)=gggm(2)+ees0mijp*yj gggm(3)=gggm(3)+ees0mijp*zj C Derivatives due to the contact function gacont_hbr(1,num_conti,i)=fprimcont*xj gacont_hbr(2,num_conti,i)=fprimcont*yj gacont_hbr(3,num_conti,i)=fprimcont*zj do k=1,3 c c 10/24/08 cgrad and ! comments indicate the parts of the code removed c following the change of gradient-summation algorithm. c cgrad ghalfp=0.5D0*gggp(k) cgrad ghalfm=0.5D0*gggm(k) gacontp_hb1(k,num_conti,i)=!ghalfp & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) & *fac_shield(i)*fac_shield(j) gacontp_hb2(k,num_conti,i)=!ghalfp & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) & *fac_shield(i)*fac_shield(j) gacontp_hb3(k,num_conti,i)=gggp(k) & *fac_shield(i)*fac_shield(j) gacontm_hb1(k,num_conti,i)=!ghalfm & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) & *fac_shield(i)*fac_shield(j) gacontm_hb2(k,num_conti,i)=!ghalfm & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) & *fac_shield(i)*fac_shield(j) gacontm_hb3(k,num_conti,i)=gggm(k) & *fac_shield(i)*fac_shield(j) enddo C Diagnostics. Comment out or remove after debugging! cdiag do k=1,3 cdiag gacontp_hb1(k,num_conti,i)=0.0D0 cdiag gacontp_hb2(k,num_conti,i)=0.0D0 cdiag gacontp_hb3(k,num_conti,i)=0.0D0 cdiag gacontm_hb1(k,num_conti,i)=0.0D0 cdiag gacontm_hb2(k,num_conti,i)=0.0D0 cdiag gacontm_hb3(k,num_conti,i)=0.0D0 cdiag enddo endif ! calc_grad ENDIF ! wcorr endif ! num_conti.le.maxconts endif ! fcont.gt.0 endif ! j.gt.i+1 if (calc_grad) then if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then do k=1,4 do l=1,3 ghalf=0.5d0*agg(l,k) aggi(l,k)=aggi(l,k)+ghalf aggi1(l,k)=aggi1(l,k)+agg(l,k) aggj(l,k)=aggj(l,k)+ghalf enddo enddo if (j.eq.nres-1 .and. i.lt.j-2) then do k=1,4 do l=1,3 aggj1(l,k)=aggj1(l,k)+agg(l,k) enddo enddo endif endif endif ! calc_grad c t_eelecij=t_eelecij+MPI_Wtime()-time00 return end C----------------------------------------------------------------------------- subroutine eturn3(i,eello_turn3) C Third- and fourth-order contributions from turns implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' include 'COMMON.CONTROL' include 'COMMON.SHIELD' dimension ggg(3) double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2), & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2), & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2), & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2), & auxgmat2(2,2),auxgmatt2(2,2) double precision agg(3,4),aggi(3,4),aggi1(3,4), & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2) common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, & num_conti,j1,j2 j=i+2 c write (iout,*) "eturn3",i,j,j1,j2 a_temp(1,1)=a22 a_temp(1,2)=a23 a_temp(2,1)=a32 a_temp(2,2)=a33 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C Third-order contributions C C (i+2)o----(i+3) C | | C | | C (i+1)o----i C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC cd call checkint_turn3(i,a_temp,eello_turn3_num) call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1)) c auxalary matices for theta gradient c auxalary matrix for i+1 and constant i+2 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1)) c auxalary matrix for i+2 and constant i+1 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1)) call transpose2(auxmat(1,1),auxmat1(1,1)) call transpose2(auxgmat1(1,1),auxgmatt1(1,1)) call transpose2(auxgmat2(1,1),auxgmatt2(1,1)) call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1)) call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1)) if (shield_mode.eq.0) then fac_shield(i)=1.0 fac_shield(j)=1.0 C else C fac_shield(i)=0.4 C fac_shield(j)=0.6 endif eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) & *fac_shield(i)*fac_shield(j) eello_t3=0.5d0*(pizda(1,1)+pizda(2,2)) & *fac_shield(i)*fac_shield(j) if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2, & eello_t3 if (calc_grad) then C#ifdef NEWCORR C Derivatives in theta gloc(nphi+i,icg)=gloc(nphi+i,icg) & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3 & *fac_shield(i)*fac_shield(j) gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg) & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3 & *fac_shield(i)*fac_shield(j) C#endif C Derivatives in shield mode if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (shield_mode.gt.0)) then C print *,i,j do ilist=1,ishield_list(i) iresshield=shield_list(ilist,i) do k=1,3 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i) C & *2.0 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ & rlocshield & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i) gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) & +rlocshield enddo enddo do ilist=1,ishield_list(j) iresshield=shield_list(ilist,j) do k=1,3 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j) C & *2.0 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ & rlocshield & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j) gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) & +rlocshield enddo enddo do k=1,3 gshieldc_t3(k,i)=gshieldc_t3(k,i)+ & grad_shield(k,i)*eello_t3/fac_shield(i) gshieldc_t3(k,j)=gshieldc_t3(k,j)+ & grad_shield(k,j)*eello_t3/fac_shield(j) gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+ & grad_shield(k,i)*eello_t3/fac_shield(i) gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+ & grad_shield(k,j)*eello_t3/fac_shield(j) enddo endif C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') cd write (2,*) 'i,',i,' j',j,'eello_turn3', cd & 0.5d0*(pizda(1,1)+pizda(2,2)), cd & ' eello_turn3_num',4*eello_turn3_num C Derivatives in gamma(i) call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1)) call transpose2(auxmat2(1,1),auxmat3(1,1)) call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1)) gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2)) & *fac_shield(i)*fac_shield(j) C Derivatives in gamma(i+1) call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1)) call transpose2(auxmat2(1,1),auxmat3(1,1)) call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1)) gel_loc_turn3(i+1)=gel_loc_turn3(i+1) & +0.5d0*(pizda(1,1)+pizda(2,2)) & *fac_shield(i)*fac_shield(j) C Cartesian derivatives do l=1,3 c ghalf1=0.5d0*agg(l,1) c ghalf2=0.5d0*agg(l,2) c ghalf3=0.5d0*agg(l,3) c ghalf4=0.5d0*agg(l,4) a_temp(1,1)=aggi(l,1)!+ghalf1 a_temp(1,2)=aggi(l,2)!+ghalf2 a_temp(2,1)=aggi(l,3)!+ghalf3 a_temp(2,2)=aggi(l,4)!+ghalf4 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) gcorr3_turn(l,i)=gcorr3_turn(l,i) & +0.5d0*(pizda(1,1)+pizda(2,2)) & *fac_shield(i)*fac_shield(j) a_temp(1,1)=aggi1(l,1)!+agg(l,1) a_temp(1,2)=aggi1(l,2)!+agg(l,2) a_temp(2,1)=aggi1(l,3)!+agg(l,3) a_temp(2,2)=aggi1(l,4)!+agg(l,4) call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) & +0.5d0*(pizda(1,1)+pizda(2,2)) & *fac_shield(i)*fac_shield(j) a_temp(1,1)=aggj(l,1)!+ghalf1 a_temp(1,2)=aggj(l,2)!+ghalf2 a_temp(2,1)=aggj(l,3)!+ghalf3 a_temp(2,2)=aggj(l,4)!+ghalf4 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) gcorr3_turn(l,j)=gcorr3_turn(l,j) & +0.5d0*(pizda(1,1)+pizda(2,2)) & *fac_shield(i)*fac_shield(j) a_temp(1,1)=aggj1(l,1) a_temp(1,2)=aggj1(l,2) a_temp(2,1)=aggj1(l,3) a_temp(2,2)=aggj1(l,4) call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) gcorr3_turn(l,j1)=gcorr3_turn(l,j1) & +0.5d0*(pizda(1,1)+pizda(2,2)) & *fac_shield(i)*fac_shield(j) enddo endif ! calc_grad return end C------------------------------------------------------------------------------- subroutine eturn4(i,eello_turn4) C Third- and fourth-order contributions from turns implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' include 'COMMON.CONTROL' include 'COMMON.SHIELD' dimension ggg(3) double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2), & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2), & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2), & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2), & gte1t(2,2),gte2t(2,2),gte3t(2,2), & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2), & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2) double precision agg(3,4),aggi(3,4),aggi1(3,4), & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2) common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, & num_conti,j1,j2 j=i+3 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C Fourth-order contributions C C (i+3)o----(i+4) C / | C (i+2)o | C \ | C (i+1)o----i C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC cd call checkint_turn4(i,a_temp,eello_turn4_num) c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2 c write(iout,*)"WCHODZE W PROGRAM" a_temp(1,1)=a22 a_temp(1,2)=a23 a_temp(2,1)=a32 a_temp(2,2)=a33 iti1=itype2loc(itype(i+1)) iti2=itype2loc(itype(i+2)) iti3=itype2loc(itype(i+3)) c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3 call transpose2(EUg(1,1,i+1),e1t(1,1)) call transpose2(Eug(1,1,i+2),e2t(1,1)) call transpose2(Eug(1,1,i+3),e3t(1,1)) C Ematrix derivative in theta call transpose2(gtEUg(1,1,i+1),gte1t(1,1)) call transpose2(gtEug(1,1,i+2),gte2t(1,1)) call transpose2(gtEug(1,1,i+3),gte3t(1,1)) call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) c eta1 in derivative theta call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1)) call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) c auxgvec is derivative of Ub2 so i+3 theta call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1)) c auxalary matrix of E i+1 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1)) c s1=0.0 c gs1=0.0 s1=scalar2(b1(1,i+2),auxvec(1)) c derivative of theta i+2 with constant i+3 gs23=scalar2(gtb1(1,i+2),auxvec(1)) c derivative of theta i+2 with constant i+2 gs32=scalar2(b1(1,i+2),auxgvec(1)) c derivative of E matix in theta of i+1 gsE13=scalar2(b1(1,i+2),auxgEvec1(1)) call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) c ea31 in derivative theta call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1)) call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) c auxilary matrix auxgvec of Ub2 with constant E matirx call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1)) c auxilary matrix auxgEvec1 of E matix with Ub2 constant call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1)) c s2=0.0 c gs2=0.0 s2=scalar2(b1(1,i+1),auxvec(1)) c derivative of theta i+1 with constant i+3 gs13=scalar2(gtb1(1,i+1),auxvec(1)) c derivative of theta i+2 with constant i+1 gs21=scalar2(b1(1,i+1),auxgvec(1)) c derivative of theta i+3 with constant i+1 gsE31=scalar2(b1(1,i+1),auxgEvec3(1)) c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2), c & gtb1(1,i+1) call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) c two derivatives over diffetent matrices c gtae3e2 is derivative over i+3 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1)) c ae3gte2 is derivative over i+2 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1)) call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) c three possible derivative over theta E matices c i+1 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1)) c i+2 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1)) c i+3 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2)) gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2)) gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2)) if (shield_mode.eq.0) then fac_shield(i)=1.0 fac_shield(j)=1.0 C else C fac_shield(i)=0.6 C fac_shield(j)=0.4 endif eello_turn4=eello_turn4-(s1+s2+s3) & *fac_shield(i)*fac_shield(j) eello_t4=-(s1+s2+s3) & *fac_shield(i)*fac_shield(j) c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2) if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)') & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3 C Now derivative over shield: if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (shield_mode.gt.0)) then C print *,i,j do ilist=1,ishield_list(i) iresshield=shield_list(ilist,i) do k=1,3 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i) C & *2.0 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ & rlocshield & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i) gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) & +rlocshield enddo enddo do ilist=1,ishield_list(j) iresshield=shield_list(ilist,j) do k=1,3 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j) C & *2.0 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ & rlocshield & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j) gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) & +rlocshield enddo enddo do k=1,3 gshieldc_t4(k,i)=gshieldc_t4(k,i)+ & grad_shield(k,i)*eello_t4/fac_shield(i) gshieldc_t4(k,j)=gshieldc_t4(k,j)+ & grad_shield(k,j)*eello_t4/fac_shield(j) gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+ & grad_shield(k,i)*eello_t4/fac_shield(i) gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+ & grad_shield(k,j)*eello_t4/fac_shield(j) enddo endif cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3), cd & ' eello_turn4_num',8*eello_turn4_num #ifdef NEWCORR gloc(nphi+i,icg)=gloc(nphi+i,icg) & -(gs13+gsE13+gsEE1)*wturn4 & *fac_shield(i)*fac_shield(j) gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg) & -(gs23+gs21+gsEE2)*wturn4 & *fac_shield(i)*fac_shield(j) gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg) & -(gs32+gsE31+gsEE3)*wturn4 & *fac_shield(i)*fac_shield(j) c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)- c & gs2 #endif if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & 'eturn4',i,j,-(s1+s2+s3) c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3), c & ' eello_turn4_num',8*eello_turn4_num C Derivatives in gamma(i) call transpose2(EUgder(1,1,i+1),e1tder(1,1)) call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1)) call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1)) s1=scalar2(b1(1,i+2),auxvec(1)) call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) & *fac_shield(i)*fac_shield(j) C Derivatives in gamma(i+1) call transpose2(EUgder(1,1,i+2),e2tder(1,1)) call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1)) s2=scalar2(b1(1,i+1),auxvec(1)) call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1)) call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) & *fac_shield(i)*fac_shield(j) C Derivatives in gamma(i+2) call transpose2(EUgder(1,1,i+3),e3tder(1,1)) call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1)) s1=scalar2(b1(1,i+2),auxvec(1)) call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1)) call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1)) s2=scalar2(b1(1,i+1),auxvec(1)) call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1)) call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) & *fac_shield(i)*fac_shield(j) if (calc_grad) then C Cartesian derivatives C Derivatives of this turn contributions in DC(i+2) if (j.lt.nres-1) then do l=1,3 a_temp(1,1)=agg(l,1) a_temp(1,2)=agg(l,2) a_temp(2,1)=agg(l,3) a_temp(2,2)=agg(l,4) call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) s1=scalar2(b1(1,i+2),auxvec(1)) call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) s2=scalar2(b1(1,i+1),auxvec(1)) call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) ggg(l)=-(s1+s2+s3) gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3) & *fac_shield(i)*fac_shield(j) enddo endif C Remaining derivatives of this turn contribution do l=1,3 a_temp(1,1)=aggi(l,1) a_temp(1,2)=aggi(l,2) a_temp(2,1)=aggi(l,3) a_temp(2,2)=aggi(l,4) call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) s1=scalar2(b1(1,i+2),auxvec(1)) call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) s2=scalar2(b1(1,i+1),auxvec(1)) call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) & *fac_shield(i)*fac_shield(j) a_temp(1,1)=aggi1(l,1) a_temp(1,2)=aggi1(l,2) a_temp(2,1)=aggi1(l,3) a_temp(2,2)=aggi1(l,4) call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) s1=scalar2(b1(1,i+2),auxvec(1)) call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) s2=scalar2(b1(1,i+1),auxvec(1)) call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) & *fac_shield(i)*fac_shield(j) a_temp(1,1)=aggj(l,1) a_temp(1,2)=aggj(l,2) a_temp(2,1)=aggj(l,3) a_temp(2,2)=aggj(l,4) call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) s1=scalar2(b1(1,i+2),auxvec(1)) call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) s2=scalar2(b1(1,i+1),auxvec(1)) call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) & *fac_shield(i)*fac_shield(j) a_temp(1,1)=aggj1(l,1) a_temp(1,2)=aggj1(l,2) a_temp(2,1)=aggj1(l,3) a_temp(2,2)=aggj1(l,4) call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) s1=scalar2(b1(1,i+2),auxvec(1)) call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) s2=scalar2(b1(1,i+1),auxvec(1)) call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) & *fac_shield(i)*fac_shield(j) enddo endif ! calc_grad return end C----------------------------------------------------------------------------- subroutine vecpr(u,v,w) implicit real*8(a-h,o-z) dimension u(3),v(3),w(3) w(1)=u(2)*v(3)-u(3)*v(2) w(2)=-u(1)*v(3)+u(3)*v(1) w(3)=u(1)*v(2)-u(2)*v(1) return end C----------------------------------------------------------------------------- subroutine unormderiv(u,ugrad,unorm,ungrad) C This subroutine computes the derivatives of a normalized vector u, given C the derivatives computed without normalization conditions, ugrad. Returns C ungrad. implicit none double precision u(3),ugrad(3,3),unorm,ungrad(3,3) double precision vec(3) double precision scalar integer i,j c write (2,*) 'ugrad',ugrad c write (2,*) 'u',u do i=1,3 vec(i)=scalar(ugrad(1,i),u(1)) enddo c write (2,*) 'vec',vec do i=1,3 do j=1,3 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm enddo enddo c write (2,*) 'ungrad',ungrad return end C----------------------------------------------------------------------------- subroutine escp(evdw2,evdw2_14) C C This subroutine calculates the excluded-volume interaction energy between C peptide-group centers and side chains and its gradient in virtual-bond and C side-chain vectors. C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.FFIELD' include 'COMMON.IOUNITS' dimension ggg(3) evdw2=0.0D0 evdw2_14=0.0d0 cd print '(a)','Enter ESCP' c write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e, c & ' scal14',scal14 do i=iatscp_s,iatscp_e if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle iteli=itel(i) c write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i), c & " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) if (iteli.eq.0) goto 1225 xi=0.5D0*(c(1,i)+c(1,i+1)) yi=0.5D0*(c(2,i)+c(2,i+1)) zi=0.5D0*(c(3,i)+c(3,i+1)) C Returning the ith atom to box xi=mod(xi,boxxsize) if (xi.lt.0) xi=xi+boxxsize yi=mod(yi,boxysize) if (yi.lt.0) yi=yi+boxysize zi=mod(zi,boxzsize) if (zi.lt.0) zi=zi+boxzsize do iint=1,nscp_gr(i) do j=iscpstart(i,iint),iscpend(i,iint) itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle C Uncomment following three lines for SC-p interactions c xj=c(1,nres+j)-xi c yj=c(2,nres+j)-yi c zj=c(3,nres+j)-zi C Uncomment following three lines for Ca-p interactions xj=c(1,j) yj=c(2,j) zj=c(3,j) C returning the jth atom to box xj=mod(xj,boxxsize) if (xj.lt.0) xj=xj+boxxsize yj=mod(yj,boxysize) if (yj.lt.0) yj=yj+boxysize zj=mod(zj,boxzsize) if (zj.lt.0) zj=zj+boxzsize dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 xj_safe=xj yj_safe=yj zj_safe=zj subchap=0 C Finding the closest jth atom do xshift=-1,1 do yshift=-1,1 do zshift=-1,1 xj=xj_safe+xshift*boxxsize yj=yj_safe+yshift*boxysize zj=zj_safe+zshift*boxzsize dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 if(dist_temp.lt.dist_init) then dist_init=dist_temp xj_temp=xj yj_temp=yj zj_temp=zj subchap=1 endif enddo enddo enddo if (subchap.eq.1) then xj=xj_temp-xi yj=yj_temp-yi zj=zj_temp-zi else xj=xj_safe-xi yj=yj_safe-yi zj=zj_safe-zi endif rrij=1.0D0/(xj*xj+yj*yj+zj*zj) C sss is scaling function for smoothing the cutoff gradient otherwise C the gradient would not be continuouse sss=sscale(1.0d0/(dsqrt(rrij))) if (sss.le.0.0d0) cycle sssgrad=sscagrad(1.0d0/(dsqrt(rrij))) fac=rrij**expon2 e1=fac*fac*aad(itypj,iteli) e2=fac*bad(itypj,iteli) if (iabs(j-i) .le. 2) then e1=scal14*e1 e2=scal14*e2 evdw2_14=evdw2_14+(e1+e2)*sss endif evdwij=e1+e2 c write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') c & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli), c & bad(itypj,iteli) evdw2=evdw2+evdwij*sss if (calc_grad) then C C Calculate contributions to the gradient in the virtual-bond and SC vectors. C fac=-(evdwij+e1)*rrij*sss fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon ggg(1)=xj*fac ggg(2)=yj*fac ggg(3)=zj*fac if (j.lt.i) then cd write (iout,*) 'ji' do k=1,3 ggg(k)=-ggg(k) C Uncomment following line for SC-p interactions c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) enddo endif do k=1,3 gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) enddo kstart=min0(i+1,j) kend=max0(i-1,j-1) cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend cd write (iout,*) ggg(1),ggg(2),ggg(3) do k=kstart,kend do l=1,3 gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) enddo enddo endif ! calc_grad enddo enddo ! iint 1225 continue enddo ! i do i=1,nct do j=1,3 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) gradx_scp(j,i)=expon*gradx_scp(j,i) enddo enddo C****************************************************************************** C C N O T E !!! C C To save time the factor EXPON has been extracted from ALL components C of GVDWC and GRADX. Remember to multiply them by this factor before further C use! C C****************************************************************************** return end C-------------------------------------------------------------------------- subroutine edis(ehpb) C C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.SBRIDGE' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.VAR' include 'COMMON.INTERACT' include 'COMMON.CONTROL' include 'COMMON.IOUNITS' dimension ggg(3) ehpb=0.0D0 cd print *,'edis: nhpb=',nhpb,' fbr=',fbr cd print *,'link_start=',link_start,' link_end=',link_end C write(iout,*) link_end, "link_end" if (link_end.eq.0) return do i=link_start,link_end C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a C CA-CA distance used in regularization of structure. ii=ihpb(i) jj=jhpb(i) C iii and jjj point to the residues for which the distance is assigned. if (ii.gt.nres) then iii=ii-nres jjj=jj-nres else iii=ii jjj=jj endif C 24/11/03 AL: SS bridges handled separately because of introducing a specific C distance and angle dependent SS bond potential. C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. C & iabs(itype(jjj)).eq.1) then C write(iout,*) constr_dist,"const" if (.not.dyn_ss .and. i.le.nss) then if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. & iabs(itype(jjj)).eq.1) then call ssbond_ene(iii,jjj,eij) ehpb=ehpb+2*eij endif !ii.gt.neres else if (ii.gt.nres .and. jj.gt.nres) then c Restraints from contact prediction dd=dist(ii,jj) if (constr_dist.eq.11) then C ehpb=ehpb+fordepth(i)**4.0d0 C & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) ehpb=ehpb+fordepth(i)**4.0d0 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) fac=fordepth(i)**4.0d0 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, C & ehpb,fordepth(i),dd C write(iout,*) ehpb,"atu?" C ehpb,"tu?" C fac=fordepth(i)**4.0d0 C & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd else if (dhpb1(i).gt.0.0d0) then ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd c write (iout,*) "beta nmr", c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) else dd=dist(ii,jj) rdis=dd-dhpb(i) C Get the force constant corresponding to this distance. waga=forcon(i) C Calculate the contribution to energy. ehpb=ehpb+waga*rdis*rdis c write (iout,*) "beta reg",dd,waga*rdis*rdis C C Evaluate gradient. C fac=waga*rdis/dd endif !end dhpb1(i).gt.0 endif !end const_dist=11 do j=1,3 ggg(j)=fac*(c(j,jj)-c(j,ii)) enddo do j=1,3 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) enddo do k=1,3 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) enddo else !ii.gt.nres C write(iout,*) "before" dd=dist(ii,jj) C write(iout,*) "after",dd if (constr_dist.eq.11) then ehpb=ehpb+fordepth(i)**4.0d0 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) fac=fordepth(i)**4.0d0 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd C ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i)) C fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd C print *,ehpb,"tu?" C write(iout,*) ehpb,"btu?", C & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i) C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, C & ehpb,fordepth(i),dd else if (dhpb1(i).gt.0.0d0) then ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd c write (iout,*) "alph nmr", c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) else rdis=dd-dhpb(i) C Get the force constant corresponding to this distance. waga=forcon(i) C Calculate the contribution to energy. ehpb=ehpb+waga*rdis*rdis c write (iout,*) "alpha reg",dd,waga*rdis*rdis C C Evaluate gradient. C fac=waga*rdis/dd endif endif do j=1,3 ggg(j)=fac*(c(j,jj)-c(j,ii)) enddo cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) C If this is a SC-SC distance, we need to calculate the contributions to the C Cartesian gradient in the SC vectors (ghpbx). if (iii.lt.ii) then do j=1,3 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) enddo endif do j=iii,jjj-1 do k=1,3 ghpbc(k,j)=ghpbc(k,j)+ggg(k) enddo enddo endif enddo if (constr_dist.ne.11) ehpb=0.5D0*ehpb return end C-------------------------------------------------------------------------- subroutine ssbond_ene(i,j,eij) C C Calculate the distance and angle dependent SS-bond potential energy C using a free-energy function derived based on RHF/6-31G** ab initio C calculations of diethyl disulfide. C C A. Liwo and U. Kozlowska, 11/24/03 C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.SBRIDGE' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.VAR' include 'COMMON.IOUNITS' double precision erij(3),dcosom1(3),dcosom2(3),gg(3) itypi=iabs(itype(i)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) dsci_inv=dsc_inv(itypi) itypj=iabs(itype(j)) dscj_inv=dsc_inv(itypj) xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi dxj=dc_norm(1,nres+j) dyj=dc_norm(2,nres+j) dzj=dc_norm(3,nres+j) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) erij(1)=xj*rij erij(2)=yj*rij erij(3)=zj*rij om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) om12=dxi*dxj+dyi*dyj+dzi*dzj do k=1,3 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) enddo rij=1.0d0/rij deltad=rij-d0cm deltat1=1.0d0-om1 deltat2=1.0d0+om2 deltat12=om2-om1+2.0d0 cosphi=om12-om1*om2 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) & +akct*deltad*deltat12 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, c & " deltat12",deltat12," eij",eij ed=2*akcm*deltad+akct*deltat12 pom1=akct*deltad pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi eom1=-2*akth*deltat1-pom1-om2*pom2 eom2= 2*akth*deltat2+pom1-om1*pom2 eom12=pom2 do k=1,3 gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) enddo do k=1,3 ghpbx(k,i)=ghpbx(k,i)-gg(k) & +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv ghpbx(k,j)=ghpbx(k,j)+gg(k) & +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv enddo C C Calculate the components of the gradient in DC and X C do k=i,j-1 do l=1,3 ghpbc(l,k)=ghpbc(l,k)+gg(l) enddo enddo return end C-------------------------------------------------------------------------- subroutine ebond(estr) c c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds c implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.LOCAL' include 'COMMON.GEO' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.FFIELD' include 'COMMON.CONTROL' double precision u(3),ud(3) estr=0.0d0 estr1=0.0d0 c write (iout,*) "distchainmax",distchainmax do i=nnt+1,nct if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle C estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) C do j=1,3 C gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) C & *dc(j,i-1)/vbld(i) C enddo C if (energy_dec) write(iout,*) C & "estr1",i,vbld(i),distchainmax, C & gnmr1(vbld(i),-1.0d0,distchainmax) C else if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then diff = vbld(i)-vbldpDUM C write(iout,*) i,diff else diff = vbld(i)-vbldp0 c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff endif estr=estr+diff*diff do j=1,3 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) enddo C endif C write (iout,'(a7,i5,4f7.3)') C & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff enddo estr=0.5d0*AKP*estr+estr1 c c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included c do i=nnt,nct iti=iabs(itype(i)) if (iti.ne.10 .and. iti.ne.ntyp1) then nbi=nbondterm(iti) if (nbi.eq.1) then diff=vbld(i+nres)-vbldsc0(1,iti) C write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, C & AKSC(1,iti),AKSC(1,iti)*diff*diff estr=estr+0.5d0*AKSC(1,iti)*diff*diff do j=1,3 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) enddo else do j=1,nbi diff=vbld(i+nres)-vbldsc0(j,iti) ud(j)=aksc(j,iti)*diff u(j)=abond0(j,iti)+0.5d0*ud(j)*diff enddo uprod=u(1) do j=2,nbi uprod=uprod*u(j) enddo usum=0.0d0 usumsqder=0.0d0 do j=1,nbi uprod1=1.0d0 uprod2=1.0d0 do k=1,nbi if (k.ne.j) then uprod1=uprod1*u(k) uprod2=uprod2*u(k)*u(k) endif enddo usum=usum+uprod1 usumsqder=usumsqder+ud(j)*uprod2 enddo c write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti), c & AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi) estr=estr+uprod/usum do j=1,3 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) enddo endif endif enddo return end #ifdef CRYST_THETA C-------------------------------------------------------------------------- subroutine ebend(etheta,ethetacnstr) C C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral C angles gamma and its derivatives in consecutive thetas and gammas. C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.LOCAL' include 'COMMON.GEO' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.FFIELD' include 'COMMON.TORCNSTR' common /calcthet/ term1,term2,termm,diffak,ratak, & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, & delthe0,sig0inv,sigtc,sigsqtc,delthec,it double precision y(2),z(2) delta=0.02d0*pi c time11=dexp(-2*time) c time12=1.0d0 etheta=0.0D0 c write (iout,*) "nres",nres c write (*,'(a,i2)') 'EBEND ICG=',icg c write (iout,*) ithet_start,ithet_end do i=ithet_start,ithet_end C if (itype(i-1).eq.ntyp1) cycle if (i.le.2) cycle if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 & .or.itype(i).eq.ntyp1) cycle C Zero the energy function and its derivative at 0 or pi. call splinthet(theta(i),0.5d0*delta,ss,ssd) it=itype(i-1) ichir1=isign(1,itype(i-2)) ichir2=isign(1,itype(i)) if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1)) if (itype(i).eq.10) ichir2=isign(1,itype(i-1)) if (itype(i-1).eq.10) then itype1=isign(10,itype(i-2)) ichir11=isign(1,itype(i-2)) ichir12=isign(1,itype(i-2)) itype2=isign(10,itype(i)) ichir21=isign(1,itype(i)) ichir22=isign(1,itype(i)) endif if (i.eq.3) then y(1)=0.0D0 y(2)=0.0D0 else if (i.gt.3 .and. itype(i-3).ne.ntyp1) then #ifdef OSF phii=phi(i) c icrc=0 c call proc_proc(phii,icrc) if (icrc.eq.1) phii=150.0 #else phii=phi(i) #endif y(1)=dcos(phii) y(2)=dsin(phii) else y(1)=0.0D0 y(2)=0.0D0 endif endif if (i.lt.nres .and. itype(i+1).ne.ntyp1) then #ifdef OSF phii1=phi(i+1) c icrc=0 c call proc_proc(phii1,icrc) if (icrc.eq.1) phii1=150.0 phii1=pinorm(phii1) z(1)=cos(phii1) #else phii1=phi(i+1) z(1)=dcos(phii1) #endif z(2)=dsin(phii1) else z(1)=0.0D0 z(2)=0.0D0 endif C Calculate the "mean" value of theta from the part of the distribution C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). C In following comments this theta will be referred to as t_c. thet_pred_mean=0.0d0 do k=1,2 athetk=athet(k,it,ichir1,ichir2) bthetk=bthet(k,it,ichir1,ichir2) if (it.eq.10) then athetk=athet(k,itype1,ichir11,ichir12) bthetk=bthet(k,itype2,ichir21,ichir22) endif thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) enddo c write (iout,*) "thet_pred_mean",thet_pred_mean dthett=thet_pred_mean*ssd thet_pred_mean=thet_pred_mean*ss+a0thet(it) c write (iout,*) "thet_pred_mean",thet_pred_mean C Derivatives of the "mean" values in gamma1 and gamma2. dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &+athet(2,it,ichir1,ichir2)*y(1))*ss dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) & +bthet(2,it,ichir1,ichir2)*z(1))*ss if (it.eq.10) then dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &+athet(2,itype1,ichir11,ichir12)*y(1))*ss dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss endif if (theta(i).gt.pi-delta) then call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, & E_tc0) call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, & E_theta) call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, & E_tc) else if (theta(i).lt.delta) then call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, & E_theta) call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, & E_tc) else call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, & E_theta,E_tc) endif etheta=etheta+ethetai c write (iout,'(a6,i5,0pf7.3,f7.3,i5)') c & 'ebend',i,ethetai,theta(i),itype(i) c write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i), c & rad2deg*phii,rad2deg*phii1,ethetai if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) c 1215 continue enddo ethetacnstr=0.0d0 C print *,ithetaconstr_start,ithetaconstr_end,"TU" do i=1,ntheta_constr itheta=itheta_constr(i) thetiii=theta(itheta) difi=pinorm(thetiii-theta_constr0(i)) if (difi.gt.theta_drange(i)) then difi=difi-theta_drange(i) ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) & +for_thet_constr(i)*difi**3 else if (difi.lt.-drange(i)) then difi=difi+drange(i) ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) & +for_thet_constr(i)*difi**3 else difi=0.0 endif C if (energy_dec) then C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", C & i,itheta,rad2deg*thetiii, C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, C & gloc(itheta+nphi-2,icg) C endif enddo C Ufff.... We've done all this!!! return end C--------------------------------------------------------------------------- subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, & E_tc) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.LOCAL' include 'COMMON.IOUNITS' common /calcthet/ term1,term2,termm,diffak,ratak, & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, & delthe0,sig0inv,sigtc,sigsqtc,delthec,it C Calculate the contributions to both Gaussian lobes. C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) C The "polynomial part" of the "standard deviation" of this part of C the distribution. sig=polthet(3,it) do j=2,0,-1 sig=sig*thet_pred_mean+polthet(j,it) enddo C Derivative of the "interior part" of the "standard deviation of the" C gamma-dependent Gaussian lobe in t_c. sigtc=3*polthet(3,it) do j=2,1,-1 sigtc=sigtc*thet_pred_mean+j*polthet(j,it) enddo sigtc=sig*sigtc C Set the parameters of both Gaussian lobes of the distribution. C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) fac=sig*sig+sigc0(it) sigcsq=fac+fac sigc=1.0D0/sigcsq C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c sigsqtc=-4.0D0*sigcsq*sigtc c print *,i,sig,sigtc,sigsqtc C Following variable (sigtc) is d[sigma(t_c)]/dt_c sigtc=-sigtc/(fac*fac) C Following variable is sigma(t_c)**(-2) sigcsq=sigcsq*sigcsq sig0i=sig0(it) sig0inv=1.0D0/sig0i**2 delthec=thetai-thet_pred_mean delthe0=thetai-theta0i term1=-0.5D0*sigcsq*delthec*delthec term2=-0.5D0*sig0inv*delthe0*delthe0 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and C NaNs in taking the logarithm. We extract the largest exponent which is added C to the energy (this being the log of the distribution) at the end of energy C term evaluation for this virtual-bond angle. if (term1.gt.term2) then termm=term1 term2=dexp(term2-termm) term1=1.0d0 else termm=term2 term1=dexp(term1-termm) term2=1.0d0 endif C The ratio between the gamma-independent and gamma-dependent lobes of C the distribution is a Gaussian function of thet_pred_mean too. diffak=gthet(2,it)-thet_pred_mean ratak=diffak/gthet(3,it)**2 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) C Let's differentiate it in thet_pred_mean NOW. aktc=ak*ratak C Now put together the distribution terms to make complete distribution. termexp=term1+ak*term2 termpre=sigc+ak*sig0i C Contribution of the bending energy from this theta is just the -log of C the sum of the contributions from the two lobes and the pre-exponential C factor. Simple enough, isn't it? ethetai=(-dlog(termexp)-termm+dlog(termpre)) C NOW the derivatives!!! C 6/6/97 Take into account the deformation. E_theta=(delthec*sigcsq*term1 & +ak*delthe0*sig0inv*term2)/termexp E_tc=((sigtc+aktc*sig0i)/termpre & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ & aktc*term2)/termexp) return end c----------------------------------------------------------------------------- subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.LOCAL' include 'COMMON.IOUNITS' common /calcthet/ term1,term2,termm,diffak,ratak, & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, & delthe0,sig0inv,sigtc,sigsqtc,delthec,it delthec=thetai-thet_pred_mean delthe0=thetai-theta0i C "Thank you" to MAPLE (probably spared one day of hand-differentiation). t3 = thetai-thet_pred_mean t6 = t3**2 t9 = term1 t12 = t3*sigcsq t14 = t12+t6*sigsqtc t16 = 1.0d0 t21 = thetai-theta0i t23 = t21**2 t26 = term2 t27 = t21*t26 t32 = termexp t40 = t32**2 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 & *(-t12*t9-ak*sig0inv*t27) return end #else C-------------------------------------------------------------------------- subroutine ebend(etheta) C C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral C angles gamma and its derivatives in consecutive thetas and gammas. C ab initio-derived potentials from c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.LOCAL' include 'COMMON.GEO' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.FFIELD' include 'COMMON.CONTROL' include 'COMMON.TORCNSTR' double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), & sinph1ph2(maxdouble,maxdouble) logical lprn /.false./, lprn1 /.false./ etheta=0.0D0 c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) do i=ithet_start,ithet_end C if (i.eq.2) cycle C if (itype(i-1).eq.ntyp1) cycle if (i.le.2) cycle if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 & .or.itype(i).eq.ntyp1) cycle if (iabs(itype(i+1)).eq.20) iblock=2 if (iabs(itype(i+1)).ne.20) iblock=1 dethetai=0.0d0 dephii=0.0d0 dephii1=0.0d0 theti2=0.5d0*theta(i) ityp2=ithetyp((itype(i-1))) do k=1,nntheterm coskt(k)=dcos(k*theti2) sinkt(k)=dsin(k*theti2) enddo if (i.eq.3) then phii=0.0d0 ityp1=nthetyp+1 do k=1,nsingle cosph1(k)=0.0d0 sinph1(k)=0.0d0 enddo else if (i.gt.3 .and. itype(i-3).ne.ntyp1) then #ifdef OSF phii=phi(i) if (phii.ne.phii) phii=150.0 #else phii=phi(i) #endif ityp1=ithetyp((itype(i-2))) do k=1,nsingle cosph1(k)=dcos(k*phii) sinph1(k)=dsin(k*phii) enddo else phii=0.0d0 c ityp1=nthetyp+1 do k=1,nsingle ityp1=ithetyp((itype(i-2))) cosph1(k)=0.0d0 sinph1(k)=0.0d0 enddo endif endif if (i.lt.nres .and. itype(i+1).ne.ntyp1) then #ifdef OSF phii1=phi(i+1) if (phii1.ne.phii1) phii1=150.0 phii1=pinorm(phii1) #else phii1=phi(i+1) #endif ityp3=ithetyp((itype(i))) do k=1,nsingle cosph2(k)=dcos(k*phii1) sinph2(k)=dsin(k*phii1) enddo else phii1=0.0d0 c ityp3=nthetyp+1 ityp3=ithetyp((itype(i))) do k=1,nsingle cosph2(k)=0.0d0 sinph2(k)=0.0d0 enddo endif c write (iout,*) "i",i," ityp1",itype(i-2),ityp1, c & " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3 c call flush(iout) ethetai=aa0thet(ityp1,ityp2,ityp3,iblock) do k=1,ndouble do l=1,k-1 ccl=cosph1(l)*cosph2(k-l) ssl=sinph1(l)*sinph2(k-l) scl=sinph1(l)*cosph2(k-l) csl=cosph1(l)*sinph2(k-l) cosph1ph2(l,k)=ccl-ssl cosph1ph2(k,l)=ccl+ssl sinph1ph2(l,k)=scl+csl sinph1ph2(k,l)=scl-csl enddo enddo if (lprn) then write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 write (iout,*) "coskt and sinkt" do k=1,nntheterm write (iout,*) k,coskt(k),sinkt(k) enddo endif do k=1,ntheterm ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k) dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) & *coskt(k) if (lprn) & write (iout,*) "k",k," & aathet",aathet(k,ityp1,ityp2,ityp3,iblock), & " ethetai",ethetai enddo if (lprn) then write (iout,*) "cosph and sinph" do k=1,nsingle write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) enddo write (iout,*) "cosph1ph2 and sinph2ph2" do k=2,ndouble do l=1,k-1 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), & sinph1ph2(l,k),sinph1ph2(k,l) enddo enddo write(iout,*) "ethetai",ethetai endif do m=1,ntheterm2 do k=1,nsingle aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k) ethetai=ethetai+sinkt(m)*aux dethetai=dethetai+0.5d0*m*aux*coskt(m) dephii=dephii+k*sinkt(m)*( & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)) dephii1=dephii1+k*sinkt(m)*( & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)) if (lprn) & write (iout,*) "m",m," k",k," bbthet", & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai enddo enddo if (lprn) & write(iout,*) "ethetai",ethetai do m=1,ntheterm3 do k=2,ndouble do l=1,k-1 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l) ethetai=ethetai+sinkt(m)*aux dethetai=dethetai+0.5d0*m*coskt(m)*aux dephii=dephii+l*sinkt(m)*( & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) dephii1=dephii1+(k-l)*sinkt(m)*( & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) if (lprn) then write (iout,*) "m",m," k",k," l",l," ffthet", & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock), & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet", & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock), & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock), & " ethetai",ethetai write (iout,*) cosph1ph2(l,k)*sinkt(m), & cosph1ph2(k,l)*sinkt(m), & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) endif enddo enddo enddo 10 continue if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') & i,theta(i)*rad2deg,phii*rad2deg, & phii1*rad2deg,ethetai etheta=etheta+ethetai if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 c gloc(nphi+i-2,icg)=wang*dethetai gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai enddo return end #endif #ifdef CRYST_SC c----------------------------------------------------------------------------- subroutine esc(escloc) C Calculate the local energy of a side chain and its derivatives in the C corresponding virtual-bond valence angles THETA and the spherical angles C ALPHA and OMEGA. implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.VAR' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.FFIELD' double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), & ddersc0(3),ddummy(3),xtemp(3),temp(3) common /sccalc/ time11,time12,time112,theti,it,nlobit delta=0.02d0*pi escloc=0.0D0 C write (iout,*) 'ESC' do i=loc_start,loc_end it=itype(i) if (it.eq.ntyp1) cycle if (it.eq.10) goto 1 nlobit=nlob(iabs(it)) c print *,'i=',i,' it=',it,' nlobit=',nlobit C write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad theti=theta(i+1)-pipol x(1)=dtan(theti) x(2)=alph(i) x(3)=omeg(i) c write (iout,*) "i",i," x",x(1),x(2),x(3) if (x(2).gt.pi-delta) then xtemp(1)=x(1) xtemp(2)=pi-delta xtemp(3)=x(3) call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) xtemp(2)=pi call enesc(xtemp,escloci1,dersc1,ddummy,.false.) call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), & escloci,dersc(2)) call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), & ddersc0(1),dersc(1)) call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), & ddersc0(3),dersc(3)) xtemp(2)=pi-delta call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) xtemp(2)=pi call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, & dersc0(2),esclocbi,dersc02) call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), & dersc12,dersc01) call splinthet(x(2),0.5d0*delta,ss,ssd) dersc0(1)=dersc01 dersc0(2)=dersc02 dersc0(3)=0.0d0 do k=1,3 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) enddo dersc(2)=dersc(2)+ssd*(escloci-esclocbi) write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, & esclocbi,ss,ssd escloci=ss*escloci+(1.0d0-ss)*esclocbi c escloci=esclocbi c write (iout,*) escloci else if (x(2).lt.delta) then xtemp(1)=x(1) xtemp(2)=delta xtemp(3)=x(3) call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) xtemp(2)=0.0d0 call enesc(xtemp,escloci1,dersc1,ddummy,.false.) call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), & escloci,dersc(2)) call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), & ddersc0(1),dersc(1)) call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), & ddersc0(3),dersc(3)) xtemp(2)=delta call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) xtemp(2)=0.0d0 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, & dersc0(2),esclocbi,dersc02) call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), & dersc12,dersc01) dersc0(1)=dersc01 dersc0(2)=dersc02 dersc0(3)=0.0d0 call splinthet(x(2),0.5d0*delta,ss,ssd) do k=1,3 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) enddo dersc(2)=dersc(2)+ssd*(escloci-esclocbi) c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, c & esclocbi,ss,ssd escloci=ss*escloci+(1.0d0-ss)*esclocbi C write (iout,*) 'i=',i, escloci else call enesc(x,escloci,dersc,ddummy,.false.) endif escloc=escloc+escloci C write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc write (iout,'(a6,i5,0pf7.3)') & 'escloc',i,escloci gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ & wscloc*dersc(1) gloc(ialph(i,1),icg)=wscloc*dersc(2) gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) 1 continue enddo return end C--------------------------------------------------------------------------- subroutine enesc(x,escloci,dersc,ddersc,mixed) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.IOUNITS' common /sccalc/ time11,time12,time112,theti,it,nlobit double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) double precision contr(maxlob,-1:1) logical mixed c write (iout,*) 'it=',it,' nlobit=',nlobit escloc_i=0.0D0 do j=1,3 dersc(j)=0.0D0 if (mixed) ddersc(j)=0.0d0 enddo x3=x(3) C Because of periodicity of the dependence of the SC energy in omega we have C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). C To avoid underflows, first compute & store the exponents. do iii=-1,1 x(3)=x3+iii*dwapi do j=1,nlobit do k=1,3 z(k)=x(k)-censc(k,j,it) enddo do k=1,3 Axk=0.0D0 do l=1,3 Axk=Axk+gaussc(l,k,j,it)*z(l) enddo Ax(k,j,iii)=Axk enddo expfac=0.0D0 do k=1,3 expfac=expfac+Ax(k,j,iii)*z(k) enddo contr(j,iii)=expfac enddo ! j enddo ! iii x(3)=x3 C As in the case of ebend, we want to avoid underflows in exponentiation and C subsequent NaNs and INFs in energy calculation. C Find the largest exponent emin=contr(1,-1) do iii=-1,1 do j=1,nlobit if (emin.gt.contr(j,iii)) emin=contr(j,iii) enddo enddo emin=0.5D0*emin cd print *,'it=',it,' emin=',emin C Compute the contribution to SC energy and derivatives do iii=-1,1 do j=1,nlobit expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) cd print *,'j=',j,' expfac=',expfac escloc_i=escloc_i+expfac do k=1,3 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac enddo if (mixed) then do k=1,3,2 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) & +gaussc(k,2,j,it))*expfac enddo endif enddo enddo ! iii dersc(1)=dersc(1)/cos(theti)**2 ddersc(1)=ddersc(1)/cos(theti)**2 ddersc(3)=ddersc(3) escloci=-(dlog(escloc_i)-emin) do j=1,3 dersc(j)=dersc(j)/escloc_i enddo if (mixed) then do j=1,3,2 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) enddo endif return end C------------------------------------------------------------------------------ subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.IOUNITS' common /sccalc/ time11,time12,time112,theti,it,nlobit double precision x(3),z(3),Ax(3,maxlob),dersc(3) double precision contr(maxlob) logical mixed escloc_i=0.0D0 do j=1,3 dersc(j)=0.0D0 enddo do j=1,nlobit do k=1,2 z(k)=x(k)-censc(k,j,it) enddo z(3)=dwapi do k=1,3 Axk=0.0D0 do l=1,3 Axk=Axk+gaussc(l,k,j,it)*z(l) enddo Ax(k,j)=Axk enddo expfac=0.0D0 do k=1,3 expfac=expfac+Ax(k,j)*z(k) enddo contr(j)=expfac enddo ! j C As in the case of ebend, we want to avoid underflows in exponentiation and C subsequent NaNs and INFs in energy calculation. C Find the largest exponent emin=contr(1) do j=1,nlobit if (emin.gt.contr(j)) emin=contr(j) enddo emin=0.5D0*emin C Compute the contribution to SC energy and derivatives dersc12=0.0d0 do j=1,nlobit expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin) escloc_i=escloc_i+expfac do k=1,2 dersc(k)=dersc(k)+Ax(k,j)*expfac enddo if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) & +gaussc(1,2,j,it))*expfac dersc(3)=0.0d0 enddo dersc(1)=dersc(1)/cos(theti)**2 dersc12=dersc12/cos(theti)**2 escloci=-(dlog(escloc_i)-emin) do j=1,2 dersc(j)=dersc(j)/escloc_i enddo if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) return end #else c---------------------------------------------------------------------------------- subroutine esc(escloc) C Calculate the local energy of a side chain and its derivatives in the C corresponding virtual-bond valence angles THETA and the spherical angles C ALPHA and OMEGA derived from AM1 all-atom calculations. C added by Urszula Kozlowska. 07/11/2007 C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.VAR' include 'COMMON.SCROT' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.FFIELD' include 'COMMON.CONTROL' include 'COMMON.VECTORS' double precision x_prime(3),y_prime(3),z_prime(3) & , sumene,dsc_i,dp2_i,x(65), & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, & de_dxx,de_dyy,de_dzz,de_dt double precision s1_t,s1_6_t,s2_t,s2_6_t double precision & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), & dt_dCi(3),dt_dCi1(3) common /sccalc/ time11,time12,time112,theti,it,nlobit delta=0.02d0*pi escloc=0.0D0 do i=loc_start,loc_end if (itype(i).eq.ntyp1) cycle costtab(i+1) =dcos(theta(i+1)) sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) cosfac2=0.5d0/(1.0d0+costtab(i+1)) cosfac=dsqrt(cosfac2) sinfac2=0.5d0/(1.0d0-costtab(i+1)) sinfac=dsqrt(sinfac2) it=iabs(itype(i)) if (it.eq.10) goto 1 c C Compute the axes of tghe local cartesian coordinates system; store in c x_prime, y_prime and z_prime c do j=1,3 x_prime(j) = 0.00 y_prime(j) = 0.00 z_prime(j) = 0.00 enddo C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), C & dc_norm(3,i+nres) do j = 1,3 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac enddo do j = 1,3 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i))) enddo c write (2,*) "i",i c write (2,*) "x_prime",(x_prime(j),j=1,3) c write (2,*) "y_prime",(y_prime(j),j=1,3) c write (2,*) "z_prime",(z_prime(j),j=1,3) c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), c & " xy",scalar(x_prime(1),y_prime(1)), c & " xz",scalar(x_prime(1),z_prime(1)), c & " yy",scalar(y_prime(1),y_prime(1)), c & " yz",scalar(y_prime(1),z_prime(1)), c & " zz",scalar(z_prime(1),z_prime(1)) c C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), C to local coordinate system. Store in xx, yy, zz. c xx=0.0d0 yy=0.0d0 zz=0.0d0 do j = 1,3 xx = xx + x_prime(j)*dc_norm(j,i+nres) yy = yy + y_prime(j)*dc_norm(j,i+nres) zz = zz + z_prime(j)*dc_norm(j,i+nres) enddo xxtab(i)=xx yytab(i)=yy zztab(i)=zz C C Compute the energy of the ith side cbain C c write (2,*) "xx",xx," yy",yy," zz",zz it=iabs(itype(i)) do j = 1,65 x(j) = sc_parmin(j,it) enddo #ifdef CHECK_COORD Cc diagnostics - remove later xx1 = dcos(alph(2)) yy1 = dsin(alph(2))*dcos(omeg(2)) zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2)) write(2,'(3f8.1,3f9.3,1x,3f9.3)') & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, & xx1,yy1,zz1 C," --- ", xx_w,yy_w,zz_w c end diagnostics #endif sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy & + x(10)*yy*zz sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy & + x(20)*yy*zz sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy & +x(40)*xx*yy*zz sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy & +x(60)*xx*yy*zz dsc_i = 0.743d0+x(61) dp2_i = 1.9d0+x(62) dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) s1=(1+x(63))/(0.1d0 + dscp1) s1_6=(1+x(64))/(0.1d0 + dscp1**6) s2=(1+x(65))/(0.1d0 + dscp2) s2_6=(1+x(65))/(0.1d0 + dscp2**6) sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, c & sumene4, c & dscp1,dscp2,sumene c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) escloc = escloc + sumene c write (2,*) "escloc",escloc c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i), c & zz,xx,yy if (.not. calc_grad) goto 1 #ifdef DEBUG C C This section to check the numerical derivatives of the energy of ith side C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert C #define DEBUG in the code to turn it on. C write (2,*) "sumene =",sumene aincr=1.0d-7 xxsave=xx xx=xx+aincr write (2,*) xx,yy,zz sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) de_dxx_num=(sumenep-sumene)/aincr xx=xxsave write (2,*) "xx+ sumene from enesc=",sumenep yysave=yy yy=yy+aincr write (2,*) xx,yy,zz sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) de_dyy_num=(sumenep-sumene)/aincr yy=yysave write (2,*) "yy+ sumene from enesc=",sumenep zzsave=zz zz=zz+aincr write (2,*) xx,yy,zz sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) de_dzz_num=(sumenep-sumene)/aincr zz=zzsave write (2,*) "zz+ sumene from enesc=",sumenep costsave=cost2tab(i+1) sintsave=sint2tab(i+1) cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) de_dt_num=(sumenep-sumene)/aincr write (2,*) " t+ sumene from enesc=",sumenep cost2tab(i+1)=costsave sint2tab(i+1)=sintsave C End of diagnostics section. #endif C C Compute the gradient of esc C pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 pom_dx=dsc_i*dp2_i*cost2tab(i+1) pom_dy=dsc_i*dp2_i*sint2tab(i+1) pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) pom1=(sumene3*sint2tab(i+1)+sumene1) & *(pom_s1/dscp1+pom_s16*dscp1**4) pom2=(sumene4*cost2tab(i+1)+sumene2) & *(pom_s2/dscp2+pom_s26*dscp2**4) sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) & +x(40)*yy*zz sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) & +x(60)*yy*zz de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) & +(pom1+pom2)*pom_dx #ifdef DEBUG write(2,*), "de_dxx = ", de_dxx,de_dxx_num #endif C sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) & +x(40)*xx*zz sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz & +x(59)*zz**2 +x(60)*xx*zz de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) & +(pom1-pom2)*pom_dy #ifdef DEBUG write(2,*), "de_dyy = ", de_dyy,de_dyy_num #endif C de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) #ifdef DEBUG write(2,*), "de_dzz = ", de_dzz,de_dzz_num #endif C de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) & +pom1*pom_dt1+pom2*pom_dt2 #ifdef DEBUG write(2,*), "de_dt = ", de_dt,de_dt_num #endif c C cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) cosfac2xx=cosfac2*xx sinfac2yy=sinfac2*yy do k = 1,3 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* & vbld_inv(i+1) dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* & vbld_inv(i) pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy dZZ_Ci1(k)=0.0d0 dZZ_Ci(k)=0.0d0 do j=1,3 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) enddo dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) c dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) enddo do k=1,3 dXX_Ctab(k,i)=dXX_Ci(k) dXX_C1tab(k,i)=dXX_Ci1(k) dYY_Ctab(k,i)=dYY_Ci(k) dYY_C1tab(k,i)=dYY_Ci1(k) dZZ_Ctab(k,i)=dZZ_Ci(k) dZZ_C1tab(k,i)=dZZ_Ci1(k) dXX_XYZtab(k,i)=dXX_XYZ(k) dYY_XYZtab(k,i)=dYY_XYZ(k) dZZ_XYZtab(k,i)=dZZ_XYZ(k) enddo do k = 1,3 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", c & dyy_ci(k)," dzz_ci",dzz_ci(k) c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", c & dt_dci(k) c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) gsclocx(k,i)= de_dxx*dxx_XYZ(k) & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) enddo c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) C to check gradient call subroutine check_grad 1 continue enddo return end #endif c------------------------------------------------------------------------------ subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) C C This procedure calculates two-body contact function g(rij) and its derivative: C C eps0ij ! x < -1 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 C 0 ! x > 1 C C where x=(rij-r0ij)/delta C C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy C implicit none double precision rij,r0ij,eps0ij,fcont,fprimcont double precision x,x2,x4,delta c delta=0.02D0*r0ij c delta=0.2D0*r0ij x=(rij-r0ij)/delta if (x.lt.-1.0D0) then fcont=eps0ij fprimcont=0.0D0 else if (x.le.1.0D0) then x2=x*x x4=x2*x2 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta else fcont=0.0D0 fprimcont=0.0D0 endif return end c------------------------------------------------------------------------------ subroutine splinthet(theti,delta,ss,ssder) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.VAR' include 'COMMON.GEO' thetup=pi-delta thetlow=delta if (theti.gt.pipol) then call gcont(theti,thetup,1.0d0,delta,ss,ssder) else call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) ssder=-ssder endif return end c------------------------------------------------------------------------------ subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) implicit none double precision x,x0,delta,f0,f1,fprim0,f,fprim double precision ksi,ksi2,ksi3,a1,a2,a3 a1=fprim0*delta/(f1-f0) a2=3.0d0-2.0d0*a1 a3=a1-2.0d0 ksi=(x-x0)/delta ksi2=ksi*ksi ksi3=ksi2*ksi f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) return end c------------------------------------------------------------------------------ subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) implicit none double precision x,x0,delta,f0x,f1x,fprim0x,fx double precision ksi,ksi2,ksi3,a1,a2,a3 ksi=(x-x0)/delta ksi2=ksi*ksi ksi3=ksi2*ksi a1=fprim0x*delta a2=3*(f1x-f0x)-2*fprim0x*delta a3=fprim0x*delta-2*(f1x-f0x) fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 return end C----------------------------------------------------------------------------- #ifdef CRYST_TOR C----------------------------------------------------------------------------- subroutine etor(etors) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.TORSION' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.CHAIN' include 'COMMON.NAMES' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.TORCNSTR' logical lprn C Set lprn=.true. for debugging lprn=.false. c lprn=.true. etors=0.0D0 do i=iphi_start,iphi_end if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 & .or. itype(i).eq.ntyp1) cycle itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) phii=phi(i) gloci=0.0D0 C Proline-Proline pair is a special case... if (itori.eq.3 .and. itori1.eq.3) then if (phii.gt.-dwapi3) then cosphi=dcos(3*phii) fac=1.0D0/(1.0D0-cosphi) etorsi=v1(1,3,3)*fac etorsi=etorsi+etorsi etors=etors+etorsi-v1(1,3,3) gloci=gloci-3*fac*etorsi*dsin(3*phii) endif do j=1,3 v1ij=v1(j+1,itori,itori1) v2ij=v2(j+1,itori,itori1) cosphi=dcos(j*phii) sinphi=dsin(j*phii) etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) enddo else do j=1,nterm_old v1ij=v1(j,itori,itori1) v2ij=v2(j,itori,itori1) cosphi=dcos(j*phii) sinphi=dsin(j*phii) etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) enddo endif if (lprn) & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) enddo return end c------------------------------------------------------------------------------ #else subroutine etor(etors) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.TORSION' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.CHAIN' include 'COMMON.NAMES' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.TORCNSTR' include 'COMMON.WEIGHTS' include 'COMMON.WEIGHTDER' logical lprn C Set lprn=.true. for debugging lprn=.false. c lprn=.true. etors=0.0D0 do iblock=1,2 do i=-ntyp+1,ntyp-1 do j=-ntyp+1,ntyp-1 do k=0,3 do l=0,2*maxterm etor_temp(l,k,j,i,iblock)=0.0d0 enddo enddo enddo enddo enddo do i=iphi_start,iphi_end if (i.le.2) cycle if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215 if (iabs(itype(i)).eq.20) then iblock=2 else iblock=1 endif itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) weitori=weitor(0,itori,itori1,iblock) phii=phi(i) gloci=0.0D0 etori=0.0d0 C Regular cosine and sine terms do j=1,nterm(itori,itori1,iblock) v1ij=v1(j,itori,itori1,iblock) v2ij=v2(j,itori,itori1,iblock) cosphi=dcos(j*phii) sinphi=dsin(j*phii) etori=etori+v1ij*cosphi+v2ij*sinphi etor_temp(j,0,itori,itori1,iblock)= & etor_temp(j,0,itori,itori1,iblock)+cosphi*ww(13) etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)= & etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)+ & sinphi*ww(13) gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) enddo C Lorentz terms C v1 C E = SUM ----------------------------------- - v1 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 C cosphi=dcos(0.5d0*phii) sinphi=dsin(0.5d0*phii) do j=1,nlor(itori,itori1,iblock) vl1ij=vlor1(j,itori,itori1) vl2ij=vlor2(j,itori,itori1) vl3ij=vlor3(j,itori,itori1) pom=vl2ij*cosphi+vl3ij*sinphi pom1=1.0d0/(pom*pom+1.0d0) etori=etori+vl1ij*pom1 pom=-pom*pom1*pom1 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom enddo C Subtract the constant term etors=etors+(etori-v0(itori,itori1,iblock))*weitori etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)+ & (etori-v0(itori,itori1,iblock))*ww(13) if (lprn) then write (iout,'(2(a3,2x,i3,2x),2i3,8f8.3/26x,6f8.3/)') & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, & weitori,v0(itori,itori1,iblock)*weitori, & (v1(j,itori,itori1,iblock)*weitori, & j=1,6),(v2(j,itori,itori1,iblock)*weitori,j=1,6) write (iout,*) "typ",itori,iloctyp(itori),itori1, & iloctyp(itori1)," etor_temp", & etor_temp(0,0,itori,itori1,1) call flush(iout) endif gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) 1215 continue enddo return end c---------------------------------------------------------------------------- subroutine etor_d(etors_d) C 6/23/01 Compute double torsional energy implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.TORSION' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.CHAIN' include 'COMMON.NAMES' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.TORCNSTR' logical lprn C Set lprn=.true. for debugging lprn=.false. c lprn=.true. etors_d=0.0D0 do i=iphi_start,iphi_end-1 if (i.le.3) cycle C if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 C & .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or. & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or. & (itype(i+1).eq.ntyp1)) cycle if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0) & goto 1215 itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) itori2=itortyp(itype(i)) phii=phi(i) phii1=phi(i+1) gloci1=0.0D0 gloci2=0.0D0 iblock=1 if (iabs(itype(i+1)).eq.20) iblock=2 C Regular cosine and sine terms do j=1,ntermd_1(itori,itori1,itori2,iblock) v1cij=v1c(1,j,itori,itori1,itori2,iblock) v1sij=v1s(1,j,itori,itori1,itori2,iblock) v2cij=v1c(2,j,itori,itori1,itori2,iblock) v2sij=v1s(2,j,itori,itori1,itori2,iblock) cosphi1=dcos(j*phii) sinphi1=dsin(j*phii) cosphi2=dcos(j*phii1) sinphi2=dsin(j*phii1) etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ & v2cij*cosphi2+v2sij*sinphi2 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) enddo do k=2,ntermd_2(itori,itori1,itori2,iblock) do l=1,k-1 v1cdij = v2c(k,l,itori,itori1,itori2,iblock) v2cdij = v2c(l,k,itori,itori1,itori2,iblock) v1sdij = v2s(k,l,itori,itori1,itori2,iblock) v2sdij = v2s(l,k,itori,itori1,itori2,iblock) cosphi1p2=dcos(l*phii+(k-l)*phii1) cosphi1m2=dcos(l*phii-(k-l)*phii1) sinphi1p2=dsin(l*phii+(k-l)*phii1) sinphi1m2=dsin(l*phii-(k-l)*phii1) etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ & v1sdij*sinphi1p2+v2sdij*sinphi1m2 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) enddo enddo gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 1215 continue enddo return end #endif c--------------------------------------------------------------------------- C The rigorous attempt to derive energy function subroutine etor_kcc(etors) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.TORSION' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.CHAIN' include 'COMMON.NAMES' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.TORCNSTR' include 'COMMON.CONTROL' include 'COMMON.WEIGHTS' include 'COMMON.WEIGHTDER' double precision c1(0:maxval_kcc),c2(0:maxval_kcc) logical lprn c double precision thybt1(maxtermkcc),thybt2(maxtermkcc) C Set lprn=.true. for debugging lprn=energy_dec c lprn=.true. if (lprn) write (iout,*)"ETOR_KCC" do iblock=1,2 do i=-ntyp+1,ntyp-1 do j=-ntyp+1,ntyp-1 do k=0,3 do l=0,2*maxterm etor_temp(l,k,j,i,iblock)=0.0d0 enddo enddo enddo enddo enddo do i=-ntyp+1,ntyp-1 do j=-ntyp+1,ntyp-1 do k=0,2*maxtor_kcc do l=1,maxval_kcc do ll=1,maxval_kcc etor_temp_kcc(ll,l,k,j,i)=0.0d0 enddo enddo enddo enddo enddo if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode etors=0.0D0 do i=iphi_start,iphi_end C ANY TWO ARE DUMMY ATOMS in row CYCLE c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or. c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or. c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) weitori=weitor(0,itori,itori1,1) if (lprn) write (iout,*) i-2,i-2,itori,itori1,"weitor",weitori phii=phi(i) glocig=0.0D0 glocit1=0.0d0 glocit2=0.0d0 C to avoid multiple devision by 2 c theti22=0.5d0*theta(i) C theta 12 is the theta_1 /2 C theta 22 is theta_2 /2 c theti12=0.5d0*theta(i-1) C and appropriate sinus function sinthet1=dsin(theta(i-1)) sinthet2=dsin(theta(i)) costhet1=dcos(theta(i-1)) costhet2=dcos(theta(i)) C to speed up lets store its mutliplication sint1t2=sinthet2*sinthet1 sint1t2n=1.0d0 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma) C +d_n*sin(n*gamma)) * C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2))) C we have two sum 1) Non-Chebyshev which is with n and gamma nval=nterm_kcc_Tb(itori,itori1) c1(0)=0.0d0 c2(0)=0.0d0 c1(1)=1.0d0 c2(1)=1.0d0 do j=2,nval c1(j)=c1(j-1)*costhet1 c2(j)=c2(j-1)*costhet2 enddo etori=0.0d0 do j=1,nterm_kcc(itori,itori1) cosphi=dcos(j*phii) sinphi=dsin(j*phii) sint1t2n1=sint1t2n sint1t2n=sint1t2n*sint1t2 sumvalc=0.0d0 gradvalct1=0.0d0 gradvalct2=0.0d0 do k=1,nval do l=1,nval sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l) etor_temp_kcc(l,k,j,itori,itori1)= & etor_temp_kcc(l,k,j,itori,itori1)+ & c1(k)*c2(l)*sint1t2n*cosphi*ww(13) gradvalct1=gradvalct1+ & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l) gradvalct2=gradvalct2+ & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1) enddo enddo gradvalct1=-gradvalct1*sinthet1 gradvalct2=-gradvalct2*sinthet2 sumvals=0.0d0 gradvalst1=0.0d0 gradvalst2=0.0d0 do k=1,nval do l=1,nval sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l) etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)= & etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)+ & c1(k)*c2(l)*sint1t2n*sinphi*ww(13) gradvalst1=gradvalst1+ & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l) gradvalst2=gradvalst2+ & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1) enddo enddo gradvalst1=-gradvalst1*sinthet1 gradvalst2=-gradvalst2*sinthet2 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi) etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1) & +sint1t2n*(sumvalc*cosphi+sumvals*sinphi)*ww(13) C glocig is the gradient local i site in gamma glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi) C now gradient over theta_1 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi) & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi) glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi) & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi) enddo ! j etors=etors+etori*weitori C derivative over gamma gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig C derivative over theta1 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1 C now derivative over theta2 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2 if (lprn) & write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1, & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori enddo return end c--------------------------------------------------------------------------------------------- subroutine etor_constr(edihcnstr) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.TORSION' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.CHAIN' include 'COMMON.NAMES' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.TORCNSTR' include 'COMMON.CONTROL' ! 6/20/98 - dihedral angle constraints edihcnstr=0.0d0 c do i=1,ndih_constr c write (iout,*) "idihconstr_start",idihconstr_start, c & " idihconstr_end",idihconstr_end do i=idihconstr_start,idihconstr_end itori=idih_constr(i) phii=phi(itori) difi=pinorm(phii-phi0(i)) if (difi.gt.drange(i)) then difi=difi-drange(i) edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 else if (difi.lt.-drange(i)) then difi=difi+drange(i) edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 else difi=0.0 endif enddo return end c---------------------------------------------------------------------------- C The rigorous attempt to derive energy function subroutine ebend_kcc(etheta) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.TORSION' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.CHAIN' include 'COMMON.NAMES' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.TORCNSTR' include 'COMMON.CONTROL' include 'COMMON.WEIGHTDER' logical lprn double precision thybt1(maxang_kcc) C Set lprn=.true. for debugging lprn=energy_dec c lprn=.true. C print *,"wchodze kcc" if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode do i=0,ntyp do j=1,maxang_kcc ebend_temp_kcc(j,i)=0.0d0 enddo enddo etheta=0.0D0 do i=ithet_start,ithet_end c print *,i,itype(i-1),itype(i),itype(i-2) if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 & .or.itype(i).eq.ntyp1) cycle iti=iabs(itortyp(itype(i-1))) sinthet=dsin(theta(i)) costhet=dcos(theta(i)) do j=1,nbend_kcc_Tb(iti) thybt1(j)=v1bend_chyb(j,iti) ebend_temp_kcc(j,iabs(iti))= & ebend_temp_kcc(j,iabs(iti))+dcos(j*theta(i)) enddo sumth1thyb=v1bend_chyb(0,iti)+ & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet) if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg, & sumth1thyb ihelp=nbend_kcc_Tb(iti)-1 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet) etheta=etheta+sumth1thyb C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0) gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet enddo return end c------------------------------------------------------------------------------------- subroutine etheta_constr(ethetacnstr) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.TORSION' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.CHAIN' include 'COMMON.NAMES' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.TORCNSTR' include 'COMMON.CONTROL' ethetacnstr=0.0d0 C print *,ithetaconstr_start,ithetaconstr_end,"TU" do i=ithetaconstr_start,ithetaconstr_end itheta=itheta_constr(i) thetiii=theta(itheta) difi=pinorm(thetiii-theta_constr0(i)) if (difi.gt.theta_drange(i)) then difi=difi-theta_drange(i) ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) & +for_thet_constr(i)*difi**3 else if (difi.lt.-drange(i)) then difi=difi+drange(i) ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) & +for_thet_constr(i)*difi**3 else difi=0.0 endif if (energy_dec) then write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", & i,itheta,rad2deg*thetiii, & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, & gloc(itheta+nphi-2,icg) endif enddo return end c------------------------------------------------------------------------------ subroutine eback_sc_corr(esccor) c 7/21/2007 Correlations between the backbone-local and side-chain-local c conformational states; temporarily implemented as differences c between UNRES torsional potentials (dependent on three types of c residues) and the torsional potentials dependent on all 20 types c of residues computed from AM1 energy surfaces of terminally-blocked c amino-acid residues. implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.TORSION' include 'COMMON.SCCOR' include 'COMMON.INTERACT' include 'COMMON.DERIV' include 'COMMON.CHAIN' include 'COMMON.NAMES' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.CONTROL' logical lprn C Set lprn=.true. for debugging lprn=.false. c lprn=.true. c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor esccor=0.0D0 do i=itau_start,itau_end if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle esccor_ii=0.0D0 isccori=isccortyp(itype(i-2)) isccori1=isccortyp(itype(i-1)) phii=phi(i) do intertyp=1,3 !intertyp cc Added 09 May 2012 (Adasko) cc Intertyp means interaction type of backbone mainchain correlation: c 1 = SC...Ca...Ca...Ca c 2 = Ca...Ca...Ca...SC c 3 = SC...Ca...Ca...SCi gloci=0.0D0 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. & (itype(i-1).eq.ntyp1))) & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) & .or.(itype(i).eq.ntyp1))) & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. & (itype(i-3).eq.ntyp1)))) cycle if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) & cycle do j=1,nterm_sccor(isccori,isccori1) v1ij=v1sccor(j,intertyp,isccori,isccori1) v2ij=v2sccor(j,intertyp,isccori,isccori1) cosphi=dcos(j*tauangle(intertyp,i)) sinphi=dsin(j*tauangle(intertyp,i)) esccor=esccor+v1ij*cosphi+v2ij*sinphi gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) enddo C write (iout,*)"EBACK_SC_COR",esccor,i c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp, c & nterm_sccor(isccori,isccori1),isccori,isccori1 c gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci if (lprn) & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, & (v1sccor(j,1,itori,itori1),j=1,6) & ,(v2sccor(j,1,itori,itori1),j=1,6) c gsccor_loc(i-3)=gloci enddo !intertyp enddo return end c------------------------------------------------------------------------------ subroutine multibody(ecorr) C This subroutine calculates multi-body contributions to energy following C the idea of Skolnick et al. If side chains I and J make a contact and C at the same time side chains I+1 and J+1 make a contact, an extra C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' double precision gx(3),gx1(3) logical lprn C Set lprn=.true. for debugging lprn=.false. if (lprn) then write (iout,'(a)') 'Contact function values:' do i=nnt,nct-2 write (iout,'(i2,20(1x,i2,f10.5))') & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) enddo endif ecorr=0.0D0 do i=nnt,nct do j=1,3 gradcorr(j,i)=0.0D0 gradxorr(j,i)=0.0D0 enddo enddo do i=nnt,nct-2 DO ISHIFT = 3,4 i1=i+ishift num_conti=num_cont(i) num_conti1=num_cont(i1) do jj=1,num_conti j=jcont(jj,i) do kk=1,num_conti1 j1=jcont(kk,i1) if (j1.eq.j+ishift .or. j1.eq.j-ishift) then cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, cd & ' ishift=',ishift C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. C The system gains extra energy. ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) endif ! j1==j+-ishift enddo ! kk enddo ! jj ENDDO ! ISHIFT enddo ! i return end c------------------------------------------------------------------------------ double precision function esccorr(i,j,k,l,jj,kk) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' double precision gx(3),gx1(3) logical lprn lprn=.false. eij=facont(jj,i) ekl=facont(kk,k) cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl C Calculate the multi-body contribution to energy. C Calculate multi-body contributions to the gradient. cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), cd & k,l,(gacont(m,kk,k),m=1,3) do m=1,3 gx(m) =ekl*gacont(m,jj,i) gx1(m)=eij*gacont(m,kk,k) gradxorr(m,i)=gradxorr(m,i)-gx(m) gradxorr(m,j)=gradxorr(m,j)+gx(m) gradxorr(m,k)=gradxorr(m,k)-gx1(m) gradxorr(m,l)=gradxorr(m,l)+gx1(m) enddo do m=i,j-1 do ll=1,3 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) enddo enddo do m=k,l-1 do ll=1,3 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) enddo enddo esccorr=-eij*ekl return end c------------------------------------------------------------------------------ subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) C This subroutine calculates multi-body contributions to hydrogen-bonding implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' double precision gx(3),gx1(3) logical lprn,ldone C Set lprn=.true. for debugging lprn=.false. if (lprn) then write (iout,'(a)') 'Contact function values:' do i=nnt,nct-2 write (iout,'(2i3,50(1x,i2,f5.2))') & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), & j=1,num_cont_hb(i)) enddo endif ecorr=0.0D0 C Remove the loop below after debugging !!! do i=nnt,nct do j=1,3 gradcorr(j,i)=0.0D0 gradxorr(j,i)=0.0D0 enddo enddo C Calculate the local-electrostatic correlation terms do i=iatel_s,iatel_e+1 i1=i+1 num_conti=num_cont_hb(i) num_conti1=num_cont_hb(i+1) do jj=1,num_conti j=jcont_hb(jj,i) do kk=1,num_conti1 j1=jcont_hb(kk,i1) c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, c & ' jj=',jj,' kk=',kk if (j1.eq.j+1 .or. j1.eq.j-1) then C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. C The system gains extra energy. ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) n_corr=n_corr+1 else if (j1.eq.j) then C Contacts I-J and I-(J+1) occur simultaneously. C The system loses extra energy. c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) endif enddo ! kk do kk=1,num_conti j1=jcont_hb(kk,i) c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, c & ' jj=',jj,' kk=',kk if (j1.eq.j+1) then C Contacts I-J and (I+1)-J occur simultaneously. C The system loses extra energy. c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) endif ! j1==j+1 enddo ! kk enddo ! jj enddo ! i return end c------------------------------------------------------------------------------ subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, & n_corr1) C This subroutine calculates multi-body contributions to hydrogen-bonding implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' #ifdef MPI include "mpif.h" #endif include 'COMMON.FFIELD' include 'COMMON.DERIV' include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.CHAIN' include 'COMMON.CONTROL' include 'COMMON.SHIELD' double precision gx(3),gx1(3) integer num_cont_hb_old(maxres) logical lprn,ldone double precision eello4,eello5,eelo6,eello_turn6 external eello4,eello5,eello6,eello_turn6 C Set lprn=.true. for debugging lprn=.false. eturn6=0.0d0 if (lprn) then write (iout,'(a)') 'Contact function values:' do i=nnt,nct-2 write (iout,'(2i3,50(1x,i2,5f6.3))') & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) enddo endif ecorr=0.0D0 ecorr5=0.0d0 ecorr6=0.0d0 C Remove the loop below after debugging !!! do i=nnt,nct do j=1,3 gradcorr(j,i)=0.0D0 gradxorr(j,i)=0.0D0 enddo enddo C Calculate the dipole-dipole interaction energies if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then do i=iatel_s,iatel_e+1 num_conti=num_cont_hb(i) do jj=1,num_conti j=jcont_hb(jj,i) #ifdef MOMENT call dipole(i,j,jj) #endif enddo enddo endif C Calculate the local-electrostatic correlation terms c write (iout,*) "gradcorr5 in eello5 before loop" c do iii=1,nres c write (iout,'(i5,3f10.5)') c & iii,(gradcorr5(jjj,iii),jjj=1,3) c enddo do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) c write (iout,*) "corr loop i",i i1=i+1 num_conti=num_cont_hb(i) num_conti1=num_cont_hb(i+1) do jj=1,num_conti j=jcont_hb(jj,i) jp=iabs(j) do kk=1,num_conti1 j1=jcont_hb(kk,i1) jp1=iabs(j1) c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, c & ' jj=',jj,' kk=',kk c if (j1.eq.j+1 .or. j1.eq.j-1) then if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 & .or. j.lt.0 .and. j1.gt.0) .and. & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. C The system gains extra energy. n_corr=n_corr+1 sqd1=dsqrt(d_cont(jj,i)) sqd2=dsqrt(d_cont(kk,i1)) sred_geom = sqd1*sqd2 IF (sred_geom.lt.cutoff_corr) THEN call gcont(sred_geom,r0_corr,1.0D0,delt_corr, & ekont,fprimcont) cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, cd & ' jj=',jj,' kk=',kk fac_prim1=0.5d0*sqd2/sqd1*fprimcont fac_prim2=0.5d0*sqd1/sqd2*fprimcont do l=1,3 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) enddo n_corr1=n_corr1+1 cd write (iout,*) 'sred_geom=',sred_geom, cd & ' ekont=',ekont,' fprim=',fprimcont, cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 cd write (iout,*) "g_contij",g_contij cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) call calc_eello(i,jp,i+1,jp1,jj,kk) if (wcorr4.gt.0.0d0) & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) CC & *fac_shield(i)**2*fac_shield(j)**2 if (energy_dec.and.wcorr4.gt.0.0d0) 1 write (iout,'(a6,4i5,0pf7.3)') 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) c write (iout,*) "gradcorr5 before eello5" c do iii=1,nres c write (iout,'(i5,3f10.5)') c & iii,(gradcorr5(jjj,iii),jjj=1,3) c enddo if (wcorr5.gt.0.0d0) & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) c write (iout,*) "gradcorr5 after eello5" c do iii=1,nres c write (iout,'(i5,3f10.5)') c & iii,(gradcorr5(jjj,iii),jjj=1,3) c enddo if (energy_dec.and.wcorr5.gt.0.0d0) 1 write (iout,'(a6,4i5,0pf7.3)') 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 cd write(2,*)'ijkl',i,jp,i+1,jp1 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 & .or. wturn6.eq.0.0d0))then cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, cd & 'ecorr6=',ecorr6 cd write (iout,'(4e15.5)') sred_geom, cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) else if (wturn6.gt.0.0d0 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 eturn6=eturn6+eello_turn6(i,jj,kk) if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) cd write (2,*) 'multibody_eello:eturn6',eturn6 endif ENDIF 1111 continue endif enddo ! kk enddo ! jj enddo ! i do i=1,nres num_cont_hb(i)=num_cont_hb_old(i) enddo c write (iout,*) "gradcorr5 in eello5" c do iii=1,nres c write (iout,'(i5,3f10.5)') c & iii,(gradcorr5(jjj,iii),jjj=1,3) c enddo return end c------------------------------------------------------------------------------ double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.SHIELD' include 'COMMON.CONTROL' double precision gx(3),gx1(3) logical lprn lprn=.false. C print *,"wchodze",fac_shield(i),shield_mode eij=facont_hb(jj,i) ekl=facont_hb(kk,k) ees0pij=ees0p(jj,i) ees0pkl=ees0p(kk,k) ees0mij=ees0m(jj,i) ees0mkl=ees0m(kk,k) ekont=eij*ekl ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) C* C & fac_shield(i)**2*fac_shield(j)**2 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) C Following 4 lines for diagnostics. cd ees0pkl=0.0D0 cd ees0pij=1.0D0 cd ees0mkl=0.0D0 cd ees0mij=1.0D0 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') c & 'Contacts ',i,j, c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, c & 'gradcorr_long' C Calculate the multi-body contribution to energy. C ecorr=ecorr+ekont*ees C Calculate multi-body contributions to the gradient. coeffpees0pij=coeffp*ees0pij coeffmees0mij=coeffm*ees0mij coeffpees0pkl=coeffp*ees0pkl coeffmees0mkl=coeffm*ees0mkl do ll=1,3 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ & coeffmees0mkl*gacontm_hb1(ll,jj,i)) gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ & coeffmees0mkl*gacontm_hb2(ll,jj,i)) cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ & coeffmees0mij*gacontm_hb1(ll,kk,k)) gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ & coeffmees0mij*gacontm_hb2(ll,kk,k)) gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ & coeffmees0mkl*gacontm_hb3(ll,jj,i)) gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ & coeffmees0mij*gacontm_hb3(ll,kk,k)) gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl enddo c write (iout,*) cgrad do m=i+1,j-1 cgrad do ll=1,3 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ cgrad & ees*ekl*gacont_hbr(ll,jj,i)- cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) cgrad enddo cgrad enddo cgrad do m=k+1,l-1 cgrad do ll=1,3 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ cgrad & ees*eij*gacont_hbr(ll,kk,k)- cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) cgrad enddo cgrad enddo c write (iout,*) "ehbcorr",ekont*ees C print *,ekont,ees,i,k ehbcorr=ekont*ees C now gradient over shielding C return if (shield_mode.gt.0) then j=ees0plist(jj,i) l=ees0plist(kk,k) C print *,i,j,fac_shield(i),fac_shield(j), C &fac_shield(k),fac_shield(l) if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then do ilist=1,ishield_list(i) iresshield=shield_list(ilist,i) do m=1,3 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i) C & *2.0 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ & rlocshield & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i) gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &+rlocshield enddo enddo do ilist=1,ishield_list(j) iresshield=shield_list(ilist,j) do m=1,3 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j) C & *2.0 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ & rlocshield & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j) gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) & +rlocshield enddo enddo do ilist=1,ishield_list(k) iresshield=shield_list(ilist,k) do m=1,3 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k) C & *2.0 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ & rlocshield & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k) gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) & +rlocshield enddo enddo do ilist=1,ishield_list(l) iresshield=shield_list(ilist,l) do m=1,3 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l) C & *2.0 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ & rlocshield & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l) gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) & +rlocshield enddo enddo C print *,gshieldx(m,iresshield) do m=1,3 gshieldc_ec(m,i)=gshieldc_ec(m,i)+ & grad_shield(m,i)*ehbcorr/fac_shield(i) gshieldc_ec(m,j)=gshieldc_ec(m,j)+ & grad_shield(m,j)*ehbcorr/fac_shield(j) gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+ & grad_shield(m,i)*ehbcorr/fac_shield(i) gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+ & grad_shield(m,j)*ehbcorr/fac_shield(j) gshieldc_ec(m,k)=gshieldc_ec(m,k)+ & grad_shield(m,k)*ehbcorr/fac_shield(k) gshieldc_ec(m,l)=gshieldc_ec(m,l)+ & grad_shield(m,l)*ehbcorr/fac_shield(l) gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+ & grad_shield(m,k)*ehbcorr/fac_shield(k) gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+ & grad_shield(m,l)*ehbcorr/fac_shield(l) enddo endif endif return end #ifdef MOMENT C--------------------------------------------------------------------------- subroutine dipole(i,j,jj) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.FFIELD' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), & auxmat(2,2) iti1 = itortyp(itype(i+1)) if (j.lt.nres-1) then itj1 = itype2loc(itype(j+1)) else itj1=nloctyp endif do iii=1,2 dipi(iii,1)=Ub2(iii,i) dipderi(iii)=Ub2der(iii,i) dipi(iii,2)=b1(iii,i+1) dipj(iii,1)=Ub2(iii,j) dipderj(iii)=Ub2der(iii,j) dipj(iii,2)=b1(iii,j+1) enddo kkk=0 do iii=1,2 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) do jjj=1,2 kkk=kkk+1 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) enddo enddo do kkk=1,5 do lll=1,3 mmm=0 do iii=1,2 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), & auxvec(1)) do jjj=1,2 mmm=mmm+1 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) enddo enddo enddo enddo call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) do iii=1,2 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) enddo call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) do iii=1,2 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) enddo return end #endif C--------------------------------------------------------------------------- subroutine calc_eello(i,j,k,l,jj,kk) C C This subroutine computes matrices and vectors needed to calculate C the fourth-, fifth-, and sixth-order local-electrostatic terms. C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.FFIELD' double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) logical lprn common /kutas/ lprn cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, cd & ' jj=',jj,' kk=',kk cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) do iii=1,2 do jjj=1,2 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) enddo enddo call transpose2(aa1(1,1),aa1t(1,1)) call transpose2(aa2(1,1),aa2t(1,1)) do kkk=1,5 do lll=1,3 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), & aa1tder(1,1,lll,kkk)) call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), & aa2tder(1,1,lll,kkk)) enddo enddo if (l.eq.j+1) then C parallel orientation of the two CA-CA-CA frames. if (i.gt.1) then iti=itype2loc(itype(i)) else iti=nloctyp endif itk1=itype2loc(itype(k+1)) itj=itype2loc(itype(j)) if (l.lt.nres-1) then itl1=itype2loc(itype(l+1)) else itl1=nloctyp endif C A1 kernel(j+1) A2T cd do iii=1,2 cd write (iout,'(3f10.5,5x,3f10.5)') cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) cd enddo call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) C Following matrices are needed only for 6-th order cumulants IF (wcorr6.gt.0.0d0) THEN call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), & ADtEAderx(1,1,1,1,1,1)) lprn=.false. call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), & ADtEA1derx(1,1,1,1,1,1)) ENDIF C End 6-th order cumulants cd lprn=.false. cd if (lprn) then cd write (2,*) 'In calc_eello6' cd do iii=1,2 cd write (2,*) 'iii=',iii cd do kkk=1,5 cd write (2,*) 'kkk=',kkk cd do jjj=1,2 cd write (2,'(3(2f10.5),5x)') cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) cd enddo cd enddo cd enddo cd endif call transpose2(EUgder(1,1,k),auxmat(1,1)) call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) call transpose2(EUg(1,1,k),auxmat(1,1)) call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) do iii=1,2 do kkk=1,5 do lll=1,3 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), & EAEAderx(1,1,lll,kkk,iii,1)) enddo enddo enddo C A1T kernel(i+1) A2 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) C Following matrices are needed only for 6-th order cumulants IF (wcorr6.gt.0.0d0) THEN call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), & ADtEAderx(1,1,1,1,1,2)) call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), & ADtEA1derx(1,1,1,1,1,2)) ENDIF C End 6-th order cumulants call transpose2(EUgder(1,1,l),auxmat(1,1)) call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) call transpose2(EUg(1,1,l),auxmat(1,1)) call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) do iii=1,2 do kkk=1,5 do lll=1,3 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), & EAEAderx(1,1,lll,kkk,iii,2)) enddo enddo enddo C AEAb1 and AEAb2 C Calculate the vectors and their derivatives in virtual-bond dihedral angles. C They are needed only when the fifth- or the sixth-order cumulants are C indluded. IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN call transpose2(AEA(1,1,1),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1)) call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) call transpose2(AEAderg(1,1,1),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1)) call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1)) call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1)) call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) call transpose2(AEA(1,1,2),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2)) call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) call transpose2(AEAderg(1,1,2),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2)) call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2)) call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2)) call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) C Calculate the Cartesian derivatives of the vectors. do iii=1,2 do kkk=1,5 do lll=1,3 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,i), & AEAb1derx(1,lll,kkk,iii,1,1)) call matvec2(auxmat(1,1),Ub2(1,i), & AEAb2derx(1,lll,kkk,iii,1,1)) call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1), & AEAb1derx(1,lll,kkk,iii,2,1)) call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), & AEAb2derx(1,lll,kkk,iii,2,1)) call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,j), & AEAb1derx(1,lll,kkk,iii,1,2)) call matvec2(auxmat(1,1),Ub2(1,j), & AEAb2derx(1,lll,kkk,iii,1,2)) call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1), & AEAb1derx(1,lll,kkk,iii,2,2)) call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), & AEAb2derx(1,lll,kkk,iii,2,2)) enddo enddo enddo ENDIF C End vectors else C Antiparallel orientation of the two CA-CA-CA frames. if (i.gt.1) then iti=itype2loc(itype(i)) else iti=nloctyp endif itk1=itype2loc(itype(k+1)) itl=itype2loc(itype(l)) itj=itype2loc(itype(j)) if (j.lt.nres-1) then itj1=itype2loc(itype(j+1)) else itj1=nloctyp endif C A2 kernel(j-1)T A1T call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) C Following matrices are needed only for 6-th order cumulants IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. & j.eq.i+4 .and. l.eq.i+3)) THEN call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), & ADtEAderx(1,1,1,1,1,1)) call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), & ADtEA1derx(1,1,1,1,1,1)) ENDIF C End 6-th order cumulants call transpose2(EUgder(1,1,k),auxmat(1,1)) call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) call transpose2(EUg(1,1,k),auxmat(1,1)) call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) do iii=1,2 do kkk=1,5 do lll=1,3 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), & EAEAderx(1,1,lll,kkk,iii,1)) enddo enddo enddo C A2T kernel(i+1)T A1 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) C Following matrices are needed only for 6-th order cumulants IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. & j.eq.i+4 .and. l.eq.i+3)) THEN call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), & ADtEAderx(1,1,1,1,1,2)) call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), & ADtEA1derx(1,1,1,1,1,2)) ENDIF C End 6-th order cumulants call transpose2(EUgder(1,1,j),auxmat(1,1)) call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) call transpose2(EUg(1,1,j),auxmat(1,1)) call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) do iii=1,2 do kkk=1,5 do lll=1,3 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), & EAEAderx(1,1,lll,kkk,iii,2)) enddo enddo enddo C AEAb1 and AEAb2 C Calculate the vectors and their derivatives in virtual-bond dihedral angles. C They are needed only when the fifth- or the sixth-order cumulants are C indluded. IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN call transpose2(AEA(1,1,1),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1)) call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) call transpose2(AEAderg(1,1,1),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1)) call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1)) call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1)) call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) call transpose2(AEA(1,1,2),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2)) call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) call transpose2(AEAderg(1,1,2),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2)) call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2)) call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2)) call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) C Calculate the Cartesian derivatives of the vectors. do iii=1,2 do kkk=1,5 do lll=1,3 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,i), & AEAb1derx(1,lll,kkk,iii,1,1)) call matvec2(auxmat(1,1),Ub2(1,i), & AEAb2derx(1,lll,kkk,iii,1,1)) call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1), & AEAb1derx(1,lll,kkk,iii,2,1)) call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), & AEAb2derx(1,lll,kkk,iii,2,1)) call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) call matvec2(auxmat(1,1),b1(1,l), & AEAb1derx(1,lll,kkk,iii,1,2)) call matvec2(auxmat(1,1),Ub2(1,l), & AEAb2derx(1,lll,kkk,iii,1,2)) call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1), & AEAb1derx(1,lll,kkk,iii,2,2)) call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), & AEAb2derx(1,lll,kkk,iii,2,2)) enddo enddo enddo ENDIF C End vectors endif return end C--------------------------------------------------------------------------- subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, & KK,KKderg,AKA,AKAderg,AKAderx) implicit none integer nderg logical transp double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) integer iii,kkk,lll integer jjj,mmm logical lprn common /kutas/ lprn call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) do iii=1,nderg call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, & AKAderg(1,1,iii)) enddo cd if (lprn) write (2,*) 'In kernel' do kkk=1,5 cd if (lprn) write (2,*) 'kkk=',kkk do lll=1,3 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) cd if (lprn) then cd write (2,*) 'lll=',lll cd write (2,*) 'iii=1' cd do jjj=1,2 cd write (2,'(3(2f10.5),5x)') cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) cd enddo cd endif call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) cd if (lprn) then cd write (2,*) 'lll=',lll cd write (2,*) 'iii=2' cd do jjj=1,2 cd write (2,'(3(2f10.5),5x)') cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) cd enddo cd endif enddo enddo return end C--------------------------------------------------------------------------- double precision function eello4(i,j,k,l,jj,kk) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' double precision pizda(2,2),ggg1(3),ggg2(3) cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then cd eello4=0.0d0 cd return cd endif cd print *,'eello4:',i,j,k,l,jj,kk cd write (2,*) 'i',i,' j',j,' k',k,' l',l cd call checkint4(i,j,k,l,jj,kk,eel4_num) cold eij=facont_hb(jj,i) cold ekl=facont_hb(kk,k) cold ekont=eij*ekl eel4=-EAEA(1,1,1)-EAEA(2,2,1) if (calc_grad) then cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) gcorr_loc(k-1)=gcorr_loc(k-1) & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) if (l.eq.j+1) then gcorr_loc(l-1)=gcorr_loc(l-1) & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) else gcorr_loc(j-1)=gcorr_loc(j-1) & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) endif do iii=1,2 do kkk=1,5 do lll=1,3 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) & -EAEAderx(2,2,lll,kkk,iii,1) cd derx(lll,kkk,iii)=0.0d0 enddo enddo enddo cd gcorr_loc(l-1)=0.0d0 cd gcorr_loc(j-1)=0.0d0 cd gcorr_loc(k-1)=0.0d0 cd eel4=1.0d0 cd write (iout,*)'Contacts have occurred for peptide groups', cd & i,j,' fcont:',eij,' eij',' and ',k,l, cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num if (j.lt.nres-1) then j1=j+1 j2=j-1 else j1=j-1 j2=j-2 endif if (l.lt.nres-1) then l1=l+1 l2=l-1 else l1=l-1 l2=l-2 endif do ll=1,3 cgrad ggg1(ll)=eel4*g_contij(ll,1) cgrad ggg2(ll)=eel4*g_contij(ll,2) glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) cgrad ghalf=0.5d0*ggg1(ll) gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij cgrad ghalf=0.5d0*ggg2(ll) gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl enddo cgrad do m=i+1,j-1 cgrad do ll=1,3 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) cgrad enddo cgrad enddo cgrad do m=k+1,l-1 cgrad do ll=1,3 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) cgrad enddo cgrad enddo cgrad do m=i+2,j2 cgrad do ll=1,3 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) cgrad enddo cgrad enddo cgrad do m=k+2,l2 cgrad do ll=1,3 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) cgrad enddo cgrad enddo cd do iii=1,nres-3 cd write (2,*) iii,gcorr_loc(iii) cd enddo endif ! calc_grad eello4=ekont*eel4 cd write (2,*) 'ekont',ekont cd write (iout,*) 'eello4',ekont*eel4 return end C--------------------------------------------------------------------------- double precision function eello5(i,j,k,l,jj,kk) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) double precision ggg1(3),ggg2(3) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C Parallel chains C C C C o o o o C C /l\ / \ \ / \ / \ / C C / \ / \ \ / \ / \ / C C j| o |l1 | o | o| o | | o |o C C \ |/k\| |/ \| / |/ \| |/ \| C C \i/ \ / \ / / \ / \ C C o k1 o C C (I) (II) (III) (IV) C C C C eello5_1 eello5_2 eello5_3 eello5_4 C C C C Antiparallel chains C C C C o o o o C C /j\ / \ \ / \ / \ / C C / \ / \ \ / \ / \ / C C j1| o |l | o | o| o | | o |o C C \ |/k\| |/ \| / |/ \| |/ \| C C \i/ \ / \ / / \ / \ C C o k1 o C C (I) (II) (III) (IV) C C C C eello5_1 eello5_2 eello5_3 eello5_4 C C C C o denotes a local interaction, vertical lines an electrostatic interaction. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then cd eello5=0.0d0 cd return cd endif cd write (iout,*) cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, cd & ' and',k,l itk=itype2loc(itype(k)) itl=itype2loc(itype(l)) itj=itype2loc(itype(j)) eello5_1=0.0d0 eello5_2=0.0d0 eello5_3=0.0d0 eello5_4=0.0d0 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, cd & eel5_3_num,eel5_4_num) do iii=1,2 do kkk=1,5 do lll=1,3 derx(lll,kkk,iii)=0.0d0 enddo enddo enddo cd eij=facont_hb(jj,i) cd ekl=facont_hb(kk,k) cd ekont=eij*ekl cd write (iout,*)'Contacts have occurred for peptide groups', cd & i,j,' fcont:',eij,' eij',' and ',k,l cd goto 1111 C Contribution from the graph I. cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) call transpose2(EUg(1,1,k),auxmat(1,1)) call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) if (calc_grad) then C Explicit gradient in virtual-dihedral angles. if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) call transpose2(EUgder(1,1,k),auxmat1(1,1)) call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) g_corr5_loc(k-1)=g_corr5_loc(k-1) & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) if (l.eq.j+1) then if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) else if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) endif C Cartesian gradient do iii=1,2 do kkk=1,5 do lll=1,3 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), & pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) derx(lll,kkk,iii)=derx(lll,kkk,iii) & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) enddo enddo enddo endif ! calc_grad c goto 1112 c1111 continue C Contribution from graph II call transpose2(EE(1,1,k),auxmat(1,1)) call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) eello5_2=scalar2(AEAb1(1,2,1),b1(1,k)) & -0.5d0*scalar2(vv(1),Ctobr(1,k)) if (calc_grad) then C Explicit gradient in virtual-dihedral angles. g_corr5_loc(k-1)=g_corr5_loc(k-1) & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) if (l.eq.j+1) then g_corr5_loc(l-1)=g_corr5_loc(l-1) & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k)) & -0.5d0*scalar2(vv(1),Ctobr(1,k))) else g_corr5_loc(j-1)=g_corr5_loc(j-1) & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k)) & -0.5d0*scalar2(vv(1),Ctobr(1,k))) endif C Cartesian gradient do iii=1,2 do kkk=1,5 do lll=1,3 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), & pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) derx(lll,kkk,iii)=derx(lll,kkk,iii) & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k)) & -0.5d0*scalar2(vv(1),Ctobr(1,k)) enddo enddo enddo endif ! calc_grad cd goto 1112 cd1111 continue if (l.eq.j+1) then cd goto 1110 C Parallel orientation C Contribution from graph III call transpose2(EUg(1,1,l),auxmat(1,1)) call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) if (calc_grad) then C Explicit gradient in virtual-dihedral angles. g_corr5_loc(j-1)=g_corr5_loc(j-1) & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) g_corr5_loc(k-1)=g_corr5_loc(k-1) & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) call transpose2(EUgder(1,1,l),auxmat1(1,1)) call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) g_corr5_loc(l-1)=g_corr5_loc(l-1) & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) C Cartesian gradient do iii=1,2 do kkk=1,5 do lll=1,3 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), & pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) derx(lll,kkk,iii)=derx(lll,kkk,iii) & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) enddo enddo enddo cd goto 1112 C Contribution from graph IV cd1110 continue call transpose2(EE(1,1,l),auxmat(1,1)) call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) eello5_4=scalar2(AEAb1(1,2,2),b1(1,l)) & -0.5d0*scalar2(vv(1),Ctobr(1,l)) C Explicit gradient in virtual-dihedral angles. g_corr5_loc(l-1)=g_corr5_loc(l-1) & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) g_corr5_loc(k-1)=g_corr5_loc(k-1) & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l)) & -0.5d0*scalar2(vv(1),Ctobr(1,l))) C Cartesian gradient do iii=1,2 do kkk=1,5 do lll=1,3 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), & pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) derx(lll,kkk,iii)=derx(lll,kkk,iii) & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l)) & -0.5d0*scalar2(vv(1),Ctobr(1,l)) enddo enddo enddo endif ! calc_grad else C Antiparallel orientation C Contribution from graph III c goto 1110 call transpose2(EUg(1,1,j),auxmat(1,1)) call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) if (calc_grad) then C Explicit gradient in virtual-dihedral angles. g_corr5_loc(l-1)=g_corr5_loc(l-1) & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) g_corr5_loc(k-1)=g_corr5_loc(k-1) & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) call transpose2(EUgder(1,1,j),auxmat1(1,1)) call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) g_corr5_loc(j-1)=g_corr5_loc(j-1) & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) C Cartesian gradient do iii=1,2 do kkk=1,5 do lll=1,3 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), & pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) enddo enddo enddo endif ! calc_grad cd goto 1112 C Contribution from graph IV 1110 continue call transpose2(EE(1,1,j),auxmat(1,1)) call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) eello5_4=scalar2(AEAb1(1,2,2),b1(1,j)) & -0.5d0*scalar2(vv(1),Ctobr(1,j)) if (calc_grad) then C Explicit gradient in virtual-dihedral angles. g_corr5_loc(j-1)=g_corr5_loc(j-1) & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) g_corr5_loc(k-1)=g_corr5_loc(k-1) & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j)) & -0.5d0*scalar2(vv(1),Ctobr(1,j))) C Cartesian gradient do iii=1,2 do kkk=1,5 do lll=1,3 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), & pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j)) & -0.5d0*scalar2(vv(1),Ctobr(1,j)) enddo enddo enddo endif ! calc_grad endif 1112 continue eel5=eello5_1+eello5_2+eello5_3+eello5_4 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then cd write (2,*) 'ijkl',i,j,k,l cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 cd endif cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num if (calc_grad) then if (j.lt.nres-1) then j1=j+1 j2=j-1 else j1=j-1 j2=j-2 endif if (l.lt.nres-1) then l1=l+1 l2=l-1 else l1=l-1 l2=l-2 endif cd eij=1.0d0 cd ekl=1.0d0 cd ekont=1.0d0 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont C 2/11/08 AL Gradients over DC's connecting interacting sites will be C summed up outside the subrouine as for the other subroutines C handling long-range interactions. The old code is commented out C with "cgrad" to keep track of changes. do ll=1,3 cgrad ggg1(ll)=eel5*g_contij(ll,1) cgrad ggg2(ll)=eel5*g_contij(ll,2) gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), c & gradcorr5ij, c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) cgrad ghalf=0.5d0*ggg1(ll) cd ghalf=0.0d0 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) cgrad ghalf=0.5d0*ggg2(ll) cd ghalf=0.0d0 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2) gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2) gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl enddo endif ! calc_grad cd goto 1112 cgrad do m=i+1,j-1 cgrad do ll=1,3 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) cgrad enddo cgrad enddo cgrad do m=k+1,l-1 cgrad do ll=1,3 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) cgrad enddo cgrad enddo c1112 continue cgrad do m=i+2,j2 cgrad do ll=1,3 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) cgrad enddo cgrad enddo cgrad do m=k+2,l2 cgrad do ll=1,3 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) cgrad enddo cgrad enddo cd do iii=1,nres-3 cd write (2,*) iii,g_corr5_loc(iii) cd enddo eello5=ekont*eel5 cd write (2,*) 'ekont',ekont cd write (iout,*) 'eello5',ekont*eel5 return end c-------------------------------------------------------------------------- double precision function eello6(i,j,k,l,jj,kk) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.FFIELD' double precision ggg1(3),ggg2(3) cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then cd eello6=0.0d0 cd return cd endif cd write (iout,*) cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, cd & ' and',k,l eello6_1=0.0d0 eello6_2=0.0d0 eello6_3=0.0d0 eello6_4=0.0d0 eello6_5=0.0d0 eello6_6=0.0d0 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) do iii=1,2 do kkk=1,5 do lll=1,3 derx(lll,kkk,iii)=0.0d0 enddo enddo enddo cd eij=facont_hb(jj,i) cd ekl=facont_hb(kk,k) cd ekont=eij*ekl cd eij=1.0d0 cd ekl=1.0d0 cd ekont=1.0d0 if (l.eq.j+1) then eello6_1=eello6_graph1(i,j,k,l,1,.false.) eello6_2=eello6_graph1(j,i,l,k,2,.false.) eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) else eello6_1=eello6_graph1(i,j,k,l,1,.false.) eello6_2=eello6_graph1(l,k,j,i,2,.true.) eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) if (wturn6.eq.0.0d0 .or. j.ne.i+4) then eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) else eello6_5=0.0d0 endif eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) endif C If turn contributions are considered, they will be handled separately. eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num cd goto 1112 if (calc_grad) then if (j.lt.nres-1) then j1=j+1 j2=j-1 else j1=j-1 j2=j-2 endif if (l.lt.nres-1) then l1=l+1 l2=l-1 else l1=l-1 l2=l-2 endif do ll=1,3 cgrad ggg1(ll)=eel6*g_contij(ll,1) cgrad ggg2(ll)=eel6*g_contij(ll,2) cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) cgrad ghalf=0.5d0*ggg1(ll) cd ghalf=0.0d0 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij cgrad ghalf=0.5d0*ggg2(ll) cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) cd ghalf=0.0d0 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl enddo endif ! calc_grad cd goto 1112 cgrad do m=i+1,j-1 cgrad do ll=1,3 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) cgrad enddo cgrad enddo cgrad do m=k+1,l-1 cgrad do ll=1,3 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) cgrad enddo cgrad enddo cgrad1112 continue cgrad do m=i+2,j2 cgrad do ll=1,3 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) cgrad enddo cgrad enddo cgrad do m=k+2,l2 cgrad do ll=1,3 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) cgrad enddo cgrad enddo cd do iii=1,nres-3 cd write (2,*) iii,g_corr6_loc(iii) cd enddo eello6=ekont*eel6 cd write (2,*) 'ekont',ekont cd write (iout,*) 'eello6',ekont*eel6 return end c-------------------------------------------------------------------------- double precision function eello6_graph1(i,j,k,l,imat,swap) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) logical swap logical lprn common /kutas/ lprn CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C Parallel Antiparallel C C C C o o C C /l\ /j\ C C / \ / \ C C /| o | | o |\ C C \ j|/k\| / \ |/k\|l / C C \ / \ / \ / \ / C C o o o o C C i i C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC itk=itype2loc(itype(k)) s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) call transpose2(EUgC(1,1,k),auxmat(1,1)) call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) vv1(1)=pizda1(1,1)-pizda1(2,2) vv1(2)=pizda1(1,2)+pizda1(2,1) s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k) vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k) s5=scalar2(vv(1),Dtobr2(1,i)) cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) if (calc_grad) then if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) & +scalar2(vv(1),Dtobr2der(1,i))) call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) vv1(1)=pizda1(1,1)-pizda1(2,2) vv1(2)=pizda1(1,2)+pizda1(2,1) vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k) vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k) if (l.eq.j+1) then g_corr6_loc(l-1)=g_corr6_loc(l-1) & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) else g_corr6_loc(j-1)=g_corr6_loc(j-1) & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) endif call transpose2(EUgCder(1,1,k),auxmat(1,1)) call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) vv1(1)=pizda1(1,1)-pizda1(2,2) vv1(2)=pizda1(1,2)+pizda1(2,1) if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) do iii=1,2 if (swap) then ind=3-iii else ind=iii endif do kkk=1,5 do lll=1,3 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) call transpose2(EUgC(1,1,k),auxmat(1,1)) call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), & pizda1(1,1)) vv1(1)=pizda1(1,1)-pizda1(2,2) vv1(2)=pizda1(1,2)+pizda1(2,1) s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k) & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k) vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k) & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k) s5=scalar2(vv(1),Dtobr2(1,i)) derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) enddo enddo enddo endif ! calc_grad return end c---------------------------------------------------------------------------- double precision function eello6_graph2(i,j,k,l,jj,kk,swap) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' logical swap double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), & auxvec1(2),auxvec2(2),auxmat1(2,2) logical lprn common /kutas/ lprn CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C Parallel Antiparallel C C C C o o C C \ /l\ /j\ / C C \ / \ / \ / C C o| o | | o |o C C \ j|/k\| \ |/k\|l C C \ / \ \ / \ C C o o C C i i C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l C AL 7/4/01 s1 would occur in the sixth-order moment, C but not in a cluster cumulant #ifdef MOMENT s1=dip(1,jj,i)*dip(1,kk,k) #endif call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) call transpose2(EUg(1,1,k),auxmat(1,1)) call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 #ifdef MOMENT eello6_graph2=-(s1+s2+s3+s4) #else eello6_graph2=-(s2+s3+s4) #endif c eello6_graph2=-s3 C Derivatives in gamma(i-1) if (calc_grad) then if (i.gt.1) then #ifdef MOMENT s1=dipderg(1,jj,i)*dip(1,kk,k) #endif s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) #ifdef MOMENT g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) #else g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) #endif c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 endif C Derivatives in gamma(k-1) #ifdef MOMENT s1=dip(1,jj,i)*dipderg(1,kk,k) #endif call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) call transpose2(EUgder(1,1,k),auxmat1(1,1)) call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) #ifdef MOMENT g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) #else g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) #endif c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 C Derivatives in gamma(j-1) or gamma(l-1) if (j.gt.1) then #ifdef MOMENT s1=dipderg(3,jj,i)*dip(1,kk,k) #endif call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) #ifdef MOMENT if (swap) then g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 else g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 endif #endif g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 endif C Derivatives in gamma(l-1) or gamma(j-1) if (l.gt.1) then #ifdef MOMENT s1=dip(1,jj,i)*dipderg(3,kk,k) #endif call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) #ifdef MOMENT if (swap) then g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 else g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 endif #endif g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 endif C Cartesian derivatives. if (lprn) then write (2,*) 'In eello6_graph2' do iii=1,2 write (2,*) 'iii=',iii do kkk=1,5 write (2,*) 'kkk=',kkk do jjj=1,2 write (2,'(3(2f10.5),5x)') & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) enddo enddo enddo endif do iii=1,2 do kkk=1,5 do lll=1,3 #ifdef MOMENT if (iii.eq.1) then s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) else s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) endif #endif call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), & auxvec(1)) s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), & auxvec(1)) s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) call transpose2(EUg(1,1,k),auxmat(1,1)) call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), & pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(1,2)+pizda(2,1) s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 #ifdef MOMENT derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) #else derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) #endif if (swap) then derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 else derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 endif enddo enddo enddo endif ! calc_grad return end c---------------------------------------------------------------------------- double precision function eello6_graph3(i,j,k,l,jj,kk,swap) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) logical swap CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C Parallel Antiparallel C C C C o o C C /l\ / \ /j\ C C / \ / \ / \ C C /| o |o o| o |\ C C j|/k\| / |/k\|l / C C / \ / / \ / C C / o / o C C i i C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C 4/7/01 AL Component s1 was removed, because it pertains to the respective C energy moment and not to the cluster cumulant. iti=itortyp(itype(i)) if (j.lt.nres-1) then itj1=itype2loc(itype(j+1)) else itj1=nloctyp endif itk=itype2loc(itype(k)) itk1=itype2loc(itype(k+1)) if (l.lt.nres-1) then itl1=itype2loc(itype(l+1)) else itl1=nloctyp endif #ifdef MOMENT s1=dip(4,jj,i)*dip(4,kk,k) #endif call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1)) s2=0.5d0*scalar2(b1(1,k),auxvec(1)) call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1)) s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) call transpose2(EE(1,1,k),auxmat(1,1)) call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, cd & "sum",-(s2+s3+s4) #ifdef MOMENT eello6_graph3=-(s1+s2+s3+s4) #else eello6_graph3=-(s2+s3+s4) #endif c eello6_graph3=-s4 C Derivatives in gamma(k-1) if (calc_grad) then call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1)) s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) C Derivatives in gamma(l-1) call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1)) s2=0.5d0*scalar2(b1(1,k),auxvec(1)) call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) C Cartesian derivatives. do iii=1,2 do kkk=1,5 do lll=1,3 #ifdef MOMENT if (iii.eq.1) then s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) else s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) endif #endif call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1), & auxvec(1)) s2=0.5d0*scalar2(b1(1,k),auxvec(1)) call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1), & auxvec(1)) s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), & pizda(1,1)) vv(1)=pizda(1,1)+pizda(2,2) vv(2)=pizda(2,1)-pizda(1,2) s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) #ifdef MOMENT derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) #else derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) #endif if (swap) then derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 else derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 endif c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 enddo enddo enddo endif ! calc_grad return end c---------------------------------------------------------------------------- double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.FFIELD' double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), & auxvec1(2),auxmat1(2,2) logical swap CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C Parallel Antiparallel C C C C o o C C /l\ / \ /j\ C C / \ / \ / \ C C /| o |o o| o |\ C C \ j|/k\| \ |/k\|l C C \ / \ \ / \ C C o \ o \ C C i i C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C 4/7/01 AL Component s1 was removed, because it pertains to the respective C energy moment and not to the cluster cumulant. cd write (2,*) 'eello_graph4: wturn6',wturn6 iti=itype2loc(itype(i)) itj=itype2loc(itype(j)) if (j.lt.nres-1) then itj1=itype2loc(itype(j+1)) else itj1=nloctyp endif itk=itype2loc(itype(k)) if (k.lt.nres-1) then itk1=itype2loc(itype(k+1)) else itk1=nloctyp endif itl=itype2loc(itype(l)) if (l.lt.nres-1) then itl1=itype2loc(itype(l+1)) else itl1=nloctyp endif cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, cd & ' itl',itl,' itl1',itl1 #ifdef MOMENT if (imat.eq.1) then s1=dip(3,jj,i)*dip(3,kk,k) else s1=dip(2,jj,j)*dip(2,kk,l) endif #endif call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) if (j.eq.l+1) then call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) else call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) endif call transpose2(EUg(1,1,k),auxmat(1,1)) call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(2,1)+pizda(1,2) s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 #ifdef MOMENT eello6_graph4=-(s1+s2+s3+s4) #else eello6_graph4=-(s2+s3+s4) #endif C Derivatives in gamma(i-1) if (calc_grad) then if (i.gt.1) then #ifdef MOMENT if (imat.eq.1) then s1=dipderg(2,jj,i)*dip(3,kk,k) else s1=dipderg(4,jj,j)*dip(2,kk,l) endif #endif s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) if (j.eq.l+1) then call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) else call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) endif s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then cd write (2,*) 'turn6 derivatives' #ifdef MOMENT gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) #else gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) #endif else #ifdef MOMENT g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) #else g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) #endif endif endif C Derivatives in gamma(k-1) #ifdef MOMENT if (imat.eq.1) then s1=dip(3,jj,i)*dipderg(2,kk,k) else s1=dip(2,jj,j)*dipderg(4,kk,l) endif #endif call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) if (j.eq.l+1) then call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) else call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) endif call transpose2(EUgder(1,1,k),auxmat1(1,1)) call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(2,1)+pizda(1,2) s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then #ifdef MOMENT gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) #else gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) #endif else #ifdef MOMENT g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) #else g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) #endif endif C Derivatives in gamma(j-1) or gamma(l-1) if (l.eq.j+1 .and. l.gt.1) then call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(2,1)+pizda(1,2) s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) else if (j.gt.1) then call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(2,1)+pizda(1,2) s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) else g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) endif endif C Cartesian derivatives. do iii=1,2 do kkk=1,5 do lll=1,3 #ifdef MOMENT if (iii.eq.1) then if (imat.eq.1) then s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) else s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) endif else if (imat.eq.1) then s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) else s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) endif endif #endif call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), & auxvec(1)) s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) if (j.eq.l+1) then call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), & b1(1,j+1),auxvec(1)) s3=-0.5d0*scalar2(b1(1,j),auxvec(1)) else call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), & b1(1,l+1),auxvec(1)) s3=-0.5d0*scalar2(b1(1,l),auxvec(1)) endif call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), & pizda(1,1)) vv(1)=pizda(1,1)-pizda(2,2) vv(2)=pizda(2,1)+pizda(1,2) s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) if (swap) then if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then #ifdef MOMENT derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) & -(s1+s2+s4) #else derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) & -(s2+s4) #endif derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 else #ifdef MOMENT derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) #else derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) #endif derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 endif else #ifdef MOMENT derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) #else derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) #endif if (l.eq.j+1) then derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 else derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 endif endif enddo enddo enddo endif ! calc_grad return end c---------------------------------------------------------------------------- double precision function eello_turn6(i,jj,kk) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), & ggg1(3),ggg2(3) double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to C the respective energy moment and not to the cluster cumulant. s1=0.0d0 s8=0.0d0 s13=0.0d0 c eello_turn6=0.0d0 j=i+4 k=i+1 l=i+3 iti=itype2loc(itype(i)) itk=itype2loc(itype(k)) itk1=itype2loc(itype(k+1)) itl=itype2loc(itype(l)) itj=itype2loc(itype(j)) cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj cd write (2,*) 'i',i,' k',k,' j',j,' l',l cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then cd eello6=0.0d0 cd return cd endif cd write (iout,*) cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, cd & ' and',k,l cd call checkint_turn6(i,jj,kk,eel_turn6_num) do iii=1,2 do kkk=1,5 do lll=1,3 derx_turn(lll,kkk,iii)=0.0d0 enddo enddo enddo cd eij=1.0d0 cd ekl=1.0d0 cd ekont=1.0d0 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) cd eello6_5=0.0d0 cd write (2,*) 'eello6_5',eello6_5 #ifdef MOMENT call transpose2(AEA(1,1,1),auxmat(1,1)) call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) ss1=scalar2(Ub2(1,i+2),b1(1,l)) s1 = (auxmat(1,1)+auxmat(2,2))*ss1 #endif call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1)) call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) s2 = scalar2(b1(1,k),vtemp1(1)) #ifdef MOMENT call transpose2(AEA(1,1,2),atemp(1,1)) call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1)) s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1)) #endif call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) s12 = scalar2(Ub2(1,i+2),vtemp3(1)) #ifdef MOMENT call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) ss13 = scalar2(b1(1,k),vtemp4(1)) s13 = (gtemp(1,1)+gtemp(2,2))*ss13 #endif c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 c s1=0.0d0 c s2=0.0d0 c s8=0.0d0 c s12=0.0d0 c s13=0.0d0 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) C Derivatives in gamma(i+2) if (calc_grad) then s1d =0.0d0 s8d =0.0d0 #ifdef MOMENT call transpose2(AEA(1,1,1),auxmatd(1,1)) call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 call transpose2(AEAderg(1,1,2),atempd(1,1)) call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1)) #endif call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) c s1d=0.0d0 c s2d=0.0d0 c s8d=0.0d0 c s12d=0.0d0 c s13d=0.0d0 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) C Derivatives in gamma(i+3) #ifdef MOMENT call transpose2(AEA(1,1,1),auxmatd(1,1)) call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) ss1d=scalar2(Ub2der(1,i+2),b1(1,l)) s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d #endif call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1)) call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) s2d = scalar2(b1(1,k),vtemp1d(1)) #ifdef MOMENT call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1)) s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1)) #endif s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) #ifdef MOMENT call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) s13d = (gtempd(1,1)+gtempd(2,2))*ss13 #endif c s1d=0.0d0 c s2d=0.0d0 c s8d=0.0d0 c s12d=0.0d0 c s13d=0.0d0 #ifdef MOMENT gel_loc_turn6(i+1)=gel_loc_turn6(i+1) & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) #else gel_loc_turn6(i+1)=gel_loc_turn6(i+1) & -0.5d0*ekont*(s2d+s12d) #endif C Derivatives in gamma(i+4) call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) #ifdef MOMENT call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) s13d = (gtempd(1,1)+gtempd(2,2))*ss13 #endif c s1d=0.0d0 c s2d=0.0d0 c s8d=0.0d0 C s12d=0.0d0 c s13d=0.0d0 #ifdef MOMENT gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) #else gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) #endif C Derivatives in gamma(i+5) #ifdef MOMENT call transpose2(AEAderg(1,1,1),auxmatd(1,1)) call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 #endif call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1)) call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) s2d = scalar2(b1(1,k),vtemp1d(1)) #ifdef MOMENT call transpose2(AEA(1,1,2),atempd(1,1)) call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1)) #endif call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) #ifdef MOMENT call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) ss13d = scalar2(b1(1,k),vtemp4d(1)) s13d = (gtemp(1,1)+gtemp(2,2))*ss13d #endif c s1d=0.0d0 c s2d=0.0d0 c s8d=0.0d0 c s12d=0.0d0 c s13d=0.0d0 #ifdef MOMENT gel_loc_turn6(i+3)=gel_loc_turn6(i+3) & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) #else gel_loc_turn6(i+3)=gel_loc_turn6(i+3) & -0.5d0*ekont*(s2d+s12d) #endif C Cartesian derivatives do iii=1,2 do kkk=1,5 do lll=1,3 #ifdef MOMENT call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 #endif call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1)) call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), & vtemp1d(1)) s2d = scalar2(b1(1,k),vtemp1d(1)) #ifdef MOMENT call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) s8d = -(atempd(1,1)+atempd(2,2))* & scalar2(cc(1,1,l),vtemp2(1)) #endif call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), & auxmatd(1,1)) call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) c s1d=0.0d0 c s2d=0.0d0 c s8d=0.0d0 c s12d=0.0d0 c s13d=0.0d0 #ifdef MOMENT derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) & - 0.5d0*(s1d+s2d) #else derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) & - 0.5d0*s2d #endif #ifdef MOMENT derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) & - 0.5d0*(s8d+s12d) #else derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) & - 0.5d0*s12d #endif enddo enddo enddo #ifdef MOMENT do kkk=1,5 do lll=1,3 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), & achuj_tempd(1,1)) call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) s13d=(gtempd(1,1)+gtempd(2,2))*ss13 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), & vtemp4d(1)) ss13d = scalar2(b1(1,k),vtemp4d(1)) s13d = (gtemp(1,1)+gtemp(2,2))*ss13d derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d enddo enddo #endif cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', cd & 16*eel_turn6_num cd goto 1112 if (j.lt.nres-1) then j1=j+1 j2=j-1 else j1=j-1 j2=j-2 endif if (l.lt.nres-1) then l1=l+1 l2=l-1 else l1=l-1 l2=l-2 endif do ll=1,3 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1) cgrad ggg2(ll)=eel_turn6*g_contij(ll,2) cgrad ghalf=0.5d0*ggg1(ll) cd ghalf=0.0d0 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf & +ekont*derx_turn(ll,2,1) gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf & +ekont*derx_turn(ll,4,1) gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij cgrad ghalf=0.5d0*ggg2(ll) cd ghalf=0.0d0 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf & +ekont*derx_turn(ll,2,2) gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf & +ekont*derx_turn(ll,4,2) gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl enddo cd goto 1112 cgrad do m=i+1,j-1 cgrad do ll=1,3 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) cgrad enddo cgrad enddo cgrad do m=k+1,l-1 cgrad do ll=1,3 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) cgrad enddo cgrad enddo cgrad1112 continue cgrad do m=i+2,j2 cgrad do ll=1,3 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) cgrad enddo cgrad enddo cgrad do m=k+2,l2 cgrad do ll=1,3 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) cgrad enddo cgrad enddo cd do iii=1,nres-3 cd write (2,*) iii,g_corr6_loc(iii) cd enddo endif ! calc_grad eello_turn6=ekont*eel_turn6 cd write (2,*) 'ekont',ekont cd write (2,*) 'eel_turn6',ekont*eel_turn6 return end crc------------------------------------------------- CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC subroutine Eliptransfer(eliptran) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' include 'COMMON.CONTROL' include 'COMMON.SPLITELE' include 'COMMON.SBRIDGE' C this is done by Adasko C print *,"wchodze" C structure of box: C water C--bordliptop-- buffore starts C--bufliptop--- here true lipid starts C lipid C--buflipbot--- lipid ends buffore starts C--bordlipbot--buffore ends eliptran=0.0 do i=1,nres C do i=1,1 if (itype(i).eq.ntyp1) cycle positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize)) if (positi.le.0) positi=positi+boxzsize C print *,i C first for peptide groups c for each residue check if it is in lipid or lipid water border area if ((positi.gt.bordlipbot) &.and.(positi.lt.bordliptop)) then C the energy transfer exist if (positi.lt.buflipbot) then C what fraction I am in fracinbuf=1.0d0- & ((positi-bordlipbot)/lipbufthick) C lipbufthick is thickenes of lipid buffore sslip=sscalelip(fracinbuf) ssgradlip=-sscagradlip(fracinbuf)/lipbufthick eliptran=eliptran+sslip*pepliptran gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran elseif (positi.gt.bufliptop) then fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) sslip=sscalelip(fracinbuf) ssgradlip=sscagradlip(fracinbuf)/lipbufthick eliptran=eliptran+sslip*pepliptran gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran C print *, "doing sscalefor top part" C print *,i,sslip,fracinbuf,ssgradlip else eliptran=eliptran+pepliptran C print *,"I am in true lipid" endif C else C eliptran=elpitran+0.0 ! I am in water endif enddo C print *, "nic nie bylo w lipidzie?" C now multiply all by the peptide group transfer factor C eliptran=eliptran*pepliptran C now the same for side chains CV do i=1,1 do i=1,nres if (itype(i).eq.ntyp1) cycle positi=(mod(c(3,i+nres),boxzsize)) if (positi.le.0) positi=positi+boxzsize C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop c for each residue check if it is in lipid or lipid water border area C respos=mod(c(3,i+nres),boxzsize) C print *,positi,bordlipbot,buflipbot if ((positi.gt.bordlipbot) & .and.(positi.lt.bordliptop)) then C the energy transfer exist if (positi.lt.buflipbot) then fracinbuf=1.0d0- & ((positi-bordlipbot)/lipbufthick) C lipbufthick is thickenes of lipid buffore sslip=sscalelip(fracinbuf) ssgradlip=-sscagradlip(fracinbuf)/lipbufthick eliptran=eliptran+sslip*liptranene(itype(i)) gliptranx(3,i)=gliptranx(3,i) &+ssgradlip*liptranene(itype(i)) gliptranc(3,i-1)= gliptranc(3,i-1) &+ssgradlip*liptranene(itype(i)) C print *,"doing sccale for lower part" elseif (positi.gt.bufliptop) then fracinbuf=1.0d0- &((bordliptop-positi)/lipbufthick) sslip=sscalelip(fracinbuf) ssgradlip=sscagradlip(fracinbuf)/lipbufthick eliptran=eliptran+sslip*liptranene(itype(i)) gliptranx(3,i)=gliptranx(3,i) &+ssgradlip*liptranene(itype(i)) gliptranc(3,i-1)= gliptranc(3,i-1) &+ssgradlip*liptranene(itype(i)) C print *, "doing sscalefor top part",sslip,fracinbuf else eliptran=eliptran+liptranene(itype(i)) C print *,"I am in true lipid" endif endif ! if in lipid or buffor C else C eliptran=elpitran+0.0 ! I am in water enddo return end CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE MATVEC2(A1,V1,V2) implicit real*8 (a-h,o-z) include 'DIMENSIONS' DIMENSION A1(2,2),V1(2),V2(2) c DO 1 I=1,2 c VI=0.0 c DO 3 K=1,2 c 3 VI=VI+A1(I,K)*V1(K) c Vaux(I)=VI c 1 CONTINUE vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) v2(1)=vaux1 v2(2)=vaux2 END C--------------------------------------- SUBROUTINE MATMAT2(A1,A2,A3) implicit real*8 (a-h,o-z) include 'DIMENSIONS' DIMENSION A1(2,2),A2(2,2),A3(2,2) c DIMENSION AI3(2,2) c DO J=1,2 c A3IJ=0.0 c DO K=1,2 c A3IJ=A3IJ+A1(I,K)*A2(K,J) c enddo c A3(I,J)=A3IJ c enddo c enddo ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) A3(1,1)=AI3_11 A3(2,1)=AI3_21 A3(1,2)=AI3_12 A3(2,2)=AI3_22 END c------------------------------------------------------------------------- double precision function scalar2(u,v) implicit none double precision u(2),v(2) double precision sc integer i scalar2=u(1)*v(1)+u(2)*v(2) return end C----------------------------------------------------------------------------- subroutine transpose2(a,at) implicit none double precision a(2,2),at(2,2) at(1,1)=a(1,1) at(1,2)=a(2,1) at(2,1)=a(1,2) at(2,2)=a(2,2) return end c-------------------------------------------------------------------------- subroutine transpose(n,a,at) implicit none integer n,i,j double precision a(n,n),at(n,n) do i=1,n do j=1,n at(j,i)=a(i,j) enddo enddo return end C--------------------------------------------------------------------------- subroutine prodmat3(a1,a2,kk,transp,prod) implicit none integer i,j double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) logical transp crc double precision auxmat(2,2),prod_(2,2) if (transp) then crc call transpose2(kk(1,1),auxmat(1,1)) crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) else crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) endif c call transpose2(a2(1,1),a2t(1,1)) crc print *,transp crc print *,((prod_(i,j),i=1,2),j=1,2) crc print *,((prod(i,j),i=1,2),j=1,2) return end C----------------------------------------------------------------------------- double precision function scalar(u,v) implicit none double precision u(3),v(3) double precision sc integer i sc=0.0d0 do i=1,3 sc=sc+u(i)*v(i) enddo scalar=sc return end C----------------------------------------------------------------------- double precision function sscale(r) double precision r,gamm include "COMMON.SPLITELE" if(r.lt.r_cut-rlamb) then sscale=1.0d0 else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then gamm=(r-(r_cut-rlamb))/rlamb sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) else sscale=0d0 endif return end C----------------------------------------------------------------------- C----------------------------------------------------------------------- double precision function sscagrad(r) double precision r,gamm include "COMMON.SPLITELE" if(r.lt.r_cut-rlamb) then sscagrad=0.0d0 else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then gamm=(r-(r_cut-rlamb))/rlamb sscagrad=gamm*(6*gamm-6.0d0)/rlamb else sscagrad=0.0d0 endif return end C----------------------------------------------------------------------- C----------------------------------------------------------------------- double precision function sscalelip(r) double precision r,gamm include "COMMON.SPLITELE" C if(r.lt.r_cut-rlamb) then C sscale=1.0d0 C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then C gamm=(r-(r_cut-rlamb))/rlamb sscalelip=1.0d0+r*r*(2*r-3.0d0) C else C sscale=0d0 C endif return end C----------------------------------------------------------------------- double precision function sscagradlip(r) double precision r,gamm include "COMMON.SPLITELE" C if(r.lt.r_cut-rlamb) then C sscagrad=0.0d0 C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then C gamm=(r-(r_cut-rlamb))/rlamb sscagradlip=r*(6*r-6.0d0) C else C sscagrad=0.0d0 C endif return end C----------------------------------------------------------------------- subroutine set_shield_fac implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.IOUNITS' include 'COMMON.SHIELD' include 'COMMON.INTERACT' C this is the squar root 77 devided by 81 the epislion in lipid (in protein) double precision div77_81/0.974996043d0/, &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) C the vector between center of side_chain and peptide group double precision pep_side(3),long,side_calf(3), &pept_group(3),costhet_grad(3),cosphi_grad_long(3), &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) C the line belowe needs to be changed for FGPROC>1 do i=1,nres-1 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle ishield_list(i)=0 Cif there two consequtive dummy atoms there is no peptide group between them C the line below has to be changed for FGPROC>1 VolumeTotal=0.0 do k=1,nres if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle dist_pep_side=0.0 dist_side_calf=0.0 do j=1,3 C first lets set vector conecting the ithe side-chain with kth side-chain pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 C pep_side(j)=2.0d0 C and vector conecting the side-chain with its proper calfa side_calf(j)=c(j,k+nres)-c(j,k) C side_calf(j)=2.0d0 pept_group(j)=c(j,i)-c(j,i+1) C lets have their lenght dist_pep_side=pep_side(j)**2+dist_pep_side dist_side_calf=dist_side_calf+side_calf(j)**2 dist_pept_group=dist_pept_group+pept_group(j)**2 enddo dist_pep_side=dsqrt(dist_pep_side) dist_pept_group=dsqrt(dist_pept_group) dist_side_calf=dsqrt(dist_side_calf) do j=1,3 pep_side_norm(j)=pep_side(j)/dist_pep_side side_calf_norm(j)=dist_side_calf enddo C now sscale fraction sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield C print *,buff_shield,"buff" C now sscale if (sh_frac_dist.le.0.0) cycle C If we reach here it means that this side chain reaches the shielding sphere C Lets add him to the list for gradient ishield_list(i)=ishield_list(i)+1 C ishield_list is a list of non 0 side-chain that contribute to factor gradient C this list is essential otherwise problem would be O3 shield_list(ishield_list(i),i)=k C Lets have the sscale value if (sh_frac_dist.gt.1.0) then scale_fac_dist=1.0d0 do j=1,3 sh_frac_dist_grad(j)=0.0d0 enddo else scale_fac_dist=-sh_frac_dist*sh_frac_dist & *(2.0*sh_frac_dist-3.0d0) fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2) & /dist_pep_side/buff_shield*0.5 C remember for the final gradient multiply sh_frac_dist_grad(j) C for side_chain by factor -2 ! do j=1,3 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) C print *,"jestem",scale_fac_dist,fac_help_scale, C & sh_frac_dist_grad(j) enddo endif C if ((i.eq.3).and.(k.eq.2)) then C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist C & ,"TU" C endif C this is what is now we have the distance scaling now volume... short=short_r_sidechain(itype(k)) long=long_r_sidechain(itype(k)) costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2) C now costhet_grad C costhet=0.0d0 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4 C costhet_fac=0.0d0 do j=1,3 costhet_grad(j)=costhet_fac*pep_side(j) enddo C remember for the final gradient multiply costhet_grad(j) C for side_chain by factor -2 ! C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 C pep_side0pept_group is vector multiplication pep_side0pept_group=0.0 do j=1,3 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) enddo cosalfa=(pep_side0pept_group/ & (dist_pep_side*dist_side_calf)) fac_alfa_sin=1.0-cosalfa**2 fac_alfa_sin=dsqrt(fac_alfa_sin) rkprim=fac_alfa_sin*(long-short)+short C now costhet_grad cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2) cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4 do j=1,3 cosphi_grad_long(j)=cosphi_fac*pep_side(j) &+cosphi**3*0.5/dist_pep_side**2*(-rkprim) &*(long-short)/fac_alfa_sin*cosalfa/ &((dist_pep_side*dist_side_calf))* &((side_calf(j))-cosalfa* &((pep_side(j)/dist_pep_side)*dist_side_calf)) cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim) &*(long-short)/fac_alfa_sin*cosalfa &/((dist_pep_side*dist_side_calf))* &(pep_side(j)- &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) enddo VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi) & /VSolvSphere_div & *wshield C now the gradient... C grad_shield is gradient of Calfa for peptide groups C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist, C & costhet,cosphi C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group, C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k) do j=1,3 grad_shield(j,i)=grad_shield(j,i) C gradient po skalowaniu & +(sh_frac_dist_grad(j) C gradient po costhet &-scale_fac_dist*costhet_grad(j)/(1.0-costhet) &-scale_fac_dist*(cosphi_grad_long(j)) &/(1.0-cosphi) )*div77_81 &*VofOverlap C grad_shield_side is Cbeta sidechain gradient grad_shield_side(j,ishield_list(i),i)= & (sh_frac_dist_grad(j)*-2.0d0 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet) & +scale_fac_dist*(cosphi_grad_long(j)) & *2.0d0/(1.0-cosphi)) & *div77_81*VofOverlap grad_shield_loc(j,ishield_list(i),i)= & scale_fac_dist*cosphi_grad_loc(j) & *2.0d0/(1.0-cosphi) & *div77_81*VofOverlap enddo VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist enddo fac_shield(i)=VolumeTotal*div77_81+div4_81 C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) enddo return end C-------------------------------------------------------------------------- C first for shielding is setting of function of side-chains subroutine set_shield_fac2 implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.IOUNITS' include 'COMMON.SHIELD' include 'COMMON.INTERACT' C this is the squar root 77 devided by 81 the epislion in lipid (in protein) double precision div77_81/0.974996043d0/, &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) C the vector between center of side_chain and peptide group double precision pep_side(3),long,side_calf(3), &pept_group(3),costhet_grad(3),cosphi_grad_long(3), &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) C the line belowe needs to be changed for FGPROC>1 do i=1,nres-1 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle ishield_list(i)=0 Cif there two consequtive dummy atoms there is no peptide group between them C the line below has to be changed for FGPROC>1 VolumeTotal=0.0 do k=1,nres if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle dist_pep_side=0.0 dist_side_calf=0.0 do j=1,3 C first lets set vector conecting the ithe side-chain with kth side-chain pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 C pep_side(j)=2.0d0 C and vector conecting the side-chain with its proper calfa side_calf(j)=c(j,k+nres)-c(j,k) C side_calf(j)=2.0d0 pept_group(j)=c(j,i)-c(j,i+1) C lets have their lenght dist_pep_side=pep_side(j)**2+dist_pep_side dist_side_calf=dist_side_calf+side_calf(j)**2 dist_pept_group=dist_pept_group+pept_group(j)**2 enddo dist_pep_side=dsqrt(dist_pep_side) dist_pept_group=dsqrt(dist_pept_group) dist_side_calf=dsqrt(dist_side_calf) do j=1,3 pep_side_norm(j)=pep_side(j)/dist_pep_side side_calf_norm(j)=dist_side_calf enddo C now sscale fraction sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield C print *,buff_shield,"buff" C now sscale if (sh_frac_dist.le.0.0) cycle C If we reach here it means that this side chain reaches the shielding sphere C Lets add him to the list for gradient ishield_list(i)=ishield_list(i)+1 C ishield_list is a list of non 0 side-chain that contribute to factor gradient C this list is essential otherwise problem would be O3 shield_list(ishield_list(i),i)=k C Lets have the sscale value if (sh_frac_dist.gt.1.0) then scale_fac_dist=1.0d0 do j=1,3 sh_frac_dist_grad(j)=0.0d0 enddo else scale_fac_dist=-sh_frac_dist*sh_frac_dist & *(2.0d0*sh_frac_dist-3.0d0) fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) & /dist_pep_side/buff_shield*0.5d0 C remember for the final gradient multiply sh_frac_dist_grad(j) C for side_chain by factor -2 ! do j=1,3 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) C sh_frac_dist_grad(j)=0.0d0 C scale_fac_dist=1.0d0 C print *,"jestem",scale_fac_dist,fac_help_scale, C & sh_frac_dist_grad(j) enddo endif C this is what is now we have the distance scaling now volume... short=short_r_sidechain(itype(k)) long=long_r_sidechain(itype(k)) costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2) sinthet=short/dist_pep_side*costhet C now costhet_grad C costhet=0.6d0 C sinthet=0.8 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet C & -short/dist_pep_side**2/costhet) C costhet_fac=0.0d0 do j=1,3 costhet_grad(j)=costhet_fac*pep_side(j) enddo C remember for the final gradient multiply costhet_grad(j) C for side_chain by factor -2 ! C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 C pep_side0pept_group is vector multiplication pep_side0pept_group=0.0d0 do j=1,3 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) enddo cosalfa=(pep_side0pept_group/ & (dist_pep_side*dist_side_calf)) fac_alfa_sin=1.0d0-cosalfa**2 fac_alfa_sin=dsqrt(fac_alfa_sin) rkprim=fac_alfa_sin*(long-short)+short C rkprim=short C now costhet_grad cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2) C cosphi=0.6 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ & dist_pep_side**2) C sinphi=0.8 do j=1,3 cosphi_grad_long(j)=cosphi_fac*pep_side(j) &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &*(long-short)/fac_alfa_sin*cosalfa/ &((dist_pep_side*dist_side_calf))* &((side_calf(j))-cosalfa* &((pep_side(j)/dist_pep_side)*dist_side_calf)) C cosphi_grad_long(j)=0.0d0 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &*(long-short)/fac_alfa_sin*cosalfa &/((dist_pep_side*dist_side_calf))* &(pep_side(j)- &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) C cosphi_grad_loc(j)=0.0d0 enddo C print *,sinphi,sinthet VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) & /VSolvSphere_div C & *wshield C now the gradient... do j=1,3 grad_shield(j,i)=grad_shield(j,i) C gradient po skalowaniu & +(sh_frac_dist_grad(j)*VofOverlap C gradient po costhet & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( & sinphi/sinthet*costhet*costhet_grad(j) & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) & )*wshield C grad_shield_side is Cbeta sidechain gradient grad_shield_side(j,ishield_list(i),i)= & (sh_frac_dist_grad(j)*-2.0d0 & *VofOverlap & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( & sinphi/sinthet*costhet*costhet_grad(j) & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) & )*wshield grad_shield_loc(j,ishield_list(i),i)= & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*( & sinthet/sinphi*cosphi*cosphi_grad_loc(j) & )) & *wshield enddo VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist enddo fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield) C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) C write(2,*) "TU",rpp(1,1),short,long,buff_shield enddo return end C-------------------------------------------------------------------------- double precision function tschebyshev(m,n,x,y) implicit none include "DIMENSIONS" integer i,m,n double precision x(n),y,yy(0:maxvar),aux c Tschebyshev polynomial. Note that the first term is omitted c m=0: the constant term is included c m=1: the constant term is not included yy(0)=1.0d0 yy(1)=y do i=2,n yy(i)=2*yy(1)*yy(i-1)-yy(i-2) enddo aux=0.0d0 do i=m,n aux=aux+x(i)*yy(i) enddo tschebyshev=aux return end C-------------------------------------------------------------------------- double precision function gradtschebyshev(m,n,x,y) implicit none include "DIMENSIONS" integer i,m,n double precision x(n+1),y,yy(0:maxvar),aux c Tschebyshev polynomial. Note that the first term is omitted c m=0: the constant term is included c m=1: the constant term is not included yy(0)=1.0d0 yy(1)=2.0d0*y do i=2,n yy(i)=2*y*yy(i-1)-yy(i-2) enddo aux=0.0d0 do i=m,n aux=aux+x(i+1)*yy(i)*(i+1) C print *, x(i+1),yy(i),i enddo gradtschebyshev=aux return end