subroutine etotal(energia,fact) 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) #ifdef MPL include 'COMMON.INFO' external d_vadd integer ready #endif include 'COMMON.FFIELD' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.SBRIDGE' include 'COMMON.CHAIN' double precision fact(6) cd write(iout, '(a,i2)')'Calling etotal ipot=',ipot 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,evdw_t) cd print '(a)','Exit ELJ' goto 107 C Lennard-Jones-Kihara potential (shifted). 102 call eljk(evdw,evdw_t) goto 107 C Berne-Pechukas potential (dilated LJ, angular dependence). 103 call ebp(evdw,evdw_t) goto 107 C Gay-Berne potential (shifted LJ, angular dependence). 104 call egb(evdw,evdw_t) goto 107 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). 105 call egbv(evdw,evdw_t) 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 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) C 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 call ebend(ebe) cd print *,'Bend energy finished.' C C Calculate the SC local energy. C call esc(escloc) cd print *,'SCLOC energy finished.' C C Calculate the virtual-bond torsional energy. C cd print *,'nterm=',nterm call etor(etors,edihcnstr,fact(1)) C C 6/23/01 Calculate double-torsional energy C call etor_d(etors_d,fact(2)) C C 21/5/07 Calculate local sicdechain correlation energy C call eback_sc_corr(esccor) 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 print *,"calling multibody_eello" call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) c write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1 c print *,ecorr,ecorr5,ecorr6,eturn6 endif if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) endif c write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t #ifdef SPLITELE etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees & +wvdwpp*evdw1 & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d & +wbond*estr+wsccor*fact(1)*esccor #else etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2 & +welec*fact(1)*(ees+evdw1) & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d & +wbond*estr+wsccor*fact(1)*esccor #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(18)=estr energia(19)=esccor energia(20)=edihcnstr energia(21)=evdw_t 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 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 gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ & welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+ & wbond*gradb(j,i)+ & wstrain*ghpbc(j,i)+ & wcorr*fact(3)*gradcorr(j,i)+ & wel_loc*fact(2)*gel_loc(j,i)+ & wturn3*fact(2)*gcorr3_turn(j,i)+ & wturn4*fact(3)*gcorr4_turn(j,i)+ & wcorr5*fact(4)*gradcorr5(j,i)+ & wcorr6*fact(5)*gradcorr6(j,i)+ & wturn6*fact(5)*gcorr6_turn(j,i)+ & wsccor*fact(2)*gsccorc(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*fact(2)*gsccorx(j,i) enddo #else do i=1,nct do j=1,3 gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ & wbond*gradb(j,i)+ & wcorr*fact(3)*gradcorr(j,i)+ & wel_loc*fact(2)*gel_loc(j,i)+ & wturn3*fact(2)*gcorr3_turn(j,i)+ & wturn4*fact(3)*gcorr4_turn(j,i)+ & wcorr5*fact(4)*gradcorr5(j,i)+ & wcorr6*fact(5)*gradcorr6(j,i)+ & wturn6*fact(5)*gcorr6_turn(j,i)+ & wsccor*fact(2)*gsccorc(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*fact(1)*gsccorx(j,i) enddo #endif enddo do i=1,nres-3 gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i) & +wcorr5*fact(4)*g_corr5_loc(i) & +wcorr6*fact(5)*g_corr6_loc(i) & +wturn4*fact(3)*gel_loc_turn4(i) & +wturn3*fact(2)*gel_loc_turn3(i) & +wturn6*fact(5)*gel_loc_turn6(i) & +wel_loc*fact(2)*gel_loc_loc(i) & +wsccor*fact(1)*gsccor_loc(i) enddo endif return end C------------------------------------------------------------------------ subroutine enerprint(energia,fact) 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),fact(6) etot=energia(0) evdw=energia(1)+fact(6)*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(18) #ifdef SPLITELE write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1, & wvdwpp, & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), & etors_d,wtor_d*fact(2),ehpb,wstrain, & ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), & eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2), & eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5), & esccor,wsccor*fact(1),edihcnstr,ebr*nss,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)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & 'ETOT= ',1pE16.6,' (total)') #else write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond, & ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2, & ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4), & ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2), & eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3), & eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor, & edihcnstr,ebr*nss,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)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & 'ETOT= ',1pE16.6,' (total)') #endif return end C----------------------------------------------------------------------- subroutine elj(evdw,evdw_t) 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' include "DIMENSIONS.COMPAR" 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.ENEPS' 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,210 do j=1,2 eneps_temp(j,i)=0.0d0 enddo enddo evdw=0.0D0 evdw_t=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) if (bb(itypi,itypj).gt.0.0d0) then evdw=evdw+evdwij else evdw_t=evdw_t+evdwij endif 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 c write (2,*) "Rtal",Rtail," sig",sig," sigsq",sigsq, c & " sig0ij",sig0ij c write (2,*) "rij_shift",rij_shift 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) #ifdef SCALREP ! Scale down the repulsive term for 1,4 interactions. if (iabs(j-i).le.4) c1 = 0.01d0 * c1 #endif c! c1 = 0.0d0 c2 = fac * bb(itypi,itypj) c! c2 = 0.0d0 c write (2,*) "eps1",eps1," eps2rt",eps2rt," eps3rt",eps3rt, c & " c1",c1," c2",c2 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 IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') & restyp(itype(i)),i,restyp(itype(j)),j, & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, & Equad,evdwij+Fcav+eheadtail,evdw c IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)') c & restyp(itype(i)),i,restyp(itype(j)),j, c & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, c & Equad,evdwij+Fcav+eheadtail,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 if (energy_dec) write (iout,*) "evdw before exiting emomo:",evdw 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' 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! io for debug, disable it in final builds INCLUDE 'COMMON.IOUNITS' 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!!! BetaT = 1.0d0 / (298 * 1.987d-3) 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! write (2,*) "elgrad types",itypi,itypj, c! & " chi1",chi1," chi2",chi2," chi12",chi12, c! & " chip1",chip1," chip2",chip2," chip12",chip12 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' include 'COMMON.IOUNITS' 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 c! om1 = 0.0d0 c! om2 = 0.0d0 c! om12 = 0.0d0 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 write (2,*) "chi1",chi1," chi2",chi2," chi12",chi12 c write (2,*) "fsceps1",faceps1," faceps1_inv",faceps1_inv, c & " eps1",eps1 C Following variable is eps1*deps1/dom12 eps1_om12=faceps1_inv*chiom12 c diagnostics only c faceps1_inv=om12 c eps1=om12 c eps1_om12=1.0d0 c write (iout,*) "om12",om12," eps1",eps1 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 c write (2,*) "om1",om1," om2",om2," om1om2",om1om2, c & " chiom1",chiom1, c & " chiom2",chiom2," facsig",facsig," sigsq",sigsq 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 diagnostics only c sigsq=1.0d0 c sigsq_om1=0.0d0 c sigsq_om2=0.0d0 c sigsq_om12=0.0d0 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv, c & " eps1",eps1 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 write (iout,*) "chipom1",chipom1," chipom2",chipom2, c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv 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 c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular c! Or frankly, we should restructurize the whole energy section eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2, c & " eps2rt_om12",eps2rt_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 vec_and_deriv_test 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' dimension uyder(3,3,2),uzder(3,3,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 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) c write (iout,*) 'fac',fac, c & 1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) do k=1,3 uz(k,i)=fac*uz(k,i) enddo 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 C Compute the Y-axis do k=1,3 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i)) enddo facy=fac facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))* & (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2- & scalar(dc_norm(1,i),dc_norm(1,i-1))**2)) do k=1,3 c uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) uy(k,i)= c & facy*( & dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i)) & -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i) c & ) enddo c write (iout,*) 'facy',facy, c & 1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) do k=1,3 uy(k,i)=facy*uy(k,i) enddo 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 c uyder(j,j,1)=uyder(j,j,1)-costh c uyder(j,j,2)=1.0d0+uyder(j,j,2) uyder(j,j,1)=uyder(j,j,1) & -scalar(dc_norm(1,i),dc_norm(1,i-1)) uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i)) & +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)) 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) fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i))) do k=1,3 uz(k,i)=fac*uz(k,i) enddo 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 C Compute the Y-axis facy=fac facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))* & (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2- & scalar(dc_norm(1,i),dc_norm(1,i+1))**2)) do k=1,3 c uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) uy(k,i)= c & facy*( & dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i)) & -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i) c & ) enddo c write (iout,*) 'facy',facy, c & 1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i))) do k=1,3 uy(k,i)=facy*uy(k,i) enddo 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 c uyder(j,j,1)=uyder(j,j,1)-costh c uyder(j,j,2)=1.0d0+uyder(j,j,2) uyder(j,j,1)=uyder(j,j,1) & -scalar(dc_norm(1,i),dc_norm(1,i+1)) uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i)) & +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 enddo do i=1,nres-1 do j=1,2 do k=1,3 do l=1,3 uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i) uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i) enddo enddo enddo enddo return end C----------------------------------------------------------------------------- subroutine check_vecgrad 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' dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres) dimension uyt(3,maxres),uzt(3,maxres) dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3) double precision delta /1.0d-7/ call vec_and_deriv cd do i=1,nres crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i) crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i) crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i) cd write(iout,'(2i5,2(3f10.5,5x))') i,1, cd & (dc_norm(if90,i),if90=1,3) cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3) cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3) cd write(iout,'(a)') cd enddo do i=1,nres do j=1,2 do k=1,3 do l=1,3 uygradt(l,k,j,i)=uygrad(l,k,j,i) uzgradt(l,k,j,i)=uzgrad(l,k,j,i) enddo enddo enddo enddo call vec_and_deriv do i=1,nres do j=1,3 uyt(j,i)=uy(j,i) uzt(j,i)=uz(j,i) enddo enddo do i=1,nres cd write (iout,*) 'i=',i do k=1,3 erij(k)=dc_norm(k,i) enddo do j=1,3 do k=1,3 dc_norm(k,i)=erij(k) enddo dc_norm(j,i)=dc_norm(j,i)+delta c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))) c do k=1,3 c dc_norm(k,i)=dc_norm(k,i)/fac c enddo c write (iout,*) (dc_norm(k,i),k=1,3) c write (iout,*) (erij(k),k=1,3) call vec_and_deriv do k=1,3 uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta enddo c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3), c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3) enddo do k=1,3 dc_norm(k,i)=erij(k) enddo cd do k=1,3 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3), cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3) cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3), cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3) cd write (iout,'(a)') cd enddo enddo return end C-------------------------------------------------------------------------- subroutine set_matrices 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' 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 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 if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then iti = itortyp(itype(i-2)) else iti=ntortyp+1 endif if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then iti1 = itortyp(itype(i-1)) else iti1=ntortyp+1 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) if (i .gt. iatel_s+2) then call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2)) call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2)) call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2)) call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2)) call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2)) call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2)) call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2)) 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,iti),Ub2der(1,i-2)) call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2)) call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2)) call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2)) call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2)) call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2)) call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2)) do k=1,2 muder(k,i-2)=Ub2der(k,i-2) enddo if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then iti1 = itortyp(itype(i-1)) else iti1=ntortyp+1 endif do k=1,2 mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1) enddo C Vectors and matrices dependent on a single virtual-bond dihedral. call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1)) call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2)) call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2)) call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2)) call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2)) call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2)) call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2)) call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2)) call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2)) cd write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2), cd & ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2) enddo C Matrices dependent on two consecutive virtual-bond dihedrals. C The order of matrices is from left to right. do i=2,nres-1 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i)) 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)) call transpose2(DtUg2(1,1,i-1),auxmat(1,1)) call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i)) 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)) enddo cd do i=1,nres cd iti = itortyp(itype(i)) cd write (iout,*) i cd do j=1,2 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)') cd & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2) cd enddo cd enddo 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) 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' 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) common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions double precision scal_el /0.5d0/ 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 cd if (wel_loc.gt.0.0d0) then if (icheckgrad.eq.1) then call vec_and_deriv_test else call vec_and_deriv endif call set_matrices 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 num_conti_hb=0 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 do i=iatel_s,iatel_e if (itel(i).eq.0) goto 1215 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 num_conti=0 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) do j=ielstart(i),ielend(i) if (itel(j).eq.0) goto 1216 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) C Diagnostics only!!! c aaa=0.0D0 c bbb=0.0D0 c ael6i=0.0D0 c ael3i=0.0D0 C End diagnostics 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) xj=c(1,j)+0.5D0*dxj-xmedi yj=c(2,j)+0.5D0*dyj-ymedi zj=c(3,j)+0.5D0*dzj-zmedi rij=xj*xj+yj*yj+zj*zj 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 eesij=el1+el2 c write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij C 12/26/95 - for the evaluation of multi-body H-bonding interactions ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) ees=ees+eesij evdw1=evdw1+evdwij 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 C C Calculate contributions to the Cartesian gradient. C #ifdef SPLITELE facvdw=-6*rrmij*(ev1+evdwij) facel=-3*rrmij*(el1+eesij) fac1=fac erij(1)=xj*rmij erij(2)=yj*rmij erij(3)=zj*rmij if (calc_grad) then * * Radial derivatives. First process both termini of the fragment (i,j) * ggg(1)=facel*xj ggg(2)=facel*yj ggg(3)=facel*zj do k=1,3 ghalf=0.5D0*ggg(k) gelc(k,i)=gelc(k,i)+ghalf gelc(k,j)=gelc(k,j)+ghalf enddo * * Loop over residues i+1 thru j-1. * do k=i+1,j-1 do l=1,3 gelc(l,k)=gelc(l,k)+ggg(l) enddo enddo ggg(1)=facvdw*xj ggg(2)=facvdw*yj ggg(3)=facvdw*zj do k=1,3 ghalf=0.5D0*ggg(k) gvdwpp(k,i)=gvdwpp(k,i)+ghalf gvdwpp(k,j)=gvdwpp(k,j)+ghalf enddo * * Loop over residues i+1 thru j-1. * do k=i+1,j-1 do l=1,3 gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) enddo enddo #else facvdw=ev1+evdwij facel=el1+eesij fac1=fac fac=-3*rrmij*(facvdw+facvdw+facel) erij(1)=xj*rmij erij(2)=yj*rmij erij(3)=zj*rmij if (calc_grad) then * * Radial derivatives. First process both termini of the fragment (i,j) * ggg(1)=fac*xj ggg(2)=fac*yj ggg(3)=fac*zj do k=1,3 ghalf=0.5D0*ggg(k) gelc(k,i)=gelc(k,i)+ghalf gelc(k,j)=gelc(k,j)+ghalf enddo * * Loop over residues i+1 thru j-1. * do k=i+1,j-1 do l=1,3 gelc(l,k)=gelc(l,k)+ggg(l) enddo enddo #endif * * Angular part * 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) enddo do k=1,3 ghalf=0.5D0*ggg(k) gelc(k,i)=gelc(k,i)+ghalf & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) gelc(k,j)=gelc(k,j)+ghalf & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) enddo do k=i+1,j-1 do l=1,3 gelc(l,k)=gelc(l,k)+ggg(l) enddo 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 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 do k=1,2 do l=1,2 kkk=kkk+1 muij(kkk)=mu(k,i)*mu(l,j) enddo enddo cd write (iout,*) 'EELEC: i',i,' j',j cd write (iout,*) 'j',j,' j1',j1,' j2',j2 cd write(iout,*) 'muij',muij 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 C For diagnostics only cd a22=1.0d0 cd a23=1.0d0 cd a32=1.0d0 cd a33=1.0d0 fac=dsqrt(-ael6i)*r3ij cd write (2,*) 'fac=',fac C For diagnostics only cd fac=1.0d0 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(k,i),k=1,3), cd & (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3) 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,'(2i3,9f10.5/)') i,j, cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij if (calc_grad) then C Derivatives of the elements of A in virtual-bond vectors call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) cd do k=1,3 cd do l=1,3 cd erder(k,l)=0.0d0 cd enddo cd enddo 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 cd do k=1,3 cd do l=1,3 cd uryg(k,l)=0.0d0 cd urzg(k,l)=0.0d0 cd vryg(k,l)=0.0d0 cd vrzg(k,l)=0.0d0 cd enddo cd enddo C Compute radial contributions to the gradient facr=-3.0d0*rrmij a22der=a22*facr a23der=a23*facr a32der=a32*facr a33der=a33*facr cd a22der=0.0d0 cd a23der=0.0d0 cd a32der=0.0d0 cd a33der=0.0d0 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) ghalf1=0.5d0*agg(k,1) ghalf2=0.5d0*agg(k,2) ghalf3=0.5d0*agg(k,3) 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) cd aggi(k,1)=ghalf1 cd aggi(k,2)=ghalf2 cd aggi(k,3)=ghalf3 cd aggi(k,4)=ghalf4 C Derivatives in DC(i+1) cd aggi1(k,1)=agg(k,1) cd aggi1(k,2)=agg(k,2) cd aggi1(k,3)=agg(k,3) cd aggi1(k,4)=agg(k,4) C Derivatives in DC(j) cd aggj(k,1)=ghalf1 cd aggj(k,2)=ghalf2 cd aggj(k,3)=ghalf3 cd aggj(k,4)=ghalf4 C Derivatives in DC(j+1) cd aggj1(k,1)=0.0d0 cd aggj1(k,2)=0.0d0 cd aggj1(k,3)=0.0d0 cd aggj1(k,4)=0.0d0 if (j.eq.nres-1 .and. i.lt.j-2) then do l=1,4 aggj1(k,l)=aggj1(k,l)+agg(k,l) cd aggj1(k,l)=agg(k,l) enddo endif enddo endif c goto 11111 C Check the loc-el terms by numerical integration acipa(1,1)=a22 acipa(1,2)=a23 acipa(2,1)=a32 acipa(2,2)=a33 a22=-a22 a23=-a23 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 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 11111 continue 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) cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij cd write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) eel_loc=eel_loc+eel_loc_ij C Partial derivatives in virtual-bond dihedral angles gamma if (calc_grad) then 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) 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) cd call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij) cd write(iout,*) 'agg ',agg cd write(iout,*) 'aggi ',aggi cd write(iout,*) 'aggi1',aggi1 cd write(iout,*) 'aggj ',aggj cd write(iout,*) 'aggj1',aggj1 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) enddo do k=i+2,j2 do l=1,3 gel_loc(l,k)=gel_loc(l,k)+ggg(l) enddo 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) 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) 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) 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) enddo endif ENDIF if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then C Contributions from turns a_temp(1,1)=a22 a_temp(1,2)=a23 a_temp(2,1)=a32 a_temp(2,2)=a33 call eturn34(i,j,eello_turn3,eello_turn4) endif C Change 12/26/95 to calculate four-body contributions to H-bonding energy if (j.gt.i+1 .and. num_conti.le.maxconts) then 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 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 do kkk=1,3 grij_hb_cont(kkk,num_conti,i)=erij(kkk) enddo c if (i.eq.1) then c a_chuj(1,1,num_conti,i)=-0.61d0 c a_chuj(1,2,num_conti,i)= 0.4d0 c a_chuj(2,1,num_conti,i)= 0.65d0 c a_chuj(2,2,num_conti,i)= 0.50d0 c else if (i.eq.2) then c a_chuj(1,1,num_conti,i)= 0.0d0 c a_chuj(1,2,num_conti,i)= 0.0d0 c a_chuj(2,1,num_conti,i)= 0.0d0 c a_chuj(2,2,num_conti,i)= 0.0d0 c endif C --- and its gradients cd write (iout,*) 'i',i,' j',j cd do kkk=1,3 cd write (iout,*) 'iii 1 kkk',kkk cd write (iout,*) agg(kkk,:) cd enddo cd do kkk=1,3 cd write (iout,*) 'iii 2 kkk',kkk cd write (iout,*) aggi(kkk,:) cd enddo cd do kkk=1,3 cd write (iout,*) 'iii 3 kkk',kkk cd write (iout,*) aggi1(kkk,:) cd enddo cd do kkk=1,3 cd write (iout,*) 'iii 4 kkk',kkk cd write (iout,*) aggj(kkk,:) cd enddo cd do kkk=1,3 cd write (iout,*) 'iii 5 kkk',kkk cd write (iout,*) aggj1(kkk,:) cd 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) c do mm=1,5 c a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0 c enddo enddo enddo enddo 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 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) c ees0mij=0.0D0 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) 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 facont_hb(num_conti,i)=fcont if (calc_grad) then 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 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 ghalfp=0.5D0*gggp(k) 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) 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) gacontp_hb3(k,num_conti,i)=gggp(k) 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) 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) gacontm_hb3(k,num_conti,i)=gggm(k) enddo endif 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 ! wcorr endif ! num_conti.le.maxconts endif ! fcont.gt.0 endif ! j.gt.i+1 1216 continue enddo ! j num_cont_hb(i)=num_conti 1215 continue enddo ! i 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 return end C----------------------------------------------------------------------------- subroutine eturn34(i,j,eello_turn3,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' 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) double precision agg(3,4),aggi(3,4),aggi1(3,4), & aggj(3,4),aggj1(3,4),a_temp(2,2) common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2 if (j.eq.i+2) then 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)) call transpose2(auxmat(1,1),auxmat1(1,1)) call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) 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 if (calc_grad) then 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),pizda(1,1)) call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1)) gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2)) 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),pizda(1,1)) call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1)) gel_loc_turn3(i+1)=gel_loc_turn3(i+1) & +0.5d0*(pizda(1,1)+pizda(2,2)) C Cartesian derivatives 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(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)) 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(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)) 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(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)) 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)) enddo endif else if (j.eq.i+3) then 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) iti1=itortyp(itype(i+1)) iti2=itortyp(itype(i+2)) iti3=itortyp(itype(i+3)) 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)) 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,iti2),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,iti1),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)) eello_turn4=eello_turn4-(s1+s2+s3) cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3), cd & ' eello_turn4_num',8*eello_turn4_num C Derivatives in gamma(i) if (calc_grad) then 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,iti2),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) 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,iti1),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) 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,iti2),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,iti1),auxvec(1)) call matmat2(auxmat(1,1),e2t(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+2)=gel_loc_turn4(i+2)-(s1+s2+s3) 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,iti2),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,iti1),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) 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,iti2),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,iti1),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) 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,iti2),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,iti1),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) 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,iti2),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,iti1),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) 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,iti2),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,iti1),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,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) enddo endif endif 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 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)) do iint=1,nscp_gr(i) do j=iscpstart(i,iint),iscpend(i,iint) itypj=itype(j) 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)-xi yj=c(2,j)-yi zj=c(3,j)-zi rrij=1.0D0/(xj*xj+yj*yj+zj*zj) 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 endif evdwij=e1+e2 c write (iout,*) i,j,evdwij evdw2=evdw2+evdwij if (calc_grad) then C C Calculate contributions to the gradient in the virtual-bond and SC vectors. C fac=-(evdwij+e1)*rrij 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 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 'COMMON.SBRIDGE' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.VAR' include 'COMMON.INTERACT' include 'COMMON.IOUNITS' dimension ggg(3) ehpb=0.0D0 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr cd write(iout,*)'link_start=',link_start,' 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 write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, c & dhpb(i),dhpb1(i),forcon(i) C 24/11/03 AL: SS bridges handled separately because of introducing a specific C distance and angle dependent SS bond potential. if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then call ssbond_ene(iii,jjj,eij) ehpb=ehpb+2*eij cd write (iout,*) "eij",eij else if (ii.gt.nres .and. jj.gt.nres) then c Restraints from contact prediction dd=dist(ii,jj) 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 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 C Calculate the distance between the two points and its difference from the C target distance. dd=dist(ii,jj) 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 cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, cd & ' waga=',waga,' fac=',fac 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 k=1,3 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) enddo endif enddo 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=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=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 do i=nnt+1,nct diff = vbld(i)-vbldp0 c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff estr=estr+diff*diff do j=1,3 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) enddo enddo estr=0.5d0*AKP*estr c c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included c do i=nnt,nct iti=itype(i) if (iti.ne.10) 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) 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' 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 time11=dexp(-2*time) 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 Zero the energy function and its derivative at 0 or pi. call splinthet(theta(i),0.5d0*delta,ss,ssd) it=itype(i-1) c if (i.gt.ithet_start .and. c & (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215 c if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then c phii=phi(i) c y(1)=dcos(phii) c y(2)=dsin(phii) c else c y(1)=0.0D0 c y(2)=0.0D0 c endif c if (i.lt.nres .and. itel(i).ne.0) then c phii1=phi(i+1) c z(1)=dcos(phii1) c z(2)=dsin(phii1) c else c z(1)=0.0D0 c z(2)=0.0D0 c endif if (i.gt.3) then #ifdef OSF phii=phi(i) icrc=0 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 if (i.lt.nres) then #ifdef OSF phii1=phi(i+1) icrc=0 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) bthetk=bthet(k,it) 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)*y(2)+athet(2,it)*y(1))*ss dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss 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,'(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) 1215 continue 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' 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 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.gt.3) 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 ityp1=nthetyp+1 do k=1,nsingle cosph1(k)=0.0d0 sinph1(k)=0.0d0 enddo endif if (i.lt.nres) 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 ityp3=nthetyp+1 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) 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)*sinkt(k) dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3) & *coskt(k) if (lprn) & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), & " 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)*cosph1(k) & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k) & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k) & +eethet(k,m,ityp1,ityp2,ityp3)*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)*cosph1(k)- & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) dephii1=dephii1+k*sinkt(m)*( & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) if (lprn) & write (iout,*) "m",m," k",k," bbthet", & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", & eethet(k,m,ityp1,ityp2,ityp3)," 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)*cosph1ph2(l,k)+ & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ & ggthet(k,l,m,ityp1,ityp2,ityp3)*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)*sinph1ph2(l,k)- & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) dephii1=dephii1+(k-l)*sinkt(m)*( & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)- & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) if (lprn) then write (iout,*) "m",m," k",k," l",l," ffthet", & ffthet(l,k,m,ityp1,ityp2,ityp3), & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", & ggthet(l,k,m,ityp1,ityp2,ityp3), & ggthet(k,l,m,ityp1,ityp2,ityp3)," 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 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,'(a)') 'ESC' do i=loc_start,loc_end it=itype(i) if (it.eq.10) goto 1 nlobit=nlob(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) c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, c & 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,*) escloci else call enesc(x,escloci,dersc,ddummy,.false.) endif escloc=escloc+escloci c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc 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,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,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 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=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) 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=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 = -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 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)*dC_norm(j,i+nres) dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*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,edihcnstr,fact) 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 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*fact*gloci c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) enddo ! 6/20/98 - dihedral angle constraints edihcnstr=0.0d0 do i=1,ndih_constr itori=idih_constr(i) phii=phi(itori) difi=phii-phi0(i) if (difi.gt.drange(i)) then difi=difi-drange(i) edihcnstr=edihcnstr+0.25d0*ftors*difi**4 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 else if (difi.lt.-drange(i)) then difi=difi+drange(i) edihcnstr=edihcnstr+0.25d0*ftors*difi**4 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 endif ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) enddo ! write (iout,*) 'edihcnstr',edihcnstr return end c------------------------------------------------------------------------------ #else subroutine etor(etors,edihcnstr,fact) 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 (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215 itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) phii=phi(i) gloci=0.0D0 C Regular cosine and sine terms do j=1,nterm(itori,itori1) v1ij=v1(j,itori,itori1) v2ij=v2(j,itori,itori1) cosphi=dcos(j*phii) sinphi=dsin(j*phii) etors=etors+v1ij*cosphi+v2ij*sinphi 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) 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) etors=etors+vl1ij*pom1 pom=-pom*pom1*pom1 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom enddo C Subtract the constant term etors=etors-v0(itori,itori1) 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*fact*gloci c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) 1215 continue enddo ! 6/20/98 - dihedral angle constraints edihcnstr=0.0d0 do i=1,ndih_constr itori=idih_constr(i) phii=phi(itori) difi=pinorm(phii-phi0(i)) edihi=0.0d0 if (difi.gt.drange(i)) then difi=difi-drange(i) edihcnstr=edihcnstr+0.25d0*ftors*difi**4 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 edihi=0.25d0*ftors*difi**4 else if (difi.lt.-drange(i)) then difi=difi+drange(i) edihcnstr=edihcnstr+0.25d0*ftors*difi**4 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 edihi=0.25d0*ftors*difi**4 else difi=0.0d0 endif c write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi, c & drange(i),edihi ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) enddo ! write (iout,*) 'edihcnstr',edihcnstr return end c---------------------------------------------------------------------------- subroutine etor_d(etors_d,fact2) 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 (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 C Regular cosine and sine terms do j=1,ntermd_1(itori,itori1,itori2) v1cij=v1c(1,j,itori,itori1,itori2) v1sij=v1s(1,j,itori,itori1,itori2) v2cij=v1c(2,j,itori,itori1,itori2) v2sij=v1s(2,j,itori,itori1,itori2) 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) do l=1,k-1 v1cdij = v2c(k,l,itori,itori1,itori2) v2cdij = v2c(l,k,itori,itori1,itori2) v1sdij = v2s(k,l,itori,itori1,itori2) v2sdij = v2s(l,k,itori,itori1,itori2) 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*fact2*gloci1 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2 1215 continue enddo return end #endif 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",itau_start,itau_end,nterm_sccor esccor=0.0D0 do i=itau_start,itau_end esccor_ii=0.0D0 isccori=isccortyp(itype(i-2)) isccori1=isccortyp(itype(i-1)) phii=phi(i) cccc Added 9 May 2012 cc Tauangle is torsional engle depending on the value of first digit c(see comment below) cc Omicron is flat angle depending on the value of first digit c(see comment below) 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.21).or. & (itype(i-1).eq.21))) & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) & .or.(itype(i-2).eq.21))) & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. & (itype(i-1).eq.21)))) cycle if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21)) & 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 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci c write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi c &gloc_sc(intertyp,i-3,icg) 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,intertyp,itori,itori1),j=1,6) & ,(v2sccor(j,intertyp,itori,itori1),j=1,6) gsccor_loc(i-3)=gsccor_loc(i-3)+gloci enddo !intertyp enddo c do i=1,nres c write (iout,*) "W@T@F", gloc_sc(1,i,icg),gloc(i,icg) c 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 '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 '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------------------------------------------------------------------------------ #ifdef MPL subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer) implicit real*8 (a-h,o-z) include 'DIMENSIONS' integer dimen1,dimen2,atom,indx double precision buffer(dimen1,dimen2) double precision zapas common /contacts_hb/ zapas(3,20,maxres,7), & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), & num_cont_hb(maxres),jcont_hb(20,maxres) num_kont=num_cont_hb(atom) do i=1,num_kont do k=1,7 do j=1,3 buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k) enddo ! j enddo ! k buffer(i,indx+22)=facont_hb(i,atom) buffer(i,indx+23)=ees0p(i,atom) buffer(i,indx+24)=ees0m(i,atom) buffer(i,indx+25)=dfloat(jcont_hb(i,atom)) enddo ! i buffer(1,indx+26)=dfloat(num_kont) return end c------------------------------------------------------------------------------ subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer) implicit real*8 (a-h,o-z) include 'DIMENSIONS' integer dimen1,dimen2,atom,indx double precision buffer(dimen1,dimen2) double precision zapas common /contacts_hb/ zapas(3,20,maxres,7), & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), & num_cont_hb(maxres),jcont_hb(20,maxres) num_kont=buffer(1,indx+26) num_kont_old=num_cont_hb(atom) num_cont_hb(atom)=num_kont+num_kont_old do i=1,num_kont ii=i+num_kont_old do k=1,7 do j=1,3 zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j) enddo ! j enddo ! k facont_hb(ii,atom)=buffer(i,indx+22) ees0p(ii,atom)=buffer(i,indx+23) ees0m(ii,atom)=buffer(i,indx+24) jcont_hb(ii,atom)=buffer(i,indx+25) enddo ! i return end c------------------------------------------------------------------------------ #endif 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' #ifdef MPL include 'COMMON.INFO' #endif include 'COMMON.FFIELD' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' #ifdef MPL parameter (max_cont=maxconts) parameter (max_dim=2*(8*3+2)) parameter (msglen1=max_cont*max_dim*4) parameter (msglen2=2*msglen1) integer source,CorrelType,CorrelID,Error double precision buffer(max_cont,max_dim) #endif double precision gx(3),gx1(3) logical lprn,ldone C Set lprn=.true. for debugging lprn=.false. #ifdef MPL n_corr=0 n_corr1=0 if (fgProcs.le.1) goto 30 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 C Caution! Following code assumes that electrostatic interactions concerning C a given atom are split among at most two processors! CorrelType=477 CorrelID=MyID+1 ldone=.false. do i=1,max_cont do j=1,max_dim buffer(i,j)=0.0D0 enddo enddo mm=mod(MyRank,2) cd write (iout,*) 'MyRank',MyRank,' mm',mm if (mm) 20,20,10 10 continue cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone if (MyRank.gt.0) then C Send correlation contributions to the preceding processor msglen=msglen1 nn=num_cont_hb(iatel_s) call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) cd write (iout,*) 'The BUFFER array:' cd do i=1,nn cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) cd enddo if (ielstart(iatel_s).gt.iatel_s+ispp) then msglen=msglen2 call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) C Clear the contacts of the atom passed to the neighboring processor nn=num_cont_hb(iatel_s+1) cd do i=1,nn cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) cd enddo num_cont_hb(iatel_s)=0 endif cd write (iout,*) 'Processor ',MyID,MyRank, cd & ' is sending correlation contribution to processor',MyID-1, cd & ' msglen=',msglen cd write (*,*) 'Processor ',MyID,MyRank, cd & ' is sending correlation contribution to processor',MyID-1, cd & ' msglen=',msglen,' CorrelType=',CorrelType call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) cd write (iout,*) 'Processor ',MyID, cd & ' has sent correlation contribution to processor',MyID-1, cd & ' msglen=',msglen,' CorrelID=',CorrelID cd write (*,*) 'Processor ',MyID, cd & ' has sent correlation contribution to processor',MyID-1, cd & ' msglen=',msglen,' CorrelID=',CorrelID msglen=msglen1 endif ! (MyRank.gt.0) if (ldone) goto 30 ldone=.true. 20 continue cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone if (MyRank.lt.fgProcs-1) then C Receive correlation contributions from the next processor msglen=msglen1 if (ielend(iatel_e).lt.nct-1) msglen=msglen2 cd write (iout,*) 'Processor',MyID, cd & ' is receiving correlation contribution from processor',MyID+1, cd & ' msglen=',msglen,' CorrelType=',CorrelType cd write (*,*) 'Processor',MyID, cd & ' is receiving correlation contribution from processor',MyID+1, cd & ' msglen=',msglen,' CorrelType=',CorrelType nbytes=-1 do while (nbytes.le.0) call mp_probe(MyID+1,CorrelType,nbytes) enddo cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) cd write (iout,*) 'Processor',MyID, cd & ' has received correlation contribution from processor',MyID+1, cd & ' msglen=',msglen,' nbytes=',nbytes cd write (iout,*) 'The received BUFFER array:' cd do i=1,max_cont cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) cd enddo if (msglen.eq.msglen1) then call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) else if (msglen.eq.msglen2) then call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) else write (iout,*) & 'ERROR!!!! message length changed while processing correlations.' write (*,*) & 'ERROR!!!! message length changed while processing correlations.' call mp_stopall(Error) endif ! msglen.eq.msglen1 endif ! MyRank.lt.fgProcs-1 if (ldone) goto 30 ldone=.true. goto 10 30 continue #endif 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 MPL include 'COMMON.INFO' #endif include 'COMMON.FFIELD' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' #ifdef MPL parameter (max_cont=maxconts) parameter (max_dim=2*(8*3+2)) parameter (msglen1=max_cont*max_dim*4) parameter (msglen2=2*msglen1) integer source,CorrelType,CorrelID,Error double precision buffer(max_cont,max_dim) #endif double precision gx(3),gx1(3) logical lprn,ldone C Set lprn=.true. for debugging lprn=.false. eturn6=0.0d0 #ifdef MPL n_corr=0 n_corr1=0 if (fgProcs.le.1) goto 30 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 C Caution! Following code assumes that electrostatic interactions concerning C a given atom are split among at most two processors! CorrelType=477 CorrelID=MyID+1 ldone=.false. do i=1,max_cont do j=1,max_dim buffer(i,j)=0.0D0 enddo enddo mm=mod(MyRank,2) cd write (iout,*) 'MyRank',MyRank,' mm',mm if (mm) 20,20,10 10 continue cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone if (MyRank.gt.0) then C Send correlation contributions to the preceding processor msglen=msglen1 nn=num_cont_hb(iatel_s) call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) cd write (iout,*) 'The BUFFER array:' cd do i=1,nn cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) cd enddo if (ielstart(iatel_s).gt.iatel_s+ispp) then msglen=msglen2 call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) C Clear the contacts of the atom passed to the neighboring processor nn=num_cont_hb(iatel_s+1) cd do i=1,nn cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) cd enddo num_cont_hb(iatel_s)=0 endif cd write (iout,*) 'Processor ',MyID,MyRank, cd & ' is sending correlation contribution to processor',MyID-1, cd & ' msglen=',msglen cd write (*,*) 'Processor ',MyID,MyRank, cd & ' is sending correlation contribution to processor',MyID-1, cd & ' msglen=',msglen,' CorrelType=',CorrelType call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) cd write (iout,*) 'Processor ',MyID, cd & ' has sent correlation contribution to processor',MyID-1, cd & ' msglen=',msglen,' CorrelID=',CorrelID cd write (*,*) 'Processor ',MyID, cd & ' has sent correlation contribution to processor',MyID-1, cd & ' msglen=',msglen,' CorrelID=',CorrelID msglen=msglen1 endif ! (MyRank.gt.0) if (ldone) goto 30 ldone=.true. 20 continue cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone if (MyRank.lt.fgProcs-1) then C Receive correlation contributions from the next processor msglen=msglen1 if (ielend(iatel_e).lt.nct-1) msglen=msglen2 cd write (iout,*) 'Processor',MyID, cd & ' is receiving correlation contribution from processor',MyID+1, cd & ' msglen=',msglen,' CorrelType=',CorrelType cd write (*,*) 'Processor',MyID, cd & ' is receiving correlation contribution from processor',MyID+1, cd & ' msglen=',msglen,' CorrelType=',CorrelType nbytes=-1 do while (nbytes.le.0) call mp_probe(MyID+1,CorrelType,nbytes) enddo cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) cd write (iout,*) 'Processor',MyID, cd & ' has received correlation contribution from processor',MyID+1, cd & ' msglen=',msglen,' nbytes=',nbytes cd write (iout,*) 'The received BUFFER array:' cd do i=1,max_cont cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) cd enddo if (msglen.eq.msglen1) then call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) else if (msglen.eq.msglen2) then call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) else write (iout,*) & 'ERROR!!!! message length changed while processing correlations.' write (*,*) & 'ERROR!!!! message length changed while processing correlations.' call mp_stopall(Error) endif ! msglen.eq.msglen1 endif ! MyRank.lt.fgProcs-1 if (ldone) goto 30 ldone=.true. goto 10 30 continue #endif 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 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) call dipole(i,j,jj) enddo enddo endif 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 (*,*) '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. 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) c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, c & ' 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 call calc_eello(i,j,i+1,j1,jj,kk) if (wcorr4.gt.0.0d0) & ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk) if (wcorr5.gt.0.0d0) & ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk) c print *,"wcorr5",ecorr5 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 cd write(2,*)'ijkl',i,j,i+1,j1 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.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,j,i+1,j1,jj,kk) cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, cd & 'ecorr6=',ecorr6 cd write (iout,'(4e15.5)') sred_geom, cd & dabs(eello4(i,j,i+1,j1,jj,kk)), cd & dabs(eello5(i,j,i+1,j1,jj,kk)), cd & dabs(eello6(i,j,i+1,j1,jj,kk)) else if (wturn6.gt.0.0d0 & .and. (j.eq.i+4 .and. j1.eq.i+3)) then cd write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1 eturn6=eturn6+eello_turn6(i,jj,kk) cd write (2,*) 'multibody_eello:eturn6',eturn6 endif ENDIF 1111 continue 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------------------------------------------------------------------------------ double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' double precision gx(3),gx1(3) logical lprn lprn=.false. 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) 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,*)'Contacts have occurred for peptide groups',i,j, c & ' and',k,l c write (iout,*)'Contacts have occurred for peptide groups', c & i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees C Calculate the multi-body contribution to energy. ecorr=ecorr+ekont*ees if (calc_grad) then C Calculate multi-body contributions to the gradient. do ll=1,3 ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i) gradcorr(ll,i)=gradcorr(ll,i)+ghalf & -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+ & coeffm*ees0mkl*gacontm_hb1(ll,jj,i)) gradcorr(ll,j)=gradcorr(ll,j)+ghalf & -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+ & coeffm*ees0mkl*gacontm_hb2(ll,jj,i)) ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k) gradcorr(ll,k)=gradcorr(ll,k)+ghalf & -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+ & coeffm*ees0mij*gacontm_hb1(ll,kk,k)) gradcorr(ll,l)=gradcorr(ll,l)+ghalf & -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+ & coeffm*ees0mij*gacontm_hb2(ll,kk,k)) enddo do m=i+1,j-1 do ll=1,3 gradcorr(ll,m)=gradcorr(ll,m)+ & ees*ekl*gacont_hbr(ll,jj,i)- & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) enddo enddo do m=k+1,l-1 do ll=1,3 gradcorr(ll,m)=gradcorr(ll,m)+ & ees*eij*gacont_hbr(ll,kk,k)- & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) enddo enddo endif ehbcorr=ekont*ees return end 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 = itortyp(itype(j+1)) else itj1=ntortyp+1 endif do iii=1,2 dipi(iii,1)=Ub2(iii,i) dipderi(iii)=Ub2der(iii,i) dipi(iii,2)=b1(iii,iti1) dipj(iii,1)=Ub2(iii,j) dipderj(iii)=Ub2der(iii,j) dipj(iii,2)=b1(iii,itj1) 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 if (.not.calc_grad) return 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 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 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=itortyp(itype(i)) else iti=ntortyp+1 endif itk1=itortyp(itype(k+1)) itj=itortyp(itype(j)) if (l.lt.nres-1) then itl1=itortyp(itype(l+1)) else itl1=ntortyp+1 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,iti),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,iti),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,itk1),AEAb1(1,2,1)) call matvec2(AEAderg(1,1,1),b1(1,itk1),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,itj),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,itj),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,itl1),AEAb1(1,2,2)) call matvec2(AEAderg(1,1,2),b1(1,itl1),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,iti), & 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,itk1), & 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,itj), & 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,itl1), & 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=itortyp(itype(i)) else iti=ntortyp+1 endif itk1=itortyp(itype(k+1)) itl=itortyp(itype(l)) itj=itortyp(itype(j)) if (j.lt.nres-1) then itj1=itortyp(itype(j+1)) else itj1=ntortyp+1 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,iti),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,iti),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,itk1),AEAb1(1,2,1)) call matvec2(AEAderg(1,1,1),b1(1,itk1),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,itj1),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,itl),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,itj1),AEAb1(1,2,2)) call matvec2(AEAderg(1,1,2),b1(1,itj1),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,iti), & 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,itk1), & 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,itl), & 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,itj1), & 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 cold ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i) ggg1(ll)=eel4*g_contij(ll,1) ggg2(ll)=eel4*g_contij(ll,2) ghalf=0.5d0*ggg1(ll) cd ghalf=0.0d0 gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1) gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1) gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) cold ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k) ghalf=0.5d0*ggg2(ll) cd ghalf=0.0d0 gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2) gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2) gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) enddo cd goto 1112 do m=i+1,j-1 do ll=1,3 cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i) gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) enddo enddo do m=k+1,l-1 do ll=1,3 cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k) gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) enddo enddo 1112 continue do m=i+2,j2 do ll=1,3 gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) enddo enddo do m=k+2,l2 do ll=1,3 gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) enddo enddo cd do iii=1,nres-3 cd write (2,*) iii,gcorr_loc(iii) cd enddo endif 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=itortyp(itype(k)) itl=itortyp(itype(l)) itj=itortyp(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 c goto 1112 endif c1111 continue C Contribution from graph II call transpose2(EE(1,1,itk),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,itk)) & -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,itk)) & -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,itk)) & -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,itk)) & -0.5d0*scalar2(vv(1),Ctobr(1,k)) enddo enddo enddo cd goto 1112 endif 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 endif C Contribution from graph IV cd1110 continue call transpose2(EE(1,1,itl),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,itl)) & -0.5d0*scalar2(vv(1),Ctobr(1,l)) if (calc_grad) then 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,itl)) & -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,itl)) & -0.5d0*scalar2(vv(1),Ctobr(1,l)) enddo enddo enddo endif 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 cd goto 1112 endif C Contribution from graph IV 1110 continue call transpose2(EE(1,1,itj),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,itj)) & -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,itj)) & -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,itj)) & -0.5d0*scalar2(vv(1),Ctobr(1,j)) enddo enddo enddo endif 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 do ll=1,3 ggg1(ll)=eel5*g_contij(ll,1) ggg2(ll)=eel5*g_contij(ll,2) cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) ghalf=0.5d0*ggg1(ll) cd ghalf=0.0d0 gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1) gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1) gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) ghalf=0.5d0*ggg2(ll) cd ghalf=0.0d0 gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) enddo cd goto 1112 do m=i+1,j-1 do ll=1,3 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) enddo enddo do m=k+1,l-1 do ll=1,3 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) enddo enddo c1112 continue do m=i+2,j2 do ll=1,3 gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) enddo enddo do m=k+2,l2 do ll=1,3 gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) enddo enddo cd do iii=1,nres-3 cd write (2,*) iii,g_corr5_loc(iii) cd enddo endif 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 ggg1(ll)=eel6*g_contij(ll,1) ggg2(ll)=eel6*g_contij(ll,2) cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) ghalf=0.5d0*ggg1(ll) cd ghalf=0.0d0 gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1) gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1) gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) 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)+ghalf+ekont*derx(ll,2,2) gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2) gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) enddo cd goto 1112 do m=i+1,j-1 do ll=1,3 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) enddo enddo do m=k+1,l-1 do ll=1,3 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) enddo enddo 1112 continue do m=i+2,j2 do ll=1,3 gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) enddo enddo do m=k+2,l2 do ll=1,3 gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) enddo enddo cd do iii=1,nres-3 cd write (2,*) iii,g_corr6_loc(iii) cd enddo endif 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=itortyp(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,itk)-AEAb1(2,2,imat)*b1(2,itk) vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) 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 (.not. calc_grad) return 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,itk)-AEAb1derg(2,2,imat)*b1(2,itk) vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) 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,itk) & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) 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 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(1),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 if (.not. calc_grad) return C Derivatives in gamma(i-1) 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 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=itortyp(itype(j+1)) else itj1=ntortyp+1 endif itk=itortyp(itype(k)) itk1=itortyp(itype(k+1)) if (l.lt.nres-1) then itl1=itortyp(itype(l+1)) else itl1=ntortyp+1 endif #ifdef MOMENT s1=dip(4,jj,i)*dip(4,kk,k) #endif call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) call transpose2(EE(1,1,itk),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 #ifdef MOMENT eello6_graph3=-(s1+s2+s3+s4) #else eello6_graph3=-(s2+s3+s4) #endif c eello6_graph3=-s4 if (.not. calc_grad) return C Derivatives in gamma(k-1) call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) s3=0.5d0*scalar2(b1(1,itj1),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,itk1),auxvec(1)) s2=0.5d0*scalar2(b1(1,itk),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,itk1), & auxvec(1)) s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), & auxvec(1)) s3=0.5d0*scalar2(b1(1,itj1),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 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=itortyp(itype(i)) itj=itortyp(itype(j)) if (j.lt.nres-1) then itj1=itortyp(itype(j+1)) else itj1=ntortyp+1 endif itk=itortyp(itype(k)) if (k.lt.nres-1) then itk1=itortyp(itype(k+1)) else itk1=ntortyp+1 endif itl=itortyp(itype(l)) if (l.lt.nres-1) then itl1=itortyp(itype(l+1)) else itl1=ntortyp+1 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,itj1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) else call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,itl),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 if (.not. calc_grad) return C Derivatives in gamma(i-1) 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,itj1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) else call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,itl),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,itj1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) else call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) s3=-0.5d0*scalar2(b1(1,itl),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,itj1),auxvec(1)) s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) else call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), & b1(1,itl1),auxvec(1)) s3=-0.5d0*scalar2(b1(1,itl),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 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. eello_turn6=0.0d0 j=i+4 k=i+1 l=i+3 iti=itortyp(itype(i)) itk=itortyp(itype(k)) itk1=itortyp(itype(k+1)) itl=itortyp(itype(l)) itj=itortyp(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,itl)) s1 = (auxmat(1,1)+auxmat(2,2))*ss1 #else s1 = 0.0d0 #endif call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) s2 = scalar2(b1(1,itk),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,itk1),vtemp2(1)) s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) #else s8=0.0d0 #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,itk),vtemp4(1)) s13 = (gtemp(1,1)+gtemp(2,2))*ss13 #else s13=0.0d0 #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) if (calc_grad) then C Derivatives in gamma(i+2) #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,itl),vtemp2(1)) #else s8d=0.0d0 #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,itl)) s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d #else s1d=0.0d0 #endif call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) s2d = scalar2(b1(1,itk),vtemp1d(1)) #ifdef MOMENT call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),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 #else s13d=0.0d0 #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 #else s13d = 0.0d0 #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 #else s1d = 0.0d0 #endif call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) s2d = scalar2(b1(1,itk),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,itl),vtemp2(1)) #else s8d = 0.0d0 #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,itk),vtemp4d(1)) s13d = (gtemp(1,1)+gtemp(2,2))*ss13d #else s13d = 0.0d0 #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 #else s1d = 0.0d0 #endif call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), & vtemp1d(1)) s2d = scalar2(b1(1,itk),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,itl),vtemp2(1)) #else s8d = 0.0d0 #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,itk),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 ggg1(ll)=eel_turn6*g_contij(ll,1) ggg2(ll)=eel_turn6*g_contij(ll,2) ghalf=0.5d0*ggg1(ll) cd ghalf=0.0d0 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) 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) enddo cd goto 1112 do m=i+1,j-1 do ll=1,3 gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) enddo enddo do m=k+1,l-1 do ll=1,3 gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) enddo enddo 1112 continue do m=i+2,j2 do ll=1,3 gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) enddo enddo do m=k+2,l2 do ll=1,3 gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) enddo enddo cd do iii=1,nres-3 cd write (2,*) iii,g_corr6_loc(iii) cd enddo endif eello_turn6=ekont*eel_turn6 cd write (2,*) 'ekont',ekont cd write (2,*) 'eel_turn6',ekont*eel_turn6 return end crc------------------------------------------------- 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