--- /dev/null
+ SUBROUTINE etotal(energia)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+#ifndef ISNAN\r
+ external proc_proc\r
+#ifdef WINPGI\r
+cMS$ATTRIBUTES C :: proc_proc\r
+#endif\r
+#endif\r
+#ifdef MPI\r
+ include "mpif.h"\r
+ double precision weights_(n_ene)\r
+#endif\r
+ include 'COMMON.SETUP'\r
+ include 'COMMON.IOUNITS'\r
+ double precision energia(0:n_ene)\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.SBRIDGE'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.MD'\r
+ include 'COMMON.CONTROL'\r
+ include 'COMMON.TIME1'\r
+#ifdef MPI \r
+c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,\r
+c & " nfgtasks",nfgtasks\r
+ if (nfgtasks.gt.1) then\r
+#ifdef MPI\r
+ time00=MPI_Wtime()\r
+#else\r
+ time00=tcpu()\r
+#endif\r
+C FG slaves call the following matching MPI_Bcast in ERGASTULUM\r
+ if (fg_rank.eq.0) then\r
+ call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)\r
+c print *,"Processor",myrank," BROADCAST iorder"\r
+C FG master sets up the WEIGHTS_ array which will be broadcast to the \r
+C FG slaves as WEIGHTS array.\r
+ weights_(1)=wsc\r
+ weights_(2)=wscp\r
+ weights_(3)=welec\r
+ weights_(4)=wcorr\r
+ weights_(5)=wcorr5\r
+ weights_(6)=wcorr6\r
+ weights_(7)=wel_loc\r
+ weights_(8)=wturn3\r
+ weights_(9)=wturn4\r
+ weights_(10)=wturn6\r
+ weights_(11)=wang\r
+ weights_(12)=wscloc\r
+ weights_(13)=wtor\r
+ weights_(14)=wtor_d\r
+ weights_(15)=wstrain\r
+ weights_(16)=wvdwpp\r
+ weights_(17)=wbond\r
+ weights_(18)=scal14\r
+ weights_(21)=wsccor\r
+ weights_(22)=wsct\r
+C FG Master broadcasts the WEIGHTS_ array\r
+ call MPI_Bcast(weights_(1),n_ene,\r
+ & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)\r
+ else\r
+C FG slaves receive the WEIGHTS array\r
+ call MPI_Bcast(weights(1),n_ene,\r
+ & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)\r
+ wsc=weights(1)\r
+ wscp=weights(2)\r
+ welec=weights(3)\r
+ wcorr=weights(4)\r
+ wcorr5=weights(5)\r
+ wcorr6=weights(6)\r
+ wel_loc=weights(7)\r
+ wturn3=weights(8)\r
+ wturn4=weights(9)\r
+ wturn6=weights(10)\r
+ wang=weights(11)\r
+ wscloc=weights(12)\r
+ wtor=weights(13)\r
+ wtor_d=weights(14)\r
+ wstrain=weights(15)\r
+ wvdwpp=weights(16)\r
+ wbond=weights(17)\r
+ scal14=weights(18)\r
+ wsccor=weights(21)\r
+ wsct=weights(22)\r
+ endif\r
+ time_Bcast=time_Bcast+MPI_Wtime()-time00\r
+ time_Bcastw=time_Bcastw+MPI_Wtime()-time00\r
+c call chainbuild_cart\r
+ endif\r
+c print *,'Processor',myrank,' calling etotal ipot=',ipot\r
+c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct\r
+#else\r
+c if (modecalc.eq.12.or.modecalc.eq.14) then\r
+c call int_from_cart1(.false.)\r
+c endif\r
+#endif \r
+#ifdef TIMING\r
+#ifdef MPI\r
+ time00=MPI_Wtime()\r
+#else\r
+ time00=tcpu()\r
+#endif\r
+#endif\r
+C \r
+C Compute the side-chain and electrostatic interaction energy\r
+C\r
+ goto (101,102,103,104,105,106,107) ipot\r
+C Lennard-Jones potential.\r
+ 101 call elj(evdw,evdw_p,evdw_m)\r
+cd print '(a)','Exit ELJ'\r
+ goto 108\r
+C Lennard-Jones-Kihara potential (shifted).\r
+ 102 call eljk(evdw,evdw_p,evdw_m)\r
+ goto 108\r
+C Berne-Pechukas potential (dilated LJ, angular dependence).\r
+ 103 call ebp(evdw,evdw_p,evdw_m)\r
+ goto 108\r
+C Gay-Berne potential (shifted LJ, angular dependence).\r
+ 104 call egb(evdw,evdw_p,evdw_m)\r
+ goto 108\r
+C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).\r
+ 105 call egbv(evdw,evdw_p,evdw_m)\r
+ goto 108\r
+C New SC-SC potential\r
+ 106 call emomo(evdw,evdw_p,evdw_m)\r
+ goto 108\r
+C Soft-sphere potential\r
+ 107 call e_softsphere(evdw)\r
+C\r
+C Calculate electrostatic (H-bonding) energy of the main chain.\r
+C\r
+ 108 continue\r
+c print *,"Processor",myrank," computed USCSC"\r
+#ifdef TIMING\r
+#ifdef MPI\r
+ time01=MPI_Wtime() \r
+#else\r
+ time00=tcpu()\r
+#endif\r
+#endif\r
+ call vec_and_deriv\r
+#ifdef TIMING\r
+#ifdef MPI\r
+ time_vec=time_vec+MPI_Wtime()-time01\r
+#else\r
+ time_vec=time_vec+tcpu()-time01\r
+#endif\r
+#endif\r
+c print *,"Processor",myrank," left VEC_AND_DERIV"\r
+ IF (ipot.lt.7) THEN\r
+#ifdef SPLITELE\r
+ if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.\r
+ & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0\r
+ & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0\r
+ & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then\r
+#else\r
+ if (welec.gt.0d0.or.wel_loc.gt.0d0.or.\r
+ & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0\r
+ & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 \r
+ & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then\r
+#endif\r
+ call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)\r
+ else\r
+ ees=0.0d0\r
+ evdw1=0.0d0\r
+ eel_loc=0.0d0\r
+ eello_turn3=0.0d0\r
+ eello_turn4=0.0d0\r
+ endif\r
+ else\r
+c write (iout,*) "Soft-spheer ELEC potential"\r
+ call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,\r
+ & eello_turn4)\r
+ endif\r
+c print *,"Processor",myrank," computed UELEC"\r
+C\r
+C Calculate excluded-volume interaction energy between peptide groups\r
+C and side chains.\r
+C\r
+ if (ipot.lt.7) then\r
+ if(wscp.gt.0d0) then\r
+ call escp(evdw2,evdw2_14)\r
+ else\r
+ evdw2=0\r
+ evdw2_14=0\r
+ endif\r
+ else\r
+c write (iout,*) "Soft-sphere SCP potential"\r
+ call escp_soft_sphere(evdw2,evdw2_14)\r
+ endif\r
+c\r
+c Calculate the bond-stretching energy\r
+c\r
+ call ebond(estr)\r
+C \r
+C Calculate the disulfide-bridge and other energy and the contributions\r
+C from other distance constraints.\r
+cd print *,'Calling EHPB'\r
+ call edis(ehpb)\r
+cd print *,'EHPB exitted succesfully.'\r
+C\r
+C Calculate the virtual-bond-angle energy.\r
+C\r
+ if (wang.gt.0d0) then\r
+ call ebend(ebe)\r
+ else\r
+ ebe=0\r
+ endif\r
+c print *,"Processor",myrank," computed UB"\r
+C\r
+C Calculate the SC local energy.\r
+C\r
+ call esc(escloc)\r
+c print *,"Processor",myrank," computed USC"\r
+C\r
+C Calculate the virtual-bond torsional energy.\r
+C\r
+cd print *,'nterm=',nterm\r
+ if (wtor.gt.0) then\r
+ call etor(etors,edihcnstr)\r
+ else\r
+ etors=0\r
+ edihcnstr=0\r
+ endif\r
+c print *,"Processor",myrank," computed Utor"\r
+C\r
+C 6/23/01 Calculate double-torsional energy\r
+C\r
+ if (wtor_d.gt.0) then\r
+ call etor_d(etors_d)\r
+ else\r
+ etors_d=0\r
+ endif\r
+c print *,"Processor",myrank," computed Utord"\r
+C\r
+C 21/5/07 Calculate local sicdechain correlation energy\r
+C\r
+ write (*,*) "eback_sc_corr XX"\r
+ if (wsccor.gt.0.0d0) then\r
+ write (*,*) "eback_sc_corr 00a"\r
+ call eback_sc_corr(esccor)\r
+ else\r
+ write (*,*) "eback_sc_corr 00b"\r
+ esccor=0.0d0\r
+ END IF\r
+c print *,"Processor",myrank," computed Usccorr"\r
+C \r
+C 12/1/95 Multi-body terms\r
+C\r
+ n_corr=0\r
+ n_corr1=0\r
+ if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 \r
+ & .or. wturn6.gt.0.0d0) .and. ipot.lt.7) then\r
+ call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)\r
+cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,\r
+cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6\r
+ else\r
+ ecorr=0.0d0\r
+ ecorr5=0.0d0\r
+ ecorr6=0.0d0\r
+ eturn6=0.0d0\r
+ end if\r
+ if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.7) then\r
+ call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)\r
+cd write (iout,*) "multibody_hb ecorr",ecorr\r
+ end if\r
+c print *,"Processor",myrank," computed Ucorr"\r
+C \r
+C If performing constraint dynamics, call the constraint energy\r
+C after the equilibration time\r
+ IF(usampl.and.totT.gt.eq_time) THEN\r
+ call EconstrQ \r
+ call Econstr_back\r
+ ELSE\r
+ Uconst=0.0d0\r
+ Uconst_back=0.0d0\r
+ ENDIF\r
+#ifdef TIMING\r
+#ifdef MPI\r
+ time_enecalc=time_enecalc+MPI_Wtime()-time00\r
+#else\r
+ time_enecalc=time_enecalc+tcpu()-time00\r
+#endif\r
+#endif\r
+c print *,"Processor",myrank," computed Uconstr"\r
+#ifdef TIMING\r
+#ifdef MPI\r
+ time00=MPI_Wtime()\r
+#else\r
+ time00=tcpu()\r
+#endif\r
+#endif\r
+c\r
+C Sum the energies\r
+C\r
+ energia(1)=evdw\r
+#ifdef SCP14\r
+ energia(2)=evdw2-evdw2_14\r
+ energia(18)=evdw2_14\r
+#else\r
+ energia(2)=evdw2\r
+ energia(18)=0.0d0\r
+#endif\r
+#ifdef SPLITELE\r
+ energia(3)=ees\r
+ energia(16)=evdw1\r
+#else\r
+ energia(3)=ees+evdw1\r
+ energia(16)=0.0d0\r
+#endif\r
+ energia(4)=ecorr\r
+ energia(5)=ecorr5\r
+ energia(6)=ecorr6\r
+ energia(7)=eel_loc\r
+ energia(8)=eello_turn3\r
+ energia(9)=eello_turn4\r
+ energia(10)=eturn6\r
+ energia(11)=ebe\r
+ energia(12)=escloc\r
+ energia(13)=etors\r
+ energia(14)=etors_d\r
+ energia(15)=ehpb\r
+ energia(19)=edihcnstr\r
+ energia(17)=estr\r
+ energia(20)=Uconst+Uconst_back\r
+ energia(21)=esccor\r
+ energia(22)=evdw_p\r
+ energia(23)=evdw_m\r
+c print *," Processor",myrank," calls SUM_ENERGY"\r
+ call sum_energy(energia,.true.)\r
+c print *," Processor",myrank," left SUM_ENERGY"\r
+#ifdef TIMING\r
+#ifdef MPI\r
+ time_sumene=time_sumene+MPI_Wtime()-time00\r
+#else\r
+ time_sumene=time_sumene+tcpu()-time00\r
+#endif\r
+#endif\r
+ RETURN\r
+ END SUBROUTINE etotal\r
+\r
+\r
+c-------------------------------------------------------------------------------\r
+\r
+\r
+ subroutine sum_energy(energia,reduce)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+#ifndef ISNAN\r
+ external proc_proc\r
+#ifdef WINPGI\r
+cMS$ATTRIBUTES C :: proc_proc\r
+#endif\r
+#endif\r
+#ifdef MPI\r
+ include "mpif.h"\r
+#endif\r
+ include 'COMMON.SETUP'\r
+ include 'COMMON.IOUNITS'\r
+ double precision energia(0:n_ene),enebuff(0:n_ene+1)\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.SBRIDGE'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.CONTROL'\r
+ include 'COMMON.TIME1'\r
+ logical reduce\r
+#ifdef MPI\r
+ if (nfgtasks.gt.1 .and. reduce) then\r
+#ifdef DEBUG\r
+ write (iout,*) "energies before REDUCE"\r
+ call enerprint(energia)\r
+ call flush(iout)\r
+#endif\r
+ do i=0,n_ene\r
+ enebuff(i)=energia(i)\r
+ enddo\r
+ time00=MPI_Wtime()\r
+ call MPI_Barrier(FG_COMM,IERR)\r
+ time_barrier_e=time_barrier_e+MPI_Wtime()-time00\r
+ time00=MPI_Wtime()\r
+ call MPI_Reduce(enebuff(0),energia(0),n_ene+1,\r
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)\r
+#ifdef DEBUG\r
+ write (iout,*) "energies after REDUCE"\r
+ call enerprint(energia)\r
+ call flush(iout)\r
+#endif\r
+ time_Reduce=time_Reduce+MPI_Wtime()-time00\r
+ endif\r
+ if (fg_rank.eq.0) then\r
+#endif\r
+#ifdef TSCSC\r
+ evdw=energia(22)+wsct*energia(23)\r
+#else\r
+ evdw=energia(1)\r
+#endif\r
+#ifdef SCP14\r
+ evdw2=energia(2)+energia(18)\r
+ evdw2_14=energia(18)\r
+#else\r
+ evdw2=energia(2)\r
+#endif\r
+#ifdef SPLITELE\r
+ ees=energia(3)\r
+ evdw1=energia(16)\r
+#else\r
+ ees=energia(3)\r
+ evdw1=0.0d0\r
+#endif\r
+ ecorr=energia(4)\r
+ ecorr5=energia(5)\r
+ ecorr6=energia(6)\r
+ eel_loc=energia(7)\r
+ eello_turn3=energia(8)\r
+ eello_turn4=energia(9)\r
+ eturn6=energia(10)\r
+ ebe=energia(11)\r
+ escloc=energia(12)\r
+ etors=energia(13)\r
+ etors_d=energia(14)\r
+ ehpb=energia(15)\r
+ edihcnstr=energia(19)\r
+ estr=energia(17)\r
+ Uconst=energia(20)\r
+ esccor=energia(21)\r
+#ifdef SPLITELE\r
+ etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1\r
+ & +wang*ebe+wtor*etors+wscloc*escloc\r
+ & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5\r
+ & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3\r
+ & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d\r
+ & +wbond*estr+Uconst+wsccor*esccor\r
+#else\r
+ etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)\r
+ & +wang*ebe+wtor*etors+wscloc*escloc\r
+ & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5\r
+ & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3\r
+ & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d\r
+ & +wbond*estr+Uconst+wsccor*esccor\r
+#endif\r
+ energia(0)=etot\r
+c detecting NaNQ\r
+#ifdef ISNAN\r
+#ifdef AIX\r
+ if (isnan(etot).ne.0) energia(0)=1.0d+99\r
+#else\r
+ if (isnan(etot)) energia(0)=1.0d+99\r
+#endif\r
+#else\r
+ i=0\r
+#ifdef WINPGI\r
+ idumm=proc_proc(etot,i)\r
+#else\r
+ call proc_proc(etot,i)\r
+#endif\r
+ if(i.eq.1)energia(0)=1.0d+99\r
+#endif\r
+#ifdef MPI\r
+ endif\r
+#endif\r
+ return\r
+ end\r
+\r
+\r
+c-------------------------------------------------------------------------------\r
+\r
+\r
+ subroutine sum_gradient\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+#ifndef ISNAN\r
+ external proc_proc\r
+#ifdef WINPGI\r
+cMS$ATTRIBUTES C :: proc_proc\r
+#endif\r
+#endif\r
+#ifdef MPI\r
+ include 'mpif.h'\r
+#endif\r
+ double precision gradbufc(3,maxres),gradbufx(3,maxres),\r
+ & glocbuf(4*maxres),gradbufc_sum(3,maxres)\r
+ include 'COMMON.SETUP'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.SBRIDGE'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.CONTROL'\r
+ include 'COMMON.TIME1'\r
+ include 'COMMON.MAXGRAD'\r
+#ifdef TIMING\r
+#ifdef MPI\r
+ time01=MPI_Wtime()\r
+#else\r
+ time01=tcpu()\r
+#endif\r
+#endif\r
+#ifdef DEBUG\r
+ write (iout,*) "sum_gradient gvdwc, gvdwx"\r
+ do i=1,nres\r
+ write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)') \r
+ & i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),\r
+ & (gvdwcT(j,i),j=1,3)\r
+ enddo\r
+ call flush(iout)\r
+#endif\r
+#ifdef MPI\r
+C FG slaves call the following matching MPI_Bcast in ERGASTULUM\r
+ if (nfgtasks.gt.1 .and. fg_rank.eq.0) \r
+ & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)\r
+#endif\r
+C\r
+C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient\r
+C in virtual-bond-vector coordinates\r
+C\r
+#ifdef DEBUG\r
+c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"\r
+c do i=1,nres-1\r
+c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') \r
+c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)\r
+c enddo\r
+c write (iout,*) "gel_loc_tur3 gel_loc_turn4"\r
+c do i=1,nres-1\r
+c write (iout,'(i5,3f10.5,2x,f10.5)') \r
+c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)\r
+c enddo\r
+ write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"\r
+ do i=1,nres\r
+ write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') \r
+ & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),\r
+ & g_corr5_loc(i)\r
+ enddo\r
+ call flush(iout)\r
+#endif\r
+#ifdef SPLITELE\r
+#ifdef TSCSC\r
+ do i=1,nct\r
+ do j=1,3\r
+ gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+\r
+ & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+\r
+ & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+\r
+ & wel_loc*gel_loc_long(j,i)+\r
+ & wcorr*gradcorr_long(j,i)+\r
+ & wcorr5*gradcorr5_long(j,i)+\r
+ & wcorr6*gradcorr6_long(j,i)+\r
+ & wturn6*gcorr6_turn_long(j,i)+\r
+ & wstrain*ghpbc(j,i)\r
+ enddo\r
+ enddo \r
+#else\r
+ do i=1,nct\r
+ do j=1,3\r
+ gradbufc(j,i)=wsc*gvdwc(j,i)+\r
+ & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+\r
+ & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+\r
+ & wel_loc*gel_loc_long(j,i)+\r
+ & wcorr*gradcorr_long(j,i)+\r
+ & wcorr5*gradcorr5_long(j,i)+\r
+ & wcorr6*gradcorr6_long(j,i)+\r
+ & wturn6*gcorr6_turn_long(j,i)+\r
+ & wstrain*ghpbc(j,i)\r
+ enddo\r
+ enddo\r
+#endif\r
+#else\r
+ do i=1,nct\r
+ do j=1,3\r
+ gradbufc(j,i)=wsc*gvdwc(j,i)+\r
+ & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+\r
+ & welec*gelc_long(j,i)+\r
+ & wbond*gradb(j,i)+\r
+ & wel_loc*gel_loc_long(j,i)+\r
+ & wcorr*gradcorr_long(j,i)+\r
+ & wcorr5*gradcorr5_long(j,i)+\r
+ & wcorr6*gradcorr6_long(j,i)+\r
+ & wturn6*gcorr6_turn_long(j,i)+\r
+ & wstrain*ghpbc(j,i)\r
+ enddo\r
+ enddo \r
+#endif\r
+#ifdef MPI\r
+ if (nfgtasks.gt.1) then\r
+ time00=MPI_Wtime()\r
+#ifdef DEBUG\r
+ write (iout,*) "gradbufc before allreduce"\r
+ do i=1,nres\r
+ write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)\r
+ enddo\r
+ call flush(iout)\r
+#endif\r
+ do i=1,nres\r
+ do j=1,3\r
+ gradbufc_sum(j,i)=gradbufc(j,i)\r
+ enddo\r
+ enddo\r
+c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,\r
+c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)\r
+c time_reduce=time_reduce+MPI_Wtime()-time00\r
+#ifdef DEBUG\r
+c write (iout,*) "gradbufc_sum after allreduce"\r
+c do i=1,nres\r
+c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)\r
+c enddo\r
+c call flush(iout)\r
+#endif\r
+#ifdef TIMING\r
+c time_allreduce=time_allreduce+MPI_Wtime()-time00\r
+#endif\r
+ do i=nnt,nres\r
+ do k=1,3\r
+ gradbufc(k,i)=0.0d0\r
+ enddo\r
+ enddo\r
+#ifdef DEBUG\r
+ write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end\r
+ write (iout,*) (i," jgrad_start",jgrad_start(i),\r
+ & " jgrad_end ",jgrad_end(i),\r
+ & i=igrad_start,igrad_end)\r
+#endif\r
+c\r
+c Obsolete and inefficient code; we can make the effort O(n) and, therefore,\r
+c do not parallelize this part.\r
+c\r
+c do i=igrad_start,igrad_end\r
+c do j=jgrad_start(i),jgrad_end(i)\r
+c do k=1,3\r
+c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)\r
+c enddo\r
+c enddo\r
+c enddo\r
+ do j=1,3\r
+ gradbufc(j,nres-1)=gradbufc_sum(j,nres)\r
+ enddo\r
+ do i=nres-2,nnt,-1\r
+ do j=1,3\r
+ gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)\r
+ enddo\r
+ enddo\r
+#ifdef DEBUG\r
+ write (iout,*) "gradbufc after summing"\r
+ do i=1,nres\r
+ write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)\r
+ enddo\r
+ call flush(iout)\r
+#endif\r
+ else\r
+#endif\r
+#ifdef DEBUG\r
+ write (iout,*) "gradbufc"\r
+ do i=1,nres\r
+ write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)\r
+ enddo\r
+ call flush(iout)\r
+#endif\r
+ do i=1,nres\r
+ do j=1,3\r
+ gradbufc_sum(j,i)=gradbufc(j,i)\r
+ gradbufc(j,i)=0.0d0\r
+ enddo\r
+ enddo\r
+ do j=1,3\r
+ gradbufc(j,nres-1)=gradbufc_sum(j,nres)\r
+ enddo\r
+ do i=nres-2,nnt,-1\r
+ do j=1,3\r
+ gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)\r
+ enddo\r
+ enddo\r
+c do i=nnt,nres-1\r
+c do k=1,3\r
+c gradbufc(k,i)=0.0d0\r
+c enddo\r
+c do j=i+1,nres\r
+c do k=1,3\r
+c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)\r
+c enddo\r
+c enddo\r
+c enddo\r
+#ifdef DEBUG\r
+ write (iout,*) "gradbufc after summing"\r
+ do i=1,nres\r
+ write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)\r
+ enddo\r
+ call flush(iout)\r
+#endif\r
+#ifdef MPI\r
+ endif\r
+#endif\r
+ do k=1,3\r
+ gradbufc(k,nres)=0.0d0\r
+ enddo\r
+ do i=1,nct\r
+ do j=1,3\r
+#ifdef SPLITELE\r
+ gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+\r
+ & wel_loc*gel_loc(j,i)+\r
+ & 0.5d0*(wscp*gvdwc_scpp(j,i)+\r
+ & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+\r
+ & wel_loc*gel_loc_long(j,i)+\r
+ & wcorr*gradcorr_long(j,i)+\r
+ & wcorr5*gradcorr5_long(j,i)+\r
+ & wcorr6*gradcorr6_long(j,i)+\r
+ & wturn6*gcorr6_turn_long(j,i))+\r
+ & wbond*gradb(j,i)+\r
+ & wcorr*gradcorr(j,i)+\r
+ & wturn3*gcorr3_turn(j,i)+\r
+ & wturn4*gcorr4_turn(j,i)+\r
+ & wcorr5*gradcorr5(j,i)+\r
+ & wcorr6*gradcorr6(j,i)+\r
+ & wturn6*gcorr6_turn(j,i)+\r
+ & wsccor*gsccorc(j,i)\r
+ & +wscloc*gscloc(j,i)\r
+#else\r
+ gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+\r
+ & wel_loc*gel_loc(j,i)+\r
+ & 0.5d0*(wscp*gvdwc_scpp(j,i)+\r
+ & welec*gelc_long(j,i)+\r
+ & wel_loc*gel_loc_long(j,i)+\r
+ & wcorr*gcorr_long(j,i)+\r
+ & wcorr5*gradcorr5_long(j,i)+\r
+ & wcorr6*gradcorr6_long(j,i)+\r
+ & wturn6*gcorr6_turn_long(j,i))+\r
+ & wbond*gradb(j,i)+\r
+ & wcorr*gradcorr(j,i)+\r
+ & wturn3*gcorr3_turn(j,i)+\r
+ & wturn4*gcorr4_turn(j,i)+\r
+ & wcorr5*gradcorr5(j,i)+\r
+ & wcorr6*gradcorr6(j,i)+\r
+ & wturn6*gcorr6_turn(j,i)+\r
+ & wsccor*gsccorc(j,i)\r
+ & +wscloc*gscloc(j,i)\r
+#endif\r
+#ifdef TSCSC\r
+ gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+\r
+ & wscp*gradx_scp(j,i)+\r
+ & wbond*gradbx(j,i)+\r
+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+\r
+ & wsccor*gsccorx(j,i)\r
+ & +wscloc*gsclocx(j,i)\r
+#else\r
+ gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+\r
+ & wbond*gradbx(j,i)+\r
+ & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+\r
+ & wsccor*gsccorx(j,i)\r
+ & +wscloc*gsclocx(j,i)\r
+\r
+#endif\r
+ enddo\r
+ enddo \r
+#ifdef DEBUG\r
+ write (iout,*) "gloc before adding corr"\r
+ do i=1,4*nres\r
+ write (iout,*) i,gloc(i,icg)\r
+ enddo\r
+#endif\r
+ do i=1,nres-3\r
+ gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)\r
+ & +wcorr5*g_corr5_loc(i)\r
+ & +wcorr6*g_corr6_loc(i)\r
+ & +wturn4*gel_loc_turn4(i)\r
+ & +wturn3*gel_loc_turn3(i)\r
+ & +wturn6*gel_loc_turn6(i)\r
+ & +wel_loc*gel_loc_loc(i)\r
+ & +wsccor*gsccor_loc(i)\r
+ enddo\r
+#ifdef DEBUG\r
+ write (iout,*) "gloc after adding corr"\r
+ do i=1,4*nres\r
+ write (iout,*) i,gloc(i,icg)\r
+ enddo\r
+#endif\r
+#ifdef MPI\r
+ if (nfgtasks.gt.1) then\r
+ do j=1,3\r
+ do i=1,nres\r
+ gradbufc(j,i)=gradc(j,i,icg)\r
+ gradbufx(j,i)=gradx(j,i,icg)\r
+ enddo\r
+ enddo\r
+ do i=1,4*nres\r
+ glocbuf(i)=gloc(i,icg)\r
+ enddo\r
+ time00=MPI_Wtime()\r
+ call MPI_Barrier(FG_COMM,IERR)\r
+ time_barrier_g=time_barrier_g+MPI_Wtime()-time00\r
+ time00=MPI_Wtime()\r
+ call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,\r
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)\r
+ call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,\r
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)\r
+ call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,\r
+ & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)\r
+ time_reduce=time_reduce+MPI_Wtime()-time00\r
+#ifdef DEBUG\r
+ write (iout,*) "gloc after reduce"\r
+ do i=1,4*nres\r
+ write (iout,*) i,gloc(i,icg)\r
+ enddo\r
+#endif\r
+ endif\r
+#endif\r
+ if (gnorm_check) then\r
+c\r
+c Compute the maximum elements of the gradient\r
+c\r
+ gvdwc_max=0.0d0\r
+ gvdwc_scp_max=0.0d0\r
+ gelc_max=0.0d0\r
+ gvdwpp_max=0.0d0\r
+ gradb_max=0.0d0\r
+ ghpbc_max=0.0d0\r
+ gradcorr_max=0.0d0\r
+ gel_loc_max=0.0d0\r
+ gcorr3_turn_max=0.0d0\r
+ gcorr4_turn_max=0.0d0\r
+ gradcorr5_max=0.0d0\r
+ gradcorr6_max=0.0d0\r
+ gcorr6_turn_max=0.0d0\r
+ gsccorc_max=0.0d0\r
+ gscloc_max=0.0d0\r
+ gvdwx_max=0.0d0\r
+ gradx_scp_max=0.0d0\r
+ ghpbx_max=0.0d0\r
+ gradxorr_max=0.0d0\r
+ gsccorx_max=0.0d0\r
+ gsclocx_max=0.0d0\r
+ do i=1,nct\r
+ gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))\r
+ if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm\r
+#ifdef TSCSC\r
+ gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))\r
+ if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm \r
+#endif\r
+ gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))\r
+ if (gvdwc_scp_norm.gt.gvdwc_scp_max) \r
+ & gvdwc_scp_max=gvdwc_scp_norm\r
+ gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))\r
+ if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm\r
+ gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))\r
+ if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm\r
+ gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))\r
+ if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm\r
+ ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))\r
+ if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm\r
+ gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))\r
+ if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm\r
+ gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))\r
+ if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm\r
+ gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),\r
+ & gcorr3_turn(1,i)))\r
+ if (gcorr3_turn_norm.gt.gcorr3_turn_max) \r
+ & gcorr3_turn_max=gcorr3_turn_norm\r
+ gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),\r
+ & gcorr4_turn(1,i)))\r
+ if (gcorr4_turn_norm.gt.gcorr4_turn_max) \r
+ & gcorr4_turn_max=gcorr4_turn_norm\r
+ gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))\r
+ if (gradcorr5_norm.gt.gradcorr5_max) \r
+ & gradcorr5_max=gradcorr5_norm\r
+ gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))\r
+ if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm\r
+ gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),\r
+ & gcorr6_turn(1,i)))\r
+ if (gcorr6_turn_norm.gt.gcorr6_turn_max) \r
+ & gcorr6_turn_max=gcorr6_turn_norm\r
+ gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))\r
+ if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm\r
+ gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))\r
+ if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm\r
+ gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))\r
+ if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm\r
+#ifdef TSCSC\r
+ gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))\r
+ if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm\r
+#endif\r
+ gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))\r
+ if (gradx_scp_norm.gt.gradx_scp_max) \r
+ & gradx_scp_max=gradx_scp_norm\r
+ ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))\r
+ if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm\r
+ gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))\r
+ if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm\r
+ gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))\r
+ if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm\r
+ gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))\r
+ if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm\r
+ enddo \r
+ if (gradout) then\r
+#ifdef AIX\r
+ open(istat,file=statname,position="append")\r
+#else\r
+ open(istat,file=statname,access="append")\r
+#endif\r
+ write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,\r
+ & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,\r
+ & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,\r
+ & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,\r
+ & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,\r
+ & gsccorx_max,gsclocx_max\r
+ close(istat)\r
+ if (gvdwc_max.gt.1.0d4) then\r
+ write (iout,*) "gvdwc gvdwx gradb gradbx"\r
+ do i=nnt,nct\r
+ write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),\r
+ & gradb(j,i),gradbx(j,i),j=1,3)\r
+ enddo\r
+ call pdbout(0.0d0,'cipiszcze',iout)\r
+ call flush(iout)\r
+ endif\r
+ endif\r
+ endif\r
+#ifdef DEBUG\r
+ write (iout,*) "gradc gradx gloc"\r
+ do i=1,nres\r
+ write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') \r
+ & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)\r
+ enddo \r
+#endif\r
+#ifdef TIMING\r
+#ifdef MPI\r
+ time_sumgradient=time_sumgradient+MPI_Wtime()-time01\r
+#else\r
+ time_sumgradient=time_sumgradient+tcpu()-time01\r
+#endif\r
+#endif\r
+ return\r
+ end\r
+\r
+\r
+c-------------------------------------------------------------------------------\r
+\r
+\r
+ subroutine rescale_weights(t_bath)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.SBRIDGE'\r
+ double precision kfac /2.4d0/\r
+ double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/\r
+c facT=temp0/t_bath\r
+c facT=2*temp0/(t_bath+temp0)\r
+ if (rescale_mode.eq.0) then\r
+ facT=1.0d0\r
+ facT2=1.0d0\r
+ facT3=1.0d0\r
+ facT4=1.0d0\r
+ facT5=1.0d0\r
+ else if (rescale_mode.eq.1) then\r
+ facT=kfac/(kfac-1.0d0+t_bath/temp0)\r
+ facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)\r
+ facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)\r
+ facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)\r
+ facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)\r
+ else if (rescale_mode.eq.2) then\r
+ x=t_bath/temp0\r
+ x2=x*x\r
+ x3=x2*x\r
+ x4=x3*x\r
+ x5=x4*x\r
+ facT=licznik/dlog(dexp(x)+dexp(-x))\r
+ facT2=licznik/dlog(dexp(x2)+dexp(-x2))\r
+ facT3=licznik/dlog(dexp(x3)+dexp(-x3))\r
+ facT4=licznik/dlog(dexp(x4)+dexp(-x4))\r
+ facT5=licznik/dlog(dexp(x5)+dexp(-x5))\r
+ else\r
+ write (iout,*) "Wrong RESCALE_MODE",rescale_mode\r
+ write (*,*) "Wrong RESCALE_MODE",rescale_mode\r
+#ifdef MPI\r
+ call MPI_Finalize(MPI_COMM_WORLD,IERROR)\r
+#endif\r
+ stop 555\r
+ endif\r
+ welec=weights(3)*fact\r
+ wcorr=weights(4)*fact3\r
+ wcorr5=weights(5)*fact4\r
+ wcorr6=weights(6)*fact5\r
+ wel_loc=weights(7)*fact2\r
+ wturn3=weights(8)*fact2\r
+ wturn4=weights(9)*fact3\r
+ wturn6=weights(10)*fact5\r
+ wtor=weights(13)*fact\r
+ wtor_d=weights(14)*fact2\r
+ wsccor=weights(21)*fact\r
+#ifdef TSCSC\r
+c wsct=t_bath/temp0\r
+ wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0\r
+#endif\r
+ return\r
+ end\r
+\r
+\r
+C------------------------------------------------------------------------\r
+\r
+\r
+ subroutine enerprint(energia)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.SBRIDGE'\r
+ include 'COMMON.MD'\r
+ double precision energia(0:n_ene)\r
+ etot=energia(0)\r
+#ifdef TSCSC\r
+ evdw=energia(22)+wsct*energia(23)\r
+#else\r
+ evdw=energia(1)\r
+#endif\r
+ evdw2=energia(2)\r
+#ifdef SCP14\r
+ evdw2=energia(2)+energia(18)\r
+#else\r
+ evdw2=energia(2)\r
+#endif\r
+ ees=energia(3)\r
+#ifdef SPLITELE\r
+ evdw1=energia(16)\r
+#endif\r
+ ecorr=energia(4)\r
+ ecorr5=energia(5)\r
+ ecorr6=energia(6)\r
+ eel_loc=energia(7)\r
+ eello_turn3=energia(8)\r
+ eello_turn4=energia(9)\r
+ eello_turn6=energia(10)\r
+ ebe=energia(11)\r
+ escloc=energia(12)\r
+ etors=energia(13)\r
+ etors_d=energia(14)\r
+ ehpb=energia(15)\r
+ edihcnstr=energia(19)\r
+ estr=energia(17)\r
+ Uconst=energia(20)\r
+ esccor=energia(21)\r
+#ifdef SPLITELE\r
+ write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,\r
+ & estr,wbond,ebe,wang,\r
+ & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,\r
+ & ecorr,wcorr,\r
+ & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,\r
+ & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,\r
+ & edihcnstr,ebr*nss,\r
+ & Uconst,etot\r
+ 10 format (/'Virtual-chain energies:'//\r
+ & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/\r
+ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/\r
+ & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/\r
+ & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/\r
+ & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/\r
+ & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/\r
+ & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/\r
+ & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/\r
+ & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/\r
+ & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,\r
+ & ' (SS bridges & dist. cnstr.)'/\r
+ & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
+ & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
+ & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
+ & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/\r
+ & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/\r
+ & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/\r
+ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/\r
+ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/\r
+ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/\r
+ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/\r
+ & 'UCONST= ',1pE16.6,' (Constraint energy)'/ \r
+ & 'ETOT= ',1pE16.6,' (total)')\r
+#else\r
+ write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,\r
+ & estr,wbond,ebe,wang,\r
+ & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,\r
+ & ecorr,wcorr,\r
+ & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,\r
+ & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,\r
+ & ebr*nss,Uconst,etot\r
+ 10 format (/'Virtual-chain energies:'//\r
+ & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/\r
+ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/\r
+ & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/\r
+ & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/\r
+ & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/\r
+ & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/\r
+ & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/\r
+ & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/\r
+ & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,\r
+ & ' (SS bridges & dist. cnstr.)'/\r
+ & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
+ & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
+ & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/\r
+ & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/\r
+ & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/\r
+ & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/\r
+ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/\r
+ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/\r
+ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/\r
+ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/\r
+ & 'UCONST=',1pE16.6,' (Constraint energy)'/ \r
+ & 'ETOT= ',1pE16.6,' (total)')\r
+#endif\r
+ return\r
+ end\r
+\r
+\r
+C-----------------------------------------------------------------------\r
+\r
+\r
+ subroutine elj(evdw,evdw_p,evdw_m)\r
+C\r
+C This subroutine calculates the interaction energy of nonbonded side chains\r
+C assuming the LJ potential of interaction.\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ parameter (accur=1.0d-10)\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.SBRIDGE'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CONTACTS'\r
+ dimension gg(3)\r
+c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon\r
+ evdw=0.0D0\r
+ do i=iatsc_s,iatsc_e\r
+ itypi=itype(i)\r
+ itypi1=itype(i+1)\r
+ xi=c(1,nres+i)\r
+ yi=c(2,nres+i)\r
+ zi=c(3,nres+i)\r
+C Change 12/1/95\r
+ num_conti=0\r
+C\r
+C Calculate SC interaction energy.\r
+C\r
+ do iint=1,nint_gr(i)\r
+cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),\r
+cd & 'iend=',iend(i,iint)\r
+ do j=istart(i,iint),iend(i,iint)\r
+ itypj=itype(j)\r
+ xj=c(1,nres+j)-xi\r
+ yj=c(2,nres+j)-yi\r
+ zj=c(3,nres+j)-zi\r
+C Change 12/1/95 to calculate four-body interactions\r
+ rij=xj*xj+yj*yj+zj*zj\r
+ rrij=1.0D0/rij\r
+c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj\r
+ eps0ij=eps(itypi,itypj)\r
+ fac=rrij**expon2\r
+ e1=fac*fac*aa(itypi,itypj)\r
+ e2=fac*bb(itypi,itypj)\r
+ evdwij=e1+e2\r
+cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)\r
+cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)\r
+cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')\r
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),\r
+cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,\r
+cd & (c(k,i),k=1,3),(c(k,j),k=1,3)\r
+#ifdef TSCSC\r
+ if (bb(itypi,itypj).gt.0) then\r
+ evdw_p=evdw_p+evdwij\r
+ else\r
+ evdw_m=evdw_m+evdwij\r
+ endif\r
+#else\r
+ evdw=evdw+evdwij\r
+#endif\r
+C \r
+C Calculate the components of the gradient in DC and X\r
+C\r
+ fac=-rrij*(e1+evdwij)\r
+ gg(1)=xj*fac\r
+ gg(2)=yj*fac\r
+ gg(3)=zj*fac\r
+#ifdef TSCSC\r
+ if (bb(itypi,itypj).gt.0.0d0) then\r
+ do k=1,3\r
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)\r
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)\r
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
+ enddo\r
+ else\r
+ do k=1,3\r
+ gvdwxT(k,i)=gvdwxT(k,i)-gg(k)\r
+ gvdwxT(k,j)=gvdwxT(k,j)+gg(k)\r
+ gvdwcT(k,i)=gvdwcT(k,i)-gg(k)\r
+ gvdwcT(k,j)=gvdwcT(k,j)+gg(k)\r
+ enddo\r
+ endif\r
+#else\r
+ do k=1,3\r
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)\r
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)\r
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
+ enddo\r
+#endif\r
+cgrad do k=i,j-1\r
+cgrad do l=1,3\r
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+C\r
+C 12/1/95, revised on 5/20/97\r
+C\r
+C Calculate the contact function. The ith column of the array JCONT will \r
+C contain the numbers of atoms that make contacts with the atom I (of numbers\r
+C greater than I). The arrays FACONT and GACONT will contain the values of\r
+C the contact function and its derivative.\r
+C\r
+C Uncomment next line, if the correlation interactions include EVDW explicitly.\r
+c if (j.gt.i+1 .and. evdwij.le.0.0D0) then\r
+C Uncomment next line, if the correlation interactions are contact function only\r
+ if (j.gt.i+1.and. eps0ij.gt.0.0D0) then\r
+ rij=dsqrt(rij)\r
+ sigij=sigma(itypi,itypj)\r
+ r0ij=rs0(itypi,itypj)\r
+C\r
+C Check whether the SC's are not too far to make a contact.\r
+C\r
+ rcut=1.5d0*r0ij\r
+ call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)\r
+C Add a new contact, if the SC's are close enough, but not too close (r<sigma).\r
+C\r
+ if (fcont.gt.0.0D0) then\r
+C If the SC-SC distance if close to sigma, apply spline.\r
+cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,\r
+cAdam & fcont1,fprimcont1)\r
+cAdam fcont1=1.0d0-fcont1\r
+cAdam if (fcont1.gt.0.0d0) then\r
+cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1\r
+cAdam fcont=fcont*fcont1\r
+cAdam endif\r
+C Uncomment following 4 lines to have the geometric average of the epsilon0's\r
+cga eps0ij=1.0d0/dsqrt(eps0ij)\r
+cga do k=1,3\r
+cga gg(k)=gg(k)*eps0ij\r
+cga enddo\r
+cga eps0ij=-evdwij*eps0ij\r
+C Uncomment for AL's type of SC correlation interactions.\r
+cadam eps0ij=-evdwij\r
+ num_conti=num_conti+1\r
+ jcont(num_conti,i)=j\r
+ facont(num_conti,i)=fcont*eps0ij\r
+ fprimcont=eps0ij*fprimcont/rij\r
+ fcont=expon*fcont\r
+cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)\r
+cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)\r
+cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)\r
+C Uncomment following 3 lines for Skolnick's type of SC correlation.\r
+ gacont(1,num_conti,i)=-fprimcont*xj\r
+ gacont(2,num_conti,i)=-fprimcont*yj\r
+ gacont(3,num_conti,i)=-fprimcont*zj\r
+cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)\r
+cd write (iout,'(2i3,3f10.5)') \r
+cd & i,j,(gacont(kk,num_conti,i),kk=1,3)\r
+ endif\r
+ endif\r
+ enddo\r
+c! j\r
+ enddo\r
+c! iint\r
+C Change 12/1/95\r
+ num_cont(i)=num_conti\r
+ enddo ! i\r
+ do i=1,nct\r
+ do j=1,3\r
+ gvdwc(j,i)=expon*gvdwc(j,i)\r
+ gvdwx(j,i)=expon*gvdwx(j,i)\r
+ enddo\r
+ enddo\r
+C******************************************************************************\r
+C\r
+C N O T E !!!\r
+C\r
+C To save time, the factor of EXPON has been extracted from ALL components\r
+C of GVDWC and GRADX. Remember to multiply them by this factor before further \r
+C use!\r
+C\r
+C******************************************************************************\r
+ return\r
+ end\r
+\r
+\r
+C-----------------------------------------------------------------------------\r
+\r
+\r
+ subroutine eljk(evdw,evdw_p,evdw_m)\r
+C\r
+C This subroutine calculates the interaction energy of nonbonded side chains\r
+C assuming the LJK potential of interaction.\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.NAMES'\r
+ dimension gg(3)\r
+ logical scheck\r
+c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon\r
+ evdw=0.0D0\r
+ do i=iatsc_s,iatsc_e\r
+ itypi=itype(i)\r
+ itypi1=itype(i+1)\r
+ xi=c(1,nres+i)\r
+ yi=c(2,nres+i)\r
+ zi=c(3,nres+i)\r
+C\r
+C Calculate SC interaction energy.\r
+C\r
+ do iint=1,nint_gr(i)\r
+ do j=istart(i,iint),iend(i,iint)\r
+ itypj=itype(j)\r
+ xj=c(1,nres+j)-xi\r
+ yj=c(2,nres+j)-yi\r
+ zj=c(3,nres+j)-zi\r
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
+ fac_augm=rrij**expon\r
+ e_augm=augm(itypi,itypj)*fac_augm\r
+ r_inv_ij=dsqrt(rrij)\r
+ rij=1.0D0/r_inv_ij \r
+ r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))\r
+ fac=r_shift_inv**expon\r
+ e1=fac*fac*aa(itypi,itypj)\r
+ e2=fac*bb(itypi,itypj)\r
+ evdwij=e_augm+e1+e2\r
+cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)\r
+cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)\r
+cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')\r
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),\r
+cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,\r
+cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,\r
+cd & (c(k,i),k=1,3),(c(k,j),k=1,3)\r
+#ifdef TSCSC\r
+ if (bb(itypi,itypj).gt.0) then\r
+ evdw_p=evdw_p+evdwij\r
+ else\r
+ evdw_m=evdw_m+evdwij\r
+ endif\r
+#else\r
+ evdw=evdw+evdwij\r
+#endif\r
+C \r
+C Calculate the components of the gradient in DC and X\r
+C\r
+ fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)\r
+ gg(1)=xj*fac\r
+ gg(2)=yj*fac\r
+ gg(3)=zj*fac\r
+#ifdef TSCSC\r
+ if (bb(itypi,itypj).gt.0.0d0) then\r
+ do k=1,3\r
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)\r
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)\r
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
+ enddo\r
+ else\r
+ do k=1,3\r
+ gvdwxT(k,i)=gvdwxT(k,i)-gg(k)\r
+ gvdwxT(k,j)=gvdwxT(k,j)+gg(k)\r
+ gvdwcT(k,i)=gvdwcT(k,i)-gg(k)\r
+ gvdwcT(k,j)=gvdwcT(k,j)+gg(k)\r
+ enddo\r
+ endif\r
+#else\r
+ do k=1,3\r
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)\r
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)\r
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
+ enddo\r
+#endif\r
+cgrad do k=i,j-1\r
+cgrad do l=1,3\r
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+ enddo ! j\r
+ enddo ! iint\r
+ enddo ! i\r
+ do i=1,nct\r
+ do j=1,3\r
+ gvdwc(j,i)=expon*gvdwc(j,i)\r
+ gvdwx(j,i)=expon*gvdwx(j,i)\r
+ enddo\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+C-----------------------------------------------------------------------------\r
+\r
+\r
+ subroutine ebp(evdw,evdw_p,evdw_m)\r
+C\r
+C This subroutine calculates the interaction energy of nonbonded side chains\r
+C assuming the Berne-Pechukas potential of interaction.\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CALC'\r
+ common /srutu/ icall\r
+c double precision rrsave(maxdim)\r
+ logical lprn\r
+ evdw=0.0D0\r
+c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon\r
+c evdw=0.0D0\r
+c if (icall.eq.0) then\r
+c lprn=.true.\r
+c else\r
+ lprn=.false.\r
+c endif\r
+ ind=0\r
+ do i=iatsc_s,iatsc_e\r
+ itypi=itype(i)\r
+ itypi1=itype(i+1)\r
+ xi=c(1,nres+i)\r
+ yi=c(2,nres+i)\r
+ zi=c(3,nres+i)\r
+ dxi=dc_norm(1,nres+i)\r
+ dyi=dc_norm(2,nres+i)\r
+ dzi=dc_norm(3,nres+i)\r
+c dsci_inv=dsc_inv(itypi)\r
+ dsci_inv=vbld_inv(i+nres)\r
+C\r
+C Calculate SC interaction energy.\r
+C\r
+ do iint=1,nint_gr(i)\r
+ do j=istart(i,iint),iend(i,iint)\r
+ ind=ind+1\r
+ itypj=itype(j)\r
+c dscj_inv=dsc_inv(itypj)\r
+ dscj_inv=vbld_inv(j+nres)\r
+ chi1=chi(itypi,itypj)\r
+ chi2=chi(itypj,itypi)\r
+ chi12=chi1*chi2\r
+ chip1=chip(itypi)\r
+ chip2=chip(itypj)\r
+ chip12=chip1*chip2\r
+ alf1=alp(itypi)\r
+ alf2=alp(itypj)\r
+ alf12=0.5D0*(alf1+alf2)\r
+C For diagnostics only!!!\r
+c chi1=0.0D0\r
+c chi2=0.0D0\r
+c chi12=0.0D0\r
+c chip1=0.0D0\r
+c chip2=0.0D0\r
+c chip12=0.0D0\r
+c alf1=0.0D0\r
+c alf2=0.0D0\r
+c alf12=0.0D0\r
+ xj=c(1,nres+j)-xi\r
+ yj=c(2,nres+j)-yi\r
+ zj=c(3,nres+j)-zi\r
+ dxj=dc_norm(1,nres+j)\r
+ dyj=dc_norm(2,nres+j)\r
+ dzj=dc_norm(3,nres+j)\r
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
+cd if (icall.eq.0) then\r
+cd rrsave(ind)=rrij\r
+cd else\r
+cd rrij=rrsave(ind)\r
+cd endif\r
+ rij=dsqrt(rrij)\r
+C Calculate the angle-dependent terms of energy & contributions to derivatives.\r
+ call sc_angular\r
+C Calculate whole angle-dependent part of epsilon and contributions\r
+C to its derivatives\r
+ fac=(rrij*sigsq)**expon2\r
+ e1=fac*fac*aa(itypi,itypj)\r
+ e2=fac*bb(itypi,itypj)\r
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)\r
+ eps2der=evdwij*eps3rt\r
+ eps3der=evdwij*eps2rt\r
+ evdwij=evdwij*eps2rt*eps3rt\r
+#ifdef TSCSC\r
+ if (bb(itypi,itypj).gt.0) then\r
+ evdw_p=evdw_p+evdwij\r
+ else\r
+ evdw_m=evdw_m+evdwij\r
+ endif\r
+#else\r
+ evdw=evdw+evdwij\r
+#endif\r
+ if (lprn) then\r
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)\r
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)\r
+cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')\r
+cd & restyp(itypi),i,restyp(itypj),j,\r
+cd & epsi,sigm,chi1,chi2,chip1,chip2,\r
+cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),\r
+cd & om1,om2,om12,1.0D0/dsqrt(rrij),\r
+cd & evdwij\r
+ endif\r
+C Calculate gradient components.\r
+ e1=e1*eps1*eps2rt**2*eps3rt**2\r
+ fac=-expon*(e1+evdwij)\r
+ sigder=fac/sigsq\r
+ fac=rrij*fac\r
+C Calculate radial part of the gradient\r
+ gg(1)=xj*fac\r
+ gg(2)=yj*fac\r
+ gg(3)=zj*fac\r
+C Calculate the angular part of the gradient and sum add the contributions\r
+C to the appropriate components of the Cartesian gradient.\r
+#ifdef TSCSC\r
+ if (bb(itypi,itypj).gt.0) then\r
+ call sc_grad\r
+ else\r
+ call sc_grad_T\r
+ endif\r
+#else\r
+ call sc_grad\r
+#endif\r
+ enddo ! j\r
+ enddo ! iint\r
+ enddo ! i\r
+c stop\r
+ return\r
+ end\r
+\r
+\r
+C-----------------------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE egb(evdw,evdw_p,evdw_m)\r
+C\r
+C This subroutine calculates the interaction energy of nonbonded side chains\r
+C assuming the Gay-Berne potential of interaction.\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CALC'\r
+ include 'COMMON.CONTROL'\r
+ logical lprn\r
+ evdw=0.0D0\r
+ccccc energy_dec=.false.\r
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon\r
+c evdw=0.0D0\r
+ evdw_p=0.0D0\r
+ evdw_m=0.0D0\r
+ lprn=.false.\r
+c if (icall.eq.0) lprn=.false.\r
+ ind=0\r
+ do i=iatsc_s,iatsc_e\r
+ itypi=itype(i)\r
+ itypi1=itype(i+1)\r
+ xi=c(1,nres+i)\r
+ yi=c(2,nres+i)\r
+ zi=c(3,nres+i)\r
+ dxi=dc_norm(1,nres+i)\r
+ dyi=dc_norm(2,nres+i)\r
+ dzi=dc_norm(3,nres+i)\r
+c dsci_inv=dsc_inv(itypi)\r
+ dsci_inv=vbld_inv(i+nres)\r
+c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)\r
+c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi\r
+C\r
+C Calculate SC interaction energy.\r
+C\r
+ do iint=1,nint_gr(i)\r
+ do j=istart(i,iint),iend(i,iint)\r
+ ind=ind+1\r
+ itypj=itype(j)\r
+c dscj_inv=dsc_inv(itypj)\r
+ dscj_inv=vbld_inv(j+nres)\r
+c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,\r
+c & 1.0d0/vbld(j+nres)\r
+c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)\r
+ sig0ij=sigma(itypi,itypj)\r
+ chi1=chi(itypi,itypj)\r
+ chi2=chi(itypj,itypi)\r
+ chi12=chi1*chi2\r
+ chip1=chip(itypi)\r
+ chip2=chip(itypj)\r
+ chip12=chip1*chip2\r
+ alf1=alp(itypi)\r
+ alf2=alp(itypj)\r
+ alf12=0.5D0*(alf1+alf2)\r
+C For diagnostics only!!!\r
+c chi1=0.0D0\r
+c chi2=0.0D0\r
+c chi12=0.0D0\r
+c chip1=0.0D0\r
+c chip2=0.0D0\r
+c chip12=0.0D0\r
+c alf1=0.0D0\r
+c alf2=0.0D0\r
+c alf12=0.0D0\r
+ xj=c(1,nres+j)-xi\r
+ yj=c(2,nres+j)-yi\r
+ zj=c(3,nres+j)-zi\r
+ dxj=dc_norm(1,nres+j)\r
+ dyj=dc_norm(2,nres+j)\r
+ dzj=dc_norm(3,nres+j)\r
+c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi\r
+c write (iout,*) "j",j," dc_norm",\r
+c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)\r
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
+ rij=dsqrt(rrij)\r
+c---------------------------------------------------------------\r
+C Calculate angle-dependent terms of energy and contributions to their\r
+C derivatives.\r
+ call sc_angular\r
+ sigsq=1.0D0/sigsq\r
+ sig=sig0ij*dsqrt(sigsq)\r
+ rij_shift=1.0D0/rij-sig+sig0ij\r
+c for diagnostics; uncomment\r
+c rij_shift=1.2*sig0ij\r
+C I hate to put IF's in the loops, but here don't have another choice!!!!\r
+ if (rij_shift.le.0.0D0) then\r
+ evdw=1.0D20\r
+cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')\r
+cd & restyp(itypi),i,restyp(itypj),j,\r
+cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) \r
+ return\r
+ endif\r
+ sigder=-sig*sigsq\r
+c---------------------------------------------------------------\r
+ rij_shift=1.0D0/rij_shift \r
+ fac=rij_shift**expon\r
+ e1=fac*fac*aa(itypi,itypj)\r
+ e2=fac*bb(itypi,itypj)\r
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)\r
+ eps2der=evdwij*eps3rt\r
+ eps3der=evdwij*eps2rt\r
+c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,\r
+c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2\r
+ evdwij=evdwij*eps2rt*eps3rt\r
+#ifdef TSCSC\r
+ if (bb(itypi,itypj).gt.0) then\r
+ evdw_p=evdw_p+evdwij\r
+ else\r
+ evdw_m=evdw_m+evdwij\r
+ endif\r
+#else\r
+ evdw=evdw+evdwij\r
+#endif\r
+ if (lprn) then\r
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)\r
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)\r
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')\r
+ & restyp(itypi),i,restyp(itypj),j,\r
+ & epsi,sigm,chi1,chi2,chip1,chip2,\r
+ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,\r
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,\r
+ & evdwij\r
+ endif\r
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') \r
+ & 'evdw',i,j,evdwij\r
+C Calculate gradient components.\r
+ e1=e1*eps1*eps2rt**2*eps3rt**2\r
+ fac=-expon*(e1+evdwij)*rij_shift\r
+ sigder = fac * sigder\r
+ fac = rij * fac\r
+c fac=0.0d0\r
+C Calculate the radial part of the gradient\r
+ gg(1) = xj * fac\r
+ gg(2) = yj * fac\r
+ gg(3) = zj * fac\r
+C Calculate angular part of the gradient.\r
+#ifdef TSCSC\r
+ if (bb(itypi,itypj).gt.0) then\r
+ call sc_grad\r
+ else\r
+ call sc_grad_T\r
+ endif\r
+#else\r
+ call sc_grad\r
+#endif\r
+ enddo ! j\r
+ enddo ! iint\r
+ enddo ! i\r
+c write (iout,*) "Number of loop steps in EGB:",ind\r
+cccc energy_dec=.false.\r
+ return\r
+ end\r
+\r
+\r
+C-----------------------------------------------------------------------------\r
+\r
+\r
+ subroutine egbv(evdw,evdw_p,evdw_m)\r
+C\r
+C This subroutine calculates the interaction energy of nonbonded side chains\r
+C assuming the Gay-Berne-Vorobjev potential of interaction.\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CALC'\r
+ common /srutu/ icall\r
+ logical lprn\r
+ evdw=0.0D0\r
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon\r
+c evdw=0.0D0\r
+ lprn=.false.\r
+c if (icall.eq.0) lprn=.true.\r
+ ind=0\r
+ do i=iatsc_s,iatsc_e\r
+ itypi=itype(i)\r
+ itypi1=itype(i+1)\r
+ xi=c(1,nres+i)\r
+ yi=c(2,nres+i)\r
+ zi=c(3,nres+i)\r
+ dxi=dc_norm(1,nres+i)\r
+ dyi=dc_norm(2,nres+i)\r
+ dzi=dc_norm(3,nres+i)\r
+c dsci_inv=dsc_inv(itypi)\r
+ dsci_inv=vbld_inv(i+nres)\r
+C\r
+C Calculate SC interaction energy.\r
+C\r
+ do iint=1,nint_gr(i)\r
+ do j=istart(i,iint),iend(i,iint)\r
+ ind=ind+1\r
+ itypj=itype(j)\r
+c dscj_inv=dsc_inv(itypj)\r
+ dscj_inv=vbld_inv(j+nres)\r
+ sig0ij=sigma(itypi,itypj)\r
+ r0ij=r0(itypi,itypj)\r
+ chi1=chi(itypi,itypj)\r
+ chi2=chi(itypj,itypi)\r
+ chi12=chi1*chi2\r
+ chip1=chip(itypi)\r
+ chip2=chip(itypj)\r
+ chip12=chip1*chip2\r
+ alf1=alp(itypi)\r
+ alf2=alp(itypj)\r
+ alf12=0.5D0*(alf1+alf2)\r
+C For diagnostics only!!!\r
+c chi1=0.0D0\r
+c chi2=0.0D0\r
+c chi12=0.0D0\r
+c chip1=0.0D0\r
+c chip2=0.0D0\r
+c chip12=0.0D0\r
+c alf1=0.0D0\r
+c alf2=0.0D0\r
+c alf12=0.0D0\r
+ xj=c(1,nres+j)-xi\r
+ yj=c(2,nres+j)-yi\r
+ zj=c(3,nres+j)-zi\r
+ dxj=dc_norm(1,nres+j)\r
+ dyj=dc_norm(2,nres+j)\r
+ dzj=dc_norm(3,nres+j)\r
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
+ rij=dsqrt(rrij)\r
+C Calculate angle-dependent terms of energy and contributions to their\r
+C derivatives.\r
+ call sc_angular\r
+ sigsq=1.0D0/sigsq\r
+ sig=sig0ij*dsqrt(sigsq)\r
+ rij_shift=1.0D0/rij-sig+r0ij\r
+C I hate to put IF's in the loops, but here don't have another choice!!!!\r
+ if (rij_shift.le.0.0D0) then\r
+ evdw=1.0D20\r
+ return\r
+ endif\r
+ sigder=-sig*sigsq\r
+c---------------------------------------------------------------\r
+ rij_shift=1.0D0/rij_shift \r
+ fac=rij_shift**expon\r
+ e1=fac*fac*aa(itypi,itypj)\r
+ e2=fac*bb(itypi,itypj)\r
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)\r
+ eps2der=evdwij*eps3rt\r
+ eps3der=evdwij*eps2rt\r
+ fac_augm=rrij**expon\r
+ e_augm=augm(itypi,itypj)*fac_augm\r
+ evdwij=evdwij*eps2rt*eps3rt\r
+#ifdef TSCSC\r
+ if (bb(itypi,itypj).gt.0) then\r
+ evdw_p=evdw_p+evdwij+e_augm\r
+ else\r
+ evdw_m=evdw_m+evdwij+e_augm\r
+ endif\r
+#else\r
+ evdw=evdw+evdwij+e_augm\r
+#endif\r
+ if (lprn) then\r
+ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)\r
+ epsi=bb(itypi,itypj)**2/aa(itypi,itypj)\r
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')\r
+ & restyp(itypi),i,restyp(itypj),j,\r
+ & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),\r
+ & chi1,chi2,chip1,chip2,\r
+ & eps1,eps2rt**2,eps3rt**2,\r
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,\r
+ & evdwij+e_augm\r
+ endif\r
+C Calculate gradient components.\r
+ e1=e1*eps1*eps2rt**2*eps3rt**2\r
+ fac=-expon*(e1+evdwij)*rij_shift\r
+ sigder=fac*sigder\r
+ fac=rij*fac-2*expon*rrij*e_augm\r
+C Calculate the radial part of the gradient\r
+ gg(1)=xj*fac\r
+ gg(2)=yj*fac\r
+ gg(3)=zj*fac\r
+C Calculate angular part of the gradient.\r
+#ifdef TSCSC\r
+ if (bb(itypi,itypj).gt.0) then\r
+ call sc_grad\r
+ else\r
+ call sc_grad_T\r
+ endif\r
+#else\r
+ call sc_grad\r
+#endif\r
+ enddo ! j\r
+ enddo ! iint\r
+ enddo ! i\r
+ end\r
+\r
+\r
+C-----------------------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE emomo(evdw,evdw_p,evdw_m)\r
+C\r
+C This subroutine calculates the interaction energy of nonbonded side chains\r
+C assuming the Gay-Berne potential of interaction.\r
+C\r
+ IMPLICIT NONE\r
+ INCLUDE 'DIMENSIONS'\r
+ INCLUDE 'COMMON.CALC'\r
+ INCLUDE 'COMMON.CONTROL'\r
+ INCLUDE 'COMMON.CHAIN'\r
+ INCLUDE 'COMMON.DERIV'\r
+ INCLUDE 'COMMON.EMP'\r
+ INCLUDE 'COMMON.GEO'\r
+ INCLUDE 'COMMON.INTERACT'\r
+ INCLUDE 'COMMON.IOUNITS'\r
+ INCLUDE 'COMMON.LOCAL'\r
+ INCLUDE 'COMMON.NAMES'\r
+ INCLUDE 'COMMON.VAR'\r
+ logical lprn\r
+ double precision scalar\r
+ double precision ener(4)\r
+ evdw = 0.0D0\r
+ evdw_p = 0.0D0\r
+ evdw_m = 0.0D0\r
+c DIAGNOSTICS\r
+ccccc energy_dec=.false.\r
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon\r
+c lprn = .false.\r
+c if (icall.eq.0) lprn=.false.\r
+c END DIAGNOSTICS\r
+c ind = 0\r
+ DO i = iatsc_s, iatsc_e\r
+ itypi = itype(i)\r
+c itypi1 = itype(i+1)\r
+ dxi = dc_norm(1,nres+i)\r
+ dyi = dc_norm(2,nres+i)\r
+ dzi = dc_norm(3,nres+i)\r
+c dsci_inv=dsc_inv(itypi)\r
+ dsci_inv = vbld_inv(i+nres)\r
+c! This small loop calculates hydrophobic centre location\r
+c! by taking Calpha location and moving by appropriate\r
+c! vector built by dtail * dc_norm\r
+ DO k = 1, 3\r
+ ctail(k,1) = c(k, i+nres)\r
+ & - dtail(k, itypi) * dc_norm(k, nres+i)\r
+ END DO\r
+ xi=c(1,nres+i)\r
+ yi=c(2,nres+i)\r
+ zi=c(3,nres+i)\r
+c!-------------------------------------------------------------------\r
+C Calculate SC interaction energy.\r
+ DO iint = 1, nint_gr(i)\r
+ DO j = istart(i,iint), iend(i,iint)\r
+c! initialize variables for electrostatic gradients\r
+ CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)\r
+c ind=ind+1\r
+c dscj_inv = dsc_inv(itypj)\r
+ dscj_inv = vbld_inv(j+nres)\r
+c! rij holds 1/(distance of Calpha atoms)\r
+ rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)\r
+ rij = dsqrt(rrij)\r
+c!-------------------------------------------------------------------\r
+C Calculate angle-dependent terms of energy and contributions to their\r
+C derivatives.\r
+ CALL sc_angular\r
+c! this should be in elgrad_init but om's are calculated by sc_angular\r
+c! which in turn is used by older potentials\r
+c! which proves how tangled UNRES code is >.<\r
+c! om = omega, sqom = om^2\r
+ sqom1 = om1 * om1\r
+ sqom2 = om2 * om2\r
+ sqom12 = om12 * om12\r
+c! now we calculate FGB - Gey-Berne Force.\r
+c! It will be summed up in evdwij and saved in evdw\r
+ sigsq = 1.0D0 / sigsq\r
+ sig = sig0ij * dsqrt(sigsq)\r
+ rij_shift = 1.0D0 / rij - sig + sig0ij\r
+ IF (rij_shift.le.0.0D0) THEN\r
+ evdw = 1.0D20\r
+ RETURN\r
+ END IF\r
+ sigder = -sig * sigsq\r
+ rij_shift = 1.0D0 / rij_shift \r
+ fac = rij_shift**expon\r
+ c1 = fac * fac * aa(itypi,itypj)\r
+ c2 = fac * bb(itypi,itypj)\r
+ evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 )\r
+ eps2der = evdwij * eps3rt\r
+ eps3der = evdwij * eps2rt\r
+ evdwij = evdwij * eps2rt * eps3rt\r
+#ifdef TSCSC\r
+ IF (bb(itypi,itypj).gt.0) THEN\r
+ evdw_p = evdw_p + evdwij\r
+ ELSE\r
+ evdw_m = evdw_m + evdwij\r
+ END IF\r
+#else\r
+ evdw = evdw\r
+ & + evdwij\r
+#endif\r
+c!-------------------------------------------------------------------\r
+c! Calculate some components of GGB and EGB\r
+ c1 = c1 * eps1 * eps2rt**2 * eps3rt**2\r
+ fac = -expon * (c1 + evdwij) * rij_shift\r
+ sigder = fac * sigder\r
+ fac = rij * fac\r
+c! fac = 0.0d0\r
+c! Calculate the radial part of GGB\r
+ gg(1) = xj * fac\r
+ gg(2) = yj * fac\r
+ gg(3) = zj * fac\r
+\r
+c! The angular derivatives of GGB are brought together in sc_grad\r
+c!-------------------------------------------------------------------\r
+c! Fcav\r
+c!\r
+c! Catch gly-gly interactions to skip calculation of something that\r
+c! does not exist\r
+\r
+ IF (itypi.eq.10.and.itypj.eq.10) THEN\r
+ Fcav = 0.0d0\r
+ dFdR = 0.0d0\r
+ dCAVdOM1 = 0.0d0\r
+ dCAVdOM2 = 0.0d0\r
+ dCAVdOM12 = 0.0d0\r
+ ELSE\r
+\r
+c! we are not 2 glycines, so we calculate Fcav\r
+ fac = chis1 * sqom1 + chis2 * sqom2\r
+ & - 2.0d0 * chis12 * om1 * om2 * om12\r
+c! we will use pom later in Gcav, so dont mess with it!\r
+ pom = 1.0d0 - chis1 * chis2 * sqom12\r
+\r
+ Lambf = (1.0d0 - (fac / pom))\r
+ Lambf = dsqrt(Lambf)\r
+\r
+ sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)\r
+ Chif = Rtail * sparrow\r
+ ChiLambf = Chif * Lambf\r
+ eagle = dsqrt(ChiLambf)\r
+ bat = ChiLambf ** 11.0d0\r
+\r
+ top = b1 * ( eagle + b2 * ChiLambf - b3 )\r
+ bot = 1.0d0 + b4 * (ChiLambf * bat)\r
+ botsq = bot * bot\r
+\r
+ Fcav = top / bot\r
+\r
+c!-------------------------------------------------------------------\r
+c! derivative of Fcav is Gcav...\r
+c!---------------------------------------------------\r
+\r
+ dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))\r
+ dbot = 12.0d0 * b4 * bat * Lambf\r
+ dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow\r
+\r
+ dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))\r
+ dbot = 12.0d0 * b4 * bat * Chif\r
+ eagle = Lambf * pom\r
+ dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)\r
+ dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)\r
+ dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)\r
+ & * (chis2 * om2 * om12 - om1) / (eagle * pom)\r
+\r
+ dFdL = ((dtop * bot - top * dbot) / botsq)\r
+ dCAVdOM1 = dFdL * ( dFdOM1 )\r
+ dCAVdOM2 = dFdL * ( dFdOM2 )\r
+ dCAVdOM12 = dFdL * ( dFdOM12 )\r
+c!----------------------------------------------------\r
+c! Finally, add the distance derivatives to gvdwc\r
+c! Fac is used here to project the gradient vector into\r
+c! cartesian coordinates\r
+c! derivatives of omega angles will be added in sc_grad\r
+ DO k = 1, 3\r
+ fac = Rtail_distance(k) / Rtail\r
+ gvdwx(k,i) = gvdwx(k,i)\r
+ & - dFdR * fac\r
+\r
+ gvdwx(k,j) = gvdwx(k,j)\r
+ & + dFdR * fac\r
+\r
+ gvdwc(k,i) = gvdwc(k,i)\r
+ & - dFdR * fac\r
+\r
+ gvdwc(k,j) = gvdwc(k,j)\r
+ & + dFdR * fac\r
+ END DO\r
+\r
+c!-------------------------------------------------------------------\r
+c! Compute head-head and head-tail energies for each state\r
+\r
+ isel = iabs(Qi) + iabs(Qj)\r
+ IF (isel.eq.0) THEN\r
+c! No charges - do nothing\r
+ eheadtail = 0.0d0\r
+\r
+ ELSE IF (isel.eq.4) THEN\r
+c! Calculate dipole-dipole interactions\r
+ CALL edd(ecl)\r
+ eheadtail = ECL\r
+\r
+ ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN\r
+c! Charge-nonpolar interactions\r
+ CALL eqn(epol)\r
+ eheadtail = epol\r
+\r
+ ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN\r
+c! Nonpolar-charge interactions\r
+ CALL enq(epol)\r
+ eheadtail = epol\r
+\r
+ ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN\r
+c! Charge-dipole interactions\r
+ CALL eqd(ecl, elj, epol)\r
+ eheadtail = ECL + elj + epol\r
+\r
+ ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN\r
+c! Dipole-charge interactions\r
+ CALL edq(ecl, elj, epol)\r
+ eheadtail = ECL + elj + epol\r
+\r
+ ELSE IF ((isel.eq.2.and.\r
+ & iabs(Qi).eq.1).and.\r
+ & nstate(itypi,itypj).eq.1) THEN\r
+c! Same charge-charge interaction ( +/+ or -/- )\r
+ CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)\r
+ eheadtail = ECL + Egb + Epol + Fisocav + Elj\r
+\r
+ ELSE IF ((isel.eq.2.and.\r
+ & iabs(Qi).eq.1).and.\r
+ & nstate(itypi,itypj).ne.1) THEN\r
+c! Different charge-charge interaction ( +/- or -/+ )\r
+ CALL energy_quad\r
+ & (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)\r
+ END IF\r
+\r
+c! this endif ends the "catch the gly-gly" at the beggining of Fcav\r
+ END IF\r
+ evdw = evdw\r
+ & + Fcav\r
+ & + eheadtail\r
+c!-------------------------------------------------------------------\r
+c! As all angular derivatives are done, now we sum them up,\r
+c! then transform and project into cartesian vectors and add to gvdwc\r
+c! We call sc_grad always, with the exception of +/- interaction.\r
+c! This is because energy_quad subroutine needs to handle\r
+c! this job in his own way.\r
+c! This IS probably not very efficient and SHOULD be optimised\r
+c! but it will require major restructurization of emomo\r
+c! so it will be left as it is for now\r
+ IF (nstate(itypi,itypj).eq.1) THEN\r
+#ifdef TSCSC\r
+ IF (bb(itypi,itypj).gt.0) THEN\r
+ CALL sc_grad\r
+ ELSE\r
+ CALL sc_grad_T\r
+ END IF\r
+#else\r
+ CALL sc_grad\r
+#endif\r
+ END IF\r
+c!-------------------------------------------------------------------\r
+c! NAPISY KONCOWE\r
+c! j\r
+ END DO\r
+c! iint\r
+ END DO\r
+c! i\r
+ END DO\r
+c write (iout,*) "Number of loop steps in EGB:",ind\r
+cccc energy_dec=.false.\r
+ RETURN\r
+ END SUBROUTINE emomo\r
+\r
+c! END OF MOMO\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)\r
+ IMPLICIT NONE\r
+ INCLUDE 'DIMENSIONS'\r
+ INCLUDE 'COMMON.CALC'\r
+ INCLUDE 'COMMON.CHAIN'\r
+ INCLUDE 'COMMON.CONTROL'\r
+ INCLUDE 'COMMON.DERIV'\r
+ INCLUDE 'COMMON.EMP'\r
+ INCLUDE 'COMMON.GEO'\r
+ INCLUDE 'COMMON.INTERACT'\r
+ INCLUDE 'COMMON.IOUNITS'\r
+ INCLUDE 'COMMON.LOCAL'\r
+ INCLUDE 'COMMON.NAMES'\r
+ INCLUDE 'COMMON.VAR'\r
+ double precision scalar\r
+c! Epol and Gpol analytical parameters\r
+ alphapol1 = alphapol(itypi,itypj)\r
+ alphapol2 = alphapol(itypj,itypi)\r
+c! Fisocav and Gisocav analytical parameters\r
+ al1 = alphiso(1,itypi,itypj)\r
+ al2 = alphiso(2,itypi,itypj)\r
+ al3 = alphiso(3,itypi,itypj)\r
+ al4 = alphiso(4,itypi,itypj)\r
+ csig = sigiso(itypi, itypj)\r
+c!\r
+ w1 = wqdip(1,itypi,itypj)\r
+ w2 = wqdip(2,itypi,itypj)\r
+ pis = sig0head(itypi,itypj)\r
+ eps0 = epshead(itypi,itypj)\r
+ Rhead_sq = Rhead * Rhead\r
+\r
+c! R1 - distance between head of ith side chain and tail of jth sidechain\r
+c! R2 - distance between head of jth side chain and tail of ith sidechain\r
+ R1 = 0.0d0\r
+ R2 = 0.0d0\r
+ DO k = 1, 3\r
+c! Calculate head-to-tail distances\r
+ R1=R1+(ctail(k,2)-chead(k,1))**2\r
+ R2=R2+(chead(k,2)-ctail(k,1))**2\r
+ END DO\r
+c! Pitagoras\r
+ R1 = dsqrt(R1)\r
+ R2 = dsqrt(R2)\r
+\r
+c!-------------------------------------------------------------------\r
+c! Coulomb electrostatic interaction\r
+ Ecl = (332.0d0 * Qij) / Rhead\r
+c! write (*,*) "Ecl = ", Ecl\r
+c! derivative of Ecl is Gcl...\r
+ dGCLdR = (-332.0d0 * Qij ) / Rhead_sq\r
+c! =============\r
+c! Ecl = 0.0d0\r
+c! dGCLdR = 0.0d0\r
+c! =============\r
+ dGCLdOM1 = 0.0d0\r
+ dGCLdOM2 = 0.0d0\r
+ dGCLdOM12 = 0.0d0\r
+c!-------------------------------------------------------------------\r
+c! Generalised Born Solvent Polarization\r
+ ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))\r
+ Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)\r
+ Egb = (332.0d0 * Qij * eps_inout_fac) / Fgb\r
+\r
+c! Derivative of Egb is Ggb...\r
+ dGGBdFGB = (-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)\r
+ dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )\r
+ & / ( 2.0d0 * Fgb )\r
+ dGGBdR = dGGBdFGB * dFGBdR\r
+\r
+c! =============\r
+c! write (*,*) "Fgb = ", Fgb\r
+c! write (*,*) "Egb = ", Egb\r
+c! write (*,*) "dFGBdR = ", dFGBdR\r
+c! write (*,*) "dGGBdR = ", dGGBdR\r
+c! Egb = 0.0d0\r
+c! dGGBdR = 0.0d0\r
+c! =============\r
+c!-------------------------------------------------------------------\r
+c! Fisocav - isotropic cavity creation term\r
+ pom = Rhead * csig\r
+ top = al1 * (dsqrt(pom) + al2 * pom - al3)\r
+ bot = (1.0d0 + al4 * pom**12.0d0)\r
+ botsq = bot * bot\r
+ FisoCav = top / bot\r
+\r
+c! Derivative of Fisocav is GCV...\r
+ dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)\r
+ dbot = 12.0d0 * al4 * pom ** 11.0d0\r
+ dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig\r
+\r
+c! =============\r
+c! FisoCav = 0.0d0\r
+c! dGCVdR = 0.0d0\r
+c! =============\r
+c!-------------------------------------------------------------------\r
+c! Polarization energy\r
+c! Epol\r
+ MomoFac1 = (1.0d0 - chi1 * sqom2)\r
+ MomoFac2 = (1.0d0 - chi2 * sqom1)\r
+ RR1 = ( R1 * R1 ) / MomoFac1\r
+ RR2 = ( R2 * R2 ) / MomoFac2\r
+ ee1 = exp(-( RR1 / (4.0d0 * a12sq) ))\r
+ ee2 = exp(-( RR2 / (4.0d0 * a12sq) ))\r
+ fgb1 = sqrt( RR1 + a12sq * ee1 )\r
+ fgb2 = sqrt( RR2 + a12sq * ee2 )\r
+ epol = 332.0d0 * eps_inout_fac * (\r
+ & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))\r
+\r
+c! derivative of Epol is Gpol...\r
+ dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)\r
+ & / (fgb1 ** 5.0d0)\r
+ dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)\r
+ & / (fgb2 ** 5.0d0)\r
+ dFGBdR1 = ( (R1 / MomoFac1)\r
+ & * ( 2.0d0 - (0.5d0 * ee1) ) )\r
+ & / ( 2.0d0 * fgb1 )\r
+ dFGBdR2 = ( (R2 / MomoFac2)\r
+ & * ( 2.0d0 - (0.5d0 * ee2) ) )\r
+ & / ( 2.0d0 * fgb2 )\r
+ dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))\r
+ & * ( 2.0d0 - 0.5d0 * ee1) )\r
+ & / ( 2.0d0 * fgb1 )\r
+ dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))\r
+ & * ( 2.0d0 - 0.5d0 * ee2) )\r
+ & / ( 2.0d0 * fgb2 )\r
+ dPOLdR1 = dPOLdFGB1 * dFGBdR1\r
+ dPOLdR2 = dPOLdFGB2 * dFGBdR2\r
+ dPOLdOM1 = dPOLdFGB2 * dFGBdOM1\r
+ dPOLdOM2 = dPOLdFGB1 * dFGBdOM2\r
+c! =============\r
+c! Epol = 0.0d0\r
+c! dPOLdR1 = 0.0d0\r
+c! dPOLdR2 = 0.0d0\r
+c! dPOLdOM1 = 0.0d0\r
+c! dPOLdOM2 = 0.0d0\r
+c! =============\r
+c!-------------------------------------------------------------------\r
+c! Elj\r
+ pom = (pis / Rhead)**6.0d0\r
+ Elj = 4.0d0 * eps0 * pom * (pom-1.0d0)\r
+c! write (*,*) "ELJ = ", ELJ\r
+c! derivative of Elj is Glj\r
+ Glj = 4.0d0 * eps0 \r
+ & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))\r
+ & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0)))\r
+c! dGLJdR = glj * fish\r
+ dGLJdR = glj\r
+c! =============\r
+c! Elj = 0.0d0\r
+c! dGLJdR = 0.0d0\r
+c! =============\r
+c!-------------------------------------------------------------------\r
+c! Return the results\r
+ DO k = 1, 3\r
+ erhead(k) = Rhead_distance(k)/Rhead\r
+ erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)\r
+ erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)\r
+ END DO\r
+\r
+ erdxi = scalar( erhead(1), dC_norm(1,i+nres) )\r
+ erdxj = scalar( erhead(1), dC_norm(1,j+nres) )\r
+ bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )\r
+ eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )\r
+ facd1 = d1 * vbld_inv(i+nres)\r
+ facd2 = d2 * vbld_inv(j+nres)\r
+\r
+ DO k = 1, 3\r
+ hawk = (erhead_tail(k,1) + \r
+ & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))\r
+ condor = (erhead_tail(k,2) +\r
+ & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))\r
+\r
+ pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))\r
+ gvdwx(k,i) = gvdwx(k,i)\r
+ & - dGCLdR * pom\r
+ & - dGGBdR * pom\r
+ & - dGCVdR * pom\r
+ & - dPOLdR1 * hawk\r
+ & - dPOLdR2 * erhead_tail(k,2)\r
+ & - dGLJdR * pom\r
+\r
+ pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))\r
+ gvdwx(k,j) = gvdwx(k,j)\r
+ & + dGCLdR * pom\r
+ & + dGGBdR * pom\r
+ & + dGCVdR * pom\r
+ & + dPOLdR1 * erhead_tail(k,1)\r
+ & + dPOLdR2 * condor\r
+ & + dGLJdR * pom\r
+\r
+ gvdwc(k,i) = gvdwc(k,i)\r
+ & - dGCLdR * erhead(k)\r
+ & - dGGBdR * erhead(k)\r
+ & - dGCVdR * erhead(k)\r
+ & - dPOLdR1 * erhead_tail(k,1)\r
+ & - dPOLdR2 * erhead_tail(k,2)\r
+ & - dGLJdR * erhead(k)\r
+\r
+ gvdwc(k,j) = gvdwc(k,j)\r
+ & + dGCLdR * erhead(k)\r
+ & + dGGBdR * erhead(k)\r
+ & + dGCVdR * erhead(k)\r
+ & + dPOLdR1 * erhead_tail(k,1)\r
+ & + dPOLdR2 * erhead_tail(k,2)\r
+ & + dGLJdR * erhead(k)\r
+\r
+ END DO\r
+ RETURN\r
+ END SUBROUTINE eqq\r
+\r
+\r
+c!-------------------------------------------------------------------\r
+\r
+ SUBROUTINE energy_quad\r
+ &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)\r
+ IMPLICIT NONE\r
+ INCLUDE 'DIMENSIONS'\r
+ INCLUDE 'COMMON.CALC'\r
+ INCLUDE 'COMMON.CHAIN'\r
+ INCLUDE 'COMMON.CONTROL'\r
+ INCLUDE 'COMMON.DERIV'\r
+ INCLUDE 'COMMON.EMP'\r
+ INCLUDE 'COMMON.GEO'\r
+ INCLUDE 'COMMON.INTERACT'\r
+ INCLUDE 'COMMON.IOUNITS'\r
+ INCLUDE 'COMMON.LOCAL'\r
+ INCLUDE 'COMMON.NAMES'\r
+ INCLUDE 'COMMON.VAR'\r
+ double precision scalar\r
+ double precision ener(4)\r
+ double precision dcosom1(3),dcosom2(3)\r
+c! Epol and Gpol analytical parameters\r
+ alphapol1 = alphapol(itypi,itypj)\r
+ alphapol2 = alphapol(itypj,itypi)\r
+c! Fisocav and Gisocav analytical parameters\r
+ al1 = alphiso(1,itypi,itypj)\r
+ al2 = alphiso(2,itypi,itypj)\r
+ al3 = alphiso(3,itypi,itypj)\r
+ al4 = alphiso(4,itypi,itypj)\r
+ csig = sigiso(itypi, itypj)\r
+c!\r
+ w1 = wqdip(1,itypi,itypj)\r
+ w2 = wqdip(2,itypi,itypj)\r
+ pis = sig0head(itypi,itypj)\r
+ eps0 = epshead(itypi,itypj)\r
+\r
+c! First things first:\r
+c! We need to do sc_grad's job with GB and Fcav\r
+\r
+ eom1 =\r
+ & eps2der * eps2rt_om1\r
+ & - 2.0D0 * alf1 * eps3der\r
+ & + sigder * sigsq_om1\r
+ & + dCAVdOM1\r
+\r
+ eom2 =\r
+ & eps2der * eps2rt_om2\r
+ & + 2.0D0 * alf2 * eps3der\r
+ & + sigder * sigsq_om2\r
+ & + dCAVdOM2\r
+\r
+ eom12 =\r
+ & evdwij * eps1_om12\r
+ & + eps2der * eps2rt_om12\r
+ & - 2.0D0 * alf12 * eps3der\r
+ & + sigder *sigsq_om12\r
+ & + dCAVdOM12\r
+\r
+c! now some magical transformations to project gradient into\r
+c! three cartesian vectors\r
+\r
+ DO k = 1, 3\r
+ dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))\r
+ dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))\r
+ gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)\r
+c! this acts on hydrophobic center of interaction\r
+ gvdwx(k,i)= gvdwx(k,i) - gg(k)\r
+ & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
+ & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
+ gvdwx(k,j)= gvdwx(k,j) + gg(k)\r
+ & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
+ & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
+c! this acts on Calpha\r
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
+ END DO\r
+\r
+c! sc_grad is done, now we will compute \r
+\r
+ eheadtail = 0.0d0\r
+ eom1 = 0.0d0\r
+ eom2 = 0.0d0\r
+ eom12 = 0.0d0\r
+c*************************************************************\r
+ DO istate = 1, nstate(itypi,itypj)\r
+c! DO istate = 1, 1\r
+c! write (*,*) "istate = ", istate\r
+c*************************************************************\r
+ IF (istate.ne.1) THEN\r
+ IF (istate.lt.3) THEN\r
+ ii = 1\r
+ ELSE\r
+ ii = 2\r
+ END IF\r
+ jj = istate/ii\r
+ d1 = dhead(1,ii,itypi,itypj)\r
+ d2 = dhead(2,jj,itypi,itypj)\r
+ DO k = 1,3\r
+ chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)\r
+ chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)\r
+ Rhead_distance(k) = chead(k,2) - chead(k,1)\r
+ END DO\r
+c! pitagoras (root of sum of squares)\r
+ Rhead = dsqrt(\r
+ & (Rhead_distance(1)*Rhead_distance(1))\r
+ & + (Rhead_distance(2)*Rhead_distance(2))\r
+ & + (Rhead_distance(3)*Rhead_distance(3)))\r
+ END IF\r
+ Rhead_sq = Rhead * Rhead\r
+\r
+c! R1 - distance between head of ith side chain and tail of jth sidechain\r
+c! R2 - distance between head of jth side chain and tail of ith sidechain\r
+ R1 = 0.0d0\r
+ R2 = 0.0d0\r
+ DO k = 1, 3\r
+c! Calculate head-to-tail distances\r
+ R1=R1+(ctail(k,2)-chead(k,1))**2\r
+ R2=R2+(chead(k,2)-ctail(k,1))**2\r
+ END DO\r
+c! Pitagoras\r
+ R1 = dsqrt(R1)\r
+ R2 = dsqrt(R2)\r
+\r
+c!-------------------------------------------------------------------\r
+c! Coulomb electrostatic interaction\r
+ Ecl = (332.0d0 * Qij) / Rhead\r
+c! write (*,*) "Ecl = ", Ecl\r
+c! derivative of Ecl is Gcl...\r
+ dGCLdR = (-332.0d0 * Qij ) / Rhead_sq\r
+c! =============\r
+c! write (*,*) "Ecl = ", Ecl\r
+c! write (*,*) "dGCLdR = ", dGCLdR\r
+c! Ecl = 0.0d0\r
+c! dGCLdR = 0.0d0\r
+c! =============\r
+ dGCLdOM1 = 0.0d0\r
+ dGCLdOM2 = 0.0d0\r
+ dGCLdOM12 = 0.0d0\r
+c!-------------------------------------------------------------------\r
+c! Generalised Born Solvent Polarization\r
+ ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))\r
+ Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)\r
+ Egb = (332.0d0 * Qij * eps_inout_fac) / Fgb\r
+\r
+c! Derivative of Egb is Ggb...\r
+ dGGBdFGB = (-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)\r
+ dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )\r
+ & / ( 2.0d0 * Fgb )\r
+ dGGBdR = dGGBdFGB * dFGBdR\r
+\r
+c! =============\r
+c! write (*,*) "Fgb = ", Fgb\r
+c! write (*,*) "Egb = ", Egb\r
+c! write (*,*) "dFGBdR = ", dFGBdR\r
+c! write (*,*) "dGGBdR = ", dGGBdR\r
+c! Egb = 0.0d0\r
+c! dGGBdR = 0.0d0\r
+c! =============\r
+c!-------------------------------------------------------------------\r
+c! Fisocav - isotropic cavity creation term\r
+ pom = Rhead * csig\r
+ top = al1 * (dsqrt(pom) + al2 * pom - al3)\r
+ bot = (1.0d0 + al4 * pom**12.0d0)\r
+ botsq = bot * bot\r
+ FisoCav = top / bot\r
+\r
+c! Derivative of Fisocav is GCV...\r
+ dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)\r
+ dbot = 12.0d0 * al4 * pom ** 11.0d0\r
+ dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig\r
+\r
+c! =============\r
+c! write(*,*) "FisoCav = ", Fisocav\r
+c! write(*,*) "dGCVdR = ", dGCVdR\r
+c! FisoCav = 0.0d0\r
+c! dGCVdR = 0.0d0\r
+c! =============\r
+c!-------------------------------------------------------------------\r
+c! Polarization energy\r
+c! Epol\r
+ MomoFac1 = (1.0d0 - chi1 * sqom2)\r
+ MomoFac2 = (1.0d0 - chi2 * sqom1)\r
+ RR1 = ( R1 * R1 ) / MomoFac1\r
+ RR2 = ( R2 * R2 ) / MomoFac2\r
+ ee1 = exp(-( RR1 / (4.0d0 * a12sq) ))\r
+ ee2 = exp(-( RR2 / (4.0d0 * a12sq) ))\r
+ fgb1 = sqrt( RR1 + a12sq * ee1 )\r
+ fgb2 = sqrt( RR2 + a12sq * ee2 )\r
+ epol = 332.0d0 * eps_inout_fac * (\r
+ & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))\r
+\r
+c! derivative of Epol is Gpol...\r
+ dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)\r
+ & / (fgb1 ** 5.0d0)\r
+ dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)\r
+ & / (fgb2 ** 5.0d0)\r
+ dFGBdR1 = ( (R1 / MomoFac1)\r
+ & * ( 2.0d0 - (0.5d0 * ee1) ) )\r
+ & / ( 2.0d0 * fgb1 )\r
+ dFGBdR2 = ( (R2 / MomoFac2)\r
+ & * ( 2.0d0 - (0.5d0 * ee2) ) )\r
+ & / ( 2.0d0 * fgb2 )\r
+ dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))\r
+ & * ( 2.0d0 - 0.5d0 * ee1) )\r
+ & / ( 2.0d0 * fgb1 )\r
+ dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))\r
+ & * ( 2.0d0 - 0.5d0 * ee2) )\r
+ & / ( 2.0d0 * fgb2 )\r
+ dPOLdR1 = dPOLdFGB1 * dFGBdR1\r
+ dPOLdR2 = dPOLdFGB2 * dFGBdR2\r
+ dPOLdOM1 = dPOLdFGB2 * dFGBdOM1\r
+ dPOLdOM2 = dPOLdFGB1 * dFGBdOM2\r
+c! =============\r
+c! write(*,*) "Epol = ", Epol\r
+c! write(*,*) "dPOLdR1 = ", dPOLdOM2\r
+c! write(*,*) "dPOLdR2 = ", dPOLdR2\r
+c! write(*,*) "dPOLdOM1 = ", dPOLdOM1\r
+c! write(*,*) "dPOLdOM2 = ", dPOLdOM2\r
+c! Epol = 0.0d0\r
+c! dPOLdR1 = 0.0d0\r
+c! dPOLdR2 = 0.0d0\r
+c! dPOLdOM1 = 0.0d0\r
+c! dPOLdOM2 = 0.0d0\r
+c! =============\r
+c!-------------------------------------------------------------------\r
+c! Elj\r
+ pom = (pis / Rhead)**6.0d0\r
+ Elj = 4.0d0 * eps0 * pom * (pom-1.0d0)\r
+c! write (*,*) "ELJ = ", ELJ\r
+c! derivative of Elj is Glj\r
+ dGLJdR = 4.0d0 * eps0 \r
+ & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))\r
+ & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0)))\r
+\r
+c! =============\r
+c! write (*,*) "Elj = ", Elj\r
+c! write (*,*) "dGLJdR = ", dGLJdR\r
+c! Elj = 0.0d0\r
+c! dGLJdR = 0.0d0\r
+c! =============\r
+c!-------------------------------------------------------------------\r
+c! Equad\r
+ IF (Wqd.ne.0.0d0) THEN\r
+\r
+ Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)\r
+ & - 37.5d0 * ( sqom1 + sqom2 )\r
+ & + 157.5d0 * ( sqom1 * sqom2 )\r
+ & - 45.0d0 * om1*om2*om12\r
+ fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )\r
+ Equad = fac * Beta1\r
+c! derivative of Equad...\r
+ dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR\r
+ dQUADdOM1 = fac\r
+ & * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)\r
+ dQUADdOM2 = fac\r
+ & * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)\r
+ dQUADdOM12 = fac\r
+ & * ( 6.0d0*om12 - 45.0d0*om1*om2 )\r
+c! write(*,*) "Equad = ", Equad\r
+c! write(*,*) "dQUADdR = ", dQUADdR\r
+c! write(*,*) "dQUADdOM1 = ", dQUADdOM1\r
+c! write(*,*) "dQUADdOM2 = ", dQUADdOM2\r
+c! write(*,*) "dQUADdOM12 = ", dQUADdOM12\r
+ ELSE\r
+ Beta1 = 0.0d0\r
+ Equad = 0.0d0\r
+ END IF\r
+c!-------------------------------------------------------------------\r
+c! Return the results\r
+\r
+c! Angular stuff\r
+c! eom1 = eom1 + dPOLdOM1 + dQUADdOM1\r
+c! eom2 = eom2 + dPOLdOM2 + dQUADdOM2\r
+c! eom12 = eom12 + dQUADdOM12\r
+ eom1 = dPOLdOM1 + dQUADdOM1\r
+ eom2 = dPOLdOM2 + dQUADdOM2\r
+ eom12 = dQUADdOM12\r
+c! now some magical transformations to project gradient into\r
+c! three cartesian vectors\r
+ DO k = 1, 3\r
+ dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))\r
+ dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))\r
+c! gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)\r
+ tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)\r
+ END DO\r
+\r
+c! Radial stuff\r
+ DO k = 1, 3\r
+ erhead(k) = Rhead_distance(k)/Rhead\r
+ erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)\r
+ erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)\r
+ END DO\r
+ erdxi = scalar( erhead(1), dC_norm(1,i+nres) )\r
+ erdxj = scalar( erhead(1), dC_norm(1,j+nres) )\r
+ bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )\r
+ eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )\r
+ facd1 = d1 * vbld_inv(i+nres)\r
+ facd2 = d2 * vbld_inv(j+nres)\r
+\r
+c! Throw the results into gheadtail which holds gradients\r
+c! for each micro-state\r
+\r
+ DO k = 1, 3\r
+ hawk = (erhead_tail(k,1) + \r
+ & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))\r
+ condor = (erhead_tail(k,2) +\r
+ & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))\r
+\r
+ pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))\r
+c! this acts on hydrophobic center of interaction\r
+c! gvdwx(k,i) = gvdwx(k,i)\r
+ gheadtail(k,1,1) = gheadtail(k,1,1)\r
+ & - dGCLdR * pom\r
+ & - dGGBdR * pom\r
+ & - dGCVdR * pom\r
+ & - dPOLdR1 * hawk\r
+ & - dPOLdR2 * erhead_tail(k,2)\r
+ & - dGLJdR * pom\r
+ & - dQUADdR * pom\r
+ & - tuna(k)\r
+ & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
+ & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
+c! write (*,*) "gheadtail(k,1,1) = ", gheadtail(k,1,1)\r
+\r
+ pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))\r
+c! this acts on hydrophobic center of interaction\r
+c! gvdwx(k,j) = gvdwx(k,j)\r
+ gheadtail(k,2,1) = gheadtail(k,2,1)\r
+ & + dGCLdR * pom\r
+ & + dGGBdR * pom\r
+ & + dGCVdR * pom\r
+ & + dPOLdR1 * erhead_tail(k,1)\r
+ & + dPOLdR2 * condor\r
+ & + dGLJdR * pom\r
+ & + dQUADdR * pom\r
+ & + tuna(k)\r
+ & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
+ & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
+\r
+c! this acts on Calpha\r
+c! gvdwc(k,i) = gvdwc(k,i)\r
+ gheadtail(k,3,1) = gheadtail(k,3,1)\r
+ & - dGCLdR * erhead(k)\r
+ & - dGGBdR * erhead(k)\r
+ & - dGCVdR * erhead(k)\r
+ & - dPOLdR1 * erhead_tail(k,1)\r
+ & - dPOLdR2 * erhead_tail(k,2)\r
+ & - dGLJdR * erhead(k)\r
+ & - dQUADdR * erhead(k)\r
+ & - tuna(k)\r
+\r
+c! this acts on Calpha\r
+c! gvdwc(k,j) = gvdwc(k,j)\r
+ gheadtail(k,4,1) = gheadtail(k,4,1)\r
+ & + dGCLdR * erhead(k)\r
+ & + dGGBdR * erhead(k)\r
+ & + dGCVdR * erhead(k)\r
+ & + dPOLdR1 * erhead_tail(k,1)\r
+ & + dPOLdR2 * erhead_tail(k,2)\r
+ & + dGLJdR * erhead(k)\r
+ & + dQUADdR * erhead(k)\r
+ & + tuna(k)\r
+ END DO\r
+ ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad\r
+c! write (*,*) "ener(",istate,") = ", ener(istate)\r
+ eheadtail = eheadtail\r
+ & + wstate(istate, itypi, itypj)\r
+ & * dexp(-betaT * ener(istate))\r
+c! write (*,*) "wstate = ", wstate(istate, itypi, itypj)\r
+c! write (*,*) "betaT = ", betaT\r
+c! write (*,*) "-E1beta = ", (-betaT * ener(istate))\r
+c! write (*,*) "w1exp = ", (wstate(istate, itypi, itypj)\r
+c! & * dexp(-betaT * ener(istate)))\r
+c! foreach cartesian dimension\r
+ DO k = 1, 3\r
+c! foreach of two gvdwx and gvdwc\r
+ DO l = 1, 4\r
+ gheadtail(k,l,2) = gheadtail(k,l,2)\r
+ & + wstate( istate, itypi, itypj )\r
+ & * dexp(-betaT * ener(istate))\r
+ & * gheadtail(k,l,1)\r
+ gheadtail(k,l,1) = 0.0d0\r
+c! write (*,*) "wstate = ", wstate(istate,itypi,itypj)\r
+c! write (*,*) "-G1beta =", (-betaT * gheadtail(k,l,1))\r
+c! write (*,*) "top(",k,",",l,",",2,") = ", gheadtail(k,l,2)\r
+ END DO\r
+ END DO\r
+ END DO\r
+c! Here ended the gigantic DO istate = 1, 4, which starts\r
+c! at the beggining of the subroutine\r
+\r
+ DO k = 1, 3\r
+ DO l = 1, 4\r
+ gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail\r
+c! write (*,*) "eheadtail = ", eheadtail\r
+c! write (*,*) "gheadtail(",k,",",l,",2) = ",\r
+c! & gheadtail(k,l,2)\r
+ END DO\r
+ gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)\r
+ gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)\r
+ gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)\r
+ gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)\r
+ DO l = 1, 4\r
+ gheadtail(k,l,1) = 0.0d0\r
+ gheadtail(k,l,2) = 0.0d0\r
+ END DO\r
+ END DO\r
+ eheadtail = (-dlog(eheadtail)) / betaT\r
+c! write (*,*) "eheadtail_final = ", eheadtail\r
+ dPOLdOM1 = 0.0d0\r
+ dPOLdOM2 = 0.0d0\r
+ dQUADdOM1 = 0.0d0\r
+ dQUADdOM2 = 0.0d0\r
+ dQUADdOM12 = 0.0d0\r
+ RETURN\r
+ END SUBROUTINE energy_quad\r
+\r
+\r
+c!-------------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE eqn(Epol)\r
+ IMPLICIT NONE\r
+ INCLUDE 'DIMENSIONS'\r
+ INCLUDE 'COMMON.CALC'\r
+ INCLUDE 'COMMON.CHAIN'\r
+ INCLUDE 'COMMON.CONTROL'\r
+ INCLUDE 'COMMON.DERIV'\r
+ INCLUDE 'COMMON.EMP'\r
+ INCLUDE 'COMMON.GEO'\r
+ INCLUDE 'COMMON.INTERACT'\r
+ INCLUDE 'COMMON.IOUNITS'\r
+ INCLUDE 'COMMON.LOCAL'\r
+ INCLUDE 'COMMON.NAMES'\r
+ INCLUDE 'COMMON.VAR'\r
+ double precision scalar\r
+ alphapol1 = alphapol(itypi,itypj)\r
+c! R1 - distance between head of ith side chain and tail of jth sidechain\r
+ R1 = 0.0d0\r
+ DO k = 1, 3\r
+c! Calculate head-to-tail distances\r
+ R1=R1+(ctail(k,2)-chead(k,1))**2\r
+ END DO\r
+c! Pitagoras\r
+ R1 = dsqrt(R1)\r
+c--------------------------------------------------------------------\r
+c Polarization energy\r
+c Epol\r
+ MomoFac1 = (1.0d0 - chi1 * sqom2)\r
+ RR1 = R1 * R1 / MomoFac1\r
+ ee1 = exp(-( RR1 / (4.0d0 * a12sq) ))\r
+ fgb1 = sqrt( RR1 + a12sq * ee1)\r
+ epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)\r
+c!------------------------------------------------------------------\r
+c! derivative of Epol is Gpol...\r
+ dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)\r
+ & / (fgb1 ** 5.0d0)\r
+\r
+ dFGBdR1 = ( (R1 / MomoFac1)\r
+ & * ( 2.0d0 - (0.5d0 * ee1) ) )\r
+ & / ( 2.0d0 * fgb1 )\r
+\r
+ dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))\r
+ & * (2.0d0 - 0.5d0 * ee1) )\r
+ & / (2.0d0 * fgb1)\r
+\r
+ dPOLdR1 = dPOLdFGB1 * dFGBdR1\r
+\r
+ dPOLdOM1 = 0.0d0\r
+\r
+ dPOLdOM2 = dPOLdFGB1 * dFGBdOM2\r
+c!-------------------------------------------------------------------\r
+c! Return the results\r
+ DO k = 1, 3\r
+ erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)\r
+ END DO\r
+\r
+ bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )\r
+ facd1 = d1 * vbld_inv(i+nres)\r
+\r
+ DO k = 1, 3\r
+ hawk = (erhead_tail(k,1) + \r
+ & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))\r
+\r
+ gvdwx(k,i) = gvdwx(k,i)\r
+ & - dPOLdR1 * hawk\r
+\r
+ gvdwx(k,j) = gvdwx(k,j)\r
+ & + dPOLdR1 * erhead_tail(k,1)\r
+\r
+ gvdwc(k,i) = gvdwc(k,i)\r
+ & - dPOLdR1 * erhead_tail(k,1)\r
+\r
+ gvdwc(k,j) = gvdwc(k,j)\r
+ & + dPOLdR1 * erhead_tail(k,1)\r
+\r
+ END DO\r
+ RETURN\r
+ END SUBROUTINE eqn\r
+\r
+\r
+c!-------------------------------------------------------------------\r
+\r
+\r
+\r
+ SUBROUTINE enq(Epol)\r
+ IMPLICIT NONE\r
+ INCLUDE 'DIMENSIONS'\r
+ INCLUDE 'COMMON.CALC'\r
+ INCLUDE 'COMMON.CHAIN'\r
+ INCLUDE 'COMMON.CONTROL'\r
+ INCLUDE 'COMMON.DERIV'\r
+ INCLUDE 'COMMON.EMP'\r
+ INCLUDE 'COMMON.GEO'\r
+ INCLUDE 'COMMON.INTERACT'\r
+ INCLUDE 'COMMON.IOUNITS'\r
+ INCLUDE 'COMMON.LOCAL'\r
+ INCLUDE 'COMMON.NAMES'\r
+ INCLUDE 'COMMON.VAR'\r
+ double precision scalar\r
+ alphapol2 = alphapol(itypj,itypi)\r
+c! R2 - distance between head of jth side chain and tail of ith sidechain\r
+ R2 = 0.0d0\r
+ DO k = 1, 3\r
+c! Calculate head-to-tail distances\r
+ R2=R2+(chead(k,2)-ctail(k,1))**2\r
+ END DO\r
+c! Pitagoras\r
+ R2 = dsqrt(R2)\r
+c------------------------------------------------------------------------\r
+c Polarization energy\r
+ MomoFac2 = (1.0d0 - chi2 * sqom1)\r
+ RR2 = R2 * R2 / MomoFac2\r
+ ee2 = exp(-(RR2 / (4.0d0 * a12sq)))\r
+ fgb2 = sqrt(RR2 + a12sq * ee2)\r
+ epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )\r
+c!-------------------------------------------------------------------\r
+c! derivative of Epol is Gpol...\r
+ dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)\r
+ & / (fgb2 ** 5.0d0)\r
+\r
+ dFGBdR2 = ( (R2 / MomoFac2)\r
+ & * ( 2.0d0 - (0.5d0 * ee2) ) )\r
+ & / (2.0d0 * fgb2)\r
+\r
+ dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))\r
+ & * (2.0d0 - 0.5d0 * ee2) )\r
+ & / (2.0d0 * fgb2)\r
+\r
+ dPOLdR2 = dPOLdFGB2 * dFGBdR2\r
+\r
+ dPOLdOM1 = dPOLdFGB2 * dFGBdOM1\r
+\r
+ dPOLdOM2 = 0.0d0\r
+c!-------------------------------------------------------------------\r
+c! Return the results\r
+ DO k = 1, 3\r
+ erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)\r
+ END DO\r
+ eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )\r
+ facd2 = d2 * vbld_inv(j+nres)\r
+ DO k = 1, 3\r
+ condor = (erhead_tail(k,2)\r
+ & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))\r
+\r
+ gvdwx(k,i) = gvdwx(k,i)\r
+ & - dPOLdR2 * erhead_tail(k,2)\r
+\r
+ gvdwx(k,j) = gvdwx(k,j)\r
+ & + dPOLdR2 * condor\r
+\r
+ gvdwc(k,i) = gvdwc(k,i)\r
+ & - dPOLdR2 * erhead_tail(k,2)\r
+\r
+ gvdwc(k,j) = gvdwc(k,j)\r
+ & + dPOLdR2 * erhead_tail(k,2)\r
+\r
+ END DO\r
+ RETURN\r
+ END SUBROUTINE enq\r
+\r
+\r
+c!-------------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE eqd(Ecl,Elj,Epol)\r
+ IMPLICIT NONE\r
+ INCLUDE 'DIMENSIONS'\r
+ INCLUDE 'COMMON.CALC'\r
+ INCLUDE 'COMMON.CHAIN'\r
+ INCLUDE 'COMMON.CONTROL'\r
+ INCLUDE 'COMMON.DERIV'\r
+ INCLUDE 'COMMON.EMP'\r
+ INCLUDE 'COMMON.GEO'\r
+ INCLUDE 'COMMON.INTERACT'\r
+ INCLUDE 'COMMON.IOUNITS'\r
+ INCLUDE 'COMMON.LOCAL'\r
+ INCLUDE 'COMMON.NAMES'\r
+ INCLUDE 'COMMON.VAR'\r
+ double precision scalar\r
+ alphapol1 = alphapol(itypi,itypj)\r
+ w1 = wqdip(1,itypi,itypj)\r
+ w2 = wqdip(2,itypi,itypj)\r
+ pis = sig0head(itypi,itypj)\r
+ eps0 = epshead(itypi,itypj)\r
+c!-------------------------------------------------------------------\r
+c! R1 - distance between head of ith side chain and tail of jth sidechain\r
+ R1 = 0.0d0\r
+ DO k = 1, 3\r
+c! Calculate head-to-tail distances\r
+ R1=R1+(ctail(k,2)-chead(k,1))**2\r
+ END DO\r
+c! Pitagoras\r
+ R1 = dsqrt(R1)\r
+\r
+c!-------------------------------------------------------------------\r
+c! ecl\r
+ sparrow = w1 * Qi * om1 \r
+ hawk = w2 * Qi * Qi * (1.0d0 - sqom2)\r
+ Ecl = sparrow / Rhead**2.0d0\r
+ & - hawk / Rhead**4.0d0\r
+c! Ecl = 0.0d0\r
+c! write (iout,*) "ECL = ", ECL\r
+c!-------------------------------------------------------------------\r
+c! derivative of ecl is Gcl\r
+c! dF/dr part\r
+ dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0\r
+ & + 4.0d0 * hawk / Rhead**5.0d0\r
+c! dGCLdR = 0.0d0\r
+c! dF/dom1\r
+ dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)\r
+c! dGCLdOM1 = 0.0d0\r
+c! dF/dom2\r
+ dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)\r
+c! dGCLdOM2 = 0.0d0\r
+c--------------------------------------------------------------------\r
+c Polarization energy\r
+c Epol\r
+ MomoFac1 = (1.0d0 - chi1 * sqom2)\r
+ RR1 = R1 * R1 / MomoFac1\r
+ ee1 = exp(-( RR1 / (4.0d0 * a12sq) ))\r
+ fgb1 = sqrt( RR1 + a12sq * ee1)\r
+ epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)\r
+c! epol = 0.0d0\r
+c! write (iout,*) "EPOL = ", EPOL\r
+c!------------------------------------------------------------------\r
+c! derivative of Epol is Gpol...\r
+ dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)\r
+ & / (fgb1 ** 5.0d0)\r
+ dFGBdR1 = ( (R1 / MomoFac1)\r
+ & * ( 2.0d0 - (0.5d0 * ee1) ) )\r
+ & / ( 2.0d0 * fgb1 )\r
+ dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))\r
+ & * (2.0d0 - 0.5d0 * ee1) )\r
+ & / (2.0d0 * fgb1)\r
+ dPOLdR1 = dPOLdFGB1 * dFGBdR1\r
+c! dPOLdR1 = 0.0d0\r
+ dPOLdOM1 = 0.0d0\r
+ dPOLdOM2 = dPOLdFGB1 * dFGBdOM2\r
+c! dPOLdOM2 = 0.0d0\r
+c!-------------------------------------------------------------------\r
+c! Elj\r
+ pom = (pis / Rhead)**6.0d0\r
+ Elj = 4.0d0 * eps0 * pom * (pom-1.0d0)\r
+c! write (*,*) "ELJ = ", ELJ\r
+c! derivative of Elj is Glj\r
+ dGLJdR = 4.0d0 * eps0 \r
+ & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))\r
+ & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0)))\r
+c!-------------------------------------------------------------------\r
+c! Return the results\r
+ DO k = 1, 3\r
+ erhead(k) = Rhead_distance(k)/Rhead\r
+ erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)\r
+ END DO\r
+\r
+ erdxi = scalar( erhead(1), dC_norm(1,i+nres) )\r
+ erdxj = scalar( erhead(1), dC_norm(1,j+nres) )\r
+ bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )\r
+ facd1 = d1 * vbld_inv(i+nres)\r
+ facd2 = d2 * vbld_inv(j+nres)\r
+\r
+ DO k = 1, 3\r
+ hawk = (erhead_tail(k,1) + \r
+ & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))\r
+\r
+ pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))\r
+ gvdwx(k,i) = gvdwx(k,i)\r
+ & - dGCLdR * pom\r
+ & - dPOLdR1 * hawk\r
+ & - dGLJdR * pom\r
+\r
+ pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))\r
+ gvdwx(k,j) = gvdwx(k,j)\r
+ & + dGCLdR * pom\r
+ & + dPOLdR1 * erhead_tail(k,1)\r
+ & + dGLJdR * pom\r
+\r
+\r
+ gvdwc(k,i) = gvdwc(k,i)\r
+ & - dGCLdR * erhead(k)\r
+ & - dPOLdR1 * erhead_tail(k,1)\r
+ & - dGLJdR * erhead(k)\r
+\r
+ gvdwc(k,j) = gvdwc(k,j)\r
+ & + dGCLdR * erhead(k)\r
+ & + dPOLdR1 * erhead_tail(k,1)\r
+ & + dGLJdR * erhead(k)\r
+\r
+ END DO\r
+ RETURN\r
+ END SUBROUTINE eqd\r
+\r
+\r
+c!-------------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE edq(Ecl,Elj,Epol)\r
+ IMPLICIT NONE\r
+ INCLUDE 'DIMENSIONS'\r
+ INCLUDE 'COMMON.CALC'\r
+ INCLUDE 'COMMON.CHAIN'\r
+ INCLUDE 'COMMON.CONTROL'\r
+ INCLUDE 'COMMON.DERIV'\r
+ INCLUDE 'COMMON.EMP'\r
+ INCLUDE 'COMMON.GEO'\r
+ INCLUDE 'COMMON.INTERACT'\r
+ INCLUDE 'COMMON.IOUNITS'\r
+ INCLUDE 'COMMON.LOCAL'\r
+ INCLUDE 'COMMON.NAMES'\r
+ INCLUDE 'COMMON.VAR'\r
+ double precision scalar\r
+ alphapol2 = alphapol(itypj,itypi)\r
+ w1 = wqdip(1,itypi,itypj)\r
+ w2 = wqdip(2,itypi,itypj)\r
+ pis = sig0head(itypi,itypj)\r
+ eps0 = epshead(itypi,itypj)\r
+c!-------------------------------------------------------------------\r
+c! R2 - distance between head of jth side chain and tail of ith sidechain\r
+ R2 = 0.0d0\r
+ DO k = 1, 3\r
+c! Calculate head-to-tail distances\r
+ R2=R2+(chead(k,2)-ctail(k,1))**2\r
+ END DO\r
+c! Pitagoras\r
+ R2 = dsqrt(R2)\r
+\r
+c!-------------------------------------------------------------------\r
+c! ecl\r
+ sparrow = w1 * Qi * om1 \r
+ hawk = w2 * Qi * Qi * (1.0d0 - sqom2)\r
+ ECL = sparrow / Rhead**2.0d0\r
+ & - hawk / Rhead**4.0d0\r
+c! write (iout,*) "ECL = ", ECL\r
+c! Ecl = 0.0d0\r
+c!-------------------------------------------------------------------\r
+c! derivative of ecl is Gcl\r
+c! dF/dr part\r
+ dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0\r
+ & + 4.0d0 * hawk / Rhead**5.0d0\r
+c! dGCLdR = 0.0d0\r
+c! dF/dom1\r
+ dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)\r
+c! dGCLdOM1 = 0.0d0\r
+c! dF/dom2\r
+ dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)\r
+c! dGCLdOM2 = 0.0d0\r
+c--------------------------------------------------------------------\r
+c Polarization energy\r
+c Epol\r
+ MomoFac2 = (1.0d0 - chi2 * sqom1)\r
+ RR2 = R2 * R2 / MomoFac2\r
+ ee2 = exp(-(RR2 / (4.0d0 * a12sq)))\r
+ fgb2 = sqrt(RR2 + a12sq * ee2)\r
+ epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )\r
+c! write (iout,*) "EPOL = ", EPOL\r
+c! epol = 0.0d0\r
+c!------------------------------------------------------------------\r
+c! derivative of Epol is Gpol...\r
+ dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)\r
+ & / (fgb2 ** 5.0d0)\r
+ dFGBdR2 = ( (R2 / MomoFac2)\r
+ & * ( 2.0d0 - (0.5d0 * ee2) ) )\r
+ & / (2.0d0 * fgb2)\r
+ dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))\r
+ & * (2.0d0 - 0.5d0 * ee2) )\r
+ & / (2.0d0 * fgb2)\r
+ dPOLdR2 = dPOLdFGB2 * dFGBdR2\r
+c! dPOLdR1 = 0.0d0\r
+ dPOLdOM1 = dPOLdFGB2 * dFGBdOM1\r
+c! dPOLdOM1 = 0.0d0\r
+ dPOLdOM2 = 0.0d0\r
+c!-------------------------------------------------------------------\r
+c! Elj\r
+ pom = (pis / Rhead)**6.0d0\r
+ Elj = 4.0d0 * eps0 * pom * (pom-1.0d0)\r
+c! write (iout,*) "ELJ = ", ELJ\r
+c! derivative of Elj is Glj\r
+ dGLJdR = 4.0d0 * eps0 \r
+ & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))\r
+ & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0)))\r
+c!-------------------------------------------------------------------\r
+c! Return the results\r
+ DO k = 1, 3\r
+ erhead(k) = Rhead_distance(k)/Rhead\r
+ erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)\r
+ END DO\r
+\r
+ erdxi = scalar( erhead(1), dC_norm(1,i+nres) )\r
+ erdxj = scalar( erhead(1), dC_norm(1,j+nres) )\r
+ eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )\r
+ facd1 = d1 * vbld_inv(i+nres)\r
+ facd2 = d2 * vbld_inv(j+nres)\r
+\r
+ DO k = 1, 3\r
+ condor = (erhead_tail(k,2)\r
+ & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))\r
+\r
+ pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))\r
+ gvdwx(k,i) = gvdwx(k,i)\r
+ & - dGCLdR * pom\r
+ & - dPOLdR2 * erhead_tail(k,2)\r
+ & - dGLJdR * pom\r
+\r
+ pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))\r
+ gvdwx(k,j) = gvdwx(k,j)\r
+ & + dGCLdR * pom\r
+ & + dPOLdR2 * condor\r
+ & + dGLJdR * pom\r
+\r
+\r
+ gvdwc(k,i) = gvdwc(k,i)\r
+ & - dGCLdR * erhead(k)\r
+ & - dPOLdR2 * erhead_tail(k,2)\r
+ & - dGLJdR * erhead(k)\r
+\r
+ gvdwc(k,j) = gvdwc(k,j)\r
+ & + dGCLdR * erhead(k)\r
+ & + dPOLdR2 * erhead_tail(k,2)\r
+ & + dGLJdR * erhead(k)\r
+\r
+ END DO\r
+ RETURN\r
+ END SUBROUTINE edq\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE edd(ECL)\r
+ IMPLICIT NONE\r
+ INCLUDE 'DIMENSIONS'\r
+ INCLUDE 'COMMON.CALC'\r
+ INCLUDE 'COMMON.CHAIN'\r
+ INCLUDE 'COMMON.CONTROL'\r
+ INCLUDE 'COMMON.DERIV'\r
+ INCLUDE 'COMMON.EMP'\r
+ INCLUDE 'COMMON.GEO'\r
+ INCLUDE 'COMMON.INTERACT'\r
+ INCLUDE 'COMMON.IOUNITS'\r
+ INCLUDE 'COMMON.LOCAL'\r
+ INCLUDE 'COMMON.NAMES'\r
+ INCLUDE 'COMMON.VAR'\r
+ double precision scalar\r
+ csig = sigiso(itypi,itypj)\r
+ w1 = wqdip(1,itypi,itypj)\r
+ w2 = wqdip(2,itypi,itypj)\r
+c! intermediates\r
+ sparrow = -3.0d0 * w1\r
+ rosella = 6.0d0 * w2\r
+ hawk = Rhead**3.0d0\r
+c! bat = R^6\r
+ bat = hawk**2.0d0\r
+c! condor = -3w1 / R^3\r
+ condor = sparrow / hawk\r
+c! eagle = 6w2 / R^6\r
+ eagle = rosella / bat\r
+ fac = (om12 - 3.0d0 * om1 * om2)\r
+ c1 = (w1 / hawk) * fac\r
+ c2 = (w2 / Rhead ** 6.0d0)\r
+ & * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))\r
+ ECL = c1 - c2\r
+c!-------------------------------------------------------------------\r
+c! dervative of ECL is GCL...\r
+c! dECL/dr\r
+ c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)\r
+ c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)\r
+ & * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))\r
+ dGCLdR = c1 - c2\r
+c! dECL/dom1\r
+ c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)\r
+ c2 = (-6.0d0 * w2) / (Rhead**6.0d0)\r
+ & * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )\r
+ dGCLdOM1 = c1 - c2\r
+c! dECL/dom2\r
+ c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)\r
+ c2 = (-6.0d0 * w2) / (Rhead**6.0d0)\r
+ & * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )\r
+ dGCLdOM2 = c1 - c2\r
+c! dECL/dom12\r
+ c1 = w1 / (Rhead ** 3.0d0)\r
+ c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0\r
+ dGCLdOM12 = c1 - c2\r
+c!-------------------------------------------------------------------\r
+c! Return the results\r
+ DO k= 1, 3\r
+ erhead(k) = Rhead_distance(k)/Rhead\r
+ END DO\r
+ erdxi = scalar( erhead(1), dC_norm(1,i+nres) )\r
+ erdxj = scalar( erhead(1), dC_norm(1,j+nres) )\r
+ facd1 = d1 * vbld_inv(i+nres)\r
+ facd2 = d2 * vbld_inv(j+nres)\r
+ DO k = 1, 3\r
+\r
+ pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))\r
+ gvdwx(k,i) = gvdwx(k,i)\r
+ & - dGCLdR * pom\r
+ pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))\r
+ gvdwx(k,j) = gvdwx(k,j)\r
+ & + dGCLdR * pom\r
+\r
+ gvdwc(k,i) = gvdwc(k,i)\r
+ & - dGCLdR * erhead(k)\r
+ gvdwc(k,j) = gvdwc(k,j)\r
+ & + dGCLdR * erhead(k)\r
+ END DO\r
+ RETURN\r
+ END SUBROUTINE edd\r
+\r
+\r
+c!-------------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)\r
+ IMPLICIT NONE\r
+c! maxres\r
+ INCLUDE 'DIMENSIONS'\r
+c! itypi, itypj, i, j, k, l, chead, \r
+ INCLUDE 'COMMON.CALC'\r
+c! c, nres, dc_norm\r
+ INCLUDE 'COMMON.CHAIN'\r
+c! gradc, gradx\r
+ INCLUDE 'COMMON.DERIV'\r
+c! electrostatic gradients-specific variables\r
+ INCLUDE 'COMMON.EMP'\r
+c! wquad, dhead, alphiso, alphasur, rborn, epsintab\r
+ INCLUDE 'COMMON.INTERACT'\r
+c! Rb\r
+ INCLUDE 'COMMON.MD'\r
+c! io for debug, disable it in final builds\r
+ INCLUDE 'COMMON.IOUNITS'\r
+c!-------------------------------------------------------------------\r
+c! Variable Init\r
+\r
+c! what amino acid is the aminoacid j'th?\r
+ itypj=itype(j)\r
+c! 1/(Gas Constant * Thermostate temperature) = BetaT\r
+ BetaT = 1.0d0 / (t_bath * Rb)\r
+c! write (*,*) "t_bath = ", t_bath, "Rb = ", Rb\r
+c! write (*,'(a,f5.3)') " Betat = ", BetaT\r
+c! Gay-berne var's\r
+ sig0ij = sigma( itypi,itypj )\r
+ chi1 = chi( itypi, itypj )\r
+ chi2 = chi( itypj, itypi )\r
+ chi12 = chi1 * chi2\r
+ chip1 = chipp( itypi, itypj )\r
+ chip2 = chipp( itypj, itypi )\r
+ chip12 = chip1 * chip2\r
+c! not used by momo potential, but needed by sc_angular which is shared\r
+c! by all energy_potential subroutines\r
+ alf1 = 0.0d0\r
+ alf2 = 0.0d0\r
+ alf12 = 0.0d0\r
+c! location, location, location\r
+ xj = c( 1, nres+j ) - xi\r
+ yj = c( 2, nres+j ) - yi\r
+ zj = c( 3, nres+j ) - zi\r
+ dxj = dc_norm( 1, nres+j )\r
+ dyj = dc_norm( 2, nres+j )\r
+ dzj = dc_norm( 3, nres+j )\r
+c! distance from center of chain(?) to polar/charged head\r
+ d1 = dhead(1, 1, itypi, itypj)\r
+ d2 = dhead(2, 1, itypi, itypj)\r
+c! ai*aj from Fgb\r
+ a12sq = rborn(itypi,itypj)\r
+ a12sq = a12sq * a12sq\r
+c! charge of amino acid itypi is...\r
+ Qi = icharge(itypi)\r
+ Qj = icharge(itypj)\r
+ Qij = Qi * Qj\r
+c! Eps'(i,j) for Elj\r
+ eps_head = epshead(itypi,itypj)\r
+c! chis1,2,12\r
+ chis1 = chis(itypi,itypj) \r
+ chis2 = chis(itypj,itypi)\r
+ chis12 = chis1 * chis2\r
+ sig1 = sigmap(itypi,itypj)\r
+ sig2 = sigmap(itypj,itypi)\r
+c! alpha factors from Fcav/Gcav\r
+ b1 = alphasur(1,itypi,itypj)\r
+ b2 = alphasur(2,itypi,itypj)\r
+ b3 = alphasur(3,itypi,itypj)\r
+ b4 = alphasur(4,itypi,itypj)\r
+c! used to determine wheter we want to do quadrupole calculations\r
+ wqd = wquad(itypi, itypj)\r
+ eps_in = epsintab(itypi,itypj)\r
+ eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))\r
+c! write (*,*) "eps_inout_fac = ", eps_inout_fac\r
+c!-------------------------------------------------------------------\r
+c! tail location and distance calculations\r
+c! shameless ripoff from emomo\r
+ Rtail = 0.0d0\r
+ DO k = 1, 3\r
+ ctail(k,1)=c(k,i+nres)-dtail(k,itypi)*dc_norm(k,nres+i)\r
+ ctail(k,2)=c(k,j+nres)-dtail(k,itypj)*dc_norm(k,nres+j)\r
+ END DO\r
+c! tail distances will be themselves usefull elswhere\r
+c1 (in Gcav, for example)\r
+ Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )\r
+ Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )\r
+ Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )\r
+ Rtail = dsqrt(\r
+ & (Rtail_distance(1)*Rtail_distance(1))\r
+ & + (Rtail_distance(2)*Rtail_distance(2))\r
+ & + (Rtail_distance(3)*Rtail_distance(3)))\r
+c!-------------------------------------------------------------------\r
+c! Calculate location and distance between polar heads\r
+c! distance between heads\r
+c! for each one of our three dimensional space...\r
+ DO k = 1,3\r
+c! location of polar head is computed by taking hydrophobic centre\r
+c! and moving by a d1 * dc_norm vector\r
+c! see unres publications for very informative images\r
+ chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)\r
+ chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)\r
+c! distance \r
+c! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))\r
+c! Rsc(k) = Rsc_distance(k) * Rsc_distance(k)\r
+ Rhead_distance(k) = chead(k,2) - chead(k,1)\r
+ END DO\r
+c! pitagoras (root of sum of squares)\r
+ Rhead = dsqrt(\r
+ & (Rhead_distance(1)*Rhead_distance(1))\r
+ & + (Rhead_distance(2)*Rhead_distance(2))\r
+ & + (Rhead_distance(3)*Rhead_distance(3)))\r
+c!-------------------------------------------------------------------\r
+c! zero everything that should be zero'ed\r
+ Egb = 0.0d0\r
+ ECL = 0.0d0\r
+ Elj = 0.0d0\r
+ Equad = 0.0d0\r
+ Epol = 0.0d0\r
+ eheadtail = 0.0d0\r
+ dGCLdR = 0.0d0\r
+ dGCLdOM1 = 0.0d0\r
+ dGCLdOM2 = 0.0d0\r
+ dGCLdOM12 = 0.0d0\r
+ dPOLdR1 = 0.0d0\r
+ dPOLdOM1 = 0.0d0\r
+ dPOLdOM2 = 0.0d0\r
+ Glj = 0.0d0\r
+ dGLJdR = 0.0d0\r
+ dGLJdOM1 = 0.0d0\r
+ dGLJdOM2 = 0.0d0\r
+ dGLJdOM12 = 0.0d0\r
+ RETURN\r
+ END SUBROUTINE elgrad_init\r
+\r
+\r
+c!-------------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE sc_angular\r
+C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,\r
+C om12. Called by ebp, egb, egbv, and emomo\r
+ IMPLICIT NONE\r
+c! ntyp needed in other commons\r
+ INCLUDE 'DIMENSIONS'\r
+ INCLUDE 'COMMON.CALC'\r
+c! chi()\r
+ INCLUDE 'COMMON.INTERACT'\r
+ INCLUDE 'COMMON.IOUNITS'\r
+ INCLUDE 'COMMON.EMP'\r
+\r
+ erij(1) = xj * rij\r
+ erij(2) = yj * rij\r
+ erij(3) = zj * rij\r
+ om1 = dxi * erij(1) + dyi * erij(2) + dzi * erij(3)\r
+ om2 = dxj * erij(1) + dyj * erij(2) + dzj * erij(3)\r
+ om12 = dxi * dxj + dyi * dyj + dzi * dzj\r
+ chiom12 = chi12 * om12\r
+C Calculate eps1(om12) and its derivative in om12\r
+ faceps1 = 1.0D0 - om12 * chiom12\r
+ faceps1_inv = 1.0D0 / faceps1\r
+ eps1 = dsqrt(faceps1_inv)\r
+C Following variable is eps1*deps1/dom12\r
+ eps1_om12 = faceps1_inv * chiom12\r
+C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,\r
+C and om12.\r
+ om1om2 = om1 * om2\r
+ chiom1 = chi1 * om1\r
+ chiom2 = chi2 * om2\r
+ facsig = om1 * chiom1 + om2 * chiom2\r
+ & - 2.0D0 * om1om2 * chiom12\r
+ sigsq = 1.0D0 - facsig * faceps1_inv\r
+ sigsq_om1 = (chiom1 - chiom12 * om2) * faceps1_inv\r
+ sigsq_om2 = (chiom2 - chiom12 * om1) * faceps1_inv\r
+ sigsq_om12 = -chi12 * (om1om2 * faceps1 - om12 * facsig)\r
+ & * faceps1_inv**2\r
+C Calculate eps2 and its derivatives in om1, om2, and om12.\r
+ chipom1 = chip1 * om1\r
+ chipom2 = chip2 * om2\r
+ chipom12 = chip12 * om12\r
+ facp = 1.0D0 - om12 * chipom12\r
+ facp_inv = 1.0D0 / facp\r
+ facp1 = om1 * chipom1 + om2 * chipom2\r
+ & -2.0D0 * om1om2 * chipom12\r
+C Following variable is the square root of eps2\r
+ eps2rt = 1.0D0 - facp1 * facp_inv\r
+\r
+C Following three variables are the derivatives of the square root of eps\r
+C in om1, om2, and om12.\r
+ eps2rt_om1 =-4.0D0 * (chipom1 - chipom12 * om2) * facp_inv\r
+ eps2rt_om2 =-4.0D0 * (chipom2 - chipom12 * om1) * facp_inv\r
+ eps2rt_om12 = 4.0D0 * chip12\r
+ & * (om1om2*facp-om12*facp1)*facp_inv**2 \r
+\r
+c! Evaluate the "asymmetric" factor in the VDW constant, eps3\r
+c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular\r
+c! Or frankly, we should restructurize the whole energy section\r
+ eps3rt = 1.0D0 - alf1 * om1 + alf2 * om2 - alf12 * om12\r
+\r
+C Calculate whole angle-dependent part of epsilon and contributions\r
+C to its derivatives\r
+\r
+ RETURN\r
+ END SUBROUTINE sc_angular\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine sc_grad_T\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.CALC'\r
+ include 'COMMON.IOUNITS'\r
+ double precision dcosom1(3),dcosom2(3)\r
+ eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1\r
+ eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2\r
+ eom12=evdwij*eps1_om12+eps2der*eps2rt_om12\r
+ & -2.0D0*alf12*eps3der+sigder*sigsq_om12\r
+c diagnostics only\r
+c eom1=0.0d0\r
+c eom2=0.0d0\r
+c eom12=evdwij*eps1_om12\r
+c end diagnostics\r
+c write (iout,*) "eps2der",eps2der," eps3der",eps3der,\r
+c & " sigder",sigder\r
+c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12\r
+c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12\r
+ do k=1,3\r
+ dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))\r
+ dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))\r
+ enddo\r
+ do k=1,3\r
+ gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)\r
+ enddo \r
+c write (iout,*) "gg",(gg(k),k=1,3)\r
+ do k=1,3\r
+ gvdwxT(k,i)=gvdwxT(k,i)-gg(k)\r
+ & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
+ & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
+ gvdwxT(k,j)=gvdwxT(k,j)+gg(k)\r
+ & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
+ & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
+c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
+c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
+c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
+c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
+ enddo\r
+C \r
+C Calculate the components of the gradient in DC and X\r
+C\r
+cgrad do k=i,j-1\r
+cgrad do l=1,3\r
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+ do l=1,3\r
+ gvdwcT(l,i)=gvdwcT(l,i)-gg(l)\r
+ gvdwcT(l,j)=gvdwcT(l,j)+gg(l)\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE sc_grad\r
+ IMPLICIT real*8 (a-h,o-z)\r
+ INCLUDE 'DIMENSIONS'\r
+ INCLUDE 'COMMON.CHAIN'\r
+ INCLUDE 'COMMON.DERIV'\r
+ INCLUDE 'COMMON.CALC'\r
+ INCLUDE 'COMMON.IOUNITS'\r
+ INCLUDE 'COMMON.EMP'\r
+ double precision dcosom1(3),dcosom2(3)\r
+\r
+c! each eom holds sum of omega-angular derivatives of each component\r
+c! of energy function. First GGB, then Gcav, dipole-dipole,...\r
+ eom1 =\r
+ & eps2der * eps2rt_om1\r
+ & - 2.0D0 * alf1 * eps3der\r
+ & + sigder * sigsq_om1\r
+ & + dCAVdOM1\r
+ & + dGCLdOM1\r
+ & + dPOLdOM1\r
+\r
+ eom2 =\r
+ & eps2der * eps2rt_om2\r
+ & + 2.0D0 * alf2 * eps3der\r
+ & + sigder * sigsq_om2\r
+ & + dCAVdOM2\r
+ & + dGCLdOM2\r
+ & + dPOLdOM2\r
+\r
+ eom12 =\r
+ & evdwij * eps1_om12\r
+ & + eps2der * eps2rt_om12\r
+ & - 2.0D0 * alf12 * eps3der\r
+ & + sigder *sigsq_om12\r
+ & + dCAVdOM12\r
+ & + dGCLdOM12\r
+\r
+c! now some magical transformations to project gradient into\r
+c! three cartesian vectors\r
+\r
+ DO k = 1, 3\r
+ dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))\r
+ dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))\r
+ gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)\r
+c! this acts on hydrophobic center of interaction\r
+ gvdwx(k,i)= gvdwx(k,i) - gg(k)\r
+ & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
+ & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
+ gvdwx(k,j)= gvdwx(k,j) + gg(k)\r
+ & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
+ & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
+c! this acts on Calpha\r
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
+ END DO\r
+ RETURN\r
+ END SUBROUTINE sc_grad\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine e_softsphere(evdw)\r
+C\r
+C This subroutine calculates the interaction energy of nonbonded side chains\r
+C assuming the LJ potential of interaction.\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ parameter (accur=1.0d-10)\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.SBRIDGE'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CONTACTS'\r
+ dimension gg(3)\r
+cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct\r
+ evdw=0.0D0\r
+ do i=iatsc_s,iatsc_e\r
+ itypi=itype(i)\r
+ itypi1=itype(i+1)\r
+ xi=c(1,nres+i)\r
+ yi=c(2,nres+i)\r
+ zi=c(3,nres+i)\r
+C\r
+C Calculate SC interaction energy.\r
+C\r
+ do iint=1,nint_gr(i)\r
+cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),\r
+cd & 'iend=',iend(i,iint)\r
+ do j=istart(i,iint),iend(i,iint)\r
+ itypj=itype(j)\r
+ xj=c(1,nres+j)-xi\r
+ yj=c(2,nres+j)-yi\r
+ zj=c(3,nres+j)-zi\r
+ rij=xj*xj+yj*yj+zj*zj\r
+c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj\r
+ r0ij=r0(itypi,itypj)\r
+ r0ijsq=r0ij*r0ij\r
+c print *,i,j,r0ij,dsqrt(rij)\r
+ if (rij.lt.r0ijsq) then\r
+ evdwij=0.25d0*(rij-r0ijsq)**2\r
+ fac=rij-r0ijsq\r
+ else\r
+ evdwij=0.0d0\r
+ fac=0.0d0\r
+ endif\r
+ evdw=evdw+evdwij\r
+C \r
+C Calculate the components of the gradient in DC and X\r
+C\r
+ gg(1)=xj*fac\r
+ gg(2)=yj*fac\r
+ gg(3)=zj*fac\r
+ do k=1,3\r
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)\r
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)\r
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)\r
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)\r
+ enddo\r
+cgrad do k=i,j-1\r
+cgrad do l=1,3\r
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+ enddo ! j\r
+ enddo ! iint\r
+ enddo ! i\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,\r
+ & eello_turn4)\r
+C\r
+C Soft-sphere potential of p-p interaction\r
+C \r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.CONTROL'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VECTORS'\r
+ include 'COMMON.FFIELD'\r
+ dimension ggg(3)\r
+cd write(iout,*) 'In EELEC_soft_sphere'\r
+ ees=0.0D0\r
+ evdw1=0.0D0\r
+ eel_loc=0.0d0 \r
+ eello_turn3=0.0d0\r
+ eello_turn4=0.0d0\r
+ ind=0\r
+ do i=iatel_s,iatel_e\r
+ dxi=dc(1,i)\r
+ dyi=dc(2,i)\r
+ dzi=dc(3,i)\r
+ xmedi=c(1,i)+0.5d0*dxi\r
+ ymedi=c(2,i)+0.5d0*dyi\r
+ zmedi=c(3,i)+0.5d0*dzi\r
+ num_conti=0\r
+c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)\r
+ do j=ielstart(i),ielend(i)\r
+ ind=ind+1\r
+ iteli=itel(i)\r
+ itelj=itel(j)\r
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2\r
+ r0ij=rpp(iteli,itelj)\r
+ r0ijsq=r0ij*r0ij \r
+ dxj=dc(1,j)\r
+ dyj=dc(2,j)\r
+ dzj=dc(3,j)\r
+ xj=c(1,j)+0.5D0*dxj-xmedi\r
+ yj=c(2,j)+0.5D0*dyj-ymedi\r
+ zj=c(3,j)+0.5D0*dzj-zmedi\r
+ rij=xj*xj+yj*yj+zj*zj\r
+ if (rij.lt.r0ijsq) then\r
+ evdw1ij=0.25d0*(rij-r0ijsq)**2\r
+ fac=rij-r0ijsq\r
+ else\r
+ evdw1ij=0.0d0\r
+ fac=0.0d0\r
+ endif\r
+ evdw1=evdw1+evdw1ij\r
+C\r
+C Calculate contributions to the Cartesian gradient.\r
+C\r
+ ggg(1)=fac*xj\r
+ ggg(2)=fac*yj\r
+ ggg(3)=fac*zj\r
+ do k=1,3\r
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)\r
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)\r
+ enddo\r
+*\r
+* Loop over residues i+1 thru j-1.\r
+*\r
+cgrad do k=i+1,j-1\r
+cgrad do l=1,3\r
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+ enddo ! j\r
+ enddo ! i\r
+cgrad do i=nnt,nct-1\r
+cgrad do k=1,3\r
+cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)\r
+cgrad enddo\r
+cgrad do j=i+1,nct-1\r
+cgrad do k=1,3\r
+cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad enddo\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine vec_and_deriv\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+#ifdef MPI\r
+ include 'mpif.h'\r
+#endif\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.VECTORS'\r
+ include 'COMMON.SETUP'\r
+ include 'COMMON.TIME1'\r
+ dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)\r
+C Compute the local reference systems. For reference system (i), the\r
+C X-axis points from CA(i) to CA(i+1), the Y axis is in the \r
+C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.\r
+#ifdef PARVEC\r
+ do i=ivec_start,ivec_end\r
+#else\r
+ do i=1,nres-1\r
+#endif\r
+ if (i.eq.nres-1) then\r
+C Case of the last full residue\r
+C Compute the Z-axis\r
+ call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))\r
+ costh=dcos(pi-theta(nres))\r
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)\r
+ do k=1,3\r
+ uz(k,i)=fac*uz(k,i)\r
+ enddo\r
+C Compute the derivatives of uz\r
+ uzder(1,1,1)= 0.0d0\r
+ uzder(2,1,1)=-dc_norm(3,i-1)\r
+ uzder(3,1,1)= dc_norm(2,i-1) \r
+ uzder(1,2,1)= dc_norm(3,i-1)\r
+ uzder(2,2,1)= 0.0d0\r
+ uzder(3,2,1)=-dc_norm(1,i-1)\r
+ uzder(1,3,1)=-dc_norm(2,i-1)\r
+ uzder(2,3,1)= dc_norm(1,i-1)\r
+ uzder(3,3,1)= 0.0d0\r
+ uzder(1,1,2)= 0.0d0\r
+ uzder(2,1,2)= dc_norm(3,i)\r
+ uzder(3,1,2)=-dc_norm(2,i) \r
+ uzder(1,2,2)=-dc_norm(3,i)\r
+ uzder(2,2,2)= 0.0d0\r
+ uzder(3,2,2)= dc_norm(1,i)\r
+ uzder(1,3,2)= dc_norm(2,i)\r
+ uzder(2,3,2)=-dc_norm(1,i)\r
+ uzder(3,3,2)= 0.0d0\r
+C Compute the Y-axis\r
+ facy=fac\r
+ do k=1,3\r
+ uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))\r
+ enddo\r
+C Compute the derivatives of uy\r
+ do j=1,3\r
+ do k=1,3\r
+ uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)\r
+ & -dc_norm(k,i)*dc_norm(j,i-1)\r
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)\r
+ enddo\r
+ uyder(j,j,1)=uyder(j,j,1)-costh\r
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)\r
+ enddo\r
+ do j=1,2\r
+ do k=1,3\r
+ do l=1,3\r
+ uygrad(l,k,j,i)=uyder(l,k,j)\r
+ uzgrad(l,k,j,i)=uzder(l,k,j)\r
+ enddo\r
+ enddo\r
+ enddo \r
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))\r
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))\r
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))\r
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))\r
+ else\r
+C Other residues\r
+C Compute the Z-axis\r
+ call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))\r
+ costh=dcos(pi-theta(i+2))\r
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)\r
+ do k=1,3\r
+ uz(k,i)=fac*uz(k,i)\r
+ enddo\r
+C Compute the derivatives of uz\r
+ uzder(1,1,1)= 0.0d0\r
+ uzder(2,1,1)=-dc_norm(3,i+1)\r
+ uzder(3,1,1)= dc_norm(2,i+1) \r
+ uzder(1,2,1)= dc_norm(3,i+1)\r
+ uzder(2,2,1)= 0.0d0\r
+ uzder(3,2,1)=-dc_norm(1,i+1)\r
+ uzder(1,3,1)=-dc_norm(2,i+1)\r
+ uzder(2,3,1)= dc_norm(1,i+1)\r
+ uzder(3,3,1)= 0.0d0\r
+ uzder(1,1,2)= 0.0d0\r
+ uzder(2,1,2)= dc_norm(3,i)\r
+ uzder(3,1,2)=-dc_norm(2,i) \r
+ uzder(1,2,2)=-dc_norm(3,i)\r
+ uzder(2,2,2)= 0.0d0\r
+ uzder(3,2,2)= dc_norm(1,i)\r
+ uzder(1,3,2)= dc_norm(2,i)\r
+ uzder(2,3,2)=-dc_norm(1,i)\r
+ uzder(3,3,2)= 0.0d0\r
+C Compute the Y-axis\r
+ facy=fac\r
+ do k=1,3\r
+ uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))\r
+ enddo\r
+C Compute the derivatives of uy\r
+ do j=1,3\r
+ do k=1,3\r
+ uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)\r
+ & -dc_norm(k,i)*dc_norm(j,i+1)\r
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)\r
+ enddo\r
+ uyder(j,j,1)=uyder(j,j,1)-costh\r
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)\r
+ enddo\r
+ do j=1,2\r
+ do k=1,3\r
+ do l=1,3\r
+ uygrad(l,k,j,i)=uyder(l,k,j)\r
+ uzgrad(l,k,j,i)=uzder(l,k,j)\r
+ enddo\r
+ enddo\r
+ enddo \r
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))\r
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))\r
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))\r
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))\r
+ endif\r
+ enddo\r
+ do i=1,nres-1\r
+ vbld_inv_temp(1)=vbld_inv(i+1)\r
+ if (i.lt.nres-1) then\r
+ vbld_inv_temp(2)=vbld_inv(i+2)\r
+ else\r
+ vbld_inv_temp(2)=vbld_inv(i)\r
+ endif\r
+ do j=1,2\r
+ do k=1,3\r
+ do l=1,3\r
+ uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)\r
+ uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)\r
+ enddo\r
+ enddo\r
+ enddo\r
+ enddo\r
+#if defined(PARVEC) && defined(MPI)\r
+ if (nfgtasks1.gt.1) then\r
+ time00=MPI_Wtime()\r
+c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,\r
+c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),\r
+c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)\r
+ call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(uygrad(1,1,1,ivec_start),\r
+ & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),\r
+ & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)\r
+ call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),\r
+ & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),\r
+ & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)\r
+ time_gather=time_gather+MPI_Wtime()-time00\r
+ endif\r
+c if (fg_rank.eq.0) then\r
+c write (iout,*) "Arrays UY and UZ"\r
+c do i=1,nres-1\r
+c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),\r
+c & (uz(k,i),k=1,3)\r
+c enddo\r
+c endif\r
+#endif\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine check_vecgrad\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.VECTORS'\r
+ dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)\r
+ dimension uyt(3,maxres),uzt(3,maxres)\r
+ dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)\r
+ double precision delta /1.0d-7/\r
+ call vec_and_deriv\r
+cd do i=1,nres\r
+crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)\r
+crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)\r
+crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)\r
+cd write(iout,'(2i5,2(3f10.5,5x))') i,1,\r
+cd & (dc_norm(if90,i),if90=1,3)\r
+cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)\r
+cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)\r
+cd write(iout,'(a)')\r
+cd enddo\r
+ do i=1,nres\r
+ do j=1,2\r
+ do k=1,3\r
+ do l=1,3\r
+ uygradt(l,k,j,i)=uygrad(l,k,j,i)\r
+ uzgradt(l,k,j,i)=uzgrad(l,k,j,i)\r
+ enddo\r
+ enddo\r
+ enddo\r
+ enddo\r
+ call vec_and_deriv\r
+ do i=1,nres\r
+ do j=1,3\r
+ uyt(j,i)=uy(j,i)\r
+ uzt(j,i)=uz(j,i)\r
+ enddo\r
+ enddo\r
+ do i=1,nres\r
+cd write (iout,*) 'i=',i\r
+ do k=1,3\r
+ erij(k)=dc_norm(k,i)\r
+ enddo\r
+ do j=1,3\r
+ do k=1,3\r
+ dc_norm(k,i)=erij(k)\r
+ enddo\r
+ dc_norm(j,i)=dc_norm(j,i)+delta\r
+c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))\r
+c do k=1,3\r
+c dc_norm(k,i)=dc_norm(k,i)/fac\r
+c enddo\r
+c write (iout,*) (dc_norm(k,i),k=1,3)\r
+c write (iout,*) (erij(k),k=1,3)\r
+ call vec_and_deriv\r
+ do k=1,3\r
+ uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta\r
+ uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta\r
+ uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta\r
+ uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta\r
+ enddo \r
+c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') \r
+c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),\r
+c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)\r
+ enddo\r
+ do k=1,3\r
+ dc_norm(k,i)=erij(k)\r
+ enddo\r
+cd do k=1,3\r
+cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') \r
+cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),\r
+cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)\r
+cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') \r
+cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),\r
+cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)\r
+cd write (iout,'(a)')\r
+cd enddo\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------------\r
+\r
+\r
+ subroutine set_matrices\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+#ifdef MPI\r
+ include "mpif.h"\r
+ include "COMMON.SETUP"\r
+ integer IERR\r
+ integer status(MPI_STATUS_SIZE)\r
+#endif\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VECTORS'\r
+ include 'COMMON.FFIELD'\r
+ double precision auxvec(2),auxmat(2,2)\r
+C\r
+C Compute the virtual-bond-torsional-angle dependent quantities needed\r
+C to calculate the el-loc multibody terms of various order.\r
+C\r
+#ifdef PARMAT\r
+ do i=ivec_start+2,ivec_end+2\r
+#else\r
+ do i=3,nres+1\r
+#endif\r
+ if (i .lt. nres+1) then\r
+ sin1=dsin(phi(i))\r
+ cos1=dcos(phi(i))\r
+ sintab(i-2)=sin1\r
+ costab(i-2)=cos1\r
+ obrot(1,i-2)=cos1\r
+ obrot(2,i-2)=sin1\r
+ sin2=dsin(2*phi(i))\r
+ cos2=dcos(2*phi(i))\r
+ sintab2(i-2)=sin2\r
+ costab2(i-2)=cos2\r
+ obrot2(1,i-2)=cos2\r
+ obrot2(2,i-2)=sin2\r
+ Ug(1,1,i-2)=-cos1\r
+ Ug(1,2,i-2)=-sin1\r
+ Ug(2,1,i-2)=-sin1\r
+ Ug(2,2,i-2)= cos1\r
+ Ug2(1,1,i-2)=-cos2\r
+ Ug2(1,2,i-2)=-sin2\r
+ Ug2(2,1,i-2)=-sin2\r
+ Ug2(2,2,i-2)= cos2\r
+ else\r
+ costab(i-2)=1.0d0\r
+ sintab(i-2)=0.0d0\r
+ obrot(1,i-2)=1.0d0\r
+ obrot(2,i-2)=0.0d0\r
+ obrot2(1,i-2)=0.0d0\r
+ obrot2(2,i-2)=0.0d0\r
+ Ug(1,1,i-2)=1.0d0\r
+ Ug(1,2,i-2)=0.0d0\r
+ Ug(2,1,i-2)=0.0d0\r
+ Ug(2,2,i-2)=1.0d0\r
+ Ug2(1,1,i-2)=0.0d0\r
+ Ug2(1,2,i-2)=0.0d0\r
+ Ug2(2,1,i-2)=0.0d0\r
+ Ug2(2,2,i-2)=0.0d0\r
+ endif\r
+ if (i .gt. 3 .and. i .lt. nres+1) then\r
+ obrot_der(1,i-2)=-sin1\r
+ obrot_der(2,i-2)= cos1\r
+ Ugder(1,1,i-2)= sin1\r
+ Ugder(1,2,i-2)=-cos1\r
+ Ugder(2,1,i-2)=-cos1\r
+ Ugder(2,2,i-2)=-sin1\r
+ dwacos2=cos2+cos2\r
+ dwasin2=sin2+sin2\r
+ obrot2_der(1,i-2)=-dwasin2\r
+ obrot2_der(2,i-2)= dwacos2\r
+ Ug2der(1,1,i-2)= dwasin2\r
+ Ug2der(1,2,i-2)=-dwacos2\r
+ Ug2der(2,1,i-2)=-dwacos2\r
+ Ug2der(2,2,i-2)=-dwasin2\r
+ else\r
+ obrot_der(1,i-2)=0.0d0\r
+ obrot_der(2,i-2)=0.0d0\r
+ Ugder(1,1,i-2)=0.0d0\r
+ Ugder(1,2,i-2)=0.0d0\r
+ Ugder(2,1,i-2)=0.0d0\r
+ Ugder(2,2,i-2)=0.0d0\r
+ obrot2_der(1,i-2)=0.0d0\r
+ obrot2_der(2,i-2)=0.0d0\r
+ Ug2der(1,1,i-2)=0.0d0\r
+ Ug2der(1,2,i-2)=0.0d0\r
+ Ug2der(2,1,i-2)=0.0d0\r
+ Ug2der(2,2,i-2)=0.0d0\r
+ endif\r
+c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then\r
+ if (i.gt. nnt+2 .and. i.lt.nct+2) then\r
+ iti = itortyp(itype(i-2))\r
+ else\r
+ iti=ntortyp+1\r
+ endif\r
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then\r
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then\r
+ iti1 = itortyp(itype(i-1))\r
+ else\r
+ iti1=ntortyp+1\r
+ endif\r
+cd write (iout,*) '*******i',i,' iti1',iti\r
+cd write (iout,*) 'b1',b1(:,iti)\r
+cd write (iout,*) 'b2',b2(:,iti)\r
+cd write (iout,*) 'Ug',Ug(:,:,i-2)\r
+c if (i .gt. iatel_s+2) then\r
+ if (i .gt. nnt+2) then\r
+ call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))\r
+ call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))\r
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) \r
+ & then\r
+ call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))\r
+ call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))\r
+ call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))\r
+ call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))\r
+ call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))\r
+ endif\r
+ else\r
+ do k=1,2\r
+ Ub2(k,i-2)=0.0d0\r
+ Ctobr(k,i-2)=0.0d0 \r
+ Dtobr2(k,i-2)=0.0d0\r
+ do l=1,2\r
+ EUg(l,k,i-2)=0.0d0\r
+ CUg(l,k,i-2)=0.0d0\r
+ DUg(l,k,i-2)=0.0d0\r
+ DtUg2(l,k,i-2)=0.0d0\r
+ enddo\r
+ enddo\r
+ endif\r
+ call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))\r
+ call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))\r
+ do k=1,2\r
+ muder(k,i-2)=Ub2der(k,i-2)\r
+ enddo\r
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then\r
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then\r
+ iti1 = itortyp(itype(i-1))\r
+ else\r
+ iti1=ntortyp+1\r
+ endif\r
+ do k=1,2\r
+ mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)\r
+ enddo\r
+cd write (iout,*) 'mu ',mu(:,i-2)\r
+cd write (iout,*) 'mu1',mu1(:,i-2)\r
+cd write (iout,*) 'mu2',mu2(:,i-2)\r
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)\r
+ & then \r
+ call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))\r
+ call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))\r
+ call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))\r
+ call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))\r
+ call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))\r
+C Vectors and matrices dependent on a single virtual-bond dihedral.\r
+ call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))\r
+ call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2)) \r
+ call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2)) \r
+ call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))\r
+ call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))\r
+ call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))\r
+ call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))\r
+ call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))\r
+ call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))\r
+ endif\r
+ enddo\r
+C Matrices dependent on two consecutive virtual-bond dihedrals.\r
+C The order of matrices is from left to right.\r
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)\r
+ &then\r
+c do i=max0(ivec_start,2),ivec_end\r
+ do i=2,nres-1\r
+ call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))\r
+ call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))\r
+ call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))\r
+ call transpose2(DtUg2(1,1,i-1),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))\r
+ call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))\r
+ call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))\r
+ enddo\r
+ endif\r
+#if defined(MPI) && defined(PARMAT)\r
+#ifdef DEBUG\r
+c if (fg_rank.eq.0) then\r
+ write (iout,*) "Arrays UG and UGDER before GATHER"\r
+ do i=1,nres-1\r
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
+ & ((ug(l,k,i),l=1,2),k=1,2),\r
+ & ((ugder(l,k,i),l=1,2),k=1,2)\r
+ enddo\r
+ write (iout,*) "Arrays UG2 and UG2DER"\r
+ do i=1,nres-1\r
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
+ & ((ug2(l,k,i),l=1,2),k=1,2),\r
+ & ((ug2der(l,k,i),l=1,2),k=1,2)\r
+ enddo\r
+ write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"\r
+ do i=1,nres-1\r
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
+ & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),\r
+ & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)\r
+ enddo\r
+ write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"\r
+ do i=1,nres-1\r
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
+ & costab(i),sintab(i),costab2(i),sintab2(i)\r
+ enddo\r
+ write (iout,*) "Array MUDER"\r
+ do i=1,nres-1\r
+ write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)\r
+ enddo\r
+c endif\r
+#endif\r
+ if (nfgtasks.gt.1) then\r
+ time00=MPI_Wtime()\r
+c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,\r
+c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),\r
+c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)\r
+#ifdef MATGATHER\r
+ call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),\r
+ & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),\r
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)\r
+ call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),\r
+ & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),\r
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)\r
+ call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),\r
+ & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),\r
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)\r
+ call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),\r
+ & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),\r
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)\r
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)\r
+ & then\r
+ call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),\r
+ & ivec_count(fg_rank1),\r
+ & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Dtug2der(1,1,ivec_start),\r
+ & ivec_count(fg_rank1),\r
+ & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),\r
+ & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),\r
+ & ivec_count(fg_rank1),\r
+ & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),\r
+ & ivec_count(fg_rank1),\r
+ & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,\r
+ & FG_COMM1,IERR)\r
+ call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),\r
+ & ivec_count(fg_rank1),\r
+ & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),\r
+ & MPI_MAT2,FG_COMM1,IERR)\r
+ call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),\r
+ & ivec_count(fg_rank1),\r
+ & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),\r
+ & MPI_MAT2,FG_COMM1,IERR)\r
+ endif\r
+#else\r
+c Passes matrix info through the ring\r
+ isend=fg_rank1\r
+ irecv=fg_rank1-1\r
+ if (irecv.lt.0) irecv=nfgtasks1-1 \r
+ iprev=irecv\r
+ inext=fg_rank1+1\r
+ if (inext.ge.nfgtasks1) inext=0\r
+ do i=1,nfgtasks1-1\r
+c write (iout,*) "isend",isend," irecv",irecv\r
+c call flush(iout)\r
+ lensend=lentyp(isend)\r
+ lenrecv=lentyp(irecv)\r
+c write (iout,*) "lensend",lensend," lenrecv",lenrecv\r
+c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,\r
+c & MPI_ROTAT1(lensend),inext,2200+isend,\r
+c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),\r
+c & iprev,2200+irecv,FG_COMM,status,IERR)\r
+c write (iout,*) "Gather ROTAT1"\r
+c call flush(iout)\r
+c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,\r
+c & MPI_ROTAT2(lensend),inext,3300+isend,\r
+c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),\r
+c & iprev,3300+irecv,FG_COMM,status,IERR)\r
+c write (iout,*) "Gather ROTAT2"\r
+c call flush(iout)\r
+ call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,\r
+ & MPI_ROTAT_OLD(lensend),inext,4400+isend,\r
+ & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),\r
+ & iprev,4400+irecv,FG_COMM,status,IERR)\r
+c write (iout,*) "Gather ROTAT_OLD"\r
+c call flush(iout)\r
+ call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,\r
+ & MPI_PRECOMP11(lensend),inext,5500+isend,\r
+ & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),\r
+ & iprev,5500+irecv,FG_COMM,status,IERR)\r
+c write (iout,*) "Gather PRECOMP11"\r
+c call flush(iout)\r
+ call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,\r
+ & MPI_PRECOMP12(lensend),inext,6600+isend,\r
+ & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),\r
+ & iprev,6600+irecv,FG_COMM,status,IERR)\r
+c write (iout,*) "Gather PRECOMP12"\r
+c call flush(iout)\r
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) \r
+ & then\r
+ call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,\r
+ & MPI_ROTAT2(lensend),inext,7700+isend,\r
+ & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),\r
+ & iprev,7700+irecv,FG_COMM,status,IERR)\r
+c write (iout,*) "Gather PRECOMP21"\r
+c call flush(iout)\r
+ call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,\r
+ & MPI_PRECOMP22(lensend),inext,8800+isend,\r
+ & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),\r
+ & iprev,8800+irecv,FG_COMM,status,IERR)\r
+c write (iout,*) "Gather PRECOMP22"\r
+c call flush(iout)\r
+ call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,\r
+ & MPI_PRECOMP23(lensend),inext,9900+isend,\r
+ & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,\r
+ & MPI_PRECOMP23(lenrecv),\r
+ & iprev,9900+irecv,FG_COMM,status,IERR)\r
+c write (iout,*) "Gather PRECOMP23"\r
+c call flush(iout)\r
+ endif\r
+ isend=irecv\r
+ irecv=irecv-1\r
+ if (irecv.lt.0) irecv=nfgtasks1-1\r
+ enddo\r
+#endif\r
+ time_gather=time_gather+MPI_Wtime()-time00\r
+ endif\r
+#ifdef DEBUG\r
+c if (fg_rank.eq.0) then\r
+ write (iout,*) "Arrays UG and UGDER"\r
+ do i=1,nres-1\r
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
+ & ((ug(l,k,i),l=1,2),k=1,2),\r
+ & ((ugder(l,k,i),l=1,2),k=1,2)\r
+ enddo\r
+ write (iout,*) "Arrays UG2 and UG2DER"\r
+ do i=1,nres-1\r
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
+ & ((ug2(l,k,i),l=1,2),k=1,2),\r
+ & ((ug2der(l,k,i),l=1,2),k=1,2)\r
+ enddo\r
+ write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"\r
+ do i=1,nres-1\r
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
+ & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),\r
+ & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)\r
+ enddo\r
+ write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"\r
+ do i=1,nres-1\r
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,\r
+ & costab(i),sintab(i),costab2(i),sintab2(i)\r
+ enddo\r
+ write (iout,*) "Array MUDER"\r
+ do i=1,nres-1\r
+ write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)\r
+ enddo\r
+c endif\r
+#endif\r
+#endif\r
+cd do i=1,nres\r
+cd iti = itortyp(itype(i))\r
+cd write (iout,*) i\r
+cd do j=1,2\r
+cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)') \r
+cd & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)\r
+cd enddo\r
+cd enddo\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------------\r
+\r
+\r
+ subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)\r
+C\r
+C This subroutine calculates the average interaction energy and its gradient\r
+C in the virtual-bond vectors between non-adjacent peptide groups, based on \r
+C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. \r
+C The potential depends both on the distance of peptide-group centers and on \r
+C the orientation of the CA-CA virtual bonds.\r
+C \r
+ implicit real*8 (a-h,o-z)\r
+#ifdef MPI\r
+ include 'mpif.h'\r
+#endif\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.CONTROL'\r
+ include 'COMMON.SETUP'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VECTORS'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.TIME1'\r
+ dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),\r
+ & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)\r
+ double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),\r
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)\r
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,\r
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,\r
+ & num_conti,j1,j2\r
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions\r
+#ifdef MOMENT\r
+ double precision scal_el /1.0d0/\r
+#else\r
+ double precision scal_el /0.5d0/\r
+#endif\r
+C 12/13/98 \r
+C 13-go grudnia roku pamietnego... \r
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,\r
+ & 0.0d0,1.0d0,0.0d0,\r
+ & 0.0d0,0.0d0,1.0d0/\r
+cd write(iout,*) 'In EELEC'\r
+cd do i=1,nloctyp\r
+cd write(iout,*) 'Type',i\r
+cd write(iout,*) 'B1',B1(:,i)\r
+cd write(iout,*) 'B2',B2(:,i)\r
+cd write(iout,*) 'CC',CC(:,:,i)\r
+cd write(iout,*) 'DD',DD(:,:,i)\r
+cd write(iout,*) 'EE',EE(:,:,i)\r
+cd enddo\r
+cd call check_vecgrad\r
+cd stop\r
+ if (icheckgrad.eq.1) then\r
+ do i=1,nres-1\r
+ fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))\r
+ do k=1,3\r
+ dc_norm(k,i)=dc(k,i)*fac\r
+ enddo\r
+c write (iout,*) 'i',i,' fac',fac\r
+ enddo\r
+ endif\r
+ if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 \r
+ & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. \r
+ & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then\r
+c call vec_and_deriv\r
+#ifdef TIMING\r
+ time01=MPI_Wtime()\r
+#endif\r
+ call set_matrices\r
+#ifdef TIMING\r
+ time_mat=time_mat+MPI_Wtime()-time01\r
+#endif\r
+ endif\r
+cd do i=1,nres-1\r
+cd write (iout,*) 'i=',i\r
+cd do k=1,3\r
+cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)\r
+cd enddo\r
+cd do k=1,3\r
+cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') \r
+cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)\r
+cd enddo\r
+cd enddo\r
+ t_eelecij=0.0d0\r
+ ees=0.0D0\r
+ evdw1=0.0D0\r
+ eel_loc=0.0d0 \r
+ eello_turn3=0.0d0\r
+ eello_turn4=0.0d0\r
+ ind=0\r
+ do i=1,nres\r
+ num_cont_hb(i)=0\r
+ enddo\r
+cd print '(a)','Enter EELEC'\r
+cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e\r
+ do i=1,nres\r
+ gel_loc_loc(i)=0.0d0\r
+ gcorr_loc(i)=0.0d0\r
+ enddo\r
+c\r
+c\r
+c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms\r
+C\r
+C Loop over i,i+2 and i,i+3 pairs of the peptide groups\r
+C\r
+ do i=iturn3_start,iturn3_end\r
+ dxi=dc(1,i)\r
+ dyi=dc(2,i)\r
+ dzi=dc(3,i)\r
+ dx_normi=dc_norm(1,i)\r
+ dy_normi=dc_norm(2,i)\r
+ dz_normi=dc_norm(3,i)\r
+ xmedi=c(1,i)+0.5d0*dxi\r
+ ymedi=c(2,i)+0.5d0*dyi\r
+ zmedi=c(3,i)+0.5d0*dzi\r
+ num_conti=0\r
+ call eelecij(i,i+2,ees,evdw1,eel_loc)\r
+ if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)\r
+ num_cont_hb(i)=num_conti\r
+ enddo\r
+ do i=iturn4_start,iturn4_end\r
+ dxi=dc(1,i)\r
+ dyi=dc(2,i)\r
+ dzi=dc(3,i)\r
+ dx_normi=dc_norm(1,i)\r
+ dy_normi=dc_norm(2,i)\r
+ dz_normi=dc_norm(3,i)\r
+ xmedi=c(1,i)+0.5d0*dxi\r
+ ymedi=c(2,i)+0.5d0*dyi\r
+ zmedi=c(3,i)+0.5d0*dzi\r
+ num_conti=num_cont_hb(i)\r
+ call eelecij(i,i+3,ees,evdw1,eel_loc)\r
+ if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)\r
+ num_cont_hb(i)=num_conti\r
+ enddo ! i\r
+c\r
+c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3\r
+c\r
+ do i=iatel_s,iatel_e\r
+ dxi=dc(1,i)\r
+ dyi=dc(2,i)\r
+ dzi=dc(3,i)\r
+ dx_normi=dc_norm(1,i)\r
+ dy_normi=dc_norm(2,i)\r
+ dz_normi=dc_norm(3,i)\r
+ xmedi=c(1,i)+0.5d0*dxi\r
+ ymedi=c(2,i)+0.5d0*dyi\r
+ zmedi=c(3,i)+0.5d0*dzi\r
+c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)\r
+ num_conti=num_cont_hb(i)\r
+ do j=ielstart(i),ielend(i)\r
+ call eelecij(i,j,ees,evdw1,eel_loc)\r
+ enddo ! j\r
+ num_cont_hb(i)=num_conti\r
+ enddo ! i\r
+c write (iout,*) "Number of loop steps in EELEC:",ind\r
+cd do i=1,nres\r
+cd write (iout,'(i3,3f10.5,5x,3f10.5)') \r
+cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)\r
+cd enddo\r
+c 12/7/99 Adam eello_turn3 will be considered as a separate energy term\r
+ccc eel_loc=eel_loc+eello_turn3\r
+cd print *,"Processor",fg_rank," t_eelecij",t_eelecij\r
+ return\r
+ end\r
+\r
+\r
+C-------------------------------------------------------------------------------\r
+\r
+\r
+cDEC$ ATTRIBUTES FORCEINLINE :: eelecij\r
+ subroutine eelecij(i,j,ees,evdw1,eel_loc)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+#ifdef MPI\r
+ include "mpif.h"\r
+#endif\r
+ include 'COMMON.CONTROL'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VECTORS'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.TIME1'\r
+ dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),\r
+ & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)\r
+ double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),\r
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)\r
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,\r
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,\r
+ & num_conti,j1,j2\r
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions\r
+#ifdef MOMENT\r
+ double precision scal_el /1.0d0/\r
+#else\r
+ double precision scal_el /0.5d0/\r
+#endif\r
+C 12/13/98 \r
+C 13-go grudnia roku pamietnego... \r
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,\r
+ & 0.0d0,1.0d0,0.0d0,\r
+ & 0.0d0,0.0d0,1.0d0/\r
+c time00=MPI_Wtime()\r
+cd write (iout,*) "eelecij",i,j\r
+c ind=ind+1\r
+ iteli=itel(i)\r
+ itelj=itel(j)\r
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2\r
+ aaa=app(iteli,itelj)\r
+ bbb=bpp(iteli,itelj)\r
+ ael6i=ael6(iteli,itelj)\r
+ ael3i=ael3(iteli,itelj) \r
+ dxj=dc(1,j)\r
+ dyj=dc(2,j)\r
+ dzj=dc(3,j)\r
+ dx_normj=dc_norm(1,j)\r
+ dy_normj=dc_norm(2,j)\r
+ dz_normj=dc_norm(3,j)\r
+ xj=c(1,j)+0.5D0*dxj-xmedi\r
+ yj=c(2,j)+0.5D0*dyj-ymedi\r
+ zj=c(3,j)+0.5D0*dzj-zmedi\r
+ rij=xj*xj+yj*yj+zj*zj\r
+ rrmij=1.0D0/rij\r
+ rij=dsqrt(rij)\r
+ rmij=1.0D0/rij\r
+ r3ij=rrmij*rmij\r
+ r6ij=r3ij*r3ij \r
+ cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj\r
+ cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij\r
+ cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij\r
+ fac=cosa-3.0D0*cosb*cosg\r
+ ev1=aaa*r6ij*r6ij\r
+c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions\r
+ if (j.eq.i+2) ev1=scal_el*ev1\r
+ ev2=bbb*r6ij\r
+ fac3=ael6i*r6ij\r
+ fac4=ael3i*r3ij\r
+ evdwij=ev1+ev2\r
+ el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))\r
+ el2=fac4*fac \r
+ eesij=el1+el2\r
+C 12/26/95 - for the evaluation of multi-body H-bonding interactions\r
+ ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)\r
+ ees=ees+eesij\r
+ evdw1=evdw1+evdwij\r
+cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')\r
+cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,\r
+cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,\r
+cd & xmedi,ymedi,zmedi,xj,yj,zj\r
+\r
+ if (energy_dec) then \r
+ write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij\r
+ write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij\r
+ endif\r
+\r
+C\r
+C Calculate contributions to the Cartesian gradient.\r
+C\r
+#ifdef SPLITELE\r
+ facvdw=-6*rrmij*(ev1+evdwij)\r
+ facel=-3*rrmij*(el1+eesij)\r
+ fac1=fac\r
+ erij(1)=xj*rmij\r
+ erij(2)=yj*rmij\r
+ erij(3)=zj*rmij\r
+*\r
+* Radial derivatives. First process both termini of the fragment (i,j)\r
+*\r
+ ggg(1)=facel*xj\r
+ ggg(2)=facel*yj\r
+ ggg(3)=facel*zj\r
+c do k=1,3\r
+c ghalf=0.5D0*ggg(k)\r
+c gelc(k,i)=gelc(k,i)+ghalf\r
+c gelc(k,j)=gelc(k,j)+ghalf\r
+c enddo\r
+c 9/28/08 AL Gradient compotents will be summed only at the end\r
+ do k=1,3\r
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)\r
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)\r
+ enddo\r
+*\r
+* Loop over residues i+1 thru j-1.\r
+*\r
+cgrad do k=i+1,j-1\r
+cgrad do l=1,3\r
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+ ggg(1)=facvdw*xj\r
+ ggg(2)=facvdw*yj\r
+ ggg(3)=facvdw*zj\r
+c do k=1,3\r
+c ghalf=0.5D0*ggg(k)\r
+c gvdwpp(k,i)=gvdwpp(k,i)+ghalf\r
+c gvdwpp(k,j)=gvdwpp(k,j)+ghalf\r
+c enddo\r
+c 9/28/08 AL Gradient compotents will be summed only at the end\r
+ do k=1,3\r
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)\r
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)\r
+ enddo\r
+*\r
+* Loop over residues i+1 thru j-1.\r
+*\r
+cgrad do k=i+1,j-1\r
+cgrad do l=1,3\r
+cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+#else\r
+ facvdw=ev1+evdwij \r
+ facel=el1+eesij \r
+ fac1=fac\r
+ fac=-3*rrmij*(facvdw+facvdw+facel)\r
+ erij(1)=xj*rmij\r
+ erij(2)=yj*rmij\r
+ erij(3)=zj*rmij\r
+*\r
+* Radial derivatives. First process both termini of the fragment (i,j)\r
+* \r
+ ggg(1)=fac*xj\r
+ ggg(2)=fac*yj\r
+ ggg(3)=fac*zj\r
+c do k=1,3\r
+c ghalf=0.5D0*ggg(k)\r
+c gelc(k,i)=gelc(k,i)+ghalf\r
+c gelc(k,j)=gelc(k,j)+ghalf\r
+c enddo\r
+c 9/28/08 AL Gradient compotents will be summed only at the end\r
+ do k=1,3\r
+ gelc_long(k,j)=gelc(k,j)+ggg(k)\r
+ gelc_long(k,i)=gelc(k,i)-ggg(k)\r
+ enddo\r
+*\r
+* Loop over residues i+1 thru j-1.\r
+*\r
+cgrad do k=i+1,j-1\r
+cgrad do l=1,3\r
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+c 9/28/08 AL Gradient compotents will be summed only at the end\r
+ ggg(1)=facvdw*xj\r
+ ggg(2)=facvdw*yj\r
+ ggg(3)=facvdw*zj\r
+ do k=1,3\r
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)\r
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)\r
+ enddo\r
+#endif\r
+*\r
+* Angular part\r
+* \r
+ ecosa=2.0D0*fac3*fac1+fac4\r
+ fac4=-3.0D0*fac4\r
+ fac3=-6.0D0*fac3\r
+ ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)\r
+ ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)\r
+ do k=1,3\r
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)\r
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)\r
+ enddo\r
+cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),\r
+cd & (dcosg(k),k=1,3)\r
+ do k=1,3\r
+ ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) \r
+ enddo\r
+c do k=1,3\r
+c ghalf=0.5D0*ggg(k)\r
+c gelc(k,i)=gelc(k,i)+ghalf\r
+c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))\r
+c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)\r
+c gelc(k,j)=gelc(k,j)+ghalf\r
+c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))\r
+c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)\r
+c enddo\r
+cgrad do k=i+1,j-1\r
+cgrad do l=1,3\r
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+ do k=1,3\r
+ gelc(k,i)=gelc(k,i)\r
+ & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))\r
+ & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)\r
+ gelc(k,j)=gelc(k,j)\r
+ & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))\r
+ & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)\r
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)\r
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)\r
+ enddo\r
+ IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0\r
+ & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 \r
+ & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN\r
+C\r
+C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction \r
+C energy of a peptide unit is assumed in the form of a second-order \r
+C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.\r
+C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms\r
+C are computed for EVERY pair of non-contiguous peptide groups.\r
+C\r
+ if (j.lt.nres-1) then\r
+ j1=j+1\r
+ j2=j-1\r
+ else\r
+ j1=j-1\r
+ j2=j-2\r
+ endif\r
+ kkk=0\r
+ do k=1,2\r
+ do l=1,2\r
+ kkk=kkk+1\r
+ muij(kkk)=mu(k,i)*mu(l,j)\r
+ enddo\r
+ enddo \r
+cd write (iout,*) 'EELEC: i',i,' j',j\r
+cd write (iout,*) 'j',j,' j1',j1,' j2',j2\r
+cd write(iout,*) 'muij',muij\r
+ ury=scalar(uy(1,i),erij)\r
+ urz=scalar(uz(1,i),erij)\r
+ vry=scalar(uy(1,j),erij)\r
+ vrz=scalar(uz(1,j),erij)\r
+ a22=scalar(uy(1,i),uy(1,j))-3*ury*vry\r
+ a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz\r
+ a32=scalar(uz(1,i),uy(1,j))-3*urz*vry\r
+ a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz\r
+ fac=dsqrt(-ael6i)*r3ij\r
+ a22=a22*fac\r
+ a23=a23*fac\r
+ a32=a32*fac\r
+ a33=a33*fac\r
+cd write (iout,'(4i5,4f10.5)')\r
+cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33\r
+cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij\r
+cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),\r
+cd & uy(:,j),uz(:,j)\r
+cd write (iout,'(4f10.5)') \r
+cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),\r
+cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))\r
+cd write (iout,'(4f10.5)') ury,urz,vry,vrz\r
+cd write (iout,'(9f10.5/)') \r
+cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij\r
+C Derivatives of the elements of A in virtual-bond vectors\r
+ call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))\r
+ do k=1,3\r
+ uryg(k,1)=scalar(erder(1,k),uy(1,i))\r
+ uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))\r
+ uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))\r
+ urzg(k,1)=scalar(erder(1,k),uz(1,i))\r
+ urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))\r
+ urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))\r
+ vryg(k,1)=scalar(erder(1,k),uy(1,j))\r
+ vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))\r
+ vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))\r
+ vrzg(k,1)=scalar(erder(1,k),uz(1,j))\r
+ vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))\r
+ vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))\r
+ enddo\r
+C Compute radial contributions to the gradient\r
+ facr=-3.0d0*rrmij\r
+ a22der=a22*facr\r
+ a23der=a23*facr\r
+ a32der=a32*facr\r
+ a33der=a33*facr\r
+ agg(1,1)=a22der*xj\r
+ agg(2,1)=a22der*yj\r
+ agg(3,1)=a22der*zj\r
+ agg(1,2)=a23der*xj\r
+ agg(2,2)=a23der*yj\r
+ agg(3,2)=a23der*zj\r
+ agg(1,3)=a32der*xj\r
+ agg(2,3)=a32der*yj\r
+ agg(3,3)=a32der*zj\r
+ agg(1,4)=a33der*xj\r
+ agg(2,4)=a33der*yj\r
+ agg(3,4)=a33der*zj\r
+C Add the contributions coming from er\r
+ fac3=-3.0d0*fac\r
+ do k=1,3\r
+ agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)\r
+ agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)\r
+ agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)\r
+ agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)\r
+ enddo\r
+ do k=1,3\r
+C Derivatives in DC(i) \r
+cgrad ghalf1=0.5d0*agg(k,1)\r
+cgrad ghalf2=0.5d0*agg(k,2)\r
+cgrad ghalf3=0.5d0*agg(k,3)\r
+cgrad ghalf4=0.5d0*agg(k,4)\r
+ aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))\r
+ & -3.0d0*uryg(k,2)*vry)!+ghalf1\r
+ aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))\r
+ & -3.0d0*uryg(k,2)*vrz)!+ghalf2\r
+ aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))\r
+ & -3.0d0*urzg(k,2)*vry)!+ghalf3\r
+ aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))\r
+ & -3.0d0*urzg(k,2)*vrz)!+ghalf4\r
+C Derivatives in DC(i+1)\r
+ aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))\r
+ & -3.0d0*uryg(k,3)*vry)!+agg(k,1)\r
+ aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))\r
+ & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)\r
+ aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))\r
+ & -3.0d0*urzg(k,3)*vry)!+agg(k,3)\r
+ aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))\r
+ & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)\r
+C Derivatives in DC(j)\r
+ aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))\r
+ & -3.0d0*vryg(k,2)*ury)!+ghalf1\r
+ aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))\r
+ & -3.0d0*vrzg(k,2)*ury)!+ghalf2\r
+ aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))\r
+ & -3.0d0*vryg(k,2)*urz)!+ghalf3\r
+ aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) \r
+ & -3.0d0*vrzg(k,2)*urz)!+ghalf4\r
+C Derivatives in DC(j+1) or DC(nres-1)\r
+ aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))\r
+ & -3.0d0*vryg(k,3)*ury)\r
+ aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))\r
+ & -3.0d0*vrzg(k,3)*ury)\r
+ aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))\r
+ & -3.0d0*vryg(k,3)*urz)\r
+ aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) \r
+ & -3.0d0*vrzg(k,3)*urz)\r
+cgrad if (j.eq.nres-1 .and. i.lt.j-2) then\r
+cgrad do l=1,4\r
+cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)\r
+cgrad enddo\r
+cgrad endif\r
+ enddo\r
+ acipa(1,1)=a22\r
+ acipa(1,2)=a23\r
+ acipa(2,1)=a32\r
+ acipa(2,2)=a33\r
+ a22=-a22\r
+ a23=-a23\r
+ do l=1,2\r
+ do k=1,3\r
+ agg(k,l)=-agg(k,l)\r
+ aggi(k,l)=-aggi(k,l)\r
+ aggi1(k,l)=-aggi1(k,l)\r
+ aggj(k,l)=-aggj(k,l)\r
+ aggj1(k,l)=-aggj1(k,l)\r
+ enddo\r
+ enddo\r
+ if (j.lt.nres-1) then\r
+ a22=-a22\r
+ a32=-a32\r
+ do l=1,3,2\r
+ do k=1,3\r
+ agg(k,l)=-agg(k,l)\r
+ aggi(k,l)=-aggi(k,l)\r
+ aggi1(k,l)=-aggi1(k,l)\r
+ aggj(k,l)=-aggj(k,l)\r
+ aggj1(k,l)=-aggj1(k,l)\r
+ enddo\r
+ enddo\r
+ else\r
+ a22=-a22\r
+ a23=-a23\r
+ a32=-a32\r
+ a33=-a33\r
+ do l=1,4\r
+ do k=1,3\r
+ agg(k,l)=-agg(k,l)\r
+ aggi(k,l)=-aggi(k,l)\r
+ aggi1(k,l)=-aggi1(k,l)\r
+ aggj(k,l)=-aggj(k,l)\r
+ aggj1(k,l)=-aggj1(k,l)\r
+ enddo\r
+ enddo \r
+ endif \r
+ ENDIF ! WCORR\r
+ IF (wel_loc.gt.0.0d0) THEN\r
+C Contribution to the local-electrostatic energy coming from the i-j pair\r
+ eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)\r
+ & +a33*muij(4)\r
+cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij\r
+\r
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')\r
+ & 'eelloc',i,j,eel_loc_ij\r
+\r
+ eel_loc=eel_loc+eel_loc_ij\r
+C Partial derivatives in virtual-bond dihedral angles gamma\r
+ if (i.gt.1)\r
+ & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ \r
+ & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)\r
+ & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)\r
+ gel_loc_loc(j-1)=gel_loc_loc(j-1)+ \r
+ & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)\r
+ & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)\r
+C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)\r
+ do l=1,3\r
+ ggg(l)=agg(l,1)*muij(1)+\r
+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)\r
+ gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)\r
+ gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)\r
+cgrad ghalf=0.5d0*ggg(l)\r
+cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf\r
+cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf\r
+ enddo\r
+cgrad do k=i+1,j2\r
+cgrad do l=1,3\r
+cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+C Remaining derivatives of eello\r
+ do l=1,3\r
+ gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+\r
+ & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)\r
+ gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+\r
+ & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)\r
+ gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+\r
+ & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)\r
+ gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+\r
+ & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)\r
+ enddo\r
+ ENDIF\r
+C Change 12/26/95 to calculate four-body contributions to H-bonding energy\r
+c if (j.gt.i+1 .and. num_conti.le.maxconts) then\r
+ if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0\r
+ & .and. num_conti.le.maxconts) then\r
+c write (iout,*) i,j," entered corr"\r
+C\r
+C Calculate the contact function. The ith column of the array JCONT will \r
+C contain the numbers of atoms that make contacts with the atom I (of numbers\r
+C greater than I). The arrays FACONT and GACONT will contain the values of\r
+C the contact function and its derivative.\r
+c r0ij=1.02D0*rpp(iteli,itelj)\r
+c r0ij=1.11D0*rpp(iteli,itelj)\r
+ r0ij=2.20D0*rpp(iteli,itelj)\r
+c r0ij=1.55D0*rpp(iteli,itelj)\r
+ call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)\r
+ if (fcont.gt.0.0D0) then\r
+ num_conti=num_conti+1\r
+ if (num_conti.gt.maxconts) then\r
+ write (iout,*) 'WARNING - max. # of contacts exceeded;',\r
+ & ' will skip next contacts for this conf.'\r
+ else\r
+ jcont_hb(num_conti,i)=j\r
+cd write (iout,*) "i",i," j",j," num_conti",num_conti,\r
+cd & " jcont_hb",jcont_hb(num_conti,i)\r
+ IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. \r
+ & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN\r
+C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el\r
+C terms.\r
+ d_cont(num_conti,i)=rij\r
+cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij\r
+C --- Electrostatic-interaction matrix --- \r
+ a_chuj(1,1,num_conti,i)=a22\r
+ a_chuj(1,2,num_conti,i)=a23\r
+ a_chuj(2,1,num_conti,i)=a32\r
+ a_chuj(2,2,num_conti,i)=a33\r
+C --- Gradient of rij\r
+ do kkk=1,3\r
+ grij_hb_cont(kkk,num_conti,i)=erij(kkk)\r
+ enddo\r
+ kkll=0\r
+ do k=1,2\r
+ do l=1,2\r
+ kkll=kkll+1\r
+ do m=1,3\r
+ a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)\r
+ a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)\r
+ a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)\r
+ a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)\r
+ a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)\r
+ enddo\r
+ enddo\r
+ enddo\r
+ ENDIF\r
+ IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN\r
+C Calculate contact energies\r
+ cosa4=4.0D0*cosa\r
+ wij=cosa-3.0D0*cosb*cosg\r
+ cosbg1=cosb+cosg\r
+ cosbg2=cosb-cosg\r
+c fac3=dsqrt(-ael6i)/r0ij**3 \r
+ fac3=dsqrt(-ael6i)*r3ij\r
+c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)\r
+ ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1\r
+ if (ees0tmp.gt.0) then\r
+ ees0pij=dsqrt(ees0tmp)\r
+ else\r
+ ees0pij=0\r
+ endif\r
+c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)\r
+ ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2\r
+ if (ees0tmp.gt.0) then\r
+ ees0mij=dsqrt(ees0tmp)\r
+ else\r
+ ees0mij=0\r
+ endif\r
+c ees0mij=0.0D0\r
+ ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)\r
+ ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)\r
+C Diagnostics. Comment out or remove after debugging!\r
+c ees0p(num_conti,i)=0.5D0*fac3*ees0pij\r
+c ees0m(num_conti,i)=0.5D0*fac3*ees0mij\r
+c ees0m(num_conti,i)=0.0D0\r
+C End diagnostics.\r
+c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,\r
+c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont\r
+C Angular derivatives of the contact function\r
+ ees0pij1=fac3/ees0pij \r
+ ees0mij1=fac3/ees0mij\r
+ fac3p=-3.0D0*fac3*rrmij\r
+ ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)\r
+ ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)\r
+c ees0mij1=0.0D0\r
+ ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)\r
+ ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)\r
+ ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)\r
+ ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)\r
+ ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) \r
+ ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)\r
+ ecosap=ecosa1+ecosa2\r
+ ecosbp=ecosb1+ecosb2\r
+ ecosgp=ecosg1+ecosg2\r
+ ecosam=ecosa1-ecosa2\r
+ ecosbm=ecosb1-ecosb2\r
+ ecosgm=ecosg1-ecosg2\r
+C Diagnostics\r
+c ecosap=ecosa1\r
+c ecosbp=ecosb1\r
+c ecosgp=ecosg1\r
+c ecosam=0.0D0\r
+c ecosbm=0.0D0\r
+c ecosgm=0.0D0\r
+C End diagnostics\r
+ facont_hb(num_conti,i)=fcont\r
+ fprimcont=fprimcont/rij\r
+cd facont_hb(num_conti,i)=1.0D0\r
+C Following line is for diagnostics.\r
+cd fprimcont=0.0D0\r
+ do k=1,3\r
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)\r
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)\r
+ enddo\r
+ do k=1,3\r
+ gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)\r
+ gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)\r
+ enddo\r
+ gggp(1)=gggp(1)+ees0pijp*xj\r
+ gggp(2)=gggp(2)+ees0pijp*yj\r
+ gggp(3)=gggp(3)+ees0pijp*zj\r
+ gggm(1)=gggm(1)+ees0mijp*xj\r
+ gggm(2)=gggm(2)+ees0mijp*yj\r
+ gggm(3)=gggm(3)+ees0mijp*zj\r
+C Derivatives due to the contact function\r
+ gacont_hbr(1,num_conti,i)=fprimcont*xj\r
+ gacont_hbr(2,num_conti,i)=fprimcont*yj\r
+ gacont_hbr(3,num_conti,i)=fprimcont*zj\r
+ do k=1,3\r
+c\r
+c 10/24/08 cgrad and ! comments indicate the parts of the code removed \r
+c following the change of gradient-summation algorithm.\r
+c\r
+cgrad ghalfp=0.5D0*gggp(k)\r
+cgrad ghalfm=0.5D0*gggm(k)\r
+ gacontp_hb1(k,num_conti,i)=!ghalfp\r
+ & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))\r
+ & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)\r
+ gacontp_hb2(k,num_conti,i)=!ghalfp\r
+ & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))\r
+ & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)\r
+ gacontp_hb3(k,num_conti,i)=gggp(k)\r
+ gacontm_hb1(k,num_conti,i)=!ghalfm\r
+ & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))\r
+ & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)\r
+ gacontm_hb2(k,num_conti,i)=!ghalfm\r
+ & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))\r
+ & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)\r
+ gacontm_hb3(k,num_conti,i)=gggm(k)\r
+ enddo\r
+C Diagnostics. Comment out or remove after debugging!\r
+cdiag do k=1,3\r
+cdiag gacontp_hb1(k,num_conti,i)=0.0D0\r
+cdiag gacontp_hb2(k,num_conti,i)=0.0D0\r
+cdiag gacontp_hb3(k,num_conti,i)=0.0D0\r
+cdiag gacontm_hb1(k,num_conti,i)=0.0D0\r
+cdiag gacontm_hb2(k,num_conti,i)=0.0D0\r
+cdiag gacontm_hb3(k,num_conti,i)=0.0D0\r
+cdiag enddo\r
+ ENDIF ! wcorr\r
+ endif ! num_conti.le.maxconts\r
+ endif ! fcont.gt.0\r
+ endif ! j.gt.i+1\r
+ if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then\r
+ do k=1,4\r
+ do l=1,3\r
+ ghalf=0.5d0*agg(l,k)\r
+ aggi(l,k)=aggi(l,k)+ghalf\r
+ aggi1(l,k)=aggi1(l,k)+agg(l,k)\r
+ aggj(l,k)=aggj(l,k)+ghalf\r
+ enddo\r
+ enddo\r
+ if (j.eq.nres-1 .and. i.lt.j-2) then\r
+ do k=1,4\r
+ do l=1,3\r
+ aggj1(l,k)=aggj1(l,k)+agg(l,k)\r
+ enddo\r
+ enddo\r
+ endif\r
+ endif\r
+c t_eelecij=t_eelecij+MPI_Wtime()-time00\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine eturn3(i,eello_turn3)\r
+C Third- and fourth-order contributions from turns\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VECTORS'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.CONTROL'\r
+ dimension ggg(3)\r
+ double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),\r
+ & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),\r
+ & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)\r
+ double precision agg(3,4),aggi(3,4),aggi1(3,4),\r
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)\r
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,\r
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,\r
+ & num_conti,j1,j2\r
+ j=i+2\r
+c write (iout,*) "eturn3",i,j,j1,j2\r
+ a_temp(1,1)=a22\r
+ a_temp(1,2)=a23\r
+ a_temp(2,1)=a32\r
+ a_temp(2,2)=a33\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+C\r
+C Third-order contributions\r
+C \r
+C (i+2)o----(i+3)\r
+C | |\r
+C | |\r
+C (i+1)o----i\r
+C\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC \r
+cd call checkint_turn3(i,a_temp,eello_turn3_num)\r
+ call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))\r
+ call transpose2(auxmat(1,1),auxmat1(1,1))\r
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))\r
+ eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))\r
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')\r
+ & 'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))\r
+cd write (2,*) 'i,',i,' j',j,'eello_turn3',\r
+cd & 0.5d0*(pizda(1,1)+pizda(2,2)),\r
+cd & ' eello_turn3_num',4*eello_turn3_num\r
+C Derivatives in gamma(i)\r
+ call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))\r
+ call transpose2(auxmat2(1,1),auxmat3(1,1))\r
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))\r
+ gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))\r
+C Derivatives in gamma(i+1)\r
+ call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))\r
+ call transpose2(auxmat2(1,1),auxmat3(1,1))\r
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))\r
+ gel_loc_turn3(i+1)=gel_loc_turn3(i+1)\r
+ & +0.5d0*(pizda(1,1)+pizda(2,2))\r
+C Cartesian derivatives\r
+ do l=1,3\r
+c ghalf1=0.5d0*agg(l,1)\r
+c ghalf2=0.5d0*agg(l,2)\r
+c ghalf3=0.5d0*agg(l,3)\r
+c ghalf4=0.5d0*agg(l,4)\r
+ a_temp(1,1)=aggi(l,1)!+ghalf1\r
+ a_temp(1,2)=aggi(l,2)!+ghalf2\r
+ a_temp(2,1)=aggi(l,3)!+ghalf3\r
+ a_temp(2,2)=aggi(l,4)!+ghalf4\r
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))\r
+ gcorr3_turn(l,i)=gcorr3_turn(l,i)\r
+ & +0.5d0*(pizda(1,1)+pizda(2,2))\r
+ a_temp(1,1)=aggi1(l,1)!+agg(l,1)\r
+ a_temp(1,2)=aggi1(l,2)!+agg(l,2)\r
+ a_temp(2,1)=aggi1(l,3)!+agg(l,3)\r
+ a_temp(2,2)=aggi1(l,4)!+agg(l,4)\r
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))\r
+ gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)\r
+ & +0.5d0*(pizda(1,1)+pizda(2,2))\r
+ a_temp(1,1)=aggj(l,1)!+ghalf1\r
+ a_temp(1,2)=aggj(l,2)!+ghalf2\r
+ a_temp(2,1)=aggj(l,3)!+ghalf3\r
+ a_temp(2,2)=aggj(l,4)!+ghalf4\r
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))\r
+ gcorr3_turn(l,j)=gcorr3_turn(l,j)\r
+ & +0.5d0*(pizda(1,1)+pizda(2,2))\r
+ a_temp(1,1)=aggj1(l,1)\r
+ a_temp(1,2)=aggj1(l,2)\r
+ a_temp(2,1)=aggj1(l,3)\r
+ a_temp(2,2)=aggj1(l,4)\r
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))\r
+ gcorr3_turn(l,j1)=gcorr3_turn(l,j1)\r
+ & +0.5d0*(pizda(1,1)+pizda(2,2))\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+C-------------------------------------------------------------------------------\r
+\r
+\r
+ subroutine eturn4(i,eello_turn4)\r
+C Third- and fourth-order contributions from turns\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VECTORS'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.CONTROL'\r
+ dimension ggg(3)\r
+ double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),\r
+ & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),\r
+ & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)\r
+ double precision agg(3,4),aggi(3,4),aggi1(3,4),\r
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)\r
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,\r
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,\r
+ & num_conti,j1,j2\r
+ j=i+3\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+C\r
+C Fourth-order contributions\r
+C \r
+C (i+3)o----(i+4)\r
+C / |\r
+C (i+2)o |\r
+C \ |\r
+C (i+1)o----i\r
+C\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC \r
+cd call checkint_turn4(i,a_temp,eello_turn4_num)\r
+c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2\r
+ a_temp(1,1)=a22\r
+ a_temp(1,2)=a23\r
+ a_temp(2,1)=a32\r
+ a_temp(2,2)=a33\r
+ iti1=itortyp(itype(i+1))\r
+ iti2=itortyp(itype(i+2))\r
+ iti3=itortyp(itype(i+3))\r
+c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3\r
+ call transpose2(EUg(1,1,i+1),e1t(1,1))\r
+ call transpose2(Eug(1,1,i+2),e2t(1,1))\r
+ call transpose2(Eug(1,1,i+3),e3t(1,1))\r
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
+ s1=scalar2(b1(1,iti2),auxvec(1))\r
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
+ s2=scalar2(b1(1,iti1),auxvec(1))\r
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
+ eello_turn4=eello_turn4-(s1+s2+s3)\r
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')\r
+ & 'eturn4',i,j,-(s1+s2+s3)\r
+cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),\r
+cd & ' eello_turn4_num',8*eello_turn4_num\r
+C Derivatives in gamma(i)\r
+ call transpose2(EUgder(1,1,i+1),e1tder(1,1))\r
+ call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))\r
+ s1=scalar2(b1(1,iti2),auxvec(1))\r
+ call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))\r
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
+ gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)\r
+C Derivatives in gamma(i+1)\r
+ call transpose2(EUgder(1,1,i+2),e2tder(1,1))\r
+ call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1)) \r
+ s2=scalar2(b1(1,iti1),auxvec(1))\r
+ call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))\r
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
+ gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)\r
+C Derivatives in gamma(i+2)\r
+ call transpose2(EUgder(1,1,i+3),e3tder(1,1))\r
+ call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))\r
+ s1=scalar2(b1(1,iti2),auxvec(1))\r
+ call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1)) \r
+ s2=scalar2(b1(1,iti1),auxvec(1))\r
+ call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))\r
+ call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))\r
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
+ gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)\r
+C Cartesian derivatives\r
+C Derivatives of this turn contributions in DC(i+2)\r
+ if (j.lt.nres-1) then\r
+ do l=1,3\r
+ a_temp(1,1)=agg(l,1)\r
+ a_temp(1,2)=agg(l,2)\r
+ a_temp(2,1)=agg(l,3)\r
+ a_temp(2,2)=agg(l,4)\r
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
+ s1=scalar2(b1(1,iti2),auxvec(1))\r
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
+ s2=scalar2(b1(1,iti1),auxvec(1))\r
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
+ ggg(l)=-(s1+s2+s3)\r
+ gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)\r
+ enddo\r
+ endif\r
+C Remaining derivatives of this turn contribution\r
+ do l=1,3\r
+ a_temp(1,1)=aggi(l,1)\r
+ a_temp(1,2)=aggi(l,2)\r
+ a_temp(2,1)=aggi(l,3)\r
+ a_temp(2,2)=aggi(l,4)\r
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
+ s1=scalar2(b1(1,iti2),auxvec(1))\r
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
+ s2=scalar2(b1(1,iti1),auxvec(1))\r
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
+ gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)\r
+ a_temp(1,1)=aggi1(l,1)\r
+ a_temp(1,2)=aggi1(l,2)\r
+ a_temp(2,1)=aggi1(l,3)\r
+ a_temp(2,2)=aggi1(l,4)\r
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
+ s1=scalar2(b1(1,iti2),auxvec(1))\r
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
+ s2=scalar2(b1(1,iti1),auxvec(1))\r
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
+ gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)\r
+ a_temp(1,1)=aggj(l,1)\r
+ a_temp(1,2)=aggj(l,2)\r
+ a_temp(2,1)=aggj(l,3)\r
+ a_temp(2,2)=aggj(l,4)\r
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
+ s1=scalar2(b1(1,iti2),auxvec(1))\r
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
+ s2=scalar2(b1(1,iti1),auxvec(1))\r
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
+ gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)\r
+ a_temp(1,1)=aggj1(l,1)\r
+ a_temp(1,2)=aggj1(l,2)\r
+ a_temp(2,1)=aggj1(l,3)\r
+ a_temp(2,2)=aggj1(l,4)\r
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))\r
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))\r
+ s1=scalar2(b1(1,iti2),auxvec(1))\r
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))\r
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) \r
+ s2=scalar2(b1(1,iti1),auxvec(1))\r
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))\r
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))\r
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))\r
+c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3\r
+ gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+C-----------------------------------------------------------------------------\r
+\r
+\r
+ subroutine vecpr(u,v,w)\r
+ implicit real*8(a-h,o-z)\r
+ dimension u(3),v(3),w(3)\r
+ w(1)=u(2)*v(3)-u(3)*v(2)\r
+ w(2)=-u(1)*v(3)+u(3)*v(1)\r
+ w(3)=u(1)*v(2)-u(2)*v(1)\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine unormderiv(u,ugrad,unorm,ungrad)\r
+C This subroutine computes the derivatives of a normalized vector u, given\r
+C the derivatives computed without normalization conditions, ugrad. Returns\r
+C ungrad.\r
+ implicit none\r
+ double precision u(3),ugrad(3,3),unorm,ungrad(3,3)\r
+ double precision vec(3)\r
+ double precision scalar\r
+ integer i,j\r
+c write (2,*) 'ugrad',ugrad\r
+c write (2,*) 'u',u\r
+ do i=1,3\r
+ vec(i)=scalar(ugrad(1,i),u(1))\r
+ enddo\r
+c write (2,*) 'vec',vec\r
+ do i=1,3\r
+ do j=1,3\r
+ ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm\r
+ enddo\r
+ enddo\r
+c write (2,*) 'ungrad',ungrad\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine escp_soft_sphere(evdw2,evdw2_14)\r
+C\r
+C This subroutine calculates the excluded-volume interaction energy between\r
+C peptide-group centers and side chains and its gradient in virtual-bond and\r
+C side-chain vectors.\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CONTROL'\r
+ dimension ggg(3)\r
+ evdw2=0.0D0\r
+ evdw2_14=0.0d0\r
+ r0_scp=4.5d0\r
+cd print '(a)','Enter ESCP'\r
+cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e\r
+ do i=iatscp_s,iatscp_e\r
+ iteli=itel(i)\r
+ xi=0.5D0*(c(1,i)+c(1,i+1))\r
+ yi=0.5D0*(c(2,i)+c(2,i+1))\r
+ zi=0.5D0*(c(3,i)+c(3,i+1))\r
+\r
+ do iint=1,nscp_gr(i)\r
+\r
+ do j=iscpstart(i,iint),iscpend(i,iint)\r
+ itypj=itype(j)\r
+C Uncomment following three lines for SC-p interactions\r
+c xj=c(1,nres+j)-xi\r
+c yj=c(2,nres+j)-yi\r
+c zj=c(3,nres+j)-zi\r
+C Uncomment following three lines for Ca-p interactions\r
+ xj=c(1,j)-xi\r
+ yj=c(2,j)-yi\r
+ zj=c(3,j)-zi\r
+ rij=xj*xj+yj*yj+zj*zj\r
+ r0ij=r0_scp\r
+ r0ijsq=r0ij*r0ij\r
+ if (rij.lt.r0ijsq) then\r
+ evdwij=0.25d0*(rij-r0ijsq)**2\r
+ fac=rij-r0ijsq\r
+ else\r
+ evdwij=0.0d0\r
+ fac=0.0d0\r
+ endif \r
+ evdw2=evdw2+evdwij\r
+C\r
+C Calculate contributions to the gradient in the virtual-bond and SC vectors.\r
+C\r
+ ggg(1)=xj*fac\r
+ ggg(2)=yj*fac\r
+ ggg(3)=zj*fac\r
+cgrad if (j.lt.i) then\r
+cd write (iout,*) 'j<i'\r
+C Uncomment following three lines for SC-p interactions\r
+c do k=1,3\r
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)\r
+c enddo\r
+cgrad else\r
+cd write (iout,*) 'j>i'\r
+cgrad do k=1,3\r
+cgrad ggg(k)=-ggg(k)\r
+C Uncomment following line for SC-p interactions\r
+c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)\r
+cgrad enddo\r
+cgrad endif\r
+cgrad do k=1,3\r
+cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)\r
+cgrad enddo\r
+cgrad kstart=min0(i+1,j)\r
+cgrad kend=max0(i-1,j-1)\r
+cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend\r
+cd write (iout,*) ggg(1),ggg(2),ggg(3)\r
+cgrad do k=kstart,kend\r
+cgrad do l=1,3\r
+cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+ do k=1,3\r
+ gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)\r
+ gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)\r
+ enddo\r
+ enddo\r
+\r
+ enddo ! iint\r
+ enddo ! i\r
+ return\r
+ end\r
+\r
+\r
+C-----------------------------------------------------------------------------\r
+\r
+\r
+ subroutine escp(evdw2,evdw2_14)\r
+C\r
+C This subroutine calculates the excluded-volume interaction energy between\r
+C peptide-group centers and side chains and its gradient in virtual-bond and\r
+C side-chain vectors.\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CONTROL'\r
+ dimension ggg(3)\r
+ evdw2=0.0D0\r
+ evdw2_14=0.0d0\r
+cd print '(a)','Enter ESCP'\r
+cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e\r
+ do i=iatscp_s,iatscp_e\r
+ iteli=itel(i)\r
+ xi=0.5D0*(c(1,i)+c(1,i+1))\r
+ yi=0.5D0*(c(2,i)+c(2,i+1))\r
+ zi=0.5D0*(c(3,i)+c(3,i+1))\r
+\r
+ do iint=1,nscp_gr(i)\r
+\r
+ do j=iscpstart(i,iint),iscpend(i,iint)\r
+ itypj=itype(j)\r
+C Uncomment following three lines for SC-p interactions\r
+c xj=c(1,nres+j)-xi\r
+c yj=c(2,nres+j)-yi\r
+c zj=c(3,nres+j)-zi\r
+C Uncomment following three lines for Ca-p interactions\r
+ xj=c(1,j)-xi\r
+ yj=c(2,j)-yi\r
+ zj=c(3,j)-zi\r
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
+ fac=rrij**expon2\r
+ e1=fac*fac*aad(itypj,iteli)\r
+ e2=fac*bad(itypj,iteli)\r
+ if (iabs(j-i) .le. 2) then\r
+ e1=scal14*e1\r
+ e2=scal14*e2\r
+ evdw2_14=evdw2_14+e1+e2\r
+ endif\r
+ evdwij=e1+e2\r
+ evdw2=evdw2+evdwij\r
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')\r
+ & 'evdw2',i,j,evdwij\r
+C\r
+C Calculate contributions to the gradient in the virtual-bond and SC vectors.\r
+C\r
+ fac=-(evdwij+e1)*rrij\r
+ ggg(1)=xj*fac\r
+ ggg(2)=yj*fac\r
+ ggg(3)=zj*fac\r
+cgrad if (j.lt.i) then\r
+cd write (iout,*) 'j<i'\r
+C Uncomment following three lines for SC-p interactions\r
+c do k=1,3\r
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)\r
+c enddo\r
+cgrad else\r
+cd write (iout,*) 'j>i'\r
+cgrad do k=1,3\r
+cgrad ggg(k)=-ggg(k)\r
+C Uncomment following line for SC-p interactions\r
+ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)\r
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)\r
+cgrad enddo\r
+cgrad endif\r
+cgrad do k=1,3\r
+cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)\r
+cgrad enddo\r
+cgrad kstart=min0(i+1,j)\r
+cgrad kend=max0(i-1,j-1)\r
+cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend\r
+cd write (iout,*) ggg(1),ggg(2),ggg(3)\r
+cgrad do k=kstart,kend\r
+cgrad do l=1,3\r
+cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+ do k=1,3\r
+ gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)\r
+ gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)\r
+ enddo\r
+ enddo\r
+\r
+ enddo ! iint\r
+ enddo ! i\r
+ do i=1,nct\r
+ do j=1,3\r
+ gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)\r
+ gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)\r
+ gradx_scp(j,i)=expon*gradx_scp(j,i)\r
+ enddo\r
+ enddo\r
+C******************************************************************************\r
+C\r
+C N O T E !!!\r
+C\r
+C To save time the factor EXPON has been extracted from ALL components\r
+C of GVDWC and GRADX. Remember to multiply them by this factor before further \r
+C use!\r
+C\r
+C******************************************************************************\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine edis(ehpb)\r
+C \r
+C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.SBRIDGE'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.IOUNITS'\r
+ dimension ggg(3)\r
+ ehpb=0.0D0\r
+cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr\r
+cd write(iout,*)'link_start=',link_start,' link_end=',link_end\r
+ if (link_end.eq.0) return\r
+ do i=link_start,link_end\r
+C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a\r
+C CA-CA distance used in regularization of structure.\r
+ ii=ihpb(i)\r
+ jj=jhpb(i)\r
+C iii and jjj point to the residues for which the distance is assigned.\r
+ if (ii.gt.nres) then\r
+ iii=ii-nres\r
+ jjj=jj-nres \r
+ else\r
+ iii=ii\r
+ jjj=jj\r
+ endif\r
+cd write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj\r
+C 24/11/03 AL: SS bridges handled separately because of introducing a specific\r
+C distance and angle dependent SS bond potential.\r
+ if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then\r
+ call ssbond_ene(iii,jjj,eij)\r
+ ehpb=ehpb+2*eij\r
+cd write (iout,*) "eij",eij\r
+ else\r
+C Calculate the distance between the two points and its difference from the\r
+C target distance.\r
+ dd=dist(ii,jj)\r
+ rdis=dd-dhpb(i)\r
+C Get the force constant corresponding to this distance.\r
+ waga=forcon(i)\r
+C Calculate the contribution to energy.\r
+ ehpb=ehpb+waga*rdis*rdis\r
+C\r
+C Evaluate gradient.\r
+C\r
+ fac=waga*rdis/dd\r
+cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,\r
+cd & ' waga=',waga,' fac=',fac\r
+ do j=1,3\r
+ ggg(j)=fac*(c(j,jj)-c(j,ii))\r
+ enddo\r
+cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)\r
+C If this is a SC-SC distance, we need to calculate the contributions to the\r
+C Cartesian gradient in the SC vectors (ghpbx).\r
+ if (iii.lt.ii) then\r
+ do j=1,3\r
+ ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)\r
+ ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)\r
+ enddo\r
+ endif\r
+cgrad do j=iii,jjj-1\r
+cgrad do k=1,3\r
+cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)\r
+cgrad enddo\r
+cgrad enddo\r
+ do k=1,3\r
+ ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)\r
+ ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)\r
+ enddo\r
+ endif\r
+ enddo\r
+ ehpb=0.5D0*ehpb\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine ssbond_ene(i,j,eij)\r
+C \r
+C Calculate the distance and angle dependent SS-bond potential energy\r
+C using a free-energy function derived based on RHF/6-31G** ab initio\r
+C calculations of diethyl disulfide.\r
+C\r
+C A. Liwo and U. Kozlowska, 11/24/03\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.SBRIDGE'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.IOUNITS'\r
+ double precision erij(3),dcosom1(3),dcosom2(3),gg(3)\r
+ itypi=itype(i)\r
+ xi=c(1,nres+i)\r
+ yi=c(2,nres+i)\r
+ zi=c(3,nres+i)\r
+ dxi=dc_norm(1,nres+i)\r
+ dyi=dc_norm(2,nres+i)\r
+ dzi=dc_norm(3,nres+i)\r
+c dsci_inv=dsc_inv(itypi)\r
+ dsci_inv=vbld_inv(nres+i)\r
+ itypj=itype(j)\r
+c dscj_inv=dsc_inv(itypj)\r
+ dscj_inv=vbld_inv(nres+j)\r
+ xj=c(1,nres+j)-xi\r
+ yj=c(2,nres+j)-yi\r
+ zj=c(3,nres+j)-zi\r
+ dxj=dc_norm(1,nres+j)\r
+ dyj=dc_norm(2,nres+j)\r
+ dzj=dc_norm(3,nres+j)\r
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)\r
+ rij=dsqrt(rrij)\r
+ erij(1)=xj*rij\r
+ erij(2)=yj*rij\r
+ erij(3)=zj*rij\r
+ om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)\r
+ om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)\r
+ om12=dxi*dxj+dyi*dyj+dzi*dzj\r
+ do k=1,3\r
+ dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))\r
+ dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))\r
+ enddo\r
+ rij=1.0d0/rij\r
+ deltad=rij-d0cm\r
+ deltat1=1.0d0-om1\r
+ deltat2=1.0d0+om2\r
+ deltat12=om2-om1+2.0d0\r
+ cosphi=om12-om1*om2\r
+ eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)\r
+ & +akct*deltad*deltat12\r
+ & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi\r
+c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,\r
+c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,\r
+c & " deltat12",deltat12," eij",eij \r
+ ed=2*akcm*deltad+akct*deltat12\r
+ pom1=akct*deltad\r
+ pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi\r
+ eom1=-2*akth*deltat1-pom1-om2*pom2\r
+ eom2= 2*akth*deltat2+pom1-om1*pom2\r
+ eom12=pom2\r
+ do k=1,3\r
+ ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)\r
+ ghpbx(k,i)=ghpbx(k,i)-ggk\r
+ & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))\r
+ & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv\r
+ ghpbx(k,j)=ghpbx(k,j)+ggk\r
+ & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))\r
+ & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv\r
+ ghpbc(k,i)=ghpbc(k,i)-ggk\r
+ ghpbc(k,j)=ghpbc(k,j)+ggk\r
+ enddo\r
+C\r
+C Calculate the components of the gradient in DC and X\r
+C\r
+cgrad do k=i,j-1\r
+cgrad do l=1,3\r
+cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)\r
+cgrad enddo\r
+cgrad enddo\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine ebond(estr)\r
+c\r
+c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds\r
+c\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.CONTROL'\r
+ include 'COMMON.SETUP'\r
+ double precision u(3),ud(3)\r
+ estr=0.0d0\r
+ do i=ibondp_start,ibondp_end\r
+ diff = vbld(i)-vbldp0\r
+c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff\r
+ estr=estr+diff*diff\r
+ do j=1,3\r
+ gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)\r
+ enddo\r
+c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)\r
+ enddo\r
+ estr=0.5d0*AKP*estr\r
+c\r
+c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included\r
+c\r
+ do i=ibond_start,ibond_end\r
+ iti=itype(i)\r
+ if (iti.ne.10) then\r
+ nbi=nbondterm(iti)\r
+ if (nbi.eq.1) then\r
+ diff=vbld(i+nres)-vbldsc0(1,iti)\r
+c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,\r
+c & AKSC(1,iti),AKSC(1,iti)*diff*diff\r
+ estr=estr+0.5d0*AKSC(1,iti)*diff*diff\r
+ do j=1,3\r
+ gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)\r
+ enddo\r
+ else\r
+ do j=1,nbi\r
+ diff=vbld(i+nres)-vbldsc0(j,iti) \r
+ ud(j)=aksc(j,iti)*diff\r
+ u(j)=abond0(j,iti)+0.5d0*ud(j)*diff\r
+ enddo\r
+ uprod=u(1)\r
+ do j=2,nbi\r
+ uprod=uprod*u(j)\r
+ enddo\r
+ usum=0.0d0\r
+ usumsqder=0.0d0\r
+ do j=1,nbi\r
+ uprod1=1.0d0\r
+ uprod2=1.0d0\r
+ do k=1,nbi\r
+ if (k.ne.j) then\r
+ uprod1=uprod1*u(k)\r
+ uprod2=uprod2*u(k)*u(k)\r
+ endif\r
+ enddo\r
+ usum=usum+uprod1\r
+ usumsqder=usumsqder+ud(j)*uprod2 \r
+ enddo\r
+ estr=estr+uprod/usum\r
+ do j=1,3\r
+ gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)\r
+ enddo\r
+ endif\r
+ endif\r
+ enddo\r
+ return\r
+ end \r
+#ifdef CRYST_THETA\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine ebend(etheta)\r
+C\r
+C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral\r
+C angles gamma and its derivatives in consecutive thetas and gammas.\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.CONTROL'\r
+ common /calcthet/ term1,term2,termm,diffak,ratak,\r
+ & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,\r
+ & delthe0,sig0inv,sigtc,sigsqtc,delthec,it\r
+ double precision y(2),z(2)\r
+ delta=0.02d0*pi\r
+c time11=dexp(-2*time)\r
+c time12=1.0d0\r
+ etheta=0.0D0\r
+c write (*,'(a,i2)') 'EBEND ICG=',icg\r
+ do i=ithet_start,ithet_end\r
+C Zero the energy function and its derivative at 0 or pi.\r
+ call splinthet(theta(i),0.5d0*delta,ss,ssd)\r
+ it=itype(i-1)\r
+ if (i.gt.3) then\r
+#ifdef OSF\r
+ phii=phi(i)\r
+ if (phii.ne.phii) phii=150.0\r
+#else\r
+ phii=phi(i)\r
+#endif\r
+ y(1)=dcos(phii)\r
+ y(2)=dsin(phii)\r
+ else \r
+ y(1)=0.0D0\r
+ y(2)=0.0D0\r
+ endif\r
+ if (i.lt.nres) then\r
+#ifdef OSF\r
+ phii1=phi(i+1)\r
+ if (phii1.ne.phii1) phii1=150.0\r
+ phii1=pinorm(phii1)\r
+ z(1)=cos(phii1)\r
+#else\r
+ phii1=phi(i+1)\r
+ z(1)=dcos(phii1)\r
+#endif\r
+ z(2)=dsin(phii1)\r
+ else\r
+ z(1)=0.0D0\r
+ z(2)=0.0D0\r
+ endif \r
+C Calculate the "mean" value of theta from the part of the distribution\r
+C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).\r
+C In following comments this theta will be referred to as t_c.\r
+ thet_pred_mean=0.0d0\r
+ do k=1,2\r
+ athetk=athet(k,it)\r
+ bthetk=bthet(k,it)\r
+ thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)\r
+ enddo\r
+ dthett=thet_pred_mean*ssd\r
+ thet_pred_mean=thet_pred_mean*ss+a0thet(it)\r
+C Derivatives of the "mean" values in gamma1 and gamma2.\r
+ dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss\r
+ dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss\r
+ if (theta(i).gt.pi-delta) then\r
+ call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,\r
+ & E_tc0)\r
+ call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)\r
+ call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)\r
+ call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,\r
+ & E_theta)\r
+ call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,\r
+ & E_tc)\r
+ else if (theta(i).lt.delta) then\r
+ call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)\r
+ call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)\r
+ call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,\r
+ & E_theta)\r
+ call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)\r
+ call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,\r
+ & E_tc)\r
+ else\r
+ call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,\r
+ & E_theta,E_tc)\r
+ endif\r
+ etheta=etheta+ethetai\r
+ if (energy_dec) write (iout,'(a6,i5,0pf7.3)')\r
+ & 'ebend',i,ethetai\r
+ if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1\r
+ if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2\r
+ gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)\r
+ enddo\r
+C Ufff.... We've done all this!!! \r
+ return\r
+ end\r
+\r
+\r
+C---------------------------------------------------------------------------\r
+\r
+\r
+ subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,\r
+ & E_tc)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.IOUNITS'\r
+ common /calcthet/ term1,term2,termm,diffak,ratak,\r
+ & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,\r
+ & delthe0,sig0inv,sigtc,sigsqtc,delthec,it\r
+C Calculate the contributions to both Gaussian lobes.\r
+C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)\r
+C The "polynomial part" of the "standard deviation" of this part of \r
+C the distribution.\r
+ sig=polthet(3,it)\r
+ do j=2,0,-1\r
+ sig=sig*thet_pred_mean+polthet(j,it)\r
+ enddo\r
+C Derivative of the "interior part" of the "standard deviation of the" \r
+C gamma-dependent Gaussian lobe in t_c.\r
+ sigtc=3*polthet(3,it)\r
+ do j=2,1,-1\r
+ sigtc=sigtc*thet_pred_mean+j*polthet(j,it)\r
+ enddo\r
+ sigtc=sig*sigtc\r
+C Set the parameters of both Gaussian lobes of the distribution.\r
+C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)\r
+ fac=sig*sig+sigc0(it)\r
+ sigcsq=fac+fac\r
+ sigc=1.0D0/sigcsq\r
+C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c\r
+ sigsqtc=-4.0D0*sigcsq*sigtc\r
+c print *,i,sig,sigtc,sigsqtc\r
+C Following variable (sigtc) is d[sigma(t_c)]/dt_c\r
+ sigtc=-sigtc/(fac*fac)\r
+C Following variable is sigma(t_c)**(-2)\r
+ sigcsq=sigcsq*sigcsq\r
+ sig0i=sig0(it)\r
+ sig0inv=1.0D0/sig0i**2\r
+ delthec=thetai-thet_pred_mean\r
+ delthe0=thetai-theta0i\r
+ term1=-0.5D0*sigcsq*delthec*delthec\r
+ term2=-0.5D0*sig0inv*delthe0*delthe0\r
+C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and\r
+C NaNs in taking the logarithm. We extract the largest exponent which is added\r
+C to the energy (this being the log of the distribution) at the end of energy\r
+C term evaluation for this virtual-bond angle.\r
+ if (term1.gt.term2) then\r
+ termm=term1\r
+ term2=dexp(term2-termm)\r
+ term1=1.0d0\r
+ else\r
+ termm=term2\r
+ term1=dexp(term1-termm)\r
+ term2=1.0d0\r
+ endif\r
+C The ratio between the gamma-independent and gamma-dependent lobes of\r
+C the distribution is a Gaussian function of thet_pred_mean too.\r
+ diffak=gthet(2,it)-thet_pred_mean\r
+ ratak=diffak/gthet(3,it)**2\r
+ ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)\r
+C Let's differentiate it in thet_pred_mean NOW.\r
+ aktc=ak*ratak\r
+C Now put together the distribution terms to make complete distribution.\r
+ termexp=term1+ak*term2\r
+ termpre=sigc+ak*sig0i\r
+C Contribution of the bending energy from this theta is just the -log of\r
+C the sum of the contributions from the two lobes and the pre-exponential\r
+C factor. Simple enough, isn't it?\r
+ ethetai=(-dlog(termexp)-termm+dlog(termpre))\r
+C NOW the derivatives!!!\r
+C 6/6/97 Take into account the deformation.\r
+ E_theta=(delthec*sigcsq*term1\r
+ & +ak*delthe0*sig0inv*term2)/termexp\r
+ E_tc=((sigtc+aktc*sig0i)/termpre\r
+ & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+\r
+ & aktc*term2)/termexp)\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.IOUNITS'\r
+ common /calcthet/ term1,term2,termm,diffak,ratak,\r
+ & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,\r
+ & delthe0,sig0inv,sigtc,sigsqtc,delthec,it\r
+ delthec=thetai-thet_pred_mean\r
+ delthe0=thetai-theta0i\r
+C "Thank you" to MAPLE (probably spared one day of hand-differentiation).\r
+ t3 = thetai-thet_pred_mean\r
+ t6 = t3**2\r
+ t9 = term1\r
+ t12 = t3*sigcsq\r
+ t14 = t12+t6*sigsqtc\r
+ t16 = 1.0d0\r
+ t21 = thetai-theta0i\r
+ t23 = t21**2\r
+ t26 = term2\r
+ t27 = t21*t26\r
+ t32 = termexp\r
+ t40 = t32**2\r
+ E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9\r
+ & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40\r
+ & *(-t12*t9-ak*sig0inv*t27)\r
+ return\r
+ end\r
+#else\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine ebend(etheta)\r
+C\r
+C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral\r
+C angles gamma and its derivatives in consecutive thetas and gammas.\r
+C ab initio-derived potentials from \r
+c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.CONTROL'\r
+ double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),\r
+ & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),\r
+ & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),\r
+ & sinph1ph2(maxdouble,maxdouble)\r
+ logical lprn /.false./, lprn1 /.false./\r
+ etheta=0.0D0\r
+ do i=ithet_start,ithet_end\r
+ dethetai=0.0d0\r
+ dephii=0.0d0\r
+ dephii1=0.0d0\r
+ theti2=0.5d0*theta(i)\r
+ ityp2=ithetyp(itype(i-1))\r
+ do k=1,nntheterm\r
+ coskt(k)=dcos(k*theti2)\r
+ sinkt(k)=dsin(k*theti2)\r
+ enddo\r
+ if (i.gt.3) then\r
+#ifdef OSF\r
+ phii=phi(i)\r
+ if (phii.ne.phii) phii=150.0\r
+#else\r
+ phii=phi(i)\r
+#endif\r
+ ityp1=ithetyp(itype(i-2))\r
+ do k=1,nsingle\r
+ cosph1(k)=dcos(k*phii)\r
+ sinph1(k)=dsin(k*phii)\r
+ enddo\r
+ else\r
+ phii=0.0d0\r
+ ityp1=nthetyp+1\r
+ do k=1,nsingle\r
+ cosph1(k)=0.0d0\r
+ sinph1(k)=0.0d0\r
+ enddo \r
+ endif\r
+ if (i.lt.nres) then\r
+#ifdef OSF\r
+ phii1=phi(i+1)\r
+ if (phii1.ne.phii1) phii1=150.0\r
+ phii1=pinorm(phii1)\r
+#else\r
+ phii1=phi(i+1)\r
+#endif\r
+ ityp3=ithetyp(itype(i))\r
+ do k=1,nsingle\r
+ cosph2(k)=dcos(k*phii1)\r
+ sinph2(k)=dsin(k*phii1)\r
+ enddo\r
+ else\r
+ phii1=0.0d0\r
+ ityp3=nthetyp+1\r
+ do k=1,nsingle\r
+ cosph2(k)=0.0d0\r
+ sinph2(k)=0.0d0\r
+ enddo\r
+ endif \r
+ ethetai=aa0thet(ityp1,ityp2,ityp3)\r
+ do k=1,ndouble\r
+ do l=1,k-1\r
+ ccl=cosph1(l)*cosph2(k-l)\r
+ ssl=sinph1(l)*sinph2(k-l)\r
+ scl=sinph1(l)*cosph2(k-l)\r
+ csl=cosph1(l)*sinph2(k-l)\r
+ cosph1ph2(l,k)=ccl-ssl\r
+ cosph1ph2(k,l)=ccl+ssl\r
+ sinph1ph2(l,k)=scl+csl\r
+ sinph1ph2(k,l)=scl-csl\r
+ enddo\r
+ enddo\r
+ if (lprn) then\r
+ write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,\r
+ & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1\r
+ write (iout,*) "coskt and sinkt"\r
+ do k=1,nntheterm\r
+ write (iout,*) k,coskt(k),sinkt(k)\r
+ enddo\r
+ endif\r
+ do k=1,ntheterm\r
+ ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)\r
+ dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)\r
+ & *coskt(k)\r
+ if (lprn)\r
+ & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),\r
+ & " ethetai",ethetai\r
+ enddo\r
+ if (lprn) then\r
+ write (iout,*) "cosph and sinph"\r
+ do k=1,nsingle\r
+ write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)\r
+ enddo\r
+ write (iout,*) "cosph1ph2 and sinph2ph2"\r
+ do k=2,ndouble\r
+ do l=1,k-1\r
+ write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),\r
+ & sinph1ph2(l,k),sinph1ph2(k,l) \r
+ enddo\r
+ enddo\r
+ write(iout,*) "ethetai",ethetai\r
+ endif\r
+ do m=1,ntheterm2\r
+ do k=1,nsingle\r
+ aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)\r
+ & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)\r
+ & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)\r
+ & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)\r
+ ethetai=ethetai+sinkt(m)*aux\r
+ dethetai=dethetai+0.5d0*m*aux*coskt(m)\r
+ dephii=dephii+k*sinkt(m)*(\r
+ & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-\r
+ & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))\r
+ dephii1=dephii1+k*sinkt(m)*(\r
+ & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-\r
+ & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))\r
+ if (lprn)\r
+ & write (iout,*) "m",m," k",k," bbthet",\r
+ & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",\r
+ & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",\r
+ & ddthet(k,m,ityp1,ityp2,ityp3)," eethet",\r
+ & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai\r
+ enddo\r
+ enddo\r
+ if (lprn)\r
+ & write(iout,*) "ethetai",ethetai\r
+ do m=1,ntheterm3\r
+ do k=2,ndouble\r
+ do l=1,k-1\r
+ aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+\r
+ & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+\r
+ & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+\r
+ & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)\r
+ ethetai=ethetai+sinkt(m)*aux\r
+ dethetai=dethetai+0.5d0*m*coskt(m)*aux\r
+ dephii=dephii+l*sinkt(m)*(\r
+ & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-\r
+ & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+\r
+ & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+\r
+ & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))\r
+ dephii1=dephii1+(k-l)*sinkt(m)*(\r
+ & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+\r
+ & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+\r
+ & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-\r
+ & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))\r
+ if (lprn) then\r
+ write (iout,*) "m",m," k",k," l",l," ffthet",\r
+ & ffthet(l,k,m,ityp1,ityp2,ityp3),\r
+ & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",\r
+ & ggthet(l,k,m,ityp1,ityp2,ityp3),\r
+ & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai\r
+ write (iout,*) cosph1ph2(l,k)*sinkt(m),\r
+ & cosph1ph2(k,l)*sinkt(m),\r
+ & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)\r
+ endif\r
+ enddo\r
+ enddo\r
+ enddo\r
+10 continue\r
+ if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') \r
+ & i,theta(i)*rad2deg,phii*rad2deg,\r
+ & phii1*rad2deg,ethetai\r
+ etheta=etheta+ethetai\r
+ if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii\r
+ if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1\r
+ gloc(nphi+i-2,icg)=wang*dethetai\r
+ enddo\r
+ return\r
+ end\r
+#endif\r
+#ifdef CRYST_SC\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine esc(escloc)\r
+C Calculate the local energy of a side chain and its derivatives in the\r
+C corresponding virtual-bond valence angles THETA and the spherical angles \r
+C ALPHA and OMEGA.\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.CONTROL'\r
+ double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),\r
+ & ddersc0(3),ddummy(3),xtemp(3),temp(3)\r
+ common /sccalc/ time11,time12,time112,theti,it,nlobit\r
+ delta=0.02d0*pi\r
+ escloc=0.0D0\r
+c write (iout,'(a)') 'ESC'\r
+ do i=loc_start,loc_end\r
+ it=itype(i)\r
+ if (it.eq.10) goto 1\r
+ nlobit=nlob(it)\r
+c print *,'i=',i,' it=',it,' nlobit=',nlobit\r
+c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad\r
+ theti=theta(i+1)-pipol\r
+ x(1)=dtan(theti)\r
+ x(2)=alph(i)\r
+ x(3)=omeg(i)\r
+\r
+ if (x(2).gt.pi-delta) then\r
+ xtemp(1)=x(1)\r
+ xtemp(2)=pi-delta\r
+ xtemp(3)=x(3)\r
+ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)\r
+ xtemp(2)=pi\r
+ call enesc(xtemp,escloci1,dersc1,ddummy,.false.)\r
+ call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),\r
+ & escloci,dersc(2))\r
+ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),\r
+ & ddersc0(1),dersc(1))\r
+ call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),\r
+ & ddersc0(3),dersc(3))\r
+ xtemp(2)=pi-delta\r
+ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)\r
+ xtemp(2)=pi\r
+ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)\r
+ call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,\r
+ & dersc0(2),esclocbi,dersc02)\r
+ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),\r
+ & dersc12,dersc01)\r
+ call splinthet(x(2),0.5d0*delta,ss,ssd)\r
+ dersc0(1)=dersc01\r
+ dersc0(2)=dersc02\r
+ dersc0(3)=0.0d0\r
+ do k=1,3\r
+ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)\r
+ enddo\r
+ dersc(2)=dersc(2)+ssd*(escloci-esclocbi)\r
+c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,\r
+c & esclocbi,ss,ssd\r
+ escloci=ss*escloci+(1.0d0-ss)*esclocbi\r
+c escloci=esclocbi\r
+c write (iout,*) escloci\r
+ else if (x(2).lt.delta) then\r
+ xtemp(1)=x(1)\r
+ xtemp(2)=delta\r
+ xtemp(3)=x(3)\r
+ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)\r
+ xtemp(2)=0.0d0\r
+ call enesc(xtemp,escloci1,dersc1,ddummy,.false.)\r
+ call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),\r
+ & escloci,dersc(2))\r
+ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),\r
+ & ddersc0(1),dersc(1))\r
+ call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),\r
+ & ddersc0(3),dersc(3))\r
+ xtemp(2)=delta\r
+ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)\r
+ xtemp(2)=0.0d0\r
+ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)\r
+ call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,\r
+ & dersc0(2),esclocbi,dersc02)\r
+ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),\r
+ & dersc12,dersc01)\r
+ dersc0(1)=dersc01\r
+ dersc0(2)=dersc02\r
+ dersc0(3)=0.0d0\r
+ call splinthet(x(2),0.5d0*delta,ss,ssd)\r
+ do k=1,3\r
+ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)\r
+ enddo\r
+ dersc(2)=dersc(2)+ssd*(escloci-esclocbi)\r
+c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,\r
+c & esclocbi,ss,ssd\r
+ escloci=ss*escloci+(1.0d0-ss)*esclocbi\r
+c write (iout,*) escloci\r
+ else\r
+ call enesc(x,escloci,dersc,ddummy,.false.)\r
+ endif\r
+\r
+ escloc=escloc+escloci\r
+ if (energy_dec) write (iout,'(a6,i5,0pf7.3)')\r
+ & 'escloc',i,escloci\r
+c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc\r
+\r
+ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+\r
+ & wscloc*dersc(1)\r
+ gloc(ialph(i,1),icg)=wscloc*dersc(2)\r
+ gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)\r
+ 1 continue\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine enesc(x,escloci,dersc,ddersc,mixed)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.IOUNITS'\r
+ common /sccalc/ time11,time12,time112,theti,it,nlobit\r
+ double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)\r
+ double precision contr(maxlob,-1:1)\r
+ logical mixed\r
+c write (iout,*) 'it=',it,' nlobit=',nlobit\r
+ escloc_i=0.0D0\r
+ do j=1,3\r
+ dersc(j)=0.0D0\r
+ if (mixed) ddersc(j)=0.0d0\r
+ enddo\r
+ x3=x(3)\r
+\r
+C Because of periodicity of the dependence of the SC energy in omega we have\r
+C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).\r
+C To avoid underflows, first compute & store the exponents.\r
+\r
+ do iii=-1,1\r
+\r
+ x(3)=x3+iii*dwapi\r
+ \r
+ do j=1,nlobit\r
+ do k=1,3\r
+ z(k)=x(k)-censc(k,j,it)\r
+ enddo\r
+ do k=1,3\r
+ Axk=0.0D0\r
+ do l=1,3\r
+ Axk=Axk+gaussc(l,k,j,it)*z(l)\r
+ enddo\r
+ Ax(k,j,iii)=Axk\r
+ enddo \r
+ expfac=0.0D0 \r
+ do k=1,3\r
+ expfac=expfac+Ax(k,j,iii)*z(k)\r
+ enddo\r
+ contr(j,iii)=expfac\r
+ enddo ! j\r
+\r
+ enddo ! iii\r
+\r
+ x(3)=x3\r
+C As in the case of ebend, we want to avoid underflows in exponentiation and\r
+C subsequent NaNs and INFs in energy calculation.\r
+C Find the largest exponent\r
+ emin=contr(1,-1)\r
+ do iii=-1,1\r
+ do j=1,nlobit\r
+ if (emin.gt.contr(j,iii)) emin=contr(j,iii)\r
+ enddo \r
+ enddo\r
+ emin=0.5D0*emin\r
+cd print *,'it=',it,' emin=',emin\r
+\r
+C Compute the contribution to SC energy and derivatives\r
+ do iii=-1,1\r
+\r
+ do j=1,nlobit\r
+#ifdef OSF\r
+ adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin\r
+ if(adexp.ne.adexp) adexp=1.0\r
+ expfac=dexp(adexp)\r
+#else\r
+ expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)\r
+#endif\r
+cd print *,'j=',j,' expfac=',expfac\r
+ escloc_i=escloc_i+expfac\r
+ do k=1,3\r
+ dersc(k)=dersc(k)+Ax(k,j,iii)*expfac\r
+ enddo\r
+ if (mixed) then\r
+ do k=1,3,2\r
+ ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)\r
+ & +gaussc(k,2,j,it))*expfac\r
+ enddo\r
+ endif\r
+ enddo\r
+\r
+ enddo ! iii\r
+\r
+ dersc(1)=dersc(1)/cos(theti)**2\r
+ ddersc(1)=ddersc(1)/cos(theti)**2\r
+ ddersc(3)=ddersc(3)\r
+\r
+ escloci=-(dlog(escloc_i)-emin)\r
+ do j=1,3\r
+ dersc(j)=dersc(j)/escloc_i\r
+ enddo\r
+ if (mixed) then\r
+ do j=1,3,2\r
+ ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))\r
+ enddo\r
+ endif\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.IOUNITS'\r
+ common /sccalc/ time11,time12,time112,theti,it,nlobit\r
+ double precision x(3),z(3),Ax(3,maxlob),dersc(3)\r
+ double precision contr(maxlob)\r
+ logical mixed\r
+\r
+ escloc_i=0.0D0\r
+\r
+ do j=1,3\r
+ dersc(j)=0.0D0\r
+ enddo\r
+\r
+ do j=1,nlobit\r
+ do k=1,2\r
+ z(k)=x(k)-censc(k,j,it)\r
+ enddo\r
+ z(3)=dwapi\r
+ do k=1,3\r
+ Axk=0.0D0\r
+ do l=1,3\r
+ Axk=Axk+gaussc(l,k,j,it)*z(l)\r
+ enddo\r
+ Ax(k,j)=Axk\r
+ enddo \r
+ expfac=0.0D0 \r
+ do k=1,3\r
+ expfac=expfac+Ax(k,j)*z(k)\r
+ enddo\r
+ contr(j)=expfac\r
+ enddo ! j\r
+\r
+C As in the case of ebend, we want to avoid underflows in exponentiation and\r
+C subsequent NaNs and INFs in energy calculation.\r
+C Find the largest exponent\r
+ emin=contr(1)\r
+ do j=1,nlobit\r
+ if (emin.gt.contr(j)) emin=contr(j)\r
+ enddo \r
+ emin=0.5D0*emin\r
+ \r
+C Compute the contribution to SC energy and derivatives\r
+\r
+ dersc12=0.0d0\r
+ do j=1,nlobit\r
+ expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)\r
+ escloc_i=escloc_i+expfac\r
+ do k=1,2\r
+ dersc(k)=dersc(k)+Ax(k,j)*expfac\r
+ enddo\r
+ if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)\r
+ & +gaussc(1,2,j,it))*expfac\r
+ dersc(3)=0.0d0\r
+ enddo\r
+\r
+ dersc(1)=dersc(1)/cos(theti)**2\r
+ dersc12=dersc12/cos(theti)**2\r
+ escloci=-(dlog(escloc_i)-emin)\r
+ do j=1,2\r
+ dersc(j)=dersc(j)/escloc_i\r
+ enddo\r
+ if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))\r
+ return\r
+ end\r
+#else\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine esc(escloc)\r
+C Calculate the local energy of a side chain and its derivatives in the\r
+C corresponding virtual-bond valence angles THETA and the spherical angles \r
+C ALPHA and OMEGA derived from AM1 all-atom calculations.\r
+C added by Urszula Kozlowska. 07/11/2007\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.SCROT'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.CONTROL'\r
+ include 'COMMON.VECTORS'\r
+ double precision x_prime(3),y_prime(3),z_prime(3)\r
+ & , sumene,dsc_i,dp2_i,x(65),\r
+ & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,\r
+ & de_dxx,de_dyy,de_dzz,de_dt\r
+ double precision s1_t,s1_6_t,s2_t,s2_6_t\r
+ double precision \r
+ & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),\r
+ & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),\r
+ & dt_dCi(3),dt_dCi1(3)\r
+ common /sccalc/ time11,time12,time112,theti,it,nlobit\r
+ delta=0.02d0*pi\r
+ escloc=0.0D0\r
+ do i=loc_start,loc_end\r
+ costtab(i+1) =dcos(theta(i+1))\r
+ sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))\r
+ cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))\r
+ sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))\r
+ cosfac2=0.5d0/(1.0d0+costtab(i+1))\r
+ cosfac=dsqrt(cosfac2)\r
+ sinfac2=0.5d0/(1.0d0-costtab(i+1))\r
+ sinfac=dsqrt(sinfac2)\r
+ it=itype(i)\r
+ if (it.eq.10) goto 1\r
+c\r
+C Compute the axes of tghe local cartesian coordinates system; store in\r
+c x_prime, y_prime and z_prime \r
+c\r
+ do j=1,3\r
+ x_prime(j) = 0.00\r
+ y_prime(j) = 0.00\r
+ z_prime(j) = 0.00\r
+ enddo\r
+C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),\r
+C & dc_norm(3,i+nres)\r
+ do j = 1,3\r
+ x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac\r
+ y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac\r
+ enddo\r
+ do j = 1,3\r
+ z_prime(j) = -uz(j,i-1)\r
+ enddo \r
+c write (2,*) "i",i\r
+c write (2,*) "x_prime",(x_prime(j),j=1,3)\r
+c write (2,*) "y_prime",(y_prime(j),j=1,3)\r
+c write (2,*) "z_prime",(z_prime(j),j=1,3)\r
+c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),\r
+c & " xy",scalar(x_prime(1),y_prime(1)),\r
+c & " xz",scalar(x_prime(1),z_prime(1)),\r
+c & " yy",scalar(y_prime(1),y_prime(1)),\r
+c & " yz",scalar(y_prime(1),z_prime(1)),\r
+c & " zz",scalar(z_prime(1),z_prime(1))\r
+c\r
+C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),\r
+C to local coordinate system. Store in xx, yy, zz.\r
+c\r
+ xx=0.0d0\r
+ yy=0.0d0\r
+ zz=0.0d0\r
+ do j = 1,3\r
+ xx = xx + x_prime(j)*dc_norm(j,i+nres)\r
+ yy = yy + y_prime(j)*dc_norm(j,i+nres)\r
+ zz = zz + z_prime(j)*dc_norm(j,i+nres)\r
+ enddo\r
+\r
+ xxtab(i)=xx\r
+ yytab(i)=yy\r
+ zztab(i)=zz\r
+C\r
+C Compute the energy of the ith side cbain\r
+C\r
+c write (2,*) "xx",xx," yy",yy," zz",zz\r
+ it=itype(i)\r
+ do j = 1,65\r
+ x(j) = sc_parmin(j,it) \r
+ enddo\r
+#ifdef CHECK_COORD\r
+Cc diagnostics - remove later\r
+ xx1 = dcos(alph(2))\r
+ yy1 = dsin(alph(2))*dcos(omeg(2))\r
+ zz1 = -dsin(alph(2))*dsin(omeg(2))\r
+ write(2,'(3f8.1,3f9.3,1x,3f9.3)') \r
+ & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,\r
+ & xx1,yy1,zz1\r
+C," --- ", xx_w,yy_w,zz_w\r
+c end diagnostics\r
+#endif\r
+ sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2\r
+ & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy\r
+ & + x(10)*yy*zz\r
+ sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2\r
+ & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy\r
+ & + x(20)*yy*zz\r
+ sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2\r
+ & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy\r
+ & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3\r
+ & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx\r
+ & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy\r
+ & +x(40)*xx*yy*zz\r
+ sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2\r
+ & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy\r
+ & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3\r
+ & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx\r
+ & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy\r
+ & +x(60)*xx*yy*zz\r
+ dsc_i = 0.743d0+x(61)\r
+ dp2_i = 1.9d0+x(62)\r
+ dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i\r
+ & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))\r
+ dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i\r
+ & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))\r
+ s1=(1+x(63))/(0.1d0 + dscp1)\r
+ s1_6=(1+x(64))/(0.1d0 + dscp1**6)\r
+ s2=(1+x(65))/(0.1d0 + dscp2)\r
+ s2_6=(1+x(65))/(0.1d0 + dscp2**6)\r
+ sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)\r
+ & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)\r
+c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,\r
+c & sumene4,\r
+c & dscp1,dscp2,sumene\r
+c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))\r
+ escloc = escloc + sumene\r
+c write (2,*) "i",i," escloc",sumene,escloc\r
+#ifdef DEBUG\r
+C\r
+C This section to check the numerical derivatives of the energy of ith side\r
+C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert\r
+C #define DEBUG in the code to turn it on.\r
+C\r
+ write (2,*) "sumene =",sumene\r
+ aincr=1.0d-7\r
+ xxsave=xx\r
+ xx=xx+aincr\r
+ write (2,*) xx,yy,zz\r
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))\r
+ de_dxx_num=(sumenep-sumene)/aincr\r
+ xx=xxsave\r
+ write (2,*) "xx+ sumene from enesc=",sumenep\r
+ yysave=yy\r
+ yy=yy+aincr\r
+ write (2,*) xx,yy,zz\r
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))\r
+ de_dyy_num=(sumenep-sumene)/aincr\r
+ yy=yysave\r
+ write (2,*) "yy+ sumene from enesc=",sumenep\r
+ zzsave=zz\r
+ zz=zz+aincr\r
+ write (2,*) xx,yy,zz\r
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))\r
+ de_dzz_num=(sumenep-sumene)/aincr\r
+ zz=zzsave\r
+ write (2,*) "zz+ sumene from enesc=",sumenep\r
+ costsave=cost2tab(i+1)\r
+ sintsave=sint2tab(i+1)\r
+ cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))\r
+ sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))\r
+ sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))\r
+ de_dt_num=(sumenep-sumene)/aincr\r
+ write (2,*) " t+ sumene from enesc=",sumenep\r
+ cost2tab(i+1)=costsave\r
+ sint2tab(i+1)=sintsave\r
+C End of diagnostics section.\r
+#endif\r
+C \r
+C Compute the gradient of esc\r
+C\r
+ pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2\r
+ pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2\r
+ pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2\r
+ pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2\r
+ pom_dx=dsc_i*dp2_i*cost2tab(i+1)\r
+ pom_dy=dsc_i*dp2_i*sint2tab(i+1)\r
+ pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))\r
+ pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))\r
+ pom1=(sumene3*sint2tab(i+1)+sumene1)\r
+ & *(pom_s1/dscp1+pom_s16*dscp1**4)\r
+ pom2=(sumene4*cost2tab(i+1)+sumene2)\r
+ & *(pom_s2/dscp2+pom_s26*dscp2**4)\r
+ sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy\r
+ sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2\r
+ & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)\r
+ & +x(40)*yy*zz\r
+ sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy\r
+ sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2\r
+ & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)\r
+ & +x(60)*yy*zz\r
+ de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)\r
+ & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)\r
+ & +(pom1+pom2)*pom_dx\r
+#ifdef DEBUG\r
+ write(2,*), "de_dxx = ", de_dxx,de_dxx_num\r
+#endif\r
+C\r
+ sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz\r
+ sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2\r
+ & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)\r
+ & +x(40)*xx*zz\r
+ sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz\r
+ sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz\r
+ & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz\r
+ & +x(59)*zz**2 +x(60)*xx*zz\r
+ de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)\r
+ & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)\r
+ & +(pom1-pom2)*pom_dy\r
+#ifdef DEBUG\r
+ write(2,*), "de_dyy = ", de_dyy,de_dyy_num\r
+#endif\r
+C\r
+ de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy\r
+ & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx \r
+ & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) \r
+ & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) \r
+ & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 \r
+ & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy \r
+ & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)\r
+ & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)\r
+#ifdef DEBUG\r
+ write(2,*), "de_dzz = ", de_dzz,de_dzz_num\r
+#endif\r
+C\r
+ de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) \r
+ & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)\r
+ & +pom1*pom_dt1+pom2*pom_dt2\r
+#ifdef DEBUG\r
+ write(2,*), "de_dt = ", de_dt,de_dt_num\r
+#endif\r
+c \r
+C\r
+ cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))\r
+ cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))\r
+ cosfac2xx=cosfac2*xx\r
+ sinfac2yy=sinfac2*yy\r
+ do k = 1,3\r
+ dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*\r
+ & vbld_inv(i+1)\r
+ dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*\r
+ & vbld_inv(i)\r
+ pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)\r
+ pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)\r
+c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,\r
+c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)\r
+c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),\r
+c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)\r
+ dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx\r
+ dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx\r
+ dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy\r
+ dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy\r
+ dZZ_Ci1(k)=0.0d0\r
+ dZZ_Ci(k)=0.0d0\r
+ do j=1,3\r
+ dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)\r
+ dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)\r
+ enddo\r
+ \r
+ dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))\r
+ dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))\r
+ dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))\r
+c\r
+ dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)\r
+ dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)\r
+ enddo\r
+\r
+ do k=1,3\r
+ dXX_Ctab(k,i)=dXX_Ci(k)\r
+ dXX_C1tab(k,i)=dXX_Ci1(k)\r
+ dYY_Ctab(k,i)=dYY_Ci(k)\r
+ dYY_C1tab(k,i)=dYY_Ci1(k)\r
+ dZZ_Ctab(k,i)=dZZ_Ci(k)\r
+ dZZ_C1tab(k,i)=dZZ_Ci1(k)\r
+ dXX_XYZtab(k,i)=dXX_XYZ(k)\r
+ dYY_XYZtab(k,i)=dYY_XYZ(k)\r
+ dZZ_XYZtab(k,i)=dZZ_XYZ(k)\r
+ enddo\r
+\r
+ do k = 1,3\r
+c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",\r
+c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)\r
+c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",\r
+c & dyy_ci(k)," dzz_ci",dzz_ci(k)\r
+c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",\r
+c & dt_dci(k)\r
+c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",\r
+c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) \r
+ gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)\r
+ & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)\r
+ gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)\r
+ & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)\r
+ gsclocx(k,i)= de_dxx*dxx_XYZ(k)\r
+ & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)\r
+ enddo\r
+c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),\r
+c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) \r
+\r
+C to check gradient call subroutine check_grad\r
+\r
+ 1 continue\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ double precision function enesc(x,xx,yy,zz,cost2,sint2)\r
+ implicit none\r
+ double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,\r
+ & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6\r
+ sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2\r
+ & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy\r
+ & + x(10)*yy*zz\r
+ sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2\r
+ & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy\r
+ & + x(20)*yy*zz\r
+ sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2\r
+ & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy\r
+ & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3\r
+ & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx\r
+ & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy\r
+ & +x(40)*xx*yy*zz\r
+ sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2\r
+ & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy\r
+ & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3\r
+ & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx\r
+ & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy\r
+ & +x(60)*xx*yy*zz\r
+ dsc_i = 0.743d0+x(61)\r
+ dp2_i = 1.9d0+x(62)\r
+ dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i\r
+ & *(xx*cost2+yy*sint2))\r
+ dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i\r
+ & *(xx*cost2-yy*sint2))\r
+ s1=(1+x(63))/(0.1d0 + dscp1)\r
+ s1_6=(1+x(64))/(0.1d0 + dscp1**6)\r
+ s2=(1+x(65))/(0.1d0 + dscp2)\r
+ s2_6=(1+x(65))/(0.1d0 + dscp2**6)\r
+ sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)\r
+ & + (sumene4*cost2 +sumene2)*(s2+s2_6)\r
+ enesc=sumene\r
+ return\r
+ end\r
+#endif\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)\r
+C\r
+C This procedure calculates two-body contact function g(rij) and its derivative:\r
+C\r
+C eps0ij ! x < -1\r
+C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1\r
+C 0 ! x > 1\r
+C\r
+C where x=(rij-r0ij)/delta\r
+C\r
+C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy\r
+C\r
+ implicit none\r
+ double precision rij,r0ij,eps0ij,fcont,fprimcont\r
+ double precision x,x2,x4,delta\r
+c delta=0.02D0*r0ij\r
+c delta=0.2D0*r0ij\r
+ x=(rij-r0ij)/delta\r
+ if (x.lt.-1.0D0) then\r
+ fcont=eps0ij\r
+ fprimcont=0.0D0\r
+ else if (x.le.1.0D0) then \r
+ x2=x*x\r
+ x4=x2*x2\r
+ fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)\r
+ fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta\r
+ else\r
+ fcont=0.0D0\r
+ fprimcont=0.0D0\r
+ endif\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine splinthet(theti,delta,ss,ssder)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ thetup=pi-delta\r
+ thetlow=delta\r
+ if (theti.gt.pipol) then\r
+ call gcont(theti,thetup,1.0d0,delta,ss,ssder)\r
+ else\r
+ call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)\r
+ ssder=-ssder\r
+ endif\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)\r
+ implicit none\r
+ double precision x,x0,delta,f0,f1,fprim0,f,fprim\r
+ double precision ksi,ksi2,ksi3,a1,a2,a3\r
+ a1=fprim0*delta/(f1-f0)\r
+ a2=3.0d0-2.0d0*a1\r
+ a3=a1-2.0d0\r
+ ksi=(x-x0)/delta\r
+ ksi2=ksi*ksi\r
+ ksi3=ksi2*ksi \r
+ f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))\r
+ fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)\r
+ implicit none\r
+ double precision x,x0,delta,f0x,f1x,fprim0x,fx\r
+ double precision ksi,ksi2,ksi3,a1,a2,a3\r
+ ksi=(x-x0)/delta \r
+ ksi2=ksi*ksi\r
+ ksi3=ksi2*ksi\r
+ a1=fprim0x*delta\r
+ a2=3*(f1x-f0x)-2*fprim0x*delta\r
+ a3=fprim0x*delta-2*(f1x-f0x)\r
+ fx=f0x+a1*ksi+a2*ksi2+a3*ksi3\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+#ifdef CRYST_TOR\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine etor(etors,edihcnstr)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.TORCNSTR'\r
+ include 'COMMON.CONTROL'\r
+ logical lprn\r
+C Set lprn=.true. for debugging\r
+ lprn=.false.\r
+c lprn=.true.\r
+ etors=0.0D0\r
+ do i=iphi_start,iphi_end\r
+ etors_ii=0.0D0\r
+ itori=itortyp(itype(i-2))\r
+ itori1=itortyp(itype(i-1))\r
+ phii=phi(i)\r
+ gloci=0.0D0\r
+C Proline-Proline pair is a special case...\r
+ if (itori.eq.3 .and. itori1.eq.3) then\r
+ if (phii.gt.-dwapi3) then\r
+ cosphi=dcos(3*phii)\r
+ fac=1.0D0/(1.0D0-cosphi)\r
+ etorsi=v1(1,3,3)*fac\r
+ etorsi=etorsi+etorsi\r
+ etors=etors+etorsi-v1(1,3,3)\r
+ if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) \r
+ gloci=gloci-3*fac*etorsi*dsin(3*phii)\r
+ endif\r
+ do j=1,3\r
+ v1ij=v1(j+1,itori,itori1)\r
+ v2ij=v2(j+1,itori,itori1)\r
+ cosphi=dcos(j*phii)\r
+ sinphi=dsin(j*phii)\r
+ etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)\r
+ if (energy_dec) etors_ii=etors_ii+\r
+ & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)\r
+ gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)\r
+ enddo\r
+ else \r
+ do j=1,nterm_old\r
+ v1ij=v1(j,itori,itori1)\r
+ v2ij=v2(j,itori,itori1)\r
+ cosphi=dcos(j*phii)\r
+ sinphi=dsin(j*phii)\r
+ etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)\r
+ if (energy_dec) etors_ii=etors_ii+\r
+ & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)\r
+ gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)\r
+ enddo\r
+ endif\r
+ if (energy_dec) write (iout,'(a6,i5,0pf7.3)')\r
+ & 'etor',i,etors_ii\r
+ if (lprn)\r
+ & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')\r
+ & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,\r
+ & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)\r
+ gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci\r
+c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)\r
+ enddo\r
+! 6/20/98 - dihedral angle constraints\r
+ edihcnstr=0.0d0\r
+ do i=1,ndih_constr\r
+ itori=idih_constr(i)\r
+ phii=phi(itori)\r
+ difi=phii-phi0(i)\r
+ if (difi.gt.drange(i)) then\r
+ difi=difi-drange(i)\r
+ edihcnstr=edihcnstr+0.25d0*ftors*difi**4\r
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3\r
+ else if (difi.lt.-drange(i)) then\r
+ difi=difi+drange(i)\r
+ edihcnstr=edihcnstr+0.25d0*ftors*difi**4\r
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3\r
+ endif\r
+! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,\r
+! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)\r
+ enddo\r
+! write (iout,*) 'edihcnstr',edihcnstr\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine etor_d(etors_d)\r
+ etors_d=0.0d0\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+#else\r
+ subroutine etor(etors,edihcnstr)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.TORCNSTR'\r
+ include 'COMMON.CONTROL'\r
+ logical lprn\r
+C Set lprn=.true. for debugging\r
+ lprn=.false.\r
+c lprn=.true.\r
+ etors=0.0D0\r
+ do i=iphi_start,iphi_end\r
+ etors_ii=0.0D0\r
+ itori=itortyp(itype(i-2))\r
+ itori1=itortyp(itype(i-1))\r
+ phii=phi(i)\r
+ gloci=0.0D0\r
+C Regular cosine and sine terms\r
+ do j=1,nterm(itori,itori1)\r
+ v1ij=v1(j,itori,itori1)\r
+ v2ij=v2(j,itori,itori1)\r
+ cosphi=dcos(j*phii)\r
+ sinphi=dsin(j*phii)\r
+ etors=etors+v1ij*cosphi+v2ij*sinphi\r
+ if (energy_dec) etors_ii=etors_ii+\r
+ & v1ij*cosphi+v2ij*sinphi\r
+ gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)\r
+ enddo\r
+C Lorentz terms\r
+C v1\r
+C E = SUM ----------------------------------- - v1\r
+C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1\r
+C\r
+ cosphi=dcos(0.5d0*phii)\r
+ sinphi=dsin(0.5d0*phii)\r
+ do j=1,nlor(itori,itori1)\r
+ vl1ij=vlor1(j,itori,itori1)\r
+ vl2ij=vlor2(j,itori,itori1)\r
+ vl3ij=vlor3(j,itori,itori1)\r
+ pom=vl2ij*cosphi+vl3ij*sinphi\r
+ pom1=1.0d0/(pom*pom+1.0d0)\r
+ etors=etors+vl1ij*pom1\r
+ if (energy_dec) etors_ii=etors_ii+\r
+ & vl1ij*pom1\r
+ pom=-pom*pom1*pom1\r
+ gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom\r
+ enddo\r
+C Subtract the constant term\r
+ etors=etors-v0(itori,itori1)\r
+ if (energy_dec) write (iout,'(a6,i5,0pf7.3)')\r
+ & 'etor',i,etors_ii-v0(itori,itori1)\r
+ if (lprn)\r
+ & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')\r
+ & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,\r
+ & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)\r
+ gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci\r
+c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)\r
+ enddo\r
+! 6/20/98 - dihedral angle constraints\r
+ edihcnstr=0.0d0\r
+c do i=1,ndih_constr\r
+ do i=idihconstr_start,idihconstr_end\r
+ itori=idih_constr(i)\r
+ phii=phi(itori)\r
+ difi=pinorm(phii-phi0(i))\r
+ if (difi.gt.drange(i)) then\r
+ difi=difi-drange(i)\r
+ edihcnstr=edihcnstr+0.25d0*ftors*difi**4\r
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3\r
+ else if (difi.lt.-drange(i)) then\r
+ difi=difi+drange(i)\r
+ edihcnstr=edihcnstr+0.25d0*ftors*difi**4\r
+ gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3\r
+ else\r
+ difi=0.0\r
+ endif\r
+cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,\r
+cd & rad2deg*phi0(i), rad2deg*drange(i),\r
+cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)\r
+ enddo\r
+cd write (iout,*) 'edihcnstr',edihcnstr\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine etor_d(etors_d)\r
+C 6/23/01 Compute double torsional energy\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.TORCNSTR'\r
+ logical lprn\r
+C Set lprn=.true. for debugging\r
+ lprn=.false.\r
+c lprn=.true.\r
+ etors_d=0.0D0\r
+ do i=iphid_start,iphid_end\r
+ itori=itortyp(itype(i-2))\r
+ itori1=itortyp(itype(i-1))\r
+ itori2=itortyp(itype(i))\r
+ phii=phi(i)\r
+ phii1=phi(i+1)\r
+ gloci1=0.0D0\r
+ gloci2=0.0D0\r
+C Regular cosine and sine terms\r
+ do j=1,ntermd_1(itori,itori1,itori2)\r
+ v1cij=v1c(1,j,itori,itori1,itori2)\r
+ v1sij=v1s(1,j,itori,itori1,itori2)\r
+ v2cij=v1c(2,j,itori,itori1,itori2)\r
+ v2sij=v1s(2,j,itori,itori1,itori2)\r
+ cosphi1=dcos(j*phii)\r
+ sinphi1=dsin(j*phii)\r
+ cosphi2=dcos(j*phii1)\r
+ sinphi2=dsin(j*phii1)\r
+ etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+\r
+ & v2cij*cosphi2+v2sij*sinphi2\r
+ gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)\r
+ gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)\r
+ enddo\r
+ do k=2,ntermd_2(itori,itori1,itori2)\r
+ do l=1,k-1\r
+ v1cdij = v2c(k,l,itori,itori1,itori2)\r
+ v2cdij = v2c(l,k,itori,itori1,itori2)\r
+ v1sdij = v2s(k,l,itori,itori1,itori2)\r
+ v2sdij = v2s(l,k,itori,itori1,itori2)\r
+ cosphi1p2=dcos(l*phii+(k-l)*phii1)\r
+ cosphi1m2=dcos(l*phii-(k-l)*phii1)\r
+ sinphi1p2=dsin(l*phii+(k-l)*phii1)\r
+ sinphi1m2=dsin(l*phii-(k-l)*phii1)\r
+ etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+\r
+ & v1sdij*sinphi1p2+v2sdij*sinphi1m2\r
+ gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2\r
+ & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)\r
+ gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2\r
+ & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) \r
+ enddo\r
+ enddo\r
+ gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1\r
+ gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2\r
+ enddo\r
+ return\r
+ end\r
+#endif\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine eback_sc_corr(esccor)\r
+c 7/21/2007 Correlations between the backbone-local and side-chain-local\r
+c conformational states; temporarily implemented as differences\r
+c between UNRES torsional potentials (dependent on three types of\r
+c residues) and the torsional potentials dependent on all 20 types\r
+c of residues computed from AM1 energy surfaces of terminally-blocked\r
+c amino-acid residues.\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.SCCOR'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.NAMES'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.CONTROL'\r
+ logical lprn\r
+C Set lprn=.true. for debugging\r
+ write (*,*) "eback_sc_corr 01"\r
+ lprn=.false.\r
+c lprn=.true.\r
+c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor\r
+ esccor=0.0D0\r
+ do i=iphi_start,iphi_end\r
+ write (*,*) "eback_sc_corr 02"\r
+ esccor_ii=0.0D0\r
+ itori=itype(i-2)\r
+ itori1=itype(i-1)\r
+ phii=phi(i)\r
+ gloci=0.0D0\r
+ do j=1,nterm_sccor\r
+ write (*,*) "eback_sc_corr 03"\r
+ v1ij=v1sccor(j,itori,itori1)\r
+ v2ij=v2sccor(j,itori,itori1)\r
+ cosphi=dcos(j*phii)\r
+ sinphi=dsin(j*phii)\r
+ esccor=esccor+v1ij*cosphi+v2ij*sinphi\r
+ gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)\r
+ enddo\r
+ if (lprn)\r
+ & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')\r
+ & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,\r
+ & (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)\r
+ gsccor_loc(i-3)=gsccor_loc(i-3)+gloci\r
+ enddo\r
+ write (*,*) "eback_sc_corr 04"\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine multibody(ecorr)\r
+C This subroutine calculates multi-body contributions to energy following\r
+C the idea of Skolnick et al. If side chains I and J make a contact and\r
+C at the same time side chains I+1 and J+1 make a contact, an extra \r
+C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ double precision gx(3),gx1(3)\r
+ logical lprn\r
+\r
+C Set lprn=.true. for debugging\r
+ lprn=.false.\r
+\r
+ if (lprn) then\r
+ write (iout,'(a)') 'Contact function values:'\r
+ do i=nnt,nct-2\r
+ write (iout,'(i2,20(1x,i2,f10.5))') \r
+ & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))\r
+ enddo\r
+ endif\r
+ ecorr=0.0D0\r
+ do i=nnt,nct\r
+ do j=1,3\r
+ gradcorr(j,i)=0.0D0\r
+ gradxorr(j,i)=0.0D0\r
+ enddo\r
+ enddo\r
+ do i=nnt,nct-2\r
+\r
+ DO ISHIFT = 3,4\r
+\r
+ i1=i+ishift\r
+ num_conti=num_cont(i)\r
+ num_conti1=num_cont(i1)\r
+ do jj=1,num_conti\r
+ j=jcont(jj,i)\r
+ do kk=1,num_conti1\r
+ j1=jcont(kk,i1)\r
+ if (j1.eq.j+ishift .or. j1.eq.j-ishift) then\r
+cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,\r
+cd & ' ishift=',ishift\r
+C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. \r
+C The system gains extra energy.\r
+ ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)\r
+ endif ! j1==j+-ishift\r
+ enddo ! kk \r
+ enddo ! jj\r
+\r
+ ENDDO ! ISHIFT\r
+\r
+ enddo ! i\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ double precision function esccorr(i,j,k,l,jj,kk)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ double precision gx(3),gx1(3)\r
+ logical lprn\r
+ lprn=.false.\r
+ eij=facont(jj,i)\r
+ ekl=facont(kk,k)\r
+cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl\r
+C Calculate the multi-body contribution to energy.\r
+C Calculate multi-body contributions to the gradient.\r
+cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),\r
+cd & k,l,(gacont(m,kk,k),m=1,3)\r
+ do m=1,3\r
+ gx(m) =ekl*gacont(m,jj,i)\r
+ gx1(m)=eij*gacont(m,kk,k)\r
+ gradxorr(m,i)=gradxorr(m,i)-gx(m)\r
+ gradxorr(m,j)=gradxorr(m,j)+gx(m)\r
+ gradxorr(m,k)=gradxorr(m,k)-gx1(m)\r
+ gradxorr(m,l)=gradxorr(m,l)+gx1(m)\r
+ enddo\r
+ do m=i,j-1\r
+ do ll=1,3\r
+ gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)\r
+ enddo\r
+ enddo\r
+ do m=k,l-1\r
+ do ll=1,3\r
+ gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)\r
+ enddo\r
+ enddo \r
+ esccorr=-eij*ekl\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)\r
+C This subroutine calculates multi-body contributions to hydrogen-bonding \r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+#ifdef MPI\r
+ include "mpif.h"\r
+ parameter (max_cont=maxconts)\r
+ parameter (max_dim=26)\r
+ integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error\r
+ double precision zapas(max_dim,maxconts,max_fg_procs),\r
+ & zapas_recv(max_dim,maxconts,max_fg_procs)\r
+ common /przechowalnia/ zapas\r
+ integer status(MPI_STATUS_SIZE),req(maxconts*2),\r
+ & status_array(MPI_STATUS_SIZE,maxconts*2)\r
+#endif\r
+ include 'COMMON.SETUP'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.CONTROL'\r
+ include 'COMMON.LOCAL'\r
+ double precision gx(3),gx1(3),time00\r
+ logical lprn,ldone\r
+\r
+C Set lprn=.true. for debugging\r
+ lprn=.false.\r
+#ifdef MPI\r
+ n_corr=0\r
+ n_corr1=0\r
+ if (nfgtasks.le.1) goto 30\r
+ if (lprn) then\r
+ write (iout,'(a)') 'Contact function values before RECEIVE:'\r
+ do i=nnt,nct-2\r
+ write (iout,'(2i3,50(1x,i2,f5.2))') \r
+ & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),\r
+ & j=1,num_cont_hb(i))\r
+ enddo\r
+ endif\r
+ call flush(iout)\r
+ do i=1,ntask_cont_from\r
+ ncont_recv(i)=0\r
+ enddo\r
+ do i=1,ntask_cont_to\r
+ ncont_sent(i)=0\r
+ enddo\r
+c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",\r
+c & ntask_cont_to\r
+C Make the list of contacts to send to send to other procesors\r
+c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end\r
+c call flush(iout)\r
+ do i=iturn3_start,iturn3_end\r
+c write (iout,*) "make contact list turn3",i," num_cont",\r
+c & num_cont_hb(i)\r
+ call add_hb_contact(i,i+2,iturn3_sent_local(1,i))\r
+ enddo\r
+ do i=iturn4_start,iturn4_end\r
+c write (iout,*) "make contact list turn4",i," num_cont",\r
+c & num_cont_hb(i)\r
+ call add_hb_contact(i,i+3,iturn4_sent_local(1,i))\r
+ enddo\r
+ do ii=1,nat_sent\r
+ i=iat_sent(ii)\r
+c write (iout,*) "make contact list longrange",i,ii," num_cont",\r
+c & num_cont_hb(i)\r
+ do j=1,num_cont_hb(i)\r
+ do k=1,4\r
+ jjc=jcont_hb(j,i)\r
+ iproc=iint_sent_local(k,jjc,ii)\r
+c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc\r
+ if (iproc.gt.0) then\r
+ ncont_sent(iproc)=ncont_sent(iproc)+1\r
+ nn=ncont_sent(iproc)\r
+ zapas(1,nn,iproc)=i\r
+ zapas(2,nn,iproc)=jjc\r
+ zapas(3,nn,iproc)=facont_hb(j,i)\r
+ zapas(4,nn,iproc)=ees0p(j,i)\r
+ zapas(5,nn,iproc)=ees0m(j,i)\r
+ zapas(6,nn,iproc)=gacont_hbr(1,j,i)\r
+ zapas(7,nn,iproc)=gacont_hbr(2,j,i)\r
+ zapas(8,nn,iproc)=gacont_hbr(3,j,i)\r
+ zapas(9,nn,iproc)=gacontm_hb1(1,j,i)\r
+ zapas(10,nn,iproc)=gacontm_hb1(2,j,i)\r
+ zapas(11,nn,iproc)=gacontm_hb1(3,j,i)\r
+ zapas(12,nn,iproc)=gacontp_hb1(1,j,i)\r
+ zapas(13,nn,iproc)=gacontp_hb1(2,j,i)\r
+ zapas(14,nn,iproc)=gacontp_hb1(3,j,i)\r
+ zapas(15,nn,iproc)=gacontm_hb2(1,j,i)\r
+ zapas(16,nn,iproc)=gacontm_hb2(2,j,i)\r
+ zapas(17,nn,iproc)=gacontm_hb2(3,j,i)\r
+ zapas(18,nn,iproc)=gacontp_hb2(1,j,i)\r
+ zapas(19,nn,iproc)=gacontp_hb2(2,j,i)\r
+ zapas(20,nn,iproc)=gacontp_hb2(3,j,i)\r
+ zapas(21,nn,iproc)=gacontm_hb3(1,j,i)\r
+ zapas(22,nn,iproc)=gacontm_hb3(2,j,i)\r
+ zapas(23,nn,iproc)=gacontm_hb3(3,j,i)\r
+ zapas(24,nn,iproc)=gacontp_hb3(1,j,i)\r
+ zapas(25,nn,iproc)=gacontp_hb3(2,j,i)\r
+ zapas(26,nn,iproc)=gacontp_hb3(3,j,i)\r
+ endif\r
+ enddo\r
+ enddo\r
+ enddo\r
+ if (lprn) then\r
+ write (iout,*) \r
+ & "Numbers of contacts to be sent to other processors",\r
+ & (ncont_sent(i),i=1,ntask_cont_to)\r
+ write (iout,*) "Contacts sent"\r
+ do ii=1,ntask_cont_to\r
+ nn=ncont_sent(ii)\r
+ iproc=itask_cont_to(ii)\r
+ write (iout,*) nn," contacts to processor",iproc,\r
+ & " of CONT_TO_COMM group"\r
+ do i=1,nn\r
+ write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)\r
+ enddo\r
+ enddo\r
+ call flush(iout)\r
+ endif\r
+ CorrelType=477\r
+ CorrelID=fg_rank+1\r
+ CorrelType1=478\r
+ CorrelID1=nfgtasks+fg_rank+1\r
+ ireq=0\r
+C Receive the numbers of needed contacts from other processors \r
+ do ii=1,ntask_cont_from\r
+ iproc=itask_cont_from(ii)\r
+ ireq=ireq+1\r
+ call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,\r
+ & FG_COMM,req(ireq),IERR)\r
+ enddo\r
+c write (iout,*) "IRECV ended"\r
+c call flush(iout)\r
+C Send the number of contacts needed by other processors\r
+ do ii=1,ntask_cont_to\r
+ iproc=itask_cont_to(ii)\r
+ ireq=ireq+1\r
+ call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,\r
+ & FG_COMM,req(ireq),IERR)\r
+ enddo\r
+c write (iout,*) "ISEND ended"\r
+c write (iout,*) "number of requests (nn)",ireq\r
+ call flush(iout)\r
+ if (ireq.gt.0) \r
+ & call MPI_Waitall(ireq,req,status_array,ierr)\r
+c write (iout,*) \r
+c & "Numbers of contacts to be received from other processors",\r
+c & (ncont_recv(i),i=1,ntask_cont_from)\r
+c call flush(iout)\r
+C Receive contacts\r
+ ireq=0\r
+ do ii=1,ntask_cont_from\r
+ iproc=itask_cont_from(ii)\r
+ nn=ncont_recv(ii)\r
+c write (iout,*) "Receiving",nn," contacts from processor",iproc,\r
+c & " of CONT_TO_COMM group"\r
+ call flush(iout)\r
+ if (nn.gt.0) then\r
+ ireq=ireq+1\r
+ call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,\r
+ & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)\r
+c write (iout,*) "ireq,req",ireq,req(ireq)\r
+ endif\r
+ enddo\r
+C Send the contacts to processors that need them\r
+ do ii=1,ntask_cont_to\r
+ iproc=itask_cont_to(ii)\r
+ nn=ncont_sent(ii)\r
+c write (iout,*) nn," contacts to processor",iproc,\r
+c & " of CONT_TO_COMM group"\r
+ if (nn.gt.0) then\r
+ ireq=ireq+1 \r
+ call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,\r
+ & iproc,CorrelType1,FG_COMM,req(ireq),IERR)\r
+c write (iout,*) "ireq,req",ireq,req(ireq)\r
+c do i=1,nn\r
+c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)\r
+c enddo\r
+ endif \r
+ enddo\r
+c write (iout,*) "number of requests (contacts)",ireq\r
+c write (iout,*) "req",(req(i),i=1,4)\r
+c call flush(iout)\r
+ if (ireq.gt.0) \r
+ & call MPI_Waitall(ireq,req,status_array,ierr)\r
+ do iii=1,ntask_cont_from\r
+ iproc=itask_cont_from(iii)\r
+ nn=ncont_recv(iii)\r
+ if (lprn) then\r
+ write (iout,*) "Received",nn," contacts from processor",iproc,\r
+ & " of CONT_FROM_COMM group"\r
+ call flush(iout)\r
+ do i=1,nn\r
+ write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)\r
+ enddo\r
+ call flush(iout)\r
+ endif\r
+ do i=1,nn\r
+ ii=zapas_recv(1,i,iii)\r
+c Flag the received contacts to prevent double-counting\r
+ jj=-zapas_recv(2,i,iii)\r
+c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj\r
+c call flush(iout)\r
+ nnn=num_cont_hb(ii)+1\r
+ num_cont_hb(ii)=nnn\r
+ jcont_hb(nnn,ii)=jj\r
+ facont_hb(nnn,ii)=zapas_recv(3,i,iii)\r
+ ees0p(nnn,ii)=zapas_recv(4,i,iii)\r
+ ees0m(nnn,ii)=zapas_recv(5,i,iii)\r
+ gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)\r
+ gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)\r
+ gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)\r
+ gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)\r
+ gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)\r
+ gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)\r
+ gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)\r
+ gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)\r
+ gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)\r
+ gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)\r
+ gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)\r
+ gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)\r
+ gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)\r
+ gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)\r
+ gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)\r
+ gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)\r
+ gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)\r
+ gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)\r
+ gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)\r
+ gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)\r
+ gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)\r
+ enddo\r
+ enddo\r
+ call flush(iout)\r
+ if (lprn) then\r
+ write (iout,'(a)') 'Contact function values after receive:'\r
+ do i=nnt,nct-2\r
+ write (iout,'(2i3,50(1x,i3,f5.2))') \r
+ & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),\r
+ & j=1,num_cont_hb(i))\r
+ enddo\r
+ call flush(iout)\r
+ endif\r
+ 30 continue\r
+#endif\r
+ if (lprn) then\r
+ write (iout,'(a)') 'Contact function values:'\r
+ do i=nnt,nct-2\r
+ write (iout,'(2i3,50(1x,i3,f5.2))') \r
+ & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),\r
+ & j=1,num_cont_hb(i))\r
+ enddo\r
+ endif\r
+ ecorr=0.0D0\r
+C Remove the loop below after debugging !!!\r
+ do i=nnt,nct\r
+ do j=1,3\r
+ gradcorr(j,i)=0.0D0\r
+ gradxorr(j,i)=0.0D0\r
+ enddo\r
+ enddo\r
+C Calculate the local-electrostatic correlation terms\r
+ do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)\r
+ i1=i+1\r
+ num_conti=num_cont_hb(i)\r
+ num_conti1=num_cont_hb(i+1)\r
+ do jj=1,num_conti\r
+ j=jcont_hb(jj,i)\r
+ jp=iabs(j)\r
+ do kk=1,num_conti1\r
+ j1=jcont_hb(kk,i1)\r
+ jp1=iabs(j1)\r
+c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,\r
+c & ' jj=',jj,' kk=',kk\r
+ if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 \r
+ & .or. j.lt.0 .and. j1.gt.0) .and.\r
+ & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then\r
+C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. \r
+C The system gains extra energy.\r
+ ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)\r
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')\r
+ & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)\r
+ n_corr=n_corr+1\r
+ else if (j1.eq.j) then\r
+C Contacts I-J and I-(J+1) occur simultaneously. \r
+C The system loses extra energy.\r
+c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) \r
+ endif\r
+ enddo ! kk\r
+ do kk=1,num_conti\r
+ j1=jcont_hb(kk,i)\r
+c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,\r
+c & ' jj=',jj,' kk=',kk\r
+ if (j1.eq.j+1) then\r
+C Contacts I-J and (I+1)-J occur simultaneously. \r
+C The system loses extra energy.\r
+c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)\r
+ endif ! j1==j+1\r
+ enddo ! kk\r
+ enddo ! jj\r
+ enddo ! i\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine add_hb_contact(ii,jj,itask)\r
+ implicit real*8 (a-h,o-z)\r
+ include "DIMENSIONS"\r
+ include "COMMON.IOUNITS"\r
+ integer max_cont\r
+ integer max_dim\r
+ parameter (max_cont=maxconts)\r
+ parameter (max_dim=26)\r
+ include "COMMON.CONTACTS"\r
+ double precision zapas(max_dim,maxconts,max_fg_procs),\r
+ & zapas_recv(max_dim,maxconts,max_fg_procs)\r
+ common /przechowalnia/ zapas\r
+ integer i,j,ii,jj,iproc,itask(4),nn\r
+c write (iout,*) "itask",itask\r
+ do i=1,2\r
+ iproc=itask(i)\r
+ if (iproc.gt.0) then\r
+ do j=1,num_cont_hb(ii)\r
+ jjc=jcont_hb(j,ii)\r
+c write (iout,*) "i",ii," j",jj," jjc",jjc\r
+ if (jjc.eq.jj) then\r
+ ncont_sent(iproc)=ncont_sent(iproc)+1\r
+ nn=ncont_sent(iproc)\r
+ zapas(1,nn,iproc)=ii\r
+ zapas(2,nn,iproc)=jjc\r
+ zapas(3,nn,iproc)=facont_hb(j,ii)\r
+ zapas(4,nn,iproc)=ees0p(j,ii)\r
+ zapas(5,nn,iproc)=ees0m(j,ii)\r
+ zapas(6,nn,iproc)=gacont_hbr(1,j,ii)\r
+ zapas(7,nn,iproc)=gacont_hbr(2,j,ii)\r
+ zapas(8,nn,iproc)=gacont_hbr(3,j,ii)\r
+ zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)\r
+ zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)\r
+ zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)\r
+ zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)\r
+ zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)\r
+ zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)\r
+ zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)\r
+ zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)\r
+ zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)\r
+ zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)\r
+ zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)\r
+ zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)\r
+ zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)\r
+ zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)\r
+ zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)\r
+ zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)\r
+ zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)\r
+ zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)\r
+ exit\r
+ endif\r
+ enddo\r
+ endif\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,\r
+ & n_corr1)\r
+C This subroutine calculates multi-body contributions to hydrogen-bonding \r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+#ifdef MPI\r
+ include "mpif.h"\r
+ parameter (max_cont=maxconts)\r
+ parameter (max_dim=70)\r
+ integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error\r
+ double precision zapas(max_dim,maxconts,max_fg_procs),\r
+ & zapas_recv(max_dim,maxconts,max_fg_procs)\r
+ common /przechowalnia/ zapas\r
+ integer status(MPI_STATUS_SIZE),req(maxconts*2),\r
+ & status_array(MPI_STATUS_SIZE,maxconts*2)\r
+#endif\r
+ include 'COMMON.SETUP'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.LOCAL'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.CONTROL'\r
+ double precision gx(3),gx1(3)\r
+ integer num_cont_hb_old(maxres)\r
+ logical lprn,ldone\r
+ double precision eello4,eello5,eelo6,eello_turn6\r
+ external eello4,eello5,eello6,eello_turn6\r
+C Set lprn=.true. for debugging\r
+ lprn=.false.\r
+ eturn6=0.0d0\r
+#ifdef MPI\r
+ do i=1,nres\r
+ num_cont_hb_old(i)=num_cont_hb(i)\r
+ enddo\r
+ n_corr=0\r
+ n_corr1=0\r
+ if (nfgtasks.le.1) goto 30\r
+ if (lprn) then\r
+ write (iout,'(a)') 'Contact function values before RECEIVE:'\r
+ do i=nnt,nct-2\r
+ write (iout,'(2i3,50(1x,i2,f5.2))') \r
+ & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),\r
+ & j=1,num_cont_hb(i))\r
+ enddo\r
+ endif\r
+ call flush(iout)\r
+ do i=1,ntask_cont_from\r
+ ncont_recv(i)=0\r
+ enddo\r
+ do i=1,ntask_cont_to\r
+ ncont_sent(i)=0\r
+ enddo\r
+c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",\r
+c & ntask_cont_to\r
+C Make the list of contacts to send to send to other procesors\r
+ do i=iturn3_start,iturn3_end\r
+c write (iout,*) "make contact list turn3",i," num_cont",\r
+c & num_cont_hb(i)\r
+ call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))\r
+ enddo\r
+ do i=iturn4_start,iturn4_end\r
+c write (iout,*) "make contact list turn4",i," num_cont",\r
+c & num_cont_hb(i)\r
+ call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))\r
+ enddo\r
+ do ii=1,nat_sent\r
+ i=iat_sent(ii)\r
+c write (iout,*) "make contact list longrange",i,ii," num_cont",\r
+c & num_cont_hb(i)\r
+ do j=1,num_cont_hb(i)\r
+ do k=1,4\r
+ jjc=jcont_hb(j,i)\r
+ iproc=iint_sent_local(k,jjc,ii)\r
+c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc\r
+ if (iproc.ne.0) then\r
+ ncont_sent(iproc)=ncont_sent(iproc)+1\r
+ nn=ncont_sent(iproc)\r
+ zapas(1,nn,iproc)=i\r
+ zapas(2,nn,iproc)=jjc\r
+ zapas(3,nn,iproc)=d_cont(j,i)\r
+ ind=3\r
+ do kk=1,3\r
+ ind=ind+1\r
+ zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)\r
+ enddo\r
+ do kk=1,2\r
+ do ll=1,2\r
+ ind=ind+1\r
+ zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)\r
+ enddo\r
+ enddo\r
+ do jj=1,5\r
+ do kk=1,3\r
+ do ll=1,2\r
+ do mm=1,2\r
+ ind=ind+1\r
+ zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)\r
+ enddo\r
+ enddo\r
+ enddo\r
+ enddo\r
+ endif\r
+ enddo\r
+ enddo\r
+ enddo\r
+ if (lprn) then\r
+ write (iout,*) \r
+ & "Numbers of contacts to be sent to other processors",\r
+ & (ncont_sent(i),i=1,ntask_cont_to)\r
+ write (iout,*) "Contacts sent"\r
+ do ii=1,ntask_cont_to\r
+ nn=ncont_sent(ii)\r
+ iproc=itask_cont_to(ii)\r
+ write (iout,*) nn," contacts to processor",iproc,\r
+ & " of CONT_TO_COMM group"\r
+ do i=1,nn\r
+ write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)\r
+ enddo\r
+ enddo\r
+ call flush(iout)\r
+ endif\r
+ CorrelType=477\r
+ CorrelID=fg_rank+1\r
+ CorrelType1=478\r
+ CorrelID1=nfgtasks+fg_rank+1\r
+ ireq=0\r
+C Receive the numbers of needed contacts from other processors \r
+ do ii=1,ntask_cont_from\r
+ iproc=itask_cont_from(ii)\r
+ ireq=ireq+1\r
+ call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,\r
+ & FG_COMM,req(ireq),IERR)\r
+ enddo\r
+c write (iout,*) "IRECV ended"\r
+c call flush(iout)\r
+C Send the number of contacts needed by other processors\r
+ do ii=1,ntask_cont_to\r
+ iproc=itask_cont_to(ii)\r
+ ireq=ireq+1\r
+ call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,\r
+ & FG_COMM,req(ireq),IERR)\r
+ enddo\r
+c write (iout,*) "ISEND ended"\r
+c write (iout,*) "number of requests (nn)",ireq\r
+ call flush(iout)\r
+ if (ireq.gt.0) \r
+ & call MPI_Waitall(ireq,req,status_array,ierr)\r
+c write (iout,*) \r
+c & "Numbers of contacts to be received from other processors",\r
+c & (ncont_recv(i),i=1,ntask_cont_from)\r
+c call flush(iout)\r
+C Receive contacts\r
+ ireq=0\r
+ do ii=1,ntask_cont_from\r
+ iproc=itask_cont_from(ii)\r
+ nn=ncont_recv(ii)\r
+c write (iout,*) "Receiving",nn," contacts from processor",iproc,\r
+c & " of CONT_TO_COMM group"\r
+ call flush(iout)\r
+ if (nn.gt.0) then\r
+ ireq=ireq+1\r
+ call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,\r
+ & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)\r
+c write (iout,*) "ireq,req",ireq,req(ireq)\r
+ endif\r
+ enddo\r
+C Send the contacts to processors that need them\r
+ do ii=1,ntask_cont_to\r
+ iproc=itask_cont_to(ii)\r
+ nn=ncont_sent(ii)\r
+c write (iout,*) nn," contacts to processor",iproc,\r
+c & " of CONT_TO_COMM group"\r
+ if (nn.gt.0) then\r
+ ireq=ireq+1 \r
+ call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,\r
+ & iproc,CorrelType1,FG_COMM,req(ireq),IERR)\r
+c write (iout,*) "ireq,req",ireq,req(ireq)\r
+c do i=1,nn\r
+c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)\r
+c enddo\r
+ endif \r
+ enddo\r
+c write (iout,*) "number of requests (contacts)",ireq\r
+c write (iout,*) "req",(req(i),i=1,4)\r
+c call flush(iout)\r
+ if (ireq.gt.0) \r
+ & call MPI_Waitall(ireq,req,status_array,ierr)\r
+ do iii=1,ntask_cont_from\r
+ iproc=itask_cont_from(iii)\r
+ nn=ncont_recv(iii)\r
+ if (lprn) then\r
+ write (iout,*) "Received",nn," contacts from processor",iproc,\r
+ & " of CONT_FROM_COMM group"\r
+ call flush(iout)\r
+ do i=1,nn\r
+ write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)\r
+ enddo\r
+ call flush(iout)\r
+ endif\r
+ do i=1,nn\r
+ ii=zapas_recv(1,i,iii)\r
+c Flag the received contacts to prevent double-counting\r
+ jj=-zapas_recv(2,i,iii)\r
+c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj\r
+c call flush(iout)\r
+ nnn=num_cont_hb(ii)+1\r
+ num_cont_hb(ii)=nnn\r
+ jcont_hb(nnn,ii)=jj\r
+ d_cont(nnn,ii)=zapas_recv(3,i,iii)\r
+ ind=3\r
+ do kk=1,3\r
+ ind=ind+1\r
+ grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)\r
+ enddo\r
+ do kk=1,2\r
+ do ll=1,2\r
+ ind=ind+1\r
+ a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)\r
+ enddo\r
+ enddo\r
+ do jj=1,5\r
+ do kk=1,3\r
+ do ll=1,2\r
+ do mm=1,2\r
+ ind=ind+1\r
+ a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)\r
+ enddo\r
+ enddo\r
+ enddo\r
+ enddo\r
+ enddo\r
+ enddo\r
+ call flush(iout)\r
+ if (lprn) then\r
+ write (iout,'(a)') 'Contact function values after receive:'\r
+ do i=nnt,nct-2\r
+ write (iout,'(2i3,50(1x,i3,5f6.3))') \r
+ & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),\r
+ & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))\r
+ enddo\r
+ call flush(iout)\r
+ endif\r
+ 30 continue\r
+#endif\r
+ if (lprn) then\r
+ write (iout,'(a)') 'Contact function values:'\r
+ do i=nnt,nct-2\r
+ write (iout,'(2i3,50(1x,i2,5f6.3))') \r
+ & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),\r
+ & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))\r
+ enddo\r
+ endif\r
+ ecorr=0.0D0\r
+ ecorr5=0.0d0\r
+ ecorr6=0.0d0\r
+C Remove the loop below after debugging !!!\r
+ do i=nnt,nct\r
+ do j=1,3\r
+ gradcorr(j,i)=0.0D0\r
+ gradxorr(j,i)=0.0D0\r
+ enddo\r
+ enddo\r
+C Calculate the dipole-dipole interaction energies\r
+ if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then\r
+ do i=iatel_s,iatel_e+1\r
+ num_conti=num_cont_hb(i)\r
+ do jj=1,num_conti\r
+ j=jcont_hb(jj,i)\r
+#ifdef MOMENT\r
+ call dipole(i,j,jj)\r
+#endif\r
+ enddo\r
+ enddo\r
+ endif\r
+C Calculate the local-electrostatic correlation terms\r
+c write (iout,*) "gradcorr5 in eello5 before loop"\r
+c do iii=1,nres\r
+c write (iout,'(i5,3f10.5)') \r
+c & iii,(gradcorr5(jjj,iii),jjj=1,3)\r
+c enddo\r
+ do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)\r
+c write (iout,*) "corr loop i",i\r
+ i1=i+1\r
+ num_conti=num_cont_hb(i)\r
+ num_conti1=num_cont_hb(i+1)\r
+ do jj=1,num_conti\r
+ j=jcont_hb(jj,i)\r
+ jp=iabs(j)\r
+ do kk=1,num_conti1\r
+ j1=jcont_hb(kk,i1)\r
+ jp1=iabs(j1)\r
+c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,\r
+c & ' jj=',jj,' kk=',kk\r
+c if (j1.eq.j+1 .or. j1.eq.j-1) then\r
+ if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 \r
+ & .or. j.lt.0 .and. j1.gt.0) .and.\r
+ & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then\r
+C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. \r
+C The system gains extra energy.\r
+ n_corr=n_corr+1\r
+ sqd1=dsqrt(d_cont(jj,i))\r
+ sqd2=dsqrt(d_cont(kk,i1))\r
+ sred_geom = sqd1*sqd2\r
+ IF (sred_geom.lt.cutoff_corr) THEN\r
+ call gcont(sred_geom,r0_corr,1.0D0,delt_corr,\r
+ & ekont,fprimcont)\r
+cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,\r
+cd & ' jj=',jj,' kk=',kk\r
+ fac_prim1=0.5d0*sqd2/sqd1*fprimcont\r
+ fac_prim2=0.5d0*sqd1/sqd2*fprimcont\r
+ do l=1,3\r
+ g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)\r
+ g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)\r
+ enddo\r
+ n_corr1=n_corr1+1\r
+cd write (iout,*) 'sred_geom=',sred_geom,\r
+cd & ' ekont=',ekont,' fprim=',fprimcont,\r
+cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2\r
+cd write (iout,*) "g_contij",g_contij\r
+cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)\r
+cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)\r
+ call calc_eello(i,jp,i+1,jp1,jj,kk)\r
+ if (wcorr4.gt.0.0d0) \r
+ & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)\r
+ if (energy_dec.and.wcorr4.gt.0.0d0) \r
+ 1 write (iout,'(a6,4i5,0pf7.3)')\r
+ 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)\r
+c write (iout,*) "gradcorr5 before eello5"\r
+c do iii=1,nres\r
+c write (iout,'(i5,3f10.5)') \r
+c & iii,(gradcorr5(jjj,iii),jjj=1,3)\r
+c enddo\r
+ if (wcorr5.gt.0.0d0)\r
+ & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)\r
+c write (iout,*) "gradcorr5 after eello5"\r
+c do iii=1,nres\r
+c write (iout,'(i5,3f10.5)') \r
+c & iii,(gradcorr5(jjj,iii),jjj=1,3)\r
+c enddo\r
+ if (energy_dec.and.wcorr5.gt.0.0d0) \r
+ 1 write (iout,'(a6,4i5,0pf7.3)')\r
+ 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)\r
+cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6\r
+cd write(2,*)'ijkl',i,jp,i+1,jp1 \r
+ if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3\r
+ & .or. wturn6.eq.0.0d0))then\r
+cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1\r
+ ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)\r
+ if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')\r
+ 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)\r
+cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,\r
+cd & 'ecorr6=',ecorr6\r
+cd write (iout,'(4e15.5)') sred_geom,\r
+cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),\r
+cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),\r
+cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))\r
+ else if (wturn6.gt.0.0d0\r
+ & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then\r
+cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1\r
+ eturn6=eturn6+eello_turn6(i,jj,kk)\r
+ if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')\r
+ 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)\r
+cd write (2,*) 'multibody_eello:eturn6',eturn6\r
+ endif\r
+ ENDIF\r
+1111 continue\r
+ endif\r
+ enddo ! kk\r
+ enddo ! jj\r
+ enddo ! i\r
+ do i=1,nres\r
+ num_cont_hb(i)=num_cont_hb_old(i)\r
+ enddo\r
+c write (iout,*) "gradcorr5 in eello5"\r
+c do iii=1,nres\r
+c write (iout,'(i5,3f10.5)') \r
+c & iii,(gradcorr5(jjj,iii),jjj=1,3)\r
+c enddo\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine add_hb_contact_eello(ii,jj,itask)\r
+ implicit real*8 (a-h,o-z)\r
+ include "DIMENSIONS"\r
+ include "COMMON.IOUNITS"\r
+ integer max_cont\r
+ integer max_dim\r
+ parameter (max_cont=maxconts)\r
+ parameter (max_dim=70)\r
+ include "COMMON.CONTACTS"\r
+ double precision zapas(max_dim,maxconts,max_fg_procs),\r
+ & zapas_recv(max_dim,maxconts,max_fg_procs)\r
+ common /przechowalnia/ zapas\r
+ integer i,j,ii,jj,iproc,itask(4),nn\r
+c write (iout,*) "itask",itask\r
+ do i=1,2\r
+ iproc=itask(i)\r
+ if (iproc.gt.0) then\r
+ do j=1,num_cont_hb(ii)\r
+ jjc=jcont_hb(j,ii)\r
+c write (iout,*) "send turns i",ii," j",jj," jjc",jjc\r
+ if (jjc.eq.jj) then\r
+ ncont_sent(iproc)=ncont_sent(iproc)+1\r
+ nn=ncont_sent(iproc)\r
+ zapas(1,nn,iproc)=ii\r
+ zapas(2,nn,iproc)=jjc\r
+ zapas(3,nn,iproc)=d_cont(j,ii)\r
+ ind=3\r
+ do kk=1,3\r
+ ind=ind+1\r
+ zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)\r
+ enddo\r
+ do kk=1,2\r
+ do ll=1,2\r
+ ind=ind+1\r
+ zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)\r
+ enddo\r
+ enddo\r
+ do jj=1,5\r
+ do kk=1,3\r
+ do ll=1,2\r
+ do mm=1,2\r
+ ind=ind+1\r
+ zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)\r
+ enddo\r
+ enddo\r
+ enddo\r
+ enddo\r
+ exit\r
+ endif\r
+ enddo\r
+ endif\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ double precision gx(3),gx1(3)\r
+ logical lprn\r
+ lprn=.false.\r
+ eij=facont_hb(jj,i)\r
+ ekl=facont_hb(kk,k)\r
+ ees0pij=ees0p(jj,i)\r
+ ees0pkl=ees0p(kk,k)\r
+ ees0mij=ees0m(jj,i)\r
+ ees0mkl=ees0m(kk,k)\r
+ ekont=eij*ekl\r
+ ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)\r
+cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)\r
+C Following 4 lines for diagnostics.\r
+cd ees0pkl=0.0D0\r
+cd ees0pij=1.0D0\r
+cd ees0mkl=0.0D0\r
+cd ees0mij=1.0D0\r
+c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')\r
+c & 'Contacts ',i,j,\r
+c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l\r
+c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,\r
+c & 'gradcorr_long'\r
+C Calculate the multi-body contribution to energy.\r
+c ecorr=ecorr+ekont*ees\r
+C Calculate multi-body contributions to the gradient.\r
+ coeffpees0pij=coeffp*ees0pij\r
+ coeffmees0mij=coeffm*ees0mij\r
+ coeffpees0pkl=coeffp*ees0pkl\r
+ coeffmees0mkl=coeffm*ees0mkl\r
+ do ll=1,3\r
+cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)\r
+ gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi\r
+ & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+\r
+ & coeffmees0mkl*gacontm_hb1(ll,jj,i))\r
+ gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi\r
+ & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+\r
+ & coeffmees0mkl*gacontm_hb2(ll,jj,i))\r
+cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)\r
+ gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk\r
+ & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+\r
+ & coeffmees0mij*gacontm_hb1(ll,kk,k))\r
+ gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk\r
+ & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+\r
+ & coeffmees0mij*gacontm_hb2(ll,kk,k))\r
+ gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-\r
+ & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+\r
+ & coeffmees0mkl*gacontm_hb3(ll,jj,i))\r
+ gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij\r
+ gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij\r
+ gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-\r
+ & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+\r
+ & coeffmees0mij*gacontm_hb3(ll,kk,k))\r
+ gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl\r
+ gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl\r
+c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl\r
+ enddo\r
+c write (iout,*)\r
+cgrad do m=i+1,j-1\r
+cgrad do ll=1,3\r
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+\r
+cgrad & ees*ekl*gacont_hbr(ll,jj,i)-\r
+cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+\r
+cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad do m=k+1,l-1\r
+cgrad do ll=1,3\r
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+\r
+cgrad & ees*eij*gacont_hbr(ll,kk,k)-\r
+cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+\r
+cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))\r
+cgrad enddo\r
+cgrad enddo \r
+c write (iout,*) "ehbcorr",ekont*ees\r
+ ehbcorr=ekont*ees\r
+ return\r
+ end\r
+#ifdef MOMENT\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine dipole(i,j,jj)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.FFIELD'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),\r
+ & auxmat(2,2)\r
+ iti1 = itortyp(itype(i+1))\r
+ if (j.lt.nres-1) then\r
+ itj1 = itortyp(itype(j+1))\r
+ else\r
+ itj1=ntortyp+1\r
+ endif\r
+ do iii=1,2\r
+ dipi(iii,1)=Ub2(iii,i)\r
+ dipderi(iii)=Ub2der(iii,i)\r
+ dipi(iii,2)=b1(iii,iti1)\r
+ dipj(iii,1)=Ub2(iii,j)\r
+ dipderj(iii)=Ub2der(iii,j)\r
+ dipj(iii,2)=b1(iii,itj1)\r
+ enddo\r
+ kkk=0\r
+ do iii=1,2\r
+ call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) \r
+ do jjj=1,2\r
+ kkk=kkk+1\r
+ dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))\r
+ enddo\r
+ enddo\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ mmm=0\r
+ do iii=1,2\r
+ call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),\r
+ & auxvec(1))\r
+ do jjj=1,2\r
+ mmm=mmm+1\r
+ dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))\r
+ enddo\r
+ enddo\r
+ enddo\r
+ enddo\r
+ call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),dipderi(1),auxvec(1))\r
+ do iii=1,2\r
+ dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))\r
+ enddo\r
+ call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))\r
+ do iii=1,2\r
+ dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))\r
+ enddo\r
+ return\r
+ end\r
+#endif\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine calc_eello(i,j,k,l,jj,kk)\r
+C \r
+C This subroutine computes matrices and vectors needed to calculate \r
+C the fourth-, fifth-, and sixth-order local-electrostatic terms.\r
+C\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.FFIELD'\r
+ double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),\r
+ & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)\r
+ logical lprn\r
+ common /kutas/ lprn\r
+cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,\r
+cd & ' jj=',jj,' kk=',kk\r
+cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return\r
+cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)\r
+cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)\r
+ do iii=1,2\r
+ do jjj=1,2\r
+ aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)\r
+ aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)\r
+ enddo\r
+ enddo\r
+ call transpose2(aa1(1,1),aa1t(1,1))\r
+ call transpose2(aa2(1,1),aa2t(1,1))\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),\r
+ & aa1tder(1,1,lll,kkk))\r
+ call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),\r
+ & aa2tder(1,1,lll,kkk))\r
+ enddo\r
+ enddo \r
+ if (l.eq.j+1) then\r
+C parallel orientation of the two CA-CA-CA frames.\r
+ if (i.gt.1) then\r
+ iti=itortyp(itype(i))\r
+ else\r
+ iti=ntortyp+1\r
+ endif\r
+ itk1=itortyp(itype(k+1))\r
+ itj=itortyp(itype(j))\r
+ if (l.lt.nres-1) then\r
+ itl1=itortyp(itype(l+1))\r
+ else\r
+ itl1=ntortyp+1\r
+ endif\r
+C A1 kernel(j+1) A2T\r
+cd do iii=1,2\r
+cd write (iout,'(3f10.5,5x,3f10.5)') \r
+cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)\r
+cd enddo\r
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
+ & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),\r
+ & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))\r
+C Following matrices are needed only for 6-th order cumulants\r
+ IF (wcorr6.gt.0.0d0) THEN\r
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
+ & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),\r
+ & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))\r
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
+ & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),\r
+ & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),\r
+ & ADtEAderx(1,1,1,1,1,1))\r
+ lprn=.false.\r
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
+ & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),\r
+ & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),\r
+ & ADtEA1derx(1,1,1,1,1,1))\r
+ ENDIF\r
+C End 6-th order cumulants\r
+cd lprn=.false.\r
+cd if (lprn) then\r
+cd write (2,*) 'In calc_eello6'\r
+cd do iii=1,2\r
+cd write (2,*) 'iii=',iii\r
+cd do kkk=1,5\r
+cd write (2,*) 'kkk=',kkk\r
+cd do jjj=1,2\r
+cd write (2,'(3(2f10.5),5x)') \r
+cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)\r
+cd enddo\r
+cd enddo\r
+cd enddo\r
+cd endif\r
+ call transpose2(EUgder(1,1,k),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))\r
+ call transpose2(EUg(1,1,k),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))\r
+ call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),\r
+ & EAEAderx(1,1,lll,kkk,iii,1))\r
+ enddo\r
+ enddo\r
+ enddo\r
+C A1T kernel(i+1) A2\r
+ call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),\r
+ & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),\r
+ & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))\r
+C Following matrices are needed only for 6-th order cumulants\r
+ IF (wcorr6.gt.0.0d0) THEN\r
+ call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),\r
+ & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),\r
+ & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))\r
+ call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),\r
+ & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),\r
+ & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),\r
+ & ADtEAderx(1,1,1,1,1,2))\r
+ call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),\r
+ & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),\r
+ & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),\r
+ & ADtEA1derx(1,1,1,1,1,2))\r
+ ENDIF\r
+C End 6-th order cumulants\r
+ call transpose2(EUgder(1,1,l),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))\r
+ call transpose2(EUg(1,1,l),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))\r
+ call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),\r
+ & EAEAderx(1,1,lll,kkk,iii,2))\r
+ enddo\r
+ enddo\r
+ enddo\r
+C AEAb1 and AEAb2\r
+C Calculate the vectors and their derivatives in virtual-bond dihedral angles.\r
+C They are needed only when the fifth- or the sixth-order cumulants are\r
+C indluded.\r
+ IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN\r
+ call transpose2(AEA(1,1,1),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))\r
+ call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))\r
+ call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))\r
+ call transpose2(AEAderg(1,1,1),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))\r
+ call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))\r
+ call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))\r
+ call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))\r
+ call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))\r
+ call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))\r
+ call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))\r
+ call transpose2(AEA(1,1,2),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))\r
+ call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))\r
+ call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))\r
+ call transpose2(AEAderg(1,1,2),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))\r
+ call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))\r
+ call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))\r
+ call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))\r
+ call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))\r
+ call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))\r
+ call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))\r
+C Calculate the Cartesian derivatives of the vectors.\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,iti),\r
+ & AEAb1derx(1,lll,kkk,iii,1,1))\r
+ call matvec2(auxmat(1,1),Ub2(1,i),\r
+ & AEAb2derx(1,lll,kkk,iii,1,1))\r
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),\r
+ & AEAb1derx(1,lll,kkk,iii,2,1))\r
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),\r
+ & AEAb2derx(1,lll,kkk,iii,2,1))\r
+ call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,itj),\r
+ & AEAb1derx(1,lll,kkk,iii,1,2))\r
+ call matvec2(auxmat(1,1),Ub2(1,j),\r
+ & AEAb2derx(1,lll,kkk,iii,1,2))\r
+ call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),\r
+ & AEAb1derx(1,lll,kkk,iii,2,2))\r
+ call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),\r
+ & AEAb2derx(1,lll,kkk,iii,2,2))\r
+ enddo\r
+ enddo\r
+ enddo\r
+ ENDIF\r
+C End vectors\r
+ else\r
+C Antiparallel orientation of the two CA-CA-CA frames.\r
+ if (i.gt.1) then\r
+ iti=itortyp(itype(i))\r
+ else\r
+ iti=ntortyp+1\r
+ endif\r
+ itk1=itortyp(itype(k+1))\r
+ itl=itortyp(itype(l))\r
+ itj=itortyp(itype(j))\r
+ if (j.lt.nres-1) then\r
+ itj1=itortyp(itype(j+1))\r
+ else \r
+ itj1=ntortyp+1\r
+ endif\r
+C A2 kernel(j-1)T A1T\r
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
+ & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),\r
+ & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))\r
+C Following matrices are needed only for 6-th order cumulants\r
+ IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.\r
+ & j.eq.i+4 .and. l.eq.i+3)) THEN\r
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
+ & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),\r
+ & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))\r
+ call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
+ & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),\r
+ & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),\r
+ & ADtEAderx(1,1,1,1,1,1))\r
+ call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),\r
+ & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),\r
+ & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),\r
+ & ADtEA1derx(1,1,1,1,1,1))\r
+ ENDIF\r
+C End 6-th order cumulants\r
+ call transpose2(EUgder(1,1,k),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))\r
+ call transpose2(EUg(1,1,k),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))\r
+ call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),\r
+ & EAEAderx(1,1,lll,kkk,iii,1))\r
+ enddo\r
+ enddo\r
+ enddo\r
+C A2T kernel(i+1)T A1\r
+ call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),\r
+ & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),\r
+ & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))\r
+C Following matrices are needed only for 6-th order cumulants\r
+ IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.\r
+ & j.eq.i+4 .and. l.eq.i+3)) THEN\r
+ call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),\r
+ & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),\r
+ & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))\r
+ call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),\r
+ & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),\r
+ & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),\r
+ & ADtEAderx(1,1,1,1,1,2))\r
+ call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),\r
+ & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),\r
+ & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),\r
+ & ADtEA1derx(1,1,1,1,1,2))\r
+ ENDIF\r
+C End 6-th order cumulants\r
+ call transpose2(EUgder(1,1,j),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))\r
+ call transpose2(EUg(1,1,j),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))\r
+ call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),\r
+ & EAEAderx(1,1,lll,kkk,iii,2))\r
+ enddo\r
+ enddo\r
+ enddo\r
+C AEAb1 and AEAb2\r
+C Calculate the vectors and their derivatives in virtual-bond dihedral angles.\r
+C They are needed only when the fifth- or the sixth-order cumulants are\r
+C indluded.\r
+ IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.\r
+ & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN\r
+ call transpose2(AEA(1,1,1),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))\r
+ call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))\r
+ call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))\r
+ call transpose2(AEAderg(1,1,1),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))\r
+ call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))\r
+ call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))\r
+ call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))\r
+ call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))\r
+ call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))\r
+ call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))\r
+ call transpose2(AEA(1,1,2),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))\r
+ call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))\r
+ call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))\r
+ call transpose2(AEAderg(1,1,2),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))\r
+ call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))\r
+ call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))\r
+ call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))\r
+ call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))\r
+ call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))\r
+ call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))\r
+C Calculate the Cartesian derivatives of the vectors.\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,iti),\r
+ & AEAb1derx(1,lll,kkk,iii,1,1))\r
+ call matvec2(auxmat(1,1),Ub2(1,i),\r
+ & AEAb2derx(1,lll,kkk,iii,1,1))\r
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),\r
+ & AEAb1derx(1,lll,kkk,iii,2,1))\r
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),\r
+ & AEAb2derx(1,lll,kkk,iii,2,1))\r
+ call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),b1(1,itl),\r
+ & AEAb1derx(1,lll,kkk,iii,1,2))\r
+ call matvec2(auxmat(1,1),Ub2(1,l),\r
+ & AEAb2derx(1,lll,kkk,iii,1,2))\r
+ call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),\r
+ & AEAb1derx(1,lll,kkk,iii,2,2))\r
+ call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),\r
+ & AEAb2derx(1,lll,kkk,iii,2,2))\r
+ enddo\r
+ enddo\r
+ enddo\r
+ ENDIF\r
+C End vectors\r
+ endif\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,\r
+ & KK,KKderg,AKA,AKAderg,AKAderx)\r
+ implicit none\r
+ integer nderg\r
+ logical transp\r
+ double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),\r
+ & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),\r
+ & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)\r
+ integer iii,kkk,lll\r
+ integer jjj,mmm\r
+ logical lprn\r
+ common /kutas/ lprn\r
+ call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))\r
+ do iii=1,nderg \r
+ call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,\r
+ & AKAderg(1,1,iii))\r
+ enddo\r
+cd if (lprn) write (2,*) 'In kernel'\r
+ do kkk=1,5\r
+cd if (lprn) write (2,*) 'kkk=',kkk\r
+ do lll=1,3\r
+ call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),\r
+ & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))\r
+cd if (lprn) then\r
+cd write (2,*) 'lll=',lll\r
+cd write (2,*) 'iii=1'\r
+cd do jjj=1,2\r
+cd write (2,'(3(2f10.5),5x)') \r
+cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)\r
+cd enddo\r
+cd endif\r
+ call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),\r
+ & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))\r
+cd if (lprn) then\r
+cd write (2,*) 'lll=',lll\r
+cd write (2,*) 'iii=2'\r
+cd do jjj=1,2\r
+cd write (2,'(3(2f10.5),5x)') \r
+cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)\r
+cd enddo\r
+cd endif\r
+ enddo\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ double precision function eello4(i,j,k,l,jj,kk)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ double precision pizda(2,2),ggg1(3),ggg2(3)\r
+cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then\r
+cd eello4=0.0d0\r
+cd return\r
+cd endif\r
+cd print *,'eello4:',i,j,k,l,jj,kk\r
+cd write (2,*) 'i',i,' j',j,' k',k,' l',l\r
+cd call checkint4(i,j,k,l,jj,kk,eel4_num)\r
+cold eij=facont_hb(jj,i)\r
+cold ekl=facont_hb(kk,k)\r
+cold ekont=eij*ekl\r
+ eel4=-EAEA(1,1,1)-EAEA(2,2,1)\r
+cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)\r
+ gcorr_loc(k-1)=gcorr_loc(k-1)\r
+ & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))\r
+ if (l.eq.j+1) then\r
+ gcorr_loc(l-1)=gcorr_loc(l-1)\r
+ & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))\r
+ else\r
+ gcorr_loc(j-1)=gcorr_loc(j-1)\r
+ & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))\r
+ endif\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)\r
+ & -EAEAderx(2,2,lll,kkk,iii,1)\r
+cd derx(lll,kkk,iii)=0.0d0\r
+ enddo\r
+ enddo\r
+ enddo\r
+cd gcorr_loc(l-1)=0.0d0\r
+cd gcorr_loc(j-1)=0.0d0\r
+cd gcorr_loc(k-1)=0.0d0\r
+cd eel4=1.0d0\r
+cd write (iout,*)'Contacts have occurred for peptide groups',\r
+cd & i,j,' fcont:',eij,' eij',' and ',k,l,\r
+cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num\r
+ if (j.lt.nres-1) then\r
+ j1=j+1\r
+ j2=j-1\r
+ else\r
+ j1=j-1\r
+ j2=j-2\r
+ endif\r
+ if (l.lt.nres-1) then\r
+ l1=l+1\r
+ l2=l-1\r
+ else\r
+ l1=l-1\r
+ l2=l-2\r
+ endif\r
+ do ll=1,3\r
+cgrad ggg1(ll)=eel4*g_contij(ll,1)\r
+cgrad ggg2(ll)=eel4*g_contij(ll,2)\r
+ glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)\r
+ glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)\r
+cgrad ghalf=0.5d0*ggg1(ll)\r
+ gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)\r
+ gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)\r
+ gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)\r
+ gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)\r
+ gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij\r
+ gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij\r
+cgrad ghalf=0.5d0*ggg2(ll)\r
+ gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)\r
+ gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)\r
+ gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)\r
+ gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)\r
+ gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl\r
+ gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl\r
+ enddo\r
+cgrad do m=i+1,j-1\r
+cgrad do ll=1,3\r
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad do m=k+1,l-1\r
+cgrad do ll=1,3\r
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad do m=i+2,j2\r
+cgrad do ll=1,3\r
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad do m=k+2,l2\r
+cgrad do ll=1,3\r
+cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)\r
+cgrad enddo\r
+cgrad enddo \r
+cd do iii=1,nres-3\r
+cd write (2,*) iii,gcorr_loc(iii)\r
+cd enddo\r
+ eello4=ekont*eel4\r
+cd write (2,*) 'ekont',ekont\r
+cd write (iout,*) 'eello4',ekont*eel4\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ double precision function eello5(i,j,k,l,jj,kk)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)\r
+ double precision ggg1(3),ggg2(3)\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+C C\r
+C Parallel chains C\r
+C C\r
+C o o o o C\r
+C /l\ / \ \ / \ / \ / C\r
+C / \ / \ \ / \ / \ / C\r
+C j| o |l1 | o | o| o | | o |o C\r
+C \ |/k\| |/ \| / |/ \| |/ \| C\r
+C \i/ \ / \ / / \ / \ C\r
+C o k1 o C\r
+C (I) (II) (III) (IV) C\r
+C C\r
+C eello5_1 eello5_2 eello5_3 eello5_4 C\r
+C C\r
+C Antiparallel chains C\r
+C C\r
+C o o o o C\r
+C /j\ / \ \ / \ / \ / C\r
+C / \ / \ \ / \ / \ / C\r
+C j1| o |l | o | o| o | | o |o C\r
+C \ |/k\| |/ \| / |/ \| |/ \| C\r
+C \i/ \ / \ / / \ / \ C\r
+C o k1 o C\r
+C (I) (II) (III) (IV) C\r
+C C\r
+C eello5_1 eello5_2 eello5_3 eello5_4 C\r
+C C\r
+C o denotes a local interaction, vertical lines an electrostatic interaction. C\r
+C C\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then\r
+cd eello5=0.0d0\r
+cd return\r
+cd endif\r
+cd write (iout,*)\r
+cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,\r
+cd & ' and',k,l\r
+ itk=itortyp(itype(k))\r
+ itl=itortyp(itype(l))\r
+ itj=itortyp(itype(j))\r
+ eello5_1=0.0d0\r
+ eello5_2=0.0d0\r
+ eello5_3=0.0d0\r
+ eello5_4=0.0d0\r
+cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,\r
+cd & eel5_3_num,eel5_4_num)\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ derx(lll,kkk,iii)=0.0d0\r
+ enddo\r
+ enddo\r
+ enddo\r
+cd eij=facont_hb(jj,i)\r
+cd ekl=facont_hb(kk,k)\r
+cd ekont=eij*ekl\r
+cd write (iout,*)'Contacts have occurred for peptide groups',\r
+cd & i,j,' fcont:',eij,' eij',' and ',k,l\r
+cd goto 1111\r
+C Contribution from the graph I.\r
+cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)\r
+cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)\r
+ call transpose2(EUg(1,1,k),auxmat(1,1))\r
+ call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,i))\r
+C Explicit gradient in virtual-dihedral angles.\r
+ if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)\r
+ & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))\r
+ call transpose2(EUgder(1,1,k),auxmat1(1,1))\r
+ call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
+ & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))\r
+ call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ if (l.eq.j+1) then\r
+ if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)\r
+ & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))\r
+ else\r
+ if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)\r
+ & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))\r
+ endif \r
+C Cartesian gradient\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),\r
+ & pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)\r
+ & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,i))\r
+ enddo\r
+ enddo\r
+ enddo\r
+c goto 1112\r
+c1111 continue\r
+C Contribution from graph II \r
+ call transpose2(EE(1,1,itk),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))\r
+ & -0.5d0*scalar2(vv(1),Ctobr(1,k))\r
+C Explicit gradient in virtual-dihedral angles.\r
+ g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
+ & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))\r
+ call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ if (l.eq.j+1) then\r
+ g_corr5_loc(l-1)=g_corr5_loc(l-1)\r
+ & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))\r
+ & -0.5d0*scalar2(vv(1),Ctobr(1,k)))\r
+ else\r
+ g_corr5_loc(j-1)=g_corr5_loc(j-1)\r
+ & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))\r
+ & -0.5d0*scalar2(vv(1),Ctobr(1,k)))\r
+ endif\r
+C Cartesian gradient\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),\r
+ & pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)\r
+ & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))\r
+ & -0.5d0*scalar2(vv(1),Ctobr(1,k))\r
+ enddo\r
+ enddo\r
+ enddo\r
+cd goto 1112\r
+cd1111 continue\r
+ if (l.eq.j+1) then\r
+cd goto 1110\r
+C Parallel orientation\r
+C Contribution from graph III\r
+ call transpose2(EUg(1,1,l),auxmat(1,1))\r
+ call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,j))\r
+C Explicit gradient in virtual-dihedral angles.\r
+ g_corr5_loc(j-1)=g_corr5_loc(j-1)\r
+ & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))\r
+ call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
+ & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))\r
+ call transpose2(EUgder(1,1,l),auxmat1(1,1))\r
+ call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ g_corr5_loc(l-1)=g_corr5_loc(l-1)\r
+ & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))\r
+C Cartesian gradient\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),\r
+ & pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)\r
+ & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,j))\r
+ enddo\r
+ enddo\r
+ enddo\r
+cd goto 1112\r
+C Contribution from graph IV\r
+cd1110 continue\r
+ call transpose2(EE(1,1,itl),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))\r
+ & -0.5d0*scalar2(vv(1),Ctobr(1,l))\r
+C Explicit gradient in virtual-dihedral angles.\r
+ g_corr5_loc(l-1)=g_corr5_loc(l-1)\r
+ & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))\r
+ call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
+ & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))\r
+ & -0.5d0*scalar2(vv(1),Ctobr(1,l)))\r
+C Cartesian gradient\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),\r
+ & pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)\r
+ & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))\r
+ & -0.5d0*scalar2(vv(1),Ctobr(1,l))\r
+ enddo\r
+ enddo\r
+ enddo\r
+ else\r
+C Antiparallel orientation\r
+C Contribution from graph III\r
+c goto 1110\r
+ call transpose2(EUg(1,1,j),auxmat(1,1))\r
+ call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,l))\r
+C Explicit gradient in virtual-dihedral angles.\r
+ g_corr5_loc(l-1)=g_corr5_loc(l-1)\r
+ & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))\r
+ call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
+ & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))\r
+ call transpose2(EUgder(1,1,j),auxmat1(1,1))\r
+ call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ g_corr5_loc(j-1)=g_corr5_loc(j-1)\r
+ & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))\r
+C Cartesian gradient\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),\r
+ & pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)\r
+ & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))\r
+ & +0.5d0*scalar2(vv(1),Dtobr2(1,l))\r
+ enddo\r
+ enddo\r
+ enddo\r
+cd goto 1112\r
+C Contribution from graph IV\r
+1110 continue\r
+ call transpose2(EE(1,1,itj),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))\r
+ & -0.5d0*scalar2(vv(1),Ctobr(1,j))\r
+C Explicit gradient in virtual-dihedral angles.\r
+ g_corr5_loc(j-1)=g_corr5_loc(j-1)\r
+ & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))\r
+ call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ g_corr5_loc(k-1)=g_corr5_loc(k-1)\r
+ & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))\r
+ & -0.5d0*scalar2(vv(1),Ctobr(1,j)))\r
+C Cartesian gradient\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),\r
+ & pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)\r
+ & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))\r
+ & -0.5d0*scalar2(vv(1),Ctobr(1,j))\r
+ enddo\r
+ enddo\r
+ enddo\r
+ endif\r
+1112 continue\r
+ eel5=eello5_1+eello5_2+eello5_3+eello5_4\r
+cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then\r
+cd write (2,*) 'ijkl',i,j,k,l\r
+cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,\r
+cd & ' eello5_3',eello5_3,' eello5_4',eello5_4\r
+cd endif\r
+cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num\r
+cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num\r
+cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num\r
+cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num\r
+ if (j.lt.nres-1) then\r
+ j1=j+1\r
+ j2=j-1\r
+ else\r
+ j1=j-1\r
+ j2=j-2\r
+ endif\r
+ if (l.lt.nres-1) then\r
+ l1=l+1\r
+ l2=l-1\r
+ else\r
+ l1=l-1\r
+ l2=l-2\r
+ endif\r
+cd eij=1.0d0\r
+cd ekl=1.0d0\r
+cd ekont=1.0d0\r
+cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont\r
+C 2/11/08 AL Gradients over DC's connecting interacting sites will be\r
+C summed up outside the subrouine as for the other subroutines \r
+C handling long-range interactions. The old code is commented out\r
+C with "cgrad" to keep track of changes.\r
+ do ll=1,3\r
+cgrad ggg1(ll)=eel5*g_contij(ll,1)\r
+cgrad ggg2(ll)=eel5*g_contij(ll,2)\r
+ gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)\r
+ gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)\r
+c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') \r
+c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),\r
+c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),\r
+c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont\r
+c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') \r
+c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),\r
+c & gradcorr5ij,\r
+c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl\r
+cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)\r
+cgrad ghalf=0.5d0*ggg1(ll)\r
+cd ghalf=0.0d0\r
+ gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)\r
+ gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)\r
+ gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)\r
+ gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)\r
+ gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij\r
+ gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij\r
+cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)\r
+cgrad ghalf=0.5d0*ggg2(ll)\r
+cd ghalf=0.0d0\r
+ gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)\r
+ gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)\r
+ gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)\r
+ gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)\r
+ gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl\r
+ gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl\r
+ enddo\r
+cd goto 1112\r
+cgrad do m=i+1,j-1\r
+cgrad do ll=1,3\r
+cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)\r
+cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad do m=k+1,l-1\r
+cgrad do ll=1,3\r
+cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)\r
+cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)\r
+cgrad enddo\r
+cgrad enddo\r
+c1112 continue\r
+cgrad do m=i+2,j2\r
+cgrad do ll=1,3\r
+cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad do m=k+2,l2\r
+cgrad do ll=1,3\r
+cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)\r
+cgrad enddo\r
+cgrad enddo \r
+cd do iii=1,nres-3\r
+cd write (2,*) iii,g_corr5_loc(iii)\r
+cd enddo\r
+ eello5=ekont*eel5\r
+cd write (2,*) 'ekont',ekont\r
+cd write (iout,*) 'eello5',ekont*eel5\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ double precision function eello6(i,j,k,l,jj,kk)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.FFIELD'\r
+ double precision ggg1(3),ggg2(3)\r
+cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then\r
+cd eello6=0.0d0\r
+cd return\r
+cd endif\r
+cd write (iout,*)\r
+cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,\r
+cd & ' and',k,l\r
+ eello6_1=0.0d0\r
+ eello6_2=0.0d0\r
+ eello6_3=0.0d0\r
+ eello6_4=0.0d0\r
+ eello6_5=0.0d0\r
+ eello6_6=0.0d0\r
+cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,\r
+cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ derx(lll,kkk,iii)=0.0d0\r
+ enddo\r
+ enddo\r
+ enddo\r
+cd eij=facont_hb(jj,i)\r
+cd ekl=facont_hb(kk,k)\r
+cd ekont=eij*ekl\r
+cd eij=1.0d0\r
+cd ekl=1.0d0\r
+cd ekont=1.0d0\r
+ if (l.eq.j+1) then\r
+ eello6_1=eello6_graph1(i,j,k,l,1,.false.)\r
+ eello6_2=eello6_graph1(j,i,l,k,2,.false.)\r
+ eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)\r
+ eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)\r
+ eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)\r
+ eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)\r
+ else\r
+ eello6_1=eello6_graph1(i,j,k,l,1,.false.)\r
+ eello6_2=eello6_graph1(l,k,j,i,2,.true.)\r
+ eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)\r
+ eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)\r
+ if (wturn6.eq.0.0d0 .or. j.ne.i+4) then\r
+ eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)\r
+ else\r
+ eello6_5=0.0d0\r
+ endif\r
+ eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)\r
+ endif\r
+C If turn contributions are considered, they will be handled separately.\r
+ eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6\r
+cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num\r
+cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num\r
+cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num\r
+cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num\r
+cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num\r
+cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num\r
+cd goto 1112\r
+ if (j.lt.nres-1) then\r
+ j1=j+1\r
+ j2=j-1\r
+ else\r
+ j1=j-1\r
+ j2=j-2\r
+ endif\r
+ if (l.lt.nres-1) then\r
+ l1=l+1\r
+ l2=l-1\r
+ else\r
+ l1=l-1\r
+ l2=l-2\r
+ endif\r
+ do ll=1,3\r
+cgrad ggg1(ll)=eel6*g_contij(ll,1)\r
+cgrad ggg2(ll)=eel6*g_contij(ll,2)\r
+cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)\r
+cgrad ghalf=0.5d0*ggg1(ll)\r
+cd ghalf=0.0d0\r
+ gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)\r
+ gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)\r
+ gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)\r
+ gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)\r
+ gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)\r
+ gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)\r
+ gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij\r
+ gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij\r
+cgrad ghalf=0.5d0*ggg2(ll)\r
+cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)\r
+cd ghalf=0.0d0\r
+ gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)\r
+ gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)\r
+ gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)\r
+ gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)\r
+ gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl\r
+ gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl\r
+ enddo\r
+cd goto 1112\r
+cgrad do m=i+1,j-1\r
+cgrad do ll=1,3\r
+cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)\r
+cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad do m=k+1,l-1\r
+cgrad do ll=1,3\r
+cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)\r
+cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad1112 continue\r
+cgrad do m=i+2,j2\r
+cgrad do ll=1,3\r
+cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad do m=k+2,l2\r
+cgrad do ll=1,3\r
+cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)\r
+cgrad enddo\r
+cgrad enddo \r
+cd do iii=1,nres-3\r
+cd write (2,*) iii,g_corr6_loc(iii)\r
+cd enddo\r
+ eello6=ekont*eel6\r
+cd write (2,*) 'ekont',ekont\r
+cd write (iout,*) 'eello6',ekont*eel6\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ double precision function eello6_graph1(i,j,k,l,imat,swap)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)\r
+ logical swap\r
+ logical lprn\r
+ common /kutas/ lprn\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+C \r
+C Parallel Antiparallel\r
+C \r
+C o o \r
+C /l\ /j\ \r
+C / \ / \ \r
+C /| o | | o |\ \r
+C \ j|/k\| / \ |/k\|l / \r
+C \ / \ / \ / \ / \r
+C o o o o \r
+C i i \r
+C\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+ itk=itortyp(itype(k))\r
+ s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))\r
+ s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))\r
+ s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))\r
+ call transpose2(EUgC(1,1,k),auxmat(1,1))\r
+ call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))\r
+ vv1(1)=pizda1(1,1)-pizda1(2,2)\r
+ vv1(2)=pizda1(1,2)+pizda1(2,1)\r
+ s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))\r
+ vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)\r
+ vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)\r
+ s5=scalar2(vv(1),Dtobr2(1,i))\r
+cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5\r
+ eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)\r
+ if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)\r
+ & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))\r
+ & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))\r
+ & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))\r
+ & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))\r
+ & +scalar2(vv(1),Dtobr2der(1,i)))\r
+ call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))\r
+ vv1(1)=pizda1(1,1)-pizda1(2,2)\r
+ vv1(2)=pizda1(1,2)+pizda1(2,1)\r
+ vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)\r
+ vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)\r
+ if (l.eq.j+1) then\r
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)\r
+ & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))\r
+ & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))\r
+ & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))\r
+ & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))\r
+ else\r
+ g_corr6_loc(j-1)=g_corr6_loc(j-1)\r
+ & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))\r
+ & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))\r
+ & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))\r
+ & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))\r
+ endif\r
+ call transpose2(EUgCder(1,1,k),auxmat(1,1))\r
+ call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))\r
+ vv1(1)=pizda1(1,1)-pizda1(2,2)\r
+ vv1(2)=pizda1(1,2)+pizda1(2,1)\r
+ if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)\r
+ & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))\r
+ & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))\r
+ & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))\r
+ do iii=1,2\r
+ if (swap) then\r
+ ind=3-iii\r
+ else\r
+ ind=iii\r
+ endif\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))\r
+ s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))\r
+ s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))\r
+ call transpose2(EUgC(1,1,k),auxmat(1,1))\r
+ call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),\r
+ & pizda1(1,1))\r
+ vv1(1)=pizda1(1,1)-pizda1(2,2)\r
+ vv1(2)=pizda1(1,2)+pizda1(2,1)\r
+ s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))\r
+ vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)\r
+ & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)\r
+ vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)\r
+ & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)\r
+ s5=scalar2(vv(1),Dtobr2(1,i))\r
+ derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)\r
+ enddo\r
+ enddo\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ double precision function eello6_graph2(i,j,k,l,jj,kk,swap)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ logical swap\r
+ double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),\r
+ & auxvec1(2),auxvec2(1),auxmat1(2,2)\r
+ logical lprn\r
+ common /kutas/ lprn\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+C \r
+C Parallel Antiparallel\r
+C \r
+C o o \r
+C \ /l\ /j\ / \r
+C \ / \ / \ / \r
+C o| o | | o |o \r
+C \ j|/k\| \ |/k\|l \r
+C \ / \ \ / \ \r
+C o o \r
+C i i \r
+C\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l\r
+C AL 7/4/01 s1 would occur in the sixth-order moment, \r
+C but not in a cluster cumulant\r
+#ifdef MOMENT\r
+ s1=dip(1,jj,i)*dip(1,kk,k)\r
+#endif\r
+ call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))\r
+ s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
+ call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))\r
+ s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))\r
+ call transpose2(EUg(1,1,k),auxmat(1,1))\r
+ call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
+cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4\r
+#ifdef MOMENT\r
+ eello6_graph2=-(s1+s2+s3+s4)\r
+#else\r
+ eello6_graph2=-(s2+s3+s4)\r
+#endif\r
+c eello6_graph2=-s3\r
+C Derivatives in gamma(i-1)\r
+ if (i.gt.1) then\r
+#ifdef MOMENT\r
+ s1=dipderg(1,jj,i)*dip(1,kk,k)\r
+#endif\r
+ s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))\r
+ call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))\r
+ s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))\r
+ s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))\r
+#ifdef MOMENT\r
+ g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)\r
+#else\r
+ g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)\r
+#endif\r
+c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3\r
+ endif\r
+C Derivatives in gamma(k-1)\r
+#ifdef MOMENT\r
+ s1=dip(1,jj,i)*dipderg(1,kk,k)\r
+#endif\r
+ call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))\r
+ s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))\r
+ call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))\r
+ s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))\r
+ call transpose2(EUgder(1,1,k),auxmat1(1,1))\r
+ call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
+#ifdef MOMENT\r
+ g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)\r
+#else\r
+ g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)\r
+#endif\r
+c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3\r
+C Derivatives in gamma(j-1) or gamma(l-1)\r
+ if (j.gt.1) then\r
+#ifdef MOMENT\r
+ s1=dipderg(3,jj,i)*dip(1,kk,k) \r
+#endif\r
+ call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))\r
+ s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))\r
+ s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))\r
+ call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
+#ifdef MOMENT\r
+ if (swap) then\r
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1\r
+ else\r
+ g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1\r
+ endif\r
+#endif\r
+ g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)\r
+c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3\r
+ endif\r
+C Derivatives in gamma(l-1) or gamma(j-1)\r
+ if (l.gt.1) then \r
+#ifdef MOMENT\r
+ s1=dip(1,jj,i)*dipderg(3,kk,k)\r
+#endif\r
+ call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))\r
+ s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))\r
+ call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))\r
+ s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))\r
+ call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
+#ifdef MOMENT\r
+ if (swap) then\r
+ g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1\r
+ else\r
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1\r
+ endif\r
+#endif\r
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)\r
+c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3\r
+ endif\r
+C Cartesian derivatives.\r
+ if (lprn) then\r
+ write (2,*) 'In eello6_graph2'\r
+ do iii=1,2\r
+ write (2,*) 'iii=',iii\r
+ do kkk=1,5\r
+ write (2,*) 'kkk=',kkk\r
+ do jjj=1,2\r
+ write (2,'(3(2f10.5),5x)') \r
+ & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)\r
+ enddo\r
+ enddo\r
+ enddo\r
+ endif\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+#ifdef MOMENT\r
+ if (iii.eq.1) then\r
+ s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)\r
+ else\r
+ s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)\r
+ endif\r
+#endif\r
+ call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),\r
+ & auxvec(1))\r
+ s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
+ call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),\r
+ & auxvec(1))\r
+ s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))\r
+ call transpose2(EUg(1,1,k),auxmat(1,1))\r
+ call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),\r
+ & pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(1,2)+pizda(2,1)\r
+ s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
+cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4\r
+#ifdef MOMENT\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)\r
+#else\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)\r
+#endif\r
+ if (swap) then\r
+ derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3\r
+ else\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3\r
+ endif\r
+ enddo\r
+ enddo\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ double precision function eello6_graph3(i,j,k,l,jj,kk,swap)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)\r
+ logical swap\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+C \r
+C Parallel Antiparallel\r
+C \r
+C o o \r
+C /l\ / \ /j\ \r
+C / \ / \ / \ \r
+C /| o |o o| o |\ \r
+C j|/k\| / |/k\|l / \r
+C / \ / / \ / \r
+C / o / o \r
+C i i \r
+C\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+C\r
+C 4/7/01 AL Component s1 was removed, because it pertains to the respective \r
+C energy moment and not to the cluster cumulant.\r
+ iti=itortyp(itype(i))\r
+ if (j.lt.nres-1) then\r
+ itj1=itortyp(itype(j+1))\r
+ else\r
+ itj1=ntortyp+1\r
+ endif\r
+ itk=itortyp(itype(k))\r
+ itk1=itortyp(itype(k+1))\r
+ if (l.lt.nres-1) then\r
+ itl1=itortyp(itype(l+1))\r
+ else\r
+ itl1=ntortyp+1\r
+ endif\r
+#ifdef MOMENT\r
+ s1=dip(4,jj,i)*dip(4,kk,k)\r
+#endif\r
+ call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))\r
+ s2=0.5d0*scalar2(b1(1,itk),auxvec(1))\r
+ call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))\r
+ s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))\r
+ call transpose2(EE(1,1,itk),auxmat(1,1))\r
+ call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))\r
+cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,\r
+cd & "sum",-(s2+s3+s4)\r
+#ifdef MOMENT\r
+ eello6_graph3=-(s1+s2+s3+s4)\r
+#else\r
+ eello6_graph3=-(s2+s3+s4)\r
+#endif\r
+c eello6_graph3=-s4\r
+C Derivatives in gamma(k-1)\r
+ call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))\r
+ s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))\r
+ s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))\r
+ g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)\r
+C Derivatives in gamma(l-1)\r
+ call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))\r
+ s2=0.5d0*scalar2(b1(1,itk),auxvec(1))\r
+ call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))\r
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) \r
+C Cartesian derivatives.\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+#ifdef MOMENT\r
+ if (iii.eq.1) then\r
+ s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)\r
+ else\r
+ s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)\r
+ endif\r
+#endif\r
+ call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),\r
+ & auxvec(1))\r
+ s2=0.5d0*scalar2(b1(1,itk),auxvec(1))\r
+ call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),\r
+ & auxvec(1))\r
+ s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))\r
+ call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),\r
+ & pizda(1,1))\r
+ vv(1)=pizda(1,1)+pizda(2,2)\r
+ vv(2)=pizda(2,1)-pizda(1,2)\r
+ s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))\r
+#ifdef MOMENT\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)\r
+#else\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)\r
+#endif\r
+ if (swap) then\r
+ derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3\r
+ else\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3\r
+ endif\r
+c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4\r
+ enddo\r
+ enddo\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ include 'COMMON.FFIELD'\r
+ double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),\r
+ & auxvec1(2),auxmat1(2,2)\r
+ logical swap\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+C \r
+C Parallel Antiparallel\r
+C \r
+C o o \r
+C /l\ / \ /j\ \r
+C / \ / \ / \ \r
+C /| o |o o| o |\ \r
+C \ j|/k\| \ |/k\|l \r
+C \ / \ \ / \ \r
+C o \ o \ \r
+C i i \r
+C\r
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC\r
+C\r
+C 4/7/01 AL Component s1 was removed, because it pertains to the respective \r
+C energy moment and not to the cluster cumulant.\r
+cd write (2,*) 'eello_graph4: wturn6',wturn6\r
+ iti=itortyp(itype(i))\r
+ itj=itortyp(itype(j))\r
+ if (j.lt.nres-1) then\r
+ itj1=itortyp(itype(j+1))\r
+ else\r
+ itj1=ntortyp+1\r
+ endif\r
+ itk=itortyp(itype(k))\r
+ if (k.lt.nres-1) then\r
+ itk1=itortyp(itype(k+1))\r
+ else\r
+ itk1=ntortyp+1\r
+ endif\r
+ itl=itortyp(itype(l))\r
+ if (l.lt.nres-1) then\r
+ itl1=itortyp(itype(l+1))\r
+ else\r
+ itl1=ntortyp+1\r
+ endif\r
+cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l\r
+cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,\r
+cd & ' itl',itl,' itl1',itl1\r
+#ifdef MOMENT\r
+ if (imat.eq.1) then\r
+ s1=dip(3,jj,i)*dip(3,kk,k)\r
+ else\r
+ s1=dip(2,jj,j)*dip(2,kk,l)\r
+ endif\r
+#endif\r
+ call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))\r
+ s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
+ if (j.eq.l+1) then\r
+ call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))\r
+ s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))\r
+ else\r
+ call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))\r
+ s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))\r
+ endif\r
+ call transpose2(EUg(1,1,k),auxmat(1,1))\r
+ call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(2,1)+pizda(1,2)\r
+ s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
+cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4\r
+#ifdef MOMENT\r
+ eello6_graph4=-(s1+s2+s3+s4)\r
+#else\r
+ eello6_graph4=-(s2+s3+s4)\r
+#endif\r
+C Derivatives in gamma(i-1)\r
+ if (i.gt.1) then\r
+#ifdef MOMENT\r
+ if (imat.eq.1) then\r
+ s1=dipderg(2,jj,i)*dip(3,kk,k)\r
+ else\r
+ s1=dipderg(4,jj,j)*dip(2,kk,l)\r
+ endif\r
+#endif\r
+ s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))\r
+ if (j.eq.l+1) then\r
+ call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))\r
+ s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))\r
+ else\r
+ call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))\r
+ s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))\r
+ endif\r
+ s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))\r
+ if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then\r
+cd write (2,*) 'turn6 derivatives'\r
+#ifdef MOMENT\r
+ gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)\r
+#else\r
+ gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)\r
+#endif\r
+ else\r
+#ifdef MOMENT\r
+ g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)\r
+#else\r
+ g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)\r
+#endif\r
+ endif\r
+ endif\r
+C Derivatives in gamma(k-1)\r
+#ifdef MOMENT\r
+ if (imat.eq.1) then\r
+ s1=dip(3,jj,i)*dipderg(2,kk,k)\r
+ else\r
+ s1=dip(2,jj,j)*dipderg(4,kk,l)\r
+ endif\r
+#endif\r
+ call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))\r
+ s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))\r
+ if (j.eq.l+1) then\r
+ call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))\r
+ s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))\r
+ else\r
+ call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))\r
+ s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))\r
+ endif\r
+ call transpose2(EUgder(1,1,k),auxmat1(1,1))\r
+ call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(2,1)+pizda(1,2)\r
+ s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
+ if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then\r
+#ifdef MOMENT\r
+ gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)\r
+#else\r
+ gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)\r
+#endif\r
+ else\r
+#ifdef MOMENT\r
+ g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)\r
+#else\r
+ g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)\r
+#endif\r
+ endif\r
+C Derivatives in gamma(j-1) or gamma(l-1)\r
+ if (l.eq.j+1 .and. l.gt.1) then\r
+ call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))\r
+ s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
+ call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(2,1)+pizda(1,2)\r
+ s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
+ g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)\r
+ else if (j.gt.1) then\r
+ call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))\r
+ s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
+ call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(2,1)+pizda(1,2)\r
+ s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
+ if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then\r
+ gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)\r
+ else\r
+ g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)\r
+ endif\r
+ endif\r
+C Cartesian derivatives.\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+#ifdef MOMENT\r
+ if (iii.eq.1) then\r
+ if (imat.eq.1) then\r
+ s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)\r
+ else\r
+ s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)\r
+ endif\r
+ else\r
+ if (imat.eq.1) then\r
+ s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)\r
+ else\r
+ s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)\r
+ endif\r
+ endif\r
+#endif\r
+ call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),\r
+ & auxvec(1))\r
+ s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))\r
+ if (j.eq.l+1) then\r
+ call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),\r
+ & b1(1,itj1),auxvec(1))\r
+ s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))\r
+ else\r
+ call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),\r
+ & b1(1,itl1),auxvec(1))\r
+ s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))\r
+ endif\r
+ call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),\r
+ & pizda(1,1))\r
+ vv(1)=pizda(1,1)-pizda(2,2)\r
+ vv(2)=pizda(2,1)+pizda(1,2)\r
+ s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))\r
+ if (swap) then\r
+ if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then\r
+#ifdef MOMENT\r
+ derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)\r
+ & -(s1+s2+s4)\r
+#else\r
+ derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)\r
+ & -(s2+s4)\r
+#endif\r
+ derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3\r
+ else\r
+#ifdef MOMENT\r
+ derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)\r
+#else\r
+ derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)\r
+#endif\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3\r
+ endif\r
+ else\r
+#ifdef MOMENT\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)\r
+#else\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)\r
+#endif\r
+ if (l.eq.j+1) then\r
+ derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3\r
+ else \r
+ derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3\r
+ endif\r
+ endif \r
+ enddo\r
+ enddo\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ double precision function eello_turn6(i,jj,kk)\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ include 'COMMON.IOUNITS'\r
+ include 'COMMON.CHAIN'\r
+ include 'COMMON.DERIV'\r
+ include 'COMMON.INTERACT'\r
+ include 'COMMON.CONTACTS'\r
+ include 'COMMON.TORSION'\r
+ include 'COMMON.VAR'\r
+ include 'COMMON.GEO'\r
+ double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),\r
+ & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),\r
+ & ggg1(3),ggg2(3)\r
+ double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),\r
+ & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)\r
+C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to\r
+C the respective energy moment and not to the cluster cumulant.\r
+ s1=0.0d0\r
+ s8=0.0d0\r
+ s13=0.0d0\r
+c\r
+ eello_turn6=0.0d0\r
+ j=i+4\r
+ k=i+1\r
+ l=i+3\r
+ iti=itortyp(itype(i))\r
+ itk=itortyp(itype(k))\r
+ itk1=itortyp(itype(k+1))\r
+ itl=itortyp(itype(l))\r
+ itj=itortyp(itype(j))\r
+cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj\r
+cd write (2,*) 'i',i,' k',k,' j',j,' l',l\r
+cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then\r
+cd eello6=0.0d0\r
+cd return\r
+cd endif\r
+cd write (iout,*)\r
+cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,\r
+cd & ' and',k,l\r
+cd call checkint_turn6(i,jj,kk,eel_turn6_num)\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ derx_turn(lll,kkk,iii)=0.0d0\r
+ enddo\r
+ enddo\r
+ enddo\r
+cd eij=1.0d0\r
+cd ekl=1.0d0\r
+cd ekont=1.0d0\r
+ eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)\r
+cd eello6_5=0.0d0\r
+cd write (2,*) 'eello6_5',eello6_5\r
+#ifdef MOMENT\r
+ call transpose2(AEA(1,1,1),auxmat(1,1))\r
+ call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))\r
+ ss1=scalar2(Ub2(1,i+2),b1(1,itl))\r
+ s1 = (auxmat(1,1)+auxmat(2,2))*ss1\r
+#endif\r
+ call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))\r
+ call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))\r
+ s2 = scalar2(b1(1,itk),vtemp1(1))\r
+#ifdef MOMENT\r
+ call transpose2(AEA(1,1,2),atemp(1,1))\r
+ call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))\r
+ call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))\r
+ s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))\r
+#endif\r
+ call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))\r
+ call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))\r
+ s12 = scalar2(Ub2(1,i+2),vtemp3(1))\r
+#ifdef MOMENT\r
+ call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))\r
+ call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))\r
+ call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) \r
+ call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) \r
+ ss13 = scalar2(b1(1,itk),vtemp4(1))\r
+ s13 = (gtemp(1,1)+gtemp(2,2))*ss13\r
+#endif\r
+c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13\r
+c s1=0.0d0\r
+c s2=0.0d0\r
+c s8=0.0d0\r
+c s12=0.0d0\r
+c s13=0.0d0\r
+ eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)\r
+C Derivatives in gamma(i+2)\r
+ s1d =0.0d0\r
+ s8d =0.0d0\r
+#ifdef MOMENT\r
+ call transpose2(AEA(1,1,1),auxmatd(1,1))\r
+ call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))\r
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1\r
+ call transpose2(AEAderg(1,1,2),atempd(1,1))\r
+ call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))\r
+ s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))\r
+#endif\r
+ call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))\r
+ call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))\r
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))\r
+c s1d=0.0d0\r
+c s2d=0.0d0\r
+c s8d=0.0d0\r
+c s12d=0.0d0\r
+c s13d=0.0d0\r
+ gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)\r
+C Derivatives in gamma(i+3)\r
+#ifdef MOMENT\r
+ call transpose2(AEA(1,1,1),auxmatd(1,1))\r
+ call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))\r
+ ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))\r
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d\r
+#endif\r
+ call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))\r
+ call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))\r
+ s2d = scalar2(b1(1,itk),vtemp1d(1))\r
+#ifdef MOMENT\r
+ call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))\r
+ s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))\r
+#endif\r
+ s12d = scalar2(Ub2der(1,i+2),vtemp3(1))\r
+#ifdef MOMENT\r
+ call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))\r
+ call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) \r
+ s13d = (gtempd(1,1)+gtempd(2,2))*ss13\r
+#endif\r
+c s1d=0.0d0\r
+c s2d=0.0d0\r
+c s8d=0.0d0\r
+c s12d=0.0d0\r
+c s13d=0.0d0\r
+#ifdef MOMENT\r
+ gel_loc_turn6(i+1)=gel_loc_turn6(i+1)\r
+ & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)\r
+#else\r
+ gel_loc_turn6(i+1)=gel_loc_turn6(i+1)\r
+ & -0.5d0*ekont*(s2d+s12d)\r
+#endif\r
+C Derivatives in gamma(i+4)\r
+ call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))\r
+ call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))\r
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))\r
+#ifdef MOMENT\r
+ call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))\r
+ call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) \r
+ s13d = (gtempd(1,1)+gtempd(2,2))*ss13\r
+#endif\r
+c s1d=0.0d0\r
+c s2d=0.0d0\r
+c s8d=0.0d0\r
+C s12d=0.0d0\r
+c s13d=0.0d0\r
+#ifdef MOMENT\r
+ gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)\r
+#else\r
+ gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)\r
+#endif\r
+C Derivatives in gamma(i+5)\r
+#ifdef MOMENT\r
+ call transpose2(AEAderg(1,1,1),auxmatd(1,1))\r
+ call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))\r
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1\r
+#endif\r
+ call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))\r
+ call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))\r
+ s2d = scalar2(b1(1,itk),vtemp1d(1))\r
+#ifdef MOMENT\r
+ call transpose2(AEA(1,1,2),atempd(1,1))\r
+ call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))\r
+ s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))\r
+#endif\r
+ call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))\r
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))\r
+#ifdef MOMENT\r
+ call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) \r
+ ss13d = scalar2(b1(1,itk),vtemp4d(1))\r
+ s13d = (gtemp(1,1)+gtemp(2,2))*ss13d\r
+#endif\r
+c s1d=0.0d0\r
+c s2d=0.0d0\r
+c s8d=0.0d0\r
+c s12d=0.0d0\r
+c s13d=0.0d0\r
+#ifdef MOMENT\r
+ gel_loc_turn6(i+3)=gel_loc_turn6(i+3)\r
+ & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)\r
+#else\r
+ gel_loc_turn6(i+3)=gel_loc_turn6(i+3)\r
+ & -0.5d0*ekont*(s2d+s12d)\r
+#endif\r
+C Cartesian derivatives\r
+ do iii=1,2\r
+ do kkk=1,5\r
+ do lll=1,3\r
+#ifdef MOMENT\r
+ call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))\r
+ call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))\r
+ s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1\r
+#endif\r
+ call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))\r
+ call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),\r
+ & vtemp1d(1))\r
+ s2d = scalar2(b1(1,itk),vtemp1d(1))\r
+#ifdef MOMENT\r
+ call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))\r
+ call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))\r
+ s8d = -(atempd(1,1)+atempd(2,2))*\r
+ & scalar2(cc(1,1,itl),vtemp2(1))\r
+#endif\r
+ call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),\r
+ & auxmatd(1,1))\r
+ call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))\r
+ s12d = scalar2(Ub2(1,i+2),vtemp3d(1))\r
+c s1d=0.0d0\r
+c s2d=0.0d0\r
+c s8d=0.0d0\r
+c s12d=0.0d0\r
+c s13d=0.0d0\r
+#ifdef MOMENT\r
+ derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) \r
+ & - 0.5d0*(s1d+s2d)\r
+#else\r
+ derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) \r
+ & - 0.5d0*s2d\r
+#endif\r
+#ifdef MOMENT\r
+ derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) \r
+ & - 0.5d0*(s8d+s12d)\r
+#else\r
+ derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) \r
+ & - 0.5d0*s12d\r
+#endif\r
+ enddo\r
+ enddo\r
+ enddo\r
+#ifdef MOMENT\r
+ do kkk=1,5\r
+ do lll=1,3\r
+ call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),\r
+ & achuj_tempd(1,1))\r
+ call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))\r
+ call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) \r
+ s13d=(gtempd(1,1)+gtempd(2,2))*ss13\r
+ derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d\r
+ call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),\r
+ & vtemp4d(1)) \r
+ ss13d = scalar2(b1(1,itk),vtemp4d(1))\r
+ s13d = (gtemp(1,1)+gtemp(2,2))*ss13d\r
+ derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d\r
+ enddo\r
+ enddo\r
+#endif\r
+cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',\r
+cd & 16*eel_turn6_num\r
+cd goto 1112\r
+ if (j.lt.nres-1) then\r
+ j1=j+1\r
+ j2=j-1\r
+ else\r
+ j1=j-1\r
+ j2=j-2\r
+ endif\r
+ if (l.lt.nres-1) then\r
+ l1=l+1\r
+ l2=l-1\r
+ else\r
+ l1=l-1\r
+ l2=l-2\r
+ endif\r
+ do ll=1,3\r
+cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)\r
+cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)\r
+cgrad ghalf=0.5d0*ggg1(ll)\r
+cd ghalf=0.0d0\r
+ gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)\r
+ gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)\r
+ gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf\r
+ & +ekont*derx_turn(ll,2,1)\r
+ gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)\r
+ gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf\r
+ & +ekont*derx_turn(ll,4,1)\r
+ gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)\r
+ gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij\r
+ gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij\r
+cgrad ghalf=0.5d0*ggg2(ll)\r
+cd ghalf=0.0d0\r
+ gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf\r
+ & +ekont*derx_turn(ll,2,2)\r
+ gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)\r
+ gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf\r
+ & +ekont*derx_turn(ll,4,2)\r
+ gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)\r
+ gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl\r
+ gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl\r
+ enddo\r
+cd goto 1112\r
+cgrad do m=i+1,j-1\r
+cgrad do ll=1,3\r
+cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad do m=k+1,l-1\r
+cgrad do ll=1,3\r
+cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad1112 continue\r
+cgrad do m=i+2,j2\r
+cgrad do ll=1,3\r
+cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)\r
+cgrad enddo\r
+cgrad enddo\r
+cgrad do m=k+2,l2\r
+cgrad do ll=1,3\r
+cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)\r
+cgrad enddo\r
+cgrad enddo \r
+cd do iii=1,nres-3\r
+cd write (2,*) iii,g_corr6_loc(iii)\r
+cd enddo\r
+ eello_turn6=ekont*eel_turn6\r
+cd write (2,*) 'ekont',ekont\r
+cd write (2,*) 'eel_turn6',ekont*eel_turn6\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ double precision function scalar(u,v)\r
+!DIR$ INLINEALWAYS scalar\r
+#ifndef OSF\r
+cDEC$ ATTRIBUTES FORCEINLINE::scalar\r
+#endif\r
+ implicit none\r
+ double precision u(3),v(3)\r
+cd double precision sc\r
+cd integer i\r
+cd sc=0.0d0\r
+cd do i=1,3\r
+cd sc=sc+u(i)*v(i)\r
+cd enddo\r
+cd scalar=sc\r
+\r
+ scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)\r
+ return\r
+ end\r
+\r
+\r
+crc-----------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE MATVEC2(A1,V1,V2)\r
+!DIR$ INLINEALWAYS MATVEC2\r
+#ifndef OSF\r
+cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2\r
+#endif\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ DIMENSION A1(2,2),V1(2),V2(2)\r
+c DO 1 I=1,2\r
+c VI=0.0\r
+c DO 3 K=1,2\r
+c 3 VI=VI+A1(I,K)*V1(K)\r
+c Vaux(I)=VI\r
+c 1 CONTINUE\r
+\r
+ vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)\r
+ vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)\r
+\r
+ v2(1)=vaux1\r
+ v2(2)=vaux2\r
+ END\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ SUBROUTINE MATMAT2(A1,A2,A3)\r
+#ifndef OSF\r
+cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2 \r
+#endif\r
+ implicit real*8 (a-h,o-z)\r
+ include 'DIMENSIONS'\r
+ DIMENSION A1(2,2),A2(2,2),A3(2,2)\r
+c DIMENSION AI3(2,2)\r
+c DO J=1,2\r
+c A3IJ=0.0\r
+c DO K=1,2\r
+c A3IJ=A3IJ+A1(I,K)*A2(K,J)\r
+c enddo\r
+c A3(I,J)=A3IJ\r
+c enddo\r
+c enddo\r
+\r
+ ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)\r
+ ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)\r
+ ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)\r
+ ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)\r
+\r
+ A3(1,1)=AI3_11\r
+ A3(2,1)=AI3_21\r
+ A3(1,2)=AI3_12\r
+ A3(2,2)=AI3_22\r
+ END\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ double precision function scalar2(u,v)\r
+!DIR$ INLINEALWAYS scalar2\r
+ implicit none\r
+ double precision u(2),v(2)\r
+ double precision sc\r
+ integer i\r
+ scalar2=u(1)*v(1)+u(2)*v(2)\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine transpose2(a,at)\r
+!DIR$ INLINEALWAYS transpose2\r
+#ifndef OSF\r
+cDEC$ ATTRIBUTES FORCEINLINE::transpose2\r
+#endif\r
+ implicit none\r
+ double precision a(2,2),at(2,2)\r
+ at(1,1)=a(1,1)\r
+ at(1,2)=a(2,1)\r
+ at(2,1)=a(1,2)\r
+ at(2,2)=a(2,2)\r
+ return\r
+ end\r
+\r
+\r
+c--------------------------------------------------------------------\r
+\r
+\r
+ subroutine transpose(n,a,at)\r
+ implicit none\r
+ integer n,i,j\r
+ double precision a(n,n),at(n,n)\r
+ do i=1,n\r
+ do j=1,n\r
+ at(j,i)=a(i,j)\r
+ enddo\r
+ enddo\r
+ return\r
+ end\r
+\r
+\r
+C--------------------------------------------------------------------\r
+\r
+\r
+ subroutine prodmat3(a1,a2,kk,transp,prod)\r
+!DIR$ INLINEALWAYS prodmat3\r
+#ifndef OSF\r
+cDEC$ ATTRIBUTES FORCEINLINE::prodmat3\r
+#endif\r
+ implicit none\r
+ integer i,j\r
+ double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)\r
+ logical transp\r
+crc double precision auxmat(2,2),prod_(2,2)\r
+\r
+ if (transp) then\r
+crc call transpose2(kk(1,1),auxmat(1,1))\r
+crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))\r
+crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) \r
+ \r
+ prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)\r
+ & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)\r
+ prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)\r
+ & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)\r
+ prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)\r
+ & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)\r
+ prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)\r
+ & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)\r
+\r
+ else\r
+crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))\r
+crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))\r
+\r
+ prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)\r
+ & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)\r
+ prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)\r
+ & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)\r
+ prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)\r
+ & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)\r
+ prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)\r
+ & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)\r
+\r
+ endif\r
+c call transpose2(a2(1,1),a2t(1,1))\r
+\r
+crc print *,transp\r
+crc print *,((prod_(i,j),i=1,2),j=1,2)\r
+crc print *,((prod(i,j),i=1,2),j=1,2)\r
+\r
+ return\r
+ end\r
+\r
projects / unres.git / blobdiff