X-Git-Url: http://mmka.chem.univ.gda.pl/gitweb/?a=blobdiff_plain;f=source%2Funres%2Fsrc_MD-NEWSC%2Fenergy_p_new_barrier.F;fp=source%2Funres%2Fsrc_MD-NEWSC%2Fenergy_p_new_barrier.F;h=fc584afe869083537f8447ea9048d46ecd6f2182;hb=d101c97dea752458d76055fdbae49c26fff03c1f;hp=0000000000000000000000000000000000000000;hpb=325eda160c9ad2982501e091ca40606a29043712;p=unres.git diff --git a/source/unres/src_MD-NEWSC/energy_p_new_barrier.F b/source/unres/src_MD-NEWSC/energy_p_new_barrier.F new file mode 100644 index 0000000..fc584af --- /dev/null +++ b/source/unres/src_MD-NEWSC/energy_p_new_barrier.F @@ -0,0 +1,10943 @@ + SUBROUTINE etotal(energia) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" + double precision weights_(n_ene) +#endif + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision energia(0:n_ene) + include 'COMMON.LOCAL' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.CONTROL' + include 'COMMON.TIME1' +#ifdef MPI +c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, +c & " nfgtasks",nfgtasks + if (nfgtasks.gt.1) then +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif +C FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (fg_rank.eq.0) then + call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) +c print *,"Processor",myrank," BROADCAST iorder" +C FG master sets up the WEIGHTS_ array which will be broadcast to the +C FG slaves as WEIGHTS array. + weights_(1)=wsc + weights_(2)=wscp + weights_(3)=welec + weights_(4)=wcorr + weights_(5)=wcorr5 + weights_(6)=wcorr6 + weights_(7)=wel_loc + weights_(8)=wturn3 + weights_(9)=wturn4 + weights_(10)=wturn6 + weights_(11)=wang + weights_(12)=wscloc + weights_(13)=wtor + weights_(14)=wtor_d + weights_(15)=wstrain + weights_(16)=wvdwpp + weights_(17)=wbond + weights_(18)=scal14 + weights_(21)=wsccor + weights_(22)=wsct +C FG Master broadcasts the WEIGHTS_ array + call MPI_Bcast(weights_(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + else +C FG slaves receive the WEIGHTS array + call MPI_Bcast(weights(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + wsc=weights(1) + wscp=weights(2) + welec=weights(3) + wcorr=weights(4) + wcorr5=weights(5) + wcorr6=weights(6) + wel_loc=weights(7) + wturn3=weights(8) + wturn4=weights(9) + wturn6=weights(10) + wang=weights(11) + wscloc=weights(12) + wtor=weights(13) + wtor_d=weights(14) + wstrain=weights(15) + wvdwpp=weights(16) + wbond=weights(17) + scal14=weights(18) + wsccor=weights(21) + wsct=weights(22) + endif + time_Bcast=time_Bcast+MPI_Wtime()-time00 + time_Bcastw=time_Bcastw+MPI_Wtime()-time00 +c call chainbuild_cart + endif +c print *,'Processor',myrank,' calling etotal ipot=',ipot +c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct +#else +c if (modecalc.eq.12.or.modecalc.eq.14) then +c call int_from_cart1(.false.) +c endif +#endif +#ifdef TIMING +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif +#endif +C +C Compute the side-chain and electrostatic interaction energy +C + goto (101,102,103,104,105,106,107) ipot +C Lennard-Jones potential. + 101 call elj(evdw,evdw_p,evdw_m) +cd print '(a)','Exit ELJ' + goto 108 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk(evdw,evdw_p,evdw_m) + goto 108 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp(evdw,evdw_p,evdw_m) + goto 108 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb(evdw,evdw_p,evdw_m) + goto 108 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv(evdw,evdw_p,evdw_m) + goto 108 +C New SC-SC potential + 106 call emomo(evdw,evdw_p,evdw_m) + goto 108 +C Soft-sphere potential + 107 call e_softsphere(evdw) +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 108 continue +cmc +cmc Sep-06: egb takes care of dynamic ss bonds too +cmc +c if (dyn_ss) call dyn_set_nss + +c print *,"Processor",myrank," computed USCSC" +#ifdef TIMING +#ifdef MPI + time01=MPI_Wtime() +#else + time00=tcpu() +#endif +#endif + call vec_and_deriv +#ifdef TIMING +#ifdef MPI + time_vec=time_vec+MPI_Wtime()-time01 +#else + time_vec=time_vec+tcpu()-time01 +#endif +#endif +c print *,"Processor",myrank," left VEC_AND_DERIV" + if (ipot.lt.7) then +#ifdef SPLITELE + if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. + & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 + & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 + & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#else + if (welec.gt.0d0.or.wel_loc.gt.0d0.or. + & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 + & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 + & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#endif + call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) + else + ees=0.0d0 + evdw1=0.0d0 + eel_loc=0.0d0 + eello_turn3=0.0d0 + eello_turn4=0.0d0 + endif + else +c write (iout,*) "Soft-spheer ELEC potential" + call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, + & eello_turn4) + endif +c print *,"Processor",myrank," computed UELEC" +C +C Calculate excluded-volume interaction energy between peptide groups +C and side chains. +C + if (ipot.lt.7) then + if(wscp.gt.0d0) then + call escp(evdw2,evdw2_14) + else + evdw2=0 + evdw2_14=0 + endif + else +c write (iout,*) "Soft-sphere SCP potential" + call escp_soft_sphere(evdw2,evdw2_14) + endif +c +c Calculate the bond-stretching energy +c + call ebond(estr) +C +C Calculate the disulfide-bridge and other energy and the contributions +C from other distance constraints. +cd print *,'Calling EHPB' + call edis(ehpb) +cd print *,'EHPB exitted succesfully.' +C +C Calculate the virtual-bond-angle energy. +C + if (wang.gt.0d0) then + call ebend(ebe) + else + ebe=0 + endif +c print *,"Processor",myrank," computed UB" +C +C Calculate the SC local energy. +C + call esc(escloc) +c print *,"Processor",myrank," computed USC" +C +C Calculate the virtual-bond torsional energy. +C +cd print *,'nterm=',nterm + if (wtor.gt.0) then + call etor(etors,edihcnstr) + else + etors=0 + edihcnstr=0 + endif +c print *,"Processor",myrank," computed Utor" +C +C 6/23/01 Calculate double-torsional energy +C + if (wtor_d.gt.0) then + call etor_d(etors_d) + else + etors_d=0 + endif +c print *,"Processor",myrank," computed Utord" +C +C 21/5/07 Calculate local sicdechain correlation energy +C + if (wsccor.gt.0.0d0) then + call eback_sc_corr(esccor) + else + esccor=0.0d0 + endif +c print *,"Processor",myrank," computed Usccorr" +C +C 12/1/95 Multi-body terms +C + n_corr=0 + n_corr1=0 + if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 + & .or. wturn6.gt.0.0d0) .and. ipot.lt.7) then + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1, +cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 + else + ecorr=0.0d0 + ecorr5=0.0d0 + ecorr6=0.0d0 + eturn6=0.0d0 + endif + if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.7) then + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +cd write (iout,*) "multibody_hb ecorr",ecorr + endif +c print *,"Processor",myrank," computed Ucorr" +C +C If performing constraint dynamics, call the constraint energy +C after the equilibration time + if(usampl.and.totT.gt.eq_time) then + call EconstrQ + call Econstr_back + else + Uconst=0.0d0 + Uconst_back=0.0d0 + endif +#ifdef TIMING +#ifdef MPI + time_enecalc=time_enecalc+MPI_Wtime()-time00 +#else + time_enecalc=time_enecalc+tcpu()-time00 +#endif +#endif +c print *,"Processor",myrank," computed Uconstr" +#ifdef TIMING +#ifdef MPI + time00=MPI_Wtime() +#else + time00=tcpu() +#endif +#endif +c +C Sum the energies +C + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(18)=evdw2_14 +#else + energia(2)=evdw2 + energia(18)=0.0d0 +#endif +#ifdef SPLITELE + energia(3)=ees + energia(16)=evdw1 +#else + energia(3)=ees+evdw1 + energia(16)=0.0d0 +#endif + energia(4)=ecorr + energia(5)=ecorr5 + energia(6)=ecorr6 + energia(7)=eel_loc + energia(8)=eello_turn3 + energia(9)=eello_turn4 + energia(10)=eturn6 + energia(11)=ebe + energia(12)=escloc + energia(13)=etors + energia(14)=etors_d + energia(15)=ehpb + energia(19)=edihcnstr + energia(17)=estr + energia(20)=Uconst+Uconst_back + energia(21)=esccor + energia(22)=evdw_p + energia(23)=evdw_m +c print *," Processor",myrank," calls SUM_ENERGY" + call sum_energy(energia,.true.) + if (dyn_ss) call dyn_set_nss +c print *," Processor",myrank," left SUM_ENERGY" +#ifdef TIMING +#ifdef MPI + time_sumene=time_sumene+MPI_Wtime()-time00 +#else + time_sumene=time_sumene+tcpu()-time00 +#endif +#endif + RETURN + END SUBROUTINE etotal +c------------------------------------------------------------------------------- + subroutine sum_energy(energia,reduce) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision energia(0:n_ene),enebuff(0:n_ene+1) + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.TIME1' + logical reduce +#ifdef MPI + if (nfgtasks.gt.1 .and. reduce) then +#ifdef DEBUG + write (iout,*) "energies before REDUCE" + call enerprint(energia) + call flush(iout) +#endif + do i=0,n_ene + enebuff(i)=energia(i) + enddo + time00=MPI_Wtime() + call MPI_Barrier(FG_COMM,IERR) + time_barrier_e=time_barrier_e+MPI_Wtime()-time00 + time00=MPI_Wtime() + call MPI_Reduce(enebuff(0),energia(0),n_ene+1, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) +#ifdef DEBUG + write (iout,*) "energies after REDUCE" + call enerprint(energia) + call flush(iout) +#endif + time_Reduce=time_Reduce+MPI_Wtime()-time00 + endif + if (fg_rank.eq.0) then +#endif +#ifdef TSCSC + evdw=energia(22)+wsct*energia(23) +#else + evdw=energia(1) +#endif +#ifdef SCP14 + evdw2=energia(2)+energia(18) + evdw2_14=energia(18) +#else + evdw2=energia(2) +#endif +#ifdef SPLITELE + ees=energia(3) + evdw1=energia(16) +#else + ees=energia(3) + evdw1=0.0d0 +#endif + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eturn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + edihcnstr=energia(19) + estr=energia(17) + Uconst=energia(20) + esccor=energia(21) +#ifdef SPLITELE + etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 + & +wang*ebe+wtor*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 + & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 + & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d + & +wbond*estr+Uconst+wsccor*esccor +#else + etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) + & +wang*ebe+wtor*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 + & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 + & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d + & +wbond*estr+Uconst+wsccor*esccor +#endif + energia(0)=etot +c detecting NaNQ +#ifdef ISNAN +#ifdef AIX + if (isnan(etot).ne.0) energia(0)=1.0d+99 +#else + if (isnan(etot)) energia(0)=1.0d+99 +#endif +#else + i=0 +#ifdef WINPGI + idumm=proc_proc(etot,i) +#else + call proc_proc(etot,i) +#endif + if(i.eq.1)energia(0)=1.0d+99 +#endif +#ifdef MPI + endif +#endif + return + end +c------------------------------------------------------------------------------- + subroutine sum_gradient + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include 'mpif.h' +#endif + double precision gradbufc(3,maxres),gradbufx(3,maxres), + & glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres) + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.TIME1' + include 'COMMON.MAXGRAD' + include 'COMMON.SCCOR' +#ifdef TIMING +#ifdef MPI + time01=MPI_Wtime() +#else + time01=tcpu() +#endif +#endif +#ifdef DEBUG + write (iout,*) "sum_gradient gvdwc, gvdwx" + do i=1,nres + write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)') + & i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3), + & (gvdwcT(j,i),j=1,3) + enddo + call flush(iout) +#endif +#ifdef MPI +C FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (nfgtasks.gt.1 .and. fg_rank.eq.0) + & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif +C +C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient +C in virtual-bond-vector coordinates +C +#ifdef DEBUG +c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" +c do i=1,nres-1 +c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') +c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) +c enddo +c write (iout,*) "gel_loc_tur3 gel_loc_turn4" +c do i=1,nres-1 +c write (iout,'(i5,3f10.5,2x,f10.5)') +c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) +c enddo + write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc" + do i=1,nres + write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') + & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3), + & g_corr5_loc(i) + enddo + call flush(iout) +#endif +#ifdef SPLITELE +#ifdef TSCSC + do i=1,nct + do j=1,3 + gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+ + & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ + & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ + & wel_loc*gel_loc_long(j,i)+ + & wcorr*gradcorr_long(j,i)+ + & wcorr5*gradcorr5_long(j,i)+ + & wcorr6*gradcorr6_long(j,i)+ + & wturn6*gcorr6_turn_long(j,i)+ + & wstrain*ghpbc(j,i) + enddo + enddo +#else + do i=1,nct + do j=1,3 + gradbufc(j,i)=wsc*gvdwc(j,i)+ + & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ + & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ + & wel_loc*gel_loc_long(j,i)+ + & wcorr*gradcorr_long(j,i)+ + & wcorr5*gradcorr5_long(j,i)+ + & wcorr6*gradcorr6_long(j,i)+ + & wturn6*gcorr6_turn_long(j,i)+ + & wstrain*ghpbc(j,i) + enddo + enddo +#endif +#else + do i=1,nct + do j=1,3 + gradbufc(j,i)=wsc*gvdwc(j,i)+ + & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ + & welec*gelc_long(j,i)+ + & wbond*gradb(j,i)+ + & wel_loc*gel_loc_long(j,i)+ + & wcorr*gradcorr_long(j,i)+ + & wcorr5*gradcorr5_long(j,i)+ + & wcorr6*gradcorr6_long(j,i)+ + & wturn6*gcorr6_turn_long(j,i)+ + & wstrain*ghpbc(j,i) + enddo + enddo +#endif +#ifdef MPI + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +#ifdef DEBUG + write (iout,*) "gradbufc before allreduce" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif + do i=1,nres + do j=1,3 + gradbufc_sum(j,i)=gradbufc(j,i) + enddo + enddo +c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, +c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) +c time_reduce=time_reduce+MPI_Wtime()-time00 +#ifdef DEBUG +c write (iout,*) "gradbufc_sum after allreduce" +c do i=1,nres +c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) +c enddo +c call flush(iout) +#endif +#ifdef TIMING +c time_allreduce=time_allreduce+MPI_Wtime()-time00 +#endif + do i=nnt,nres + do k=1,3 + gradbufc(k,i)=0.0d0 + enddo + enddo +#ifdef DEBUG + write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end + write (iout,*) (i," jgrad_start",jgrad_start(i), + & " jgrad_end ",jgrad_end(i), + & i=igrad_start,igrad_end) +#endif +c +c Obsolete and inefficient code; we can make the effort O(n) and, therefore, +c do not parallelize this part. +c +c do i=igrad_start,igrad_end +c do j=jgrad_start(i),jgrad_end(i) +c do k=1,3 +c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) +c enddo +c enddo +c enddo + do j=1,3 + gradbufc(j,nres-1)=gradbufc_sum(j,nres) + enddo + do i=nres-2,nnt,-1 + do j=1,3 + gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) + enddo + enddo +#ifdef DEBUG + write (iout,*) "gradbufc after summing" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif + else +#endif +#ifdef DEBUG + write (iout,*) "gradbufc" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif + do i=1,nres + do j=1,3 + gradbufc_sum(j,i)=gradbufc(j,i) + gradbufc(j,i)=0.0d0 + enddo + enddo + do j=1,3 + gradbufc(j,nres-1)=gradbufc_sum(j,nres) + enddo + do i=nres-2,nnt,-1 + do j=1,3 + gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) + enddo + enddo +c do i=nnt,nres-1 +c do k=1,3 +c gradbufc(k,i)=0.0d0 +c enddo +c do j=i+1,nres +c do k=1,3 +c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) +c enddo +c enddo +c enddo +#ifdef DEBUG + write (iout,*) "gradbufc after summing" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif +#ifdef MPI + endif +#endif + do k=1,3 + gradbufc(k,nres)=0.0d0 + enddo + do i=1,nct + do j=1,3 +#ifdef SPLITELE + gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ + & wel_loc*gel_loc(j,i)+ + & 0.5d0*(wscp*gvdwc_scpp(j,i)+ + & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ + & wel_loc*gel_loc_long(j,i)+ + & wcorr*gradcorr_long(j,i)+ + & wcorr5*gradcorr5_long(j,i)+ + & wcorr6*gradcorr6_long(j,i)+ + & wturn6*gcorr6_turn_long(j,i))+ + & wbond*gradb(j,i)+ + & wcorr*gradcorr(j,i)+ + & wturn3*gcorr3_turn(j,i)+ + & wturn4*gcorr4_turn(j,i)+ + & wcorr5*gradcorr5(j,i)+ + & wcorr6*gradcorr6(j,i)+ + & wturn6*gcorr6_turn(j,i)+ + & wsccor*gsccorc(j,i) + & +wscloc*gscloc(j,i) +#else + gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ + & wel_loc*gel_loc(j,i)+ + & 0.5d0*(wscp*gvdwc_scpp(j,i)+ + & welec*gelc_long(j,i)+ + & wel_loc*gel_loc_long(j,i)+ + & wcorr*gcorr_long(j,i)+ + & wcorr5*gradcorr5_long(j,i)+ + & wcorr6*gradcorr6_long(j,i)+ + & wturn6*gcorr6_turn_long(j,i))+ + & wbond*gradb(j,i)+ + & wcorr*gradcorr(j,i)+ + & wturn3*gcorr3_turn(j,i)+ + & wturn4*gcorr4_turn(j,i)+ + & wcorr5*gradcorr5(j,i)+ + & wcorr6*gradcorr6(j,i)+ + & wturn6*gcorr6_turn(j,i)+ + & wsccor*gsccorc(j,i) + & +wscloc*gscloc(j,i) +#endif +#ifdef TSCSC + gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+ + & wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*gsccorx(j,i) + & +wscloc*gsclocx(j,i) +#else + gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*gsccorx(j,i) + & +wscloc*gsclocx(j,i) +#endif + enddo + enddo +#ifdef DEBUG + write (iout,*) "gloc before adding corr" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) + & +wcorr5*g_corr5_loc(i) + & +wcorr6*g_corr6_loc(i) + & +wturn4*gel_loc_turn4(i) + & +wturn3*gel_loc_turn3(i) + & +wturn6*gel_loc_turn6(i) + & +wel_loc*gel_loc_loc(i) + enddo +#ifdef DEBUG + write (iout,*) "gloc after adding corr" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif +#ifdef MPI + if (nfgtasks.gt.1) then + do j=1,3 + do i=1,nres + gradbufc(j,i)=gradc(j,i,icg) + gradbufx(j,i)=gradx(j,i,icg) + enddo + enddo + do i=1,4*nres + glocbuf(i)=gloc(i,icg) + enddo +#ifdef DEBUG + write (iout,*) "gloc_sc before reduce" + do i=1,nres + do j=1,3 + write (iout,*) i,j,gloc_sc(j,i,icg) + enddo + enddo +#endif + do i=1,nres + do j=1,3 + gloc_scbuf(j,i)=gloc_sc(j,i,icg) + enddo + enddo + time00=MPI_Wtime() + call MPI_Barrier(FG_COMM,IERR) + time_barrier_g=time_barrier_g+MPI_Wtime()-time00 + time00=MPI_Wtime() + call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 +#ifdef DEBUG + write (iout,*) "gloc_sc after reduce" + do i=1,nres + do j=1,3 + write (iout,*) i,j,gloc_sc(j,i,icg) + enddo + enddo +#endif +#ifdef DEBUG + write (iout,*) "gloc after reduce" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif + endif +#endif + if (gnorm_check) then +c +c Compute the maximum elements of the gradient +c + gvdwc_max=0.0d0 + gvdwc_scp_max=0.0d0 + gelc_max=0.0d0 + gvdwpp_max=0.0d0 + gradb_max=0.0d0 + ghpbc_max=0.0d0 + gradcorr_max=0.0d0 + gel_loc_max=0.0d0 + gcorr3_turn_max=0.0d0 + gcorr4_turn_max=0.0d0 + gradcorr5_max=0.0d0 + gradcorr6_max=0.0d0 + gcorr6_turn_max=0.0d0 + gsccorc_max=0.0d0 + gscloc_max=0.0d0 + gvdwx_max=0.0d0 + gradx_scp_max=0.0d0 + ghpbx_max=0.0d0 + gradxorr_max=0.0d0 + gsccorx_max=0.0d0 + gsclocx_max=0.0d0 + do i=1,nct + gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) + if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm +#ifdef TSCSC + gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i))) + if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm +#endif + gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i))) + if (gvdwc_scp_norm.gt.gvdwc_scp_max) + & gvdwc_scp_max=gvdwc_scp_norm + gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i))) + if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm + gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i))) + if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm + gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i))) + if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm + ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i))) + if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm + gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i))) + if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm + gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i))) + if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm + gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i), + & gcorr3_turn(1,i))) + if (gcorr3_turn_norm.gt.gcorr3_turn_max) + & gcorr3_turn_max=gcorr3_turn_norm + gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i), + & gcorr4_turn(1,i))) + if (gcorr4_turn_norm.gt.gcorr4_turn_max) + & gcorr4_turn_max=gcorr4_turn_norm + gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i))) + if (gradcorr5_norm.gt.gradcorr5_max) + & gradcorr5_max=gradcorr5_norm + gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) + if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm + gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i), + & gcorr6_turn(1,i))) + if (gcorr6_turn_norm.gt.gcorr6_turn_max) + & gcorr6_turn_max=gcorr6_turn_norm + gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) + if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm + gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) + if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm + gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) + if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm +#ifdef TSCSC + gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i))) + if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm +#endif + gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) + if (gradx_scp_norm.gt.gradx_scp_max) + & gradx_scp_max=gradx_scp_norm + ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) + if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm + gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) + if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm + gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) + if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm + gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) + if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm + enddo + if (gradout) then +#ifdef AIX + open(istat,file=statname,position="append") +#else + open(istat,file=statname,access="append") +#endif + write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max, + & gelc_max,gvdwpp_max,gradb_max,ghpbc_max, + & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, + & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, + & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, + & gsccorx_max,gsclocx_max + close(istat) + if (gvdwc_max.gt.1.0d4) then + write (iout,*) "gvdwc gvdwx gradb gradbx" + do i=nnt,nct + write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i), + & gradb(j,i),gradbx(j,i),j=1,3) + enddo + call pdbout(0.0d0,'cipiszcze',iout) + call flush(iout) + endif + endif + endif +#ifdef DEBUG + write (iout,*) "gradc gradx gloc" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') + & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) + enddo +#endif +#ifdef TIMING +#ifdef MPI + time_sumgradient=time_sumgradient+MPI_Wtime()-time01 +#else + time_sumgradient=time_sumgradient+tcpu()-time01 +#endif +#endif + return + end +c------------------------------------------------------------------------------- + subroutine rescale_weights(t_bath) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + double precision kfac /2.4d0/ + double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ +c facT=temp0/t_bath +c facT=2*temp0/(t_bath+temp0) + if (rescale_mode.eq.0) then + facT=1.0d0 + facT2=1.0d0 + facT3=1.0d0 + facT4=1.0d0 + facT5=1.0d0 + else if (rescale_mode.eq.1) then + facT=kfac/(kfac-1.0d0+t_bath/temp0) + facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) + facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) + facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) + facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) + else if (rescale_mode.eq.2) then + x=t_bath/temp0 + x2=x*x + x3=x2*x + x4=x3*x + x5=x4*x + facT=licznik/dlog(dexp(x)+dexp(-x)) + facT2=licznik/dlog(dexp(x2)+dexp(-x2)) + facT3=licznik/dlog(dexp(x3)+dexp(-x3)) + facT4=licznik/dlog(dexp(x4)+dexp(-x4)) + facT5=licznik/dlog(dexp(x5)+dexp(-x5)) + else + write (iout,*) "Wrong RESCALE_MODE",rescale_mode + write (*,*) "Wrong RESCALE_MODE",rescale_mode +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,IERROR) +#endif + stop 555 + endif + welec=weights(3)*fact + wcorr=weights(4)*fact3 + wcorr5=weights(5)*fact4 + wcorr6=weights(6)*fact5 + wel_loc=weights(7)*fact2 + wturn3=weights(8)*fact2 + wturn4=weights(9)*fact3 + wturn6=weights(10)*fact5 + wtor=weights(13)*fact + wtor_d=weights(14)*fact2 + wsccor=weights(21)*fact +#ifdef TSCSC +c wsct=t_bath/temp0 + wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0 +#endif + return + end +C------------------------------------------------------------------------ + subroutine enerprint(energia) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.MD' + double precision energia(0:n_ene) + etot=energia(0) +#ifdef TSCSC + evdw=energia(22)+wsct*energia(23) +#else + evdw=energia(1) +#endif + evdw2=energia(2) +#ifdef SCP14 + evdw2=energia(2)+energia(18) +#else + evdw2=energia(2) +#endif + ees=energia(3) +#ifdef SPLITELE + evdw1=energia(16) +#endif + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eello_turn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + edihcnstr=energia(19) + estr=energia(17) + Uconst=energia(20) + esccor=energia(21) +#ifdef SPLITELE + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, + & estr,wbond,ebe,wang, + & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, + & ecorr,wcorr, + & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor, + & edihcnstr,ebr*nss, + & Uconst,etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHPB= ',1pE16.6,' WEIGHT=',1pE16.6, + & ' (SS bridges & dist. cnstr.)'/ + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST= ',1pE16.6,' (Constraint energy)'/ + & 'ETOT= ',1pE16.6,' (total)') +#else + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, + & estr,wbond,ebe,wang, + & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, + & ecorr,wcorr, + & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr, + & ebr*nss,Uconst,etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, + & ' (SS bridges & dist. cnstr.)'/ + & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ + & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ + & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST=',1pE16.6,' (Constraint energy)'/ + & 'ETOT= ',1pE16.6,' (total)') +#endif + return + end +C----------------------------------------------------------------------- + subroutine elj(evdw,evdw_p,evdw_m) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + parameter (accur=1.0d-10) + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.TORSION' + include 'COMMON.SBRIDGE' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.CONTACTS' + dimension gg(3) +c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +C Change 12/1/95 + num_conti=0 +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi +C Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + rrij=1.0D0/rij +c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 + e1=fac*fac*aa(itypi,itypj) + e2=fac*bb(itypi,itypj) + evdwij=e1+e2 +cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), +cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, +cd & (c(k,i),k=1,3),(c(k,j),k=1,3) +#ifdef TSCSC + if (bb(itypi,itypj).gt.0) then + evdw_p=evdw_p+evdwij + else + evdw_m=evdw_m+evdwij + endif +#else + evdw=evdw+evdwij +#endif +C +C Calculate the components of the gradient in DC and X +C + fac=-rrij*(e1+evdwij) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac +#ifdef TSCSC + if (bb(itypi,itypj).gt.0.0d0) then + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo + else + do k=1,3 + gvdwxT(k,i)=gvdwxT(k,i)-gg(k) + gvdwxT(k,j)=gvdwxT(k,j)+gg(k) + gvdwcT(k,i)=gvdwcT(k,i)-gg(k) + gvdwcT(k,j)=gvdwcT(k,j)+gg(k) + enddo + endif +#else + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo +#endif +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) +cgrad enddo +cgrad enddo +C +C 12/1/95, revised on 5/20/97 +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +C +C Uncomment next line, if the correlation interactions include EVDW explicitly. +c if (j.gt.i+1 .and. evdwij.le.0.0D0) then +C Uncomment next line, if the correlation interactions are contact function only + if (j.gt.i+1.and. eps0ij.gt.0.0D0) then + rij=dsqrt(rij) + sigij=sigma(itypi,itypj) + r0ij=rs0(itypi,itypj) +C +C Check whether the SC's are not too far to make a contact. +C + rcut=1.5d0*r0ij + call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) +C Add a new contact, if the SC's are close enough, but not too close (r.< +c! om = omega, sqom = om^2 + sqom1 = om1 * om1 + sqom2 = om2 * om2 + sqom12 = om12 * om12 + +c! now we calculate EGB - Gey-Berne +c! It will be summed up in evdwij and saved in evdw + sigsq = 1.0D0 / sigsq + sig = sig0ij * dsqrt(sigsq) +c! rij_shift = 1.0D0 / rij - sig + sig0ij + rij_shift = Rtail - sig + sig0ij + IF (rij_shift.le.0.0D0) THEN + evdw = 1.0D20 + RETURN + END IF + sigder = -sig * sigsq + rij_shift = 1.0D0 / rij_shift + fac = rij_shift**expon + c1 = fac * fac * aa(itypi,itypj) +c! c1 = 0.0d0 + c2 = fac * bb(itypi,itypj) +c! c2 = 0.0d0 + evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) + eps2der = eps3rt * evdwij + eps3der = eps2rt * evdwij +c! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij + evdwij = eps2rt * eps3rt * evdwij +c! evdwij = 0.0d0 +c! write (*,*) "Gey Berne = ", evdwij +#ifdef TSCSC + IF (bb(itypi,itypj).gt.0) THEN + evdw_p = evdw_p + evdwij + ELSE + evdw_m = evdw_m + evdwij + END IF +#else + evdw = evdw + & + evdwij +#endif +c!------------------------------------------------------------------- +c! Calculate some components of GGB + c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 + fac = -expon * (c1 + evdwij) * rij_shift + sigder = fac * sigder +c! fac = rij * fac +c! Calculate distance derivative +c! gg(1) = xj * fac +c! gg(2) = yj * fac +c! gg(3) = zj * fac + gg(1) = fac + gg(2) = fac + gg(3) = fac +c! write (*,*) "gg(1) = ", gg(1) +c! write (*,*) "gg(2) = ", gg(2) +c! write (*,*) "gg(3) = ", gg(3) +c! The angular derivatives of GGB are brought together in sc_grad +c!------------------------------------------------------------------- +c! Fcav +c! +c! Catch gly-gly interactions to skip calculation of something that +c! does not exist + + IF (itypi.eq.10.and.itypj.eq.10) THEN + Fcav = 0.0d0 + dFdR = 0.0d0 + dCAVdOM1 = 0.0d0 + dCAVdOM2 = 0.0d0 + dCAVdOM12 = 0.0d0 + ELSE + +c! we are not 2 glycines, so we calculate Fcav (and maybe more) + fac = chis1 * sqom1 + chis2 * sqom2 + & - 2.0d0 * chis12 * om1 * om2 * om12 +c! we will use pom later in Gcav, so dont mess with it! + pom = 1.0d0 - chis1 * chis2 * sqom12 + + Lambf = (1.0d0 - (fac / pom)) + Lambf = dsqrt(Lambf) + + + sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0) +c! write (*,*) "sparrow = ", sparrow + Chif = Rtail * sparrow + ChiLambf = Chif * Lambf + eagle = dsqrt(ChiLambf) + bat = ChiLambf ** 11.0d0 + + top = b1 * ( eagle + b2 * ChiLambf - b3 ) + bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0) + botsq = bot * bot + +c! write (*,*) "sig1 = ",sig1 +c! write (*,*) "sig2 = ",sig2 +c! write (*,*) "Rtail = ",Rtail +c! write (*,*) "sparrow = ",sparrow +c! write (*,*) "Chis1 = ", chis1 +c! write (*,*) "Chis2 = ", chis2 +c! write (*,*) "Chis12 = ", chis12 +c! write (*,*) "om1 = ", om1 +c! write (*,*) "om2 = ", om2 +c! write (*,*) "om12 = ", om12 +c! write (*,*) "sqom1 = ", sqom1 +c! write (*,*) "sqom2 = ", sqom2 +c! write (*,*) "sqom12 = ", sqom12 +c! write (*,*) "Lambf = ",Lambf +c! write (*,*) "b1 = ",b1 +c! write (*,*) "b2 = ",b2 +c! write (*,*) "b3 = ",b3 +c! write (*,*) "b4 = ",b4 +c! write (*,*) "top = ",top +c! write (*,*) "bot = ",bot + Fcav = top / bot +c! Fcav = 0.0d0 +c! write (*,*) "Fcav = ", Fcav +c!------------------------------------------------------------------- +c! derivative of Fcav is Gcav... +c!--------------------------------------------------- + + dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf)) + dbot = 12.0d0 * b4 * bat * Lambf + dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow +c! dFdR = 0.0d0 +c! write (*,*) "dFcav/dR = ", dFdR + + dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif)) + dbot = 12.0d0 * b4 * bat * Chif + eagle = Lambf * pom + dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle) + dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle) + dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) + & * (chis2 * om2 * om12 - om1) / (eagle * pom) + + dFdL = ((dtop * bot - top * dbot) / botsq) +c! dFdL = 0.0d0 + dCAVdOM1 = dFdL * ( dFdOM1 ) + dCAVdOM2 = dFdL * ( dFdOM2 ) + dCAVdOM12 = dFdL * ( dFdOM12 ) +c! write (*,*) "dFcav/dOM1 = ", dCAVdOM1 +c! write (*,*) "dFcav/dOM2 = ", dCAVdOM2 +c! write (*,*) "dFcav/dOM12 = ", dCAVdOM12 +c! write (*,*) "" +c!------------------------------------------------------------------- +c! Finally, add the distance derivatives of GB and Fcav to gvdwc +c! Pom is used here to project the gradient vector into +c! cartesian coordinates and at the same time contains +c! dXhb/dXsc derivative (for charged amino acids +c! location of hydrophobic centre of interaction is not +c! the same as geometric centre of side chain, this +c! derivative takes that into account) +c! derivatives of omega angles will be added in sc_grad + + DO k= 1, 3 + ertail(k) = Rtail_distance(k)/Rtail + END DO + erdxi = scalar( ertail(1), dC_norm(1,i+nres) ) + erdxj = scalar( ertail(1), dC_norm(1,j+nres) ) + facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres) + facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres) + DO k = 1, 3 +c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) +c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) + pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i) + & - (( dFdR + gg(k) ) * pom) +c! & - ( dFdR * pom ) + pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j) + & + (( dFdR + gg(k) ) * pom) +c! & + ( dFdR * pom ) + + gvdwc(k,i) = gvdwc(k,i) + & - (( dFdR + gg(k) ) * ertail(k)) +c! & - ( dFdR * ertail(k)) + + gvdwc(k,j) = gvdwc(k,j) + & + (( dFdR + gg(k) ) * ertail(k)) +c! & + ( dFdR * ertail(k)) + + gg(k) = 0.0d0 +c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) +c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) + END DO + +c!------------------------------------------------------------------- +c! Compute head-head and head-tail energies for each state + + isel = iabs(Qi) + iabs(Qj) + IF (isel.eq.0) THEN +c! No charges - do nothing + eheadtail = 0.0d0 + + ELSE IF (isel.eq.4) THEN +c! Calculate dipole-dipole interactions + CALL edd(ecl) + eheadtail = ECL + + ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN +c! Charge-nonpolar interactions + CALL eqn(epol) + eheadtail = epol + + ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN +c! Nonpolar-charge interactions + CALL enq(epol) + eheadtail = epol + + ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN +c! Charge-dipole interactions + CALL eqd(ecl, elj, epol) + eheadtail = ECL + elj + epol + + ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN +c! Dipole-charge interactions + CALL edq(ecl, elj, epol) + eheadtail = ECL + elj + epol + + ELSE IF ((isel.eq.2.and. + & iabs(Qi).eq.1).and. + & nstate(itypi,itypj).eq.1) THEN +c! Same charge-charge interaction ( +/+ or -/- ) + CALL eqq(Ecl,Egb,Epol,Fisocav,Elj) + eheadtail = ECL + Egb + Epol + Fisocav + Elj + + ELSE IF ((isel.eq.2.and. + & iabs(Qi).eq.1).and. + & nstate(itypi,itypj).ne.1) THEN +c! Different charge-charge interaction ( +/- or -/+ ) + CALL energy_quad + & (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) + END IF + END IF ! this endif ends the "catch the gly-gly" at the beggining of Fcav +c! write (*,*) "evdw = ", evdw +c! write (*,*) "Fcav = ", Fcav +c! write (*,*) "eheadtail = ", eheadtail + evdw = evdw + & + Fcav + & + eheadtail + + IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)') + & restyp(itype(i)),i,restyp(itype(j)),j, + & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, + & Equad,evdw + IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)') + & restyp(itype(i)),i,restyp(itype(j)),j, + & 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj, + & Equad,evdw +#IFDEF CHECK_MOMO + evdw = 0.0d0 + END DO ! troll +#ENDIF + +c!------------------------------------------------------------------- +c! As all angular derivatives are done, now we sum them up, +c! then transform and project into cartesian vectors and add to gvdwc +c! We call sc_grad always, with the exception of +/- interaction. +c! This is because energy_quad subroutine needs to handle +c! this job in his own way. +c! This IS probably not very efficient and SHOULD be optimised +c! but it will require major restructurization of emomo +c! so it will be left as it is for now +c! write (*,*) 'troll1, nstate =', nstate (itypi,itypj) + IF (nstate(itypi,itypj).eq.1) THEN +#ifdef TSCSC + IF (bb(itypi,itypj).gt.0) THEN + CALL sc_grad + ELSE + CALL sc_grad_T + END IF +#else + CALL sc_grad +#endif + END IF +c!------------------------------------------------------------------- +c! NAPISY KONCOWE + END DO ! j + END DO ! iint + END DO ! i +c write (iout,*) "Number of loop steps in EGB:",ind +c energy_dec=.false. + RETURN + END SUBROUTINE emomo +c! END OF MOMO + + +C----------------------------------------------------------------------------- + + + SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar, facd3, facd4, federmaus, adler +c! Epol and Gpol analytical parameters + alphapol1 = alphapol(itypi,itypj) + alphapol2 = alphapol(itypj,itypi) +c! Fisocav and Gisocav analytical parameters + al1 = alphiso(1,itypi,itypj) + al2 = alphiso(2,itypi,itypj) + al3 = alphiso(3,itypi,itypj) + al4 = alphiso(4,itypi,itypj) + csig = (1.0d0 + & / dsqrt(sigiso1(itypi, itypj)**2.0d0 + & + sigiso2(itypi,itypj)**2.0d0)) +c! + pis = sig0head(itypi,itypj) + eps_head = epshead(itypi,itypj) + Rhead_sq = Rhead * Rhead +c! R1 - distance between head of ith side chain and tail of jth sidechain +c! R2 - distance between head of jth side chain and tail of ith sidechain + R1 = 0.0d0 + R2 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances needed by Epol + R1=R1+(ctail(k,2)-chead(k,1))**2 + R2=R2+(chead(k,2)-ctail(k,1))**2 + END DO +c! Pitagoras + R1 = dsqrt(R1) + R2 = dsqrt(R2) + +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,1,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,1,itypi,itypj))**2)) + +c!------------------------------------------------------------------- +c! Coulomb electrostatic interaction + Ecl = (332.0d0 * Qij) / Rhead +c! derivative of Ecl is Gcl... + dGCLdR = (-332.0d0 * Qij ) / Rhead_sq + dGCLdOM1 = 0.0d0 + dGCLdOM2 = 0.0d0 + dGCLdOM12 = 0.0d0 +c!------------------------------------------------------------------- +c! Generalised Born Solvent Polarization +c! Charged head polarizes the solvent + ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) + Fgb = sqrt( ( Rhead_sq ) + a12sq * ee) + Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb +c! Derivative of Egb is Ggb... + dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb) + dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) ) + & / ( 2.0d0 * Fgb ) + dGGBdR = dGGBdFGB * dFGBdR +c!------------------------------------------------------------------- +c! Fisocav - isotropic cavity creation term +c! or "how much energy it costs to put charged head in water" + pom = Rhead * csig + top = al1 * (dsqrt(pom) + al2 * pom - al3) + bot = (1.0d0 + al4 * pom**12.0d0) + botsq = bot * bot + FisoCav = top / bot +c! write (*,*) "Rhead = ",Rhead +c! write (*,*) "csig = ",csig +c! write (*,*) "pom = ",pom +c! write (*,*) "al1 = ",al1 +c! write (*,*) "al2 = ",al2 +c! write (*,*) "al3 = ",al3 +c! write (*,*) "al4 = ",al4 +c! write (*,*) "top = ",top +c! write (*,*) "bot = ",bot +c! Derivative of Fisocav is GCV... + dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) + dbot = 12.0d0 * al4 * pom ** 11.0d0 + dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig +c!------------------------------------------------------------------- +c! Epol +c! Polarization energy - charged heads polarize hydrophobic "neck" + MomoFac1 = (1.0d0 - chi1 * sqom2) + MomoFac2 = (1.0d0 - chi2 * sqom1) + RR1 = ( R1 * R1 ) / MomoFac1 + RR2 = ( R2 * R2 ) / MomoFac2 + ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) + ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) + fgb1 = sqrt( RR1 + a12sq * ee1 ) + fgb2 = sqrt( RR2 + a12sq * ee2 ) + epol = 332.0d0 * eps_inout_fac * ( + & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) +c! epol = 0.0d0 +c write (*,*) "eps_inout_fac = ",eps_inout_fac +c write (*,*) "alphapol1 = ", alphapol1 +c write (*,*) "alphapol2 = ", alphapol2 +c write (*,*) "fgb1 = ", fgb1 +c write (*,*) "fgb2 = ", fgb2 +c write (*,*) "epol = ", epol +c! derivative of Epol is Gpol... + dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) + & / (fgb1 ** 5.0d0) + dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) + & / (fgb2 ** 5.0d0) + dFGBdR1 = ( (R1 / MomoFac1) + & * ( 2.0d0 - (0.5d0 * ee1) ) ) + & / ( 2.0d0 * fgb1 ) + dFGBdR2 = ( (R2 / MomoFac2) + & * ( 2.0d0 - (0.5d0 * ee2) ) ) + & / ( 2.0d0 * fgb2 ) + dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) + & * ( 2.0d0 - 0.5d0 * ee1) ) + & / ( 2.0d0 * fgb1 ) + dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) + & * ( 2.0d0 - 0.5d0 * ee2) ) + & / ( 2.0d0 * fgb2 ) + dPOLdR1 = dPOLdFGB1 * dFGBdR1 +c! dPOLdR1 = 0.0d0 + dPOLdR2 = dPOLdFGB2 * dFGBdR2 +c! dPOLdR2 = 0.0d0 + dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 +c! dPOLdOM1 = 0.0d0 + dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 +c! dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Elj +c! Lennard-Jones 6-12 interaction between heads + pom = (pis / Rhead)**6.0d0 + Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) +c! derivative of Elj is Glj + dGLJdR = 4.0d0 * eps_head + & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) + & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) +c!------------------------------------------------------------------- +c! Return the results +c! These things do the dRdX derivatives, that is +c! allow us to change what we see from function that changes with +c! distance to function that changes with LOCATION (of the interaction +c! site) + DO k = 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) + erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) + END DO + + erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) + bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) + federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) + eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) + adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) + facd1 = d1 * vbld_inv(i+nres) + facd2 = d2 * vbld_inv(j+nres) + facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) + facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) + +c! Now we add appropriate partial derivatives (one in each dimension) + DO k = 1, 3 + hawk = (erhead_tail(k,1) + + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) + condor = (erhead_tail(k,2) + + & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) + + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i) + & - dGCLdR * pom + & - dGGBdR * pom + & - dGCVdR * pom + & - dPOLdR1 * hawk + & - dPOLdR2 * (erhead_tail(k,2) + & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) + & - dGLJdR * pom + + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j) + & + dGCLdR * pom + & + dGGBdR * pom + & + dGCVdR * pom + & + dPOLdR1 * (erhead_tail(k,1) + & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) + & + dPOLdR2 * condor + & + dGLJdR * pom + + gvdwc(k,i) = gvdwc(k,i) + & - dGCLdR * erhead(k) + & - dGGBdR * erhead(k) + & - dGCVdR * erhead(k) + & - dPOLdR1 * erhead_tail(k,1) + & - dPOLdR2 * erhead_tail(k,2) + & - dGLJdR * erhead(k) + + gvdwc(k,j) = gvdwc(k,j) + & + dGCLdR * erhead(k) + & + dGGBdR * erhead(k) + & + dGCVdR * erhead(k) + & + dPOLdR1 * erhead_tail(k,1) + & + dPOLdR2 * erhead_tail(k,2) + & + dGLJdR * erhead(k) + + END DO + RETURN + END SUBROUTINE eqq +c!------------------------------------------------------------------- + SUBROUTINE energy_quad + &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar + double precision ener(4) + double precision dcosom1(3),dcosom2(3) +c! used in Epol derivatives + double precision facd3, facd4 + double precision federmaus, adler +c! Epol and Gpol analytical parameters + alphapol1 = alphapol(itypi,itypj) + alphapol2 = alphapol(itypj,itypi) +c! Fisocav and Gisocav analytical parameters + al1 = alphiso(1,itypi,itypj) + al2 = alphiso(2,itypi,itypj) + al3 = alphiso(3,itypi,itypj) + al4 = alphiso(4,itypi,itypj) + csig = (1.0d0 + & / dsqrt(sigiso1(itypi, itypj)**2.0d0 + & + sigiso2(itypi,itypj)**2.0d0)) +c! + w1 = wqdip(1,itypi,itypj) + w2 = wqdip(2,itypi,itypj) + pis = sig0head(itypi,itypj) + eps_head = epshead(itypi,itypj) +c! First things first: +c! We need to do sc_grad's job with GB and Fcav + eom1 = + & eps2der * eps2rt_om1 + & - 2.0D0 * alf1 * eps3der + & + sigder * sigsq_om1 + & + dCAVdOM1 + eom2 = + & eps2der * eps2rt_om2 + & + 2.0D0 * alf2 * eps3der + & + sigder * sigsq_om2 + & + dCAVdOM2 + eom12 = + & evdwij * eps1_om12 + & + eps2der * eps2rt_om12 + & - 2.0D0 * alf12 * eps3der + & + sigder *sigsq_om12 + & + dCAVdOM12 +c! now some magical transformations to project gradient into +c! three cartesian vectors + DO k = 1, 3 + dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k)) + dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) + gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k) +c! this acts on hydrophobic center of interaction + gvdwx(k,i)= gvdwx(k,i) - gg(k) + & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwx(k,j)= gvdwx(k,j) + gg(k) + & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv +c! this acts on Calpha + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + END DO +c! sc_grad is done, now we will compute + eheadtail = 0.0d0 + eom1 = 0.0d0 + eom2 = 0.0d0 + eom12 = 0.0d0 + +c! ENERGY DEBUG +c! ii = 1 +c! jj = 1 +c! d1 = dhead(1, 1, itypi, itypj) +c! d2 = dhead(2, 1, itypi, itypj) +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,ii,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,jj,itypi,itypj))**2)) +c! Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2)) +c! END OF ENERGY DEBUG +c************************************************************* + DO istate = 1, nstate(itypi,itypj) +c************************************************************* + IF (istate.ne.1) THEN + IF (istate.lt.3) THEN + ii = 1 + ELSE + ii = 2 + END IF + jj = istate/ii + d1 = dhead(1,ii,itypi,itypj) + d2 = dhead(2,jj,itypi,itypj) + DO k = 1,3 + chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) + chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) + Rhead_distance(k) = chead(k,2) - chead(k,1) + END DO +c! pitagoras (root of sum of squares) + Rhead = dsqrt( + & (Rhead_distance(1)*Rhead_distance(1)) + & + (Rhead_distance(2)*Rhead_distance(2)) + & + (Rhead_distance(3)*Rhead_distance(3))) + END IF + Rhead_sq = Rhead * Rhead + +c! R1 - distance between head of ith side chain and tail of jth sidechain +c! R2 - distance between head of jth side chain and tail of ith sidechain + R1 = 0.0d0 + R2 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances + R1=R1+(ctail(k,2)-chead(k,1))**2 + R2=R2+(chead(k,2)-ctail(k,1))**2 + END DO +c! Pitagoras + R1 = dsqrt(R1) + R2 = dsqrt(R2) + +c! ENERGY DEBUG +c! write (*,*) "istate = ", istate +c! write (*,*) "ii = ", ii +c! write (*,*) "jj = ", jj +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,ii,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,jj,itypi,itypj))**2)) +c! Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2)) +c! Rhead_sq = Rhead * Rhead +c! write (*,*) "d1 = ",d1 +c! write (*,*) "d2 = ",d2 +c! write (*,*) "R1 = ",R1 +c! write (*,*) "R2 = ",R2 +c! write (*,*) "Rhead = ",Rhead +c! END OF ENERGY DEBUG + +c!------------------------------------------------------------------- +c! Coulomb electrostatic interaction + Ecl = (332.0d0 * Qij) / (Rhead * eps_in) +c! Ecl = 0.0d0 +c! write (*,*) "Ecl = ", Ecl +c! derivative of Ecl is Gcl... + dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in) +c! dGCLdR = 0.0d0 + dGCLdOM1 = 0.0d0 + dGCLdOM2 = 0.0d0 + dGCLdOM12 = 0.0d0 +c!------------------------------------------------------------------- +c! Generalised Born Solvent Polarization + ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) + Fgb = sqrt( ( Rhead_sq ) + a12sq * ee) + Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb +c! Egb = 0.0d0 +c! write (*,*) "a1*a2 = ", a12sq +c! write (*,*) "Rhead = ", Rhead +c! write (*,*) "Rhead_sq = ", Rhead_sq +c! write (*,*) "ee = ", ee +c! write (*,*) "Fgb = ", Fgb +c! write (*,*) "fac = ", eps_inout_fac +c! write (*,*) "Qij = ", Qij +c! write (*,*) "Egb = ", Egb +c! Derivative of Egb is Ggb... +c! dFGBdR is used by Quad's later... + dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb) + dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) ) + & / ( 2.0d0 * Fgb ) + dGGBdR = dGGBdFGB * dFGBdR +c! dGGBdR = 0.0d0 +c!------------------------------------------------------------------- +c! Fisocav - isotropic cavity creation term + pom = Rhead * csig + top = al1 * (dsqrt(pom) + al2 * pom - al3) + bot = (1.0d0 + al4 * pom**12.0d0) + botsq = bot * bot + FisoCav = top / bot +c! FisoCav = 0.0d0 +c! write (*,*) "pom = ",pom +c! write (*,*) "al1 = ",al1 +c! write (*,*) "al2 = ",al2 +c! write (*,*) "al3 = ",al3 +c! write (*,*) "al4 = ",al4 +c! write (*,*) "top = ",top +c! write (*,*) "bot = ",bot +c! write (*,*) "Fisocav = ", Fisocav + +c! Derivative of Fisocav is GCV... + dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) + dbot = 12.0d0 * al4 * pom ** 11.0d0 + dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig +c! dGCVdR = 0.0d0 +c!------------------------------------------------------------------- +c! Polarization energy +c! Epol + MomoFac1 = (1.0d0 - chi1 * sqom2) + MomoFac2 = (1.0d0 - chi2 * sqom1) + RR1 = ( R1 * R1 ) / MomoFac1 + RR2 = ( R2 * R2 ) / MomoFac2 + ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) + ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) + fgb1 = sqrt( RR1 + a12sq * ee1 ) + fgb2 = sqrt( RR2 + a12sq * ee2 ) + epol = 332.0d0 * eps_inout_fac * ( + & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) +c! epol = 0.0d0 +c! derivative of Epol is Gpol... + dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) + & / (fgb1 ** 5.0d0) + dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) + & / (fgb2 ** 5.0d0) + dFGBdR1 = ( (R1 / MomoFac1) + & * ( 2.0d0 - (0.5d0 * ee1) ) ) + & / ( 2.0d0 * fgb1 ) + dFGBdR2 = ( (R2 / MomoFac2) + & * ( 2.0d0 - (0.5d0 * ee2) ) ) + & / ( 2.0d0 * fgb2 ) + dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) + & * ( 2.0d0 - 0.5d0 * ee1) ) + & / ( 2.0d0 * fgb1 ) + dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) + & * ( 2.0d0 - 0.5d0 * ee2) ) + & / ( 2.0d0 * fgb2 ) + dPOLdR1 = dPOLdFGB1 * dFGBdR1 +c! dPOLdR1 = 0.0d0 + dPOLdR2 = dPOLdFGB2 * dFGBdR2 +c! dPOLdR2 = 0.0d0 + dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 +c! dPOLdOM1 = 0.0d0 + dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 +c! dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Elj + pom = (pis / Rhead)**6.0d0 + Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) +c! Elj = 0.0d0 +c! derivative of Elj is Glj + dGLJdR = 4.0d0 * eps_head + & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) + & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) +c! dGLJdR = 0.0d0 +c!------------------------------------------------------------------- +c! Equad + IF (Wqd.ne.0.0d0) THEN + Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) + & - 37.5d0 * ( sqom1 + sqom2 ) + & + 157.5d0 * ( sqom1 * sqom2 ) + & - 45.0d0 * om1*om2*om12 + fac = -( Wqd / (2.0d0 * Fgb**5.0d0) ) + Equad = fac * Beta1 +c! Equad = 0.0d0 +c! derivative of Equad... + dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR +c! dQUADdR = 0.0d0 + dQUADdOM1 = fac + & * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12) +c! dQUADdOM1 = 0.0d0 + dQUADdOM2 = fac + & * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12) +c! dQUADdOM2 = 0.0d0 + dQUADdOM12 = fac + & * ( 6.0d0*om12 - 45.0d0*om1*om2 ) +c! dQUADdOM12 = 0.0d0 + ELSE + Beta1 = 0.0d0 + Equad = 0.0d0 + END IF +c!------------------------------------------------------------------- +c! Return the results +c! Angular stuff + eom1 = dPOLdOM1 + dQUADdOM1 + eom2 = dPOLdOM2 + dQUADdOM2 + eom12 = dQUADdOM12 +c! now some magical transformations to project gradient into +c! three cartesian vectors + DO k = 1, 3 + dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k)) + dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) + tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k) + END DO +c! Radial stuff + DO k = 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) + erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) + END DO + erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) + bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) + federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) + eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) + adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) + facd1 = d1 * vbld_inv(i+nres) + facd2 = d2 * vbld_inv(j+nres) + facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) + facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) +c! Throw the results into gheadtail which holds gradients +c! for each micro-state + DO k = 1, 3 + hawk = erhead_tail(k,1) + + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)) + condor = erhead_tail(k,2) + + & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)) + + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) +c! this acts on hydrophobic center of interaction + gheadtail(k,1,1) = gheadtail(k,1,1) + & - dGCLdR * pom + & - dGGBdR * pom + & - dGCVdR * pom + & - dPOLdR1 * hawk + & - dPOLdR2 * (erhead_tail(k,2) + & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) + & - dGLJdR * pom + & - dQUADdR * pom + & - tuna(k) + & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) +c! this acts on hydrophobic center of interaction + gheadtail(k,2,1) = gheadtail(k,2,1) + & + dGCLdR * pom + & + dGGBdR * pom + & + dGCVdR * pom + & + dPOLdR1 * (erhead_tail(k,1) + & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) + & + dPOLdR2 * condor + & + dGLJdR * pom + & + dQUADdR * pom + & + tuna(k) + & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + +c! this acts on Calpha + gheadtail(k,3,1) = gheadtail(k,3,1) + & - dGCLdR * erhead(k) + & - dGGBdR * erhead(k) + & - dGCVdR * erhead(k) + & - dPOLdR1 * erhead_tail(k,1) + & - dPOLdR2 * erhead_tail(k,2) + & - dGLJdR * erhead(k) + & - dQUADdR * erhead(k) + & - tuna(k) + +c! this acts on Calpha + gheadtail(k,4,1) = gheadtail(k,4,1) + & + dGCLdR * erhead(k) + & + dGGBdR * erhead(k) + & + dGCVdR * erhead(k) + & + dPOLdR1 * erhead_tail(k,1) + & + dPOLdR2 * erhead_tail(k,2) + & + dGLJdR * erhead(k) + & + dQUADdR * erhead(k) + & + tuna(k) + END DO +c! write(*,*) "ECL = ", Ecl +c! write(*,*) "Egb = ", Egb +c! write(*,*) "Epol = ", Epol +c! write(*,*) "Fisocav = ", Fisocav +c! write(*,*) "Elj = ", Elj +c! write(*,*) "Equad = ", Equad +c! write(*,*) "wstate = ", wstate(istate,itypi,itypj) +c! write(*,*) "eheadtail = ", eheadtail +c! write(*,*) "TROLL = ", dexp(-betaT * ener(istate)) +c! write(*,*) "dGCLdR = ", dGCLdR +c! write(*,*) "dGGBdR = ", dGGBdR +c! write(*,*) "dGCVdR = ", dGCVdR +c! write(*,*) "dPOLdR1 = ", dPOLdR1 +c! write(*,*) "dPOLdR2 = ", dPOLdR2 +c! write(*,*) "dGLJdR = ", dGLJdR +c! write(*,*) "dQUADdR = ", dQUADdR +c! write(*,*) "tuna(",k,") = ", tuna(k) + ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad + eheadtail = eheadtail + & + wstate(istate, itypi, itypj) + & * dexp(-betaT * ener(istate)) +c! foreach cartesian dimension + DO k = 1, 3 +c! foreach of two gvdwx and gvdwc + DO l = 1, 4 + gheadtail(k,l,2) = gheadtail(k,l,2) + & + wstate( istate, itypi, itypj ) + & * dexp(-betaT * ener(istate)) + & * gheadtail(k,l,1) + gheadtail(k,l,1) = 0.0d0 + END DO + END DO + END DO +c! Here ended the gigantic DO istate = 1, 4, which starts +c! at the beggining of the subroutine + + DO k = 1, 3 + DO l = 1, 4 + gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail + END DO + gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2) + gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2) + gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2) + gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2) + DO l = 1, 4 + gheadtail(k,l,1) = 0.0d0 + gheadtail(k,l,2) = 0.0d0 + END DO + END DO + eheadtail = (-dlog(eheadtail)) / betaT + dPOLdOM1 = 0.0d0 + dPOLdOM2 = 0.0d0 + dQUADdOM1 = 0.0d0 + dQUADdOM2 = 0.0d0 + dQUADdOM12 = 0.0d0 + RETURN + END SUBROUTINE energy_quad + + +c!------------------------------------------------------------------- + + + SUBROUTINE eqn(Epol) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar, facd4, federmaus + alphapol1 = alphapol(itypi,itypj) +c! R1 - distance between head of ith side chain and tail of jth sidechain + R1 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances + R1=R1+(ctail(k,2)-chead(k,1))**2 + END DO +c! Pitagoras + R1 = dsqrt(R1) + +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,1,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,1,itypi,itypj))**2)) +c-------------------------------------------------------------------- +c Polarization energy +c Epol + MomoFac1 = (1.0d0 - chi1 * sqom2) + RR1 = R1 * R1 / MomoFac1 + ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) + fgb1 = sqrt( RR1 + a12sq * ee1) + epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) +c! epol = 0.0d0 +c!------------------------------------------------------------------ +c! derivative of Epol is Gpol... + dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) + & / (fgb1 ** 5.0d0) + dFGBdR1 = ( (R1 / MomoFac1) + & * ( 2.0d0 - (0.5d0 * ee1) ) ) + & / ( 2.0d0 * fgb1 ) + dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) + & * (2.0d0 - 0.5d0 * ee1) ) + & / (2.0d0 * fgb1) + dPOLdR1 = dPOLdFGB1 * dFGBdR1 +c! dPOLdR1 = 0.0d0 + dPOLdOM1 = 0.0d0 + dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 +c! dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Return the results +c! (see comments in Eqq) + DO k = 1, 3 + erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) + END DO + bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) + federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) + facd1 = d1 * vbld_inv(i+nres) + facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) + + DO k = 1, 3 + hawk = (erhead_tail(k,1) + + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) + + gvdwx(k,i) = gvdwx(k,i) + & - dPOLdR1 * hawk + gvdwx(k,j) = gvdwx(k,j) + & + dPOLdR1 * (erhead_tail(k,1) + & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) + + gvdwc(k,i) = gvdwc(k,i) + & - dPOLdR1 * erhead_tail(k,1) + gvdwc(k,j) = gvdwc(k,j) + & + dPOLdR1 * erhead_tail(k,1) + + END DO + RETURN + END SUBROUTINE eqn + + +c!------------------------------------------------------------------- + + + + SUBROUTINE enq(Epol) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar, facd3, adler + alphapol2 = alphapol(itypj,itypi) +c! R2 - distance between head of jth side chain and tail of ith sidechain + R2 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances + R2=R2+(chead(k,2)-ctail(k,1))**2 + END DO +c! Pitagoras + R2 = dsqrt(R2) + +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,1,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,1,itypi,itypj))**2)) +c------------------------------------------------------------------------ +c Polarization energy + MomoFac2 = (1.0d0 - chi2 * sqom1) + RR2 = R2 * R2 / MomoFac2 + ee2 = exp(-(RR2 / (4.0d0 * a12sq))) + fgb2 = sqrt(RR2 + a12sq * ee2) + epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) +c! epol = 0.0d0 +c!------------------------------------------------------------------- +c! derivative of Epol is Gpol... + dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) + & / (fgb2 ** 5.0d0) + dFGBdR2 = ( (R2 / MomoFac2) + & * ( 2.0d0 - (0.5d0 * ee2) ) ) + & / (2.0d0 * fgb2) + dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) + & * (2.0d0 - 0.5d0 * ee2) ) + & / (2.0d0 * fgb2) + dPOLdR2 = dPOLdFGB2 * dFGBdR2 +c! dPOLdR2 = 0.0d0 + dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 +c! dPOLdOM1 = 0.0d0 + dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Return the results +c! (See comments in Eqq) + DO k = 1, 3 + erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) + END DO + eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) + adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) + facd2 = d2 * vbld_inv(j+nres) + facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) + DO k = 1, 3 + condor = (erhead_tail(k,2) + & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) + + gvdwx(k,i) = gvdwx(k,i) + & - dPOLdR2 * (erhead_tail(k,2) + & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) + gvdwx(k,j) = gvdwx(k,j) + & + dPOLdR2 * condor + + gvdwc(k,i) = gvdwc(k,i) + & - dPOLdR2 * erhead_tail(k,2) + gvdwc(k,j) = gvdwc(k,j) + & + dPOLdR2 * erhead_tail(k,2) + + END DO + RETURN + END SUBROUTINE enq + + +c!------------------------------------------------------------------- + + + SUBROUTINE eqd(Ecl,Elj,Epol) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar, facd4, federmaus + alphapol1 = alphapol(itypi,itypj) + w1 = wqdip(1,itypi,itypj) + w2 = wqdip(2,itypi,itypj) + pis = sig0head(itypi,itypj) + eps_head = epshead(itypi,itypj) +c!------------------------------------------------------------------- +c! R1 - distance between head of ith side chain and tail of jth sidechain + R1 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances + R1=R1+(ctail(k,2)-chead(k,1))**2 + END DO +c! Pitagoras + R1 = dsqrt(R1) + +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,1,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,1,itypi,itypj))**2)) + +c!------------------------------------------------------------------- +c! ecl + sparrow = w1 * Qi * om1 + hawk = w2 * Qi * Qi * (1.0d0 - sqom2) + Ecl = sparrow / Rhead**2.0d0 + & - hawk / Rhead**4.0d0 +c!------------------------------------------------------------------- +c! derivative of ecl is Gcl +c! dF/dr part + dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 + & + 4.0d0 * hawk / Rhead**5.0d0 +c! dF/dom1 + dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) +c! dF/dom2 + dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) +c-------------------------------------------------------------------- +c Polarization energy +c Epol + MomoFac1 = (1.0d0 - chi1 * sqom2) + RR1 = R1 * R1 / MomoFac1 + ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) + fgb1 = sqrt( RR1 + a12sq * ee1) + epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) +c! epol = 0.0d0 +c!------------------------------------------------------------------ +c! derivative of Epol is Gpol... + dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) + & / (fgb1 ** 5.0d0) + dFGBdR1 = ( (R1 / MomoFac1) + & * ( 2.0d0 - (0.5d0 * ee1) ) ) + & / ( 2.0d0 * fgb1 ) + dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) + & * (2.0d0 - 0.5d0 * ee1) ) + & / (2.0d0 * fgb1) + dPOLdR1 = dPOLdFGB1 * dFGBdR1 +c! dPOLdR1 = 0.0d0 + dPOLdOM1 = 0.0d0 + dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 +c! dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Elj + pom = (pis / Rhead)**6.0d0 + Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) +c! derivative of Elj is Glj + dGLJdR = 4.0d0 * eps_head + & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) + & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) +c!------------------------------------------------------------------- +c! Return the results + DO k = 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) + END DO + + erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) + bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) + federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) + facd1 = d1 * vbld_inv(i+nres) + facd2 = d2 * vbld_inv(j+nres) + facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) + + DO k = 1, 3 + hawk = (erhead_tail(k,1) + + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) + + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i) + & - dGCLdR * pom + & - dPOLdR1 * hawk + & - dGLJdR * pom + + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j) + & + dGCLdR * pom + & + dPOLdR1 * (erhead_tail(k,1) + & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) + & + dGLJdR * pom + + + gvdwc(k,i) = gvdwc(k,i) + & - dGCLdR * erhead(k) + & - dPOLdR1 * erhead_tail(k,1) + & - dGLJdR * erhead(k) + + gvdwc(k,j) = gvdwc(k,j) + & + dGCLdR * erhead(k) + & + dPOLdR1 * erhead_tail(k,1) + & + dGLJdR * erhead(k) + + END DO + RETURN + END SUBROUTINE eqd + + +c!------------------------------------------------------------------- + + + SUBROUTINE edq(Ecl,Elj,Epol) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar, facd3, adler + alphapol2 = alphapol(itypj,itypi) + w1 = wqdip(1,itypi,itypj) + w2 = wqdip(2,itypi,itypj) + pis = sig0head(itypi,itypj) + eps_head = epshead(itypi,itypj) +c!------------------------------------------------------------------- +c! R2 - distance between head of jth side chain and tail of ith sidechain + R2 = 0.0d0 + DO k = 1, 3 +c! Calculate head-to-tail distances + R2=R2+(chead(k,2)-ctail(k,1))**2 + END DO +c! Pitagoras + R2 = dsqrt(R2) + +c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) +c! & +dhead(1,1,itypi,itypj))**2)) +c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) +c! & +dhead(2,1,itypi,itypj))**2)) + + +c!------------------------------------------------------------------- +c! ecl + sparrow = w1 * Qi * om1 + hawk = w2 * Qi * Qi * (1.0d0 - sqom2) + ECL = sparrow / Rhead**2.0d0 + & - hawk / Rhead**4.0d0 +c!------------------------------------------------------------------- +c! derivative of ecl is Gcl +c! dF/dr part + dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 + & + 4.0d0 * hawk / Rhead**5.0d0 +c! dF/dom1 + dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) +c! dF/dom2 + dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) +c-------------------------------------------------------------------- +c Polarization energy +c Epol + MomoFac2 = (1.0d0 - chi2 * sqom1) + RR2 = R2 * R2 / MomoFac2 + ee2 = exp(-(RR2 / (4.0d0 * a12sq))) + fgb2 = sqrt(RR2 + a12sq * ee2) + epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) +c! epol = 0.0d0 +c! derivative of Epol is Gpol... + dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) + & / (fgb2 ** 5.0d0) + dFGBdR2 = ( (R2 / MomoFac2) + & * ( 2.0d0 - (0.5d0 * ee2) ) ) + & / (2.0d0 * fgb2) + dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) + & * (2.0d0 - 0.5d0 * ee2) ) + & / (2.0d0 * fgb2) + dPOLdR2 = dPOLdFGB2 * dFGBdR2 +c! dPOLdR2 = 0.0d0 + dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 +c! dPOLdOM1 = 0.0d0 + dPOLdOM2 = 0.0d0 +c!------------------------------------------------------------------- +c! Elj + pom = (pis / Rhead)**6.0d0 + Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) +c! derivative of Elj is Glj + dGLJdR = 4.0d0 * eps_head + & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) + & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) +c!------------------------------------------------------------------- +c! Return the results +c! (see comments in Eqq) + DO k = 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) + END DO + erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) + eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) + adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) + facd1 = d1 * vbld_inv(i+nres) + facd2 = d2 * vbld_inv(j+nres) + facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) + + DO k = 1, 3 + condor = (erhead_tail(k,2) + & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) + + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i) + & - dGCLdR * pom + & - dPOLdR2 * (erhead_tail(k,2) + & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) + & - dGLJdR * pom + + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j) + & + dGCLdR * pom + & + dPOLdR2 * condor + & + dGLJdR * pom + + + gvdwc(k,i) = gvdwc(k,i) + & - dGCLdR * erhead(k) + & - dPOLdR2 * erhead_tail(k,2) + & - dGLJdR * erhead(k) + + gvdwc(k,j) = gvdwc(k,j) + & + dGCLdR * erhead(k) + & + dPOLdR2 * erhead_tail(k,2) + & + dGLJdR * erhead(k) + + END DO + RETURN + END SUBROUTINE edq + + +C-------------------------------------------------------------------- + + + SUBROUTINE edd(ECL) + IMPLICIT NONE + INCLUDE 'DIMENSIONS' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.CONTROL' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.EMP' + INCLUDE 'COMMON.GEO' + INCLUDE 'COMMON.INTERACT' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.LOCAL' + INCLUDE 'COMMON.NAMES' + INCLUDE 'COMMON.VAR' + double precision scalar +c! csig = sigiso(itypi,itypj) + w1 = wqdip(1,itypi,itypj) + w2 = wqdip(2,itypi,itypj) +c!------------------------------------------------------------------- +c! ECL + fac = (om12 - 3.0d0 * om1 * om2) + c1 = (w1 / (Rhead**3.0d0)) * fac + c2 = (w2 / Rhead ** 6.0d0) + & * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) + ECL = c1 - c2 +c! write (*,*) "w1 = ", w1 +c! write (*,*) "w2 = ", w2 +c! write (*,*) "om1 = ", om1 +c! write (*,*) "om2 = ", om2 +c! write (*,*) "om12 = ", om12 +c! write (*,*) "fac = ", fac +c! write (*,*) "c1 = ", c1 +c! write (*,*) "c2 = ", c2 +c! write (*,*) "Ecl = ", Ecl +c! write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0) +c! write (*,*) "c2_2 = ", +c! & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) +c!------------------------------------------------------------------- +c! dervative of ECL is GCL... +c! dECL/dr + c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0) + c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) + & * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2)) + dGCLdR = c1 - c2 +c! dECL/dom1 + c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0) + c2 = (-6.0d0 * w2) / (Rhead**6.0d0) + & * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 ) + dGCLdOM1 = c1 - c2 +c! dECL/dom2 + c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0) + c2 = (-6.0d0 * w2) / (Rhead**6.0d0) + & * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 ) + dGCLdOM2 = c1 - c2 +c! dECL/dom12 + c1 = w1 / (Rhead ** 3.0d0) + c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 + dGCLdOM12 = c1 - c2 +c!------------------------------------------------------------------- +c! Return the results +c! (see comments in Eqq) + DO k= 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + END DO + erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) + facd1 = d1 * vbld_inv(i+nres) + facd2 = d2 * vbld_inv(j+nres) + DO k = 1, 3 + + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i) + & - dGCLdR * pom + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j) + & + dGCLdR * pom + + gvdwc(k,i) = gvdwc(k,i) + & - dGCLdR * erhead(k) + gvdwc(k,j) = gvdwc(k,j) + & + dGCLdR * erhead(k) + END DO + RETURN + END SUBROUTINE edd + + +c!------------------------------------------------------------------- + + + SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol) + IMPLICIT NONE +c! maxres + INCLUDE 'DIMENSIONS' +c! itypi, itypj, i, j, k, l, chead, + INCLUDE 'COMMON.CALC' +c! c, nres, dc_norm + INCLUDE 'COMMON.CHAIN' +c! gradc, gradx + INCLUDE 'COMMON.DERIV' +c! electrostatic gradients-specific variables + INCLUDE 'COMMON.EMP' +c! wquad, dhead, alphiso, alphasur, rborn, epsintab + INCLUDE 'COMMON.INTERACT' +c! t_bath, Rb + INCLUDE 'COMMON.MD' +c! io for debug, disable it in final builds + INCLUDE 'COMMON.IOUNITS' +c!------------------------------------------------------------------- +c! Variable Init + +c! what amino acid is the aminoacid j'th? + itypj = itype(j) +c! 1/(Gas Constant * Thermostate temperature) = BetaT +c! ENABLE THIS LINE WHEN USING CHECKGRAD!!! +c! t_bath = 300 +c! BetaT = 1.0d0 / (t_bath * Rb) + BetaT = 1.0d0 / (298.0d0 * Rb) +c! Gay-berne var's + sig0ij = sigma( itypi,itypj ) + chi1 = chi( itypi, itypj ) + chi2 = chi( itypj, itypi ) + chi12 = chi1 * chi2 + chip1 = chipp( itypi, itypj ) + chip2 = chipp( itypj, itypi ) + chip12 = chip1 * chip2 +c! not used by momo potential, but needed by sc_angular which is shared +c! by all energy_potential subroutines + alf1 = 0.0d0 + alf2 = 0.0d0 + alf12 = 0.0d0 +c! location, location, location + xj = c( 1, nres+j ) - xi + yj = c( 2, nres+j ) - yi + zj = c( 3, nres+j ) - zi + dxj = dc_norm( 1, nres+j ) + dyj = dc_norm( 2, nres+j ) + dzj = dc_norm( 3, nres+j ) +c! distance from center of chain(?) to polar/charged head +c! write (*,*) "istate = ", 1 +c! write (*,*) "ii = ", 1 +c! write (*,*) "jj = ", 1 + d1 = dhead(1, 1, itypi, itypj) + d2 = dhead(2, 1, itypi, itypj) +c! ai*aj from Fgb + a12sq = rborn(itypi,itypj) * rborn(itypj,itypi) +c! a12sq = a12sq * a12sq +c! charge of amino acid itypi is... + Qi = icharge(itypi) + Qj = icharge(itypj) + Qij = Qi * Qj +c! chis1,2,12 + chis1 = chis(itypi,itypj) + chis2 = chis(itypj,itypi) + chis12 = chis1 * chis2 + sig1 = sigmap1(itypi,itypj) + sig2 = sigmap2(itypi,itypj) +c! write (*,*) "sig1 = ", sig1 +c! write (*,*) "sig2 = ", sig2 +c! alpha factors from Fcav/Gcav + b1 = alphasur(1,itypi,itypj) + b2 = alphasur(2,itypi,itypj) + b3 = alphasur(3,itypi,itypj) + b4 = alphasur(4,itypi,itypj) +c! used to determine whether we want to do quadrupole calculations + wqd = wquad(itypi, itypj) +c! used by Fgb + eps_in = epsintab(itypi,itypj) + eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) +c! write (*,*) "eps_inout_fac = ", eps_inout_fac +c!------------------------------------------------------------------- +c! tail location and distance calculations + Rtail = 0.0d0 + DO k = 1, 3 + ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i) + ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j) + END DO +c! tail distances will be themselves usefull elswhere +c1 (in Gcav, for example) + Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 ) + Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 ) + Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 ) + Rtail = dsqrt( + & (Rtail_distance(1)*Rtail_distance(1)) + & + (Rtail_distance(2)*Rtail_distance(2)) + & + (Rtail_distance(3)*Rtail_distance(3))) +c!------------------------------------------------------------------- +c! Calculate location and distance between polar heads +c! distance between heads +c! for each one of our three dimensional space... + DO k = 1,3 +c! location of polar head is computed by taking hydrophobic centre +c! and moving by a d1 * dc_norm vector +c! see unres publications for very informative images + chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) + chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) +c! distance +c! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) +c! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) + Rhead_distance(k) = chead(k,2) - chead(k,1) + END DO +c! pitagoras (root of sum of squares) + Rhead = dsqrt( + & (Rhead_distance(1)*Rhead_distance(1)) + & + (Rhead_distance(2)*Rhead_distance(2)) + & + (Rhead_distance(3)*Rhead_distance(3))) +c!------------------------------------------------------------------- +c! zero everything that should be zero'ed + Egb = 0.0d0 + ECL = 0.0d0 + Elj = 0.0d0 + Equad = 0.0d0 + Epol = 0.0d0 + eheadtail = 0.0d0 + dGCLdOM1 = 0.0d0 + dGCLdOM2 = 0.0d0 + dGCLdOM12 = 0.0d0 + dPOLdOM1 = 0.0d0 + dPOLdOM2 = 0.0d0 + RETURN + END SUBROUTINE elgrad_init + + +c!------------------------------------------------------------------- + + subroutine sc_angular +C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2, +C om12. Called by ebp, egb, and egbv. + implicit none + include 'COMMON.CALC' + include 'COMMON.IOUNITS' + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj +c! om1 = 0.0d0 +c! om2 = 0.0d0 +c! om12 = 0.0d0 + chiom12=chi12*om12 +C Calculate eps1(om12) and its derivative in om12 + faceps1=1.0D0-om12*chiom12 + faceps1_inv=1.0D0/faceps1 + eps1=dsqrt(faceps1_inv) +C Following variable is eps1*deps1/dom12 + eps1_om12=faceps1_inv*chiom12 +c diagnostics only +c faceps1_inv=om12 +c eps1=om12 +c eps1_om12=1.0d0 +c write (iout,*) "om12",om12," eps1",eps1 +C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2, +C and om12. + om1om2=om1*om2 + chiom1=chi1*om1 + chiom2=chi2*om2 + facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12 + sigsq=1.0D0-facsig*faceps1_inv + sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv + sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv + sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2 +c diagnostics only +c sigsq=1.0d0 +c sigsq_om1=0.0d0 +c sigsq_om2=0.0d0 +c sigsq_om12=0.0d0 +c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12 +c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv, +c & " eps1",eps1 +C Calculate eps2 and its derivatives in om1, om2, and om12. + chipom1=chip1*om1 + chipom2=chip2*om2 + chipom12=chip12*om12 + facp=1.0D0-om12*chipom12 + facp_inv=1.0D0/facp + facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12 +c write (iout,*) "chipom1",chipom1," chipom2",chipom2, +c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv +C Following variable is the square root of eps2 + eps2rt=1.0D0-facp1*facp_inv +C Following three variables are the derivatives of the square root of eps +C in om1, om2, and om12. + eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv + eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv + eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2 +C Evaluate the "asymmetric" factor in the VDW constant, eps3 +c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular +c! Or frankly, we should restructurize the whole energy section + eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12 +c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt +c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2, +c & " eps2rt_om12",eps2rt_om12 +C Calculate whole angle-dependent part of epsilon and contributions +C to its derivatives + return + end + +C---------------------------------------------------------------------------- + subroutine sc_grad_T + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.CALC' + include 'COMMON.IOUNITS' + double precision dcosom1(3),dcosom2(3) + eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 + eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 + eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 + & -2.0D0*alf12*eps3der+sigder*sigsq_om12 +c diagnostics only +c eom1=0.0d0 +c eom2=0.0d0 +c eom12=evdwij*eps1_om12 +c end diagnostics +c write (iout,*) "eps2der",eps2der," eps3der",eps3der, +c & " sigder",sigder +c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 +c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + do k=1,3 + gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo +c write (iout,*) "gg",(gg(k),k=1,3) + do k=1,3 + gvdwxT(k,i)=gvdwxT(k,i)-gg(k) + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwxT(k,j)=gvdwxT(k,j)+gg(k) + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv +c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) +c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv +c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) +c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +C +C Calculate the components of the gradient in DC and X +C +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) +cgrad enddo +cgrad enddo + do l=1,3 + gvdwcT(l,i)=gvdwcT(l,i)-gg(l) + gvdwcT(l,j)=gvdwcT(l,j)+gg(l) + enddo + return + end + +C---------------------------------------------------------------------------- + + + SUBROUTINE sc_grad + IMPLICIT real*8 (a-h,o-z) + INCLUDE 'DIMENSIONS' + INCLUDE 'COMMON.CHAIN' + INCLUDE 'COMMON.DERIV' + INCLUDE 'COMMON.CALC' + INCLUDE 'COMMON.IOUNITS' + INCLUDE 'COMMON.EMP' + double precision dcosom1(3),dcosom2(3) +c! write (*,*) "Start sc_grad" +c! each eom holds sum of omega-angular derivatives of each component +c! of energy function. First GGB, then Gcav, dipole-dipole,... + eom1 = + & eps2der * eps2rt_om1 + & - 2.0D0 * alf1 * eps3der + & + sigder * sigsq_om1 + & + dCAVdOM1 + & + dGCLdOM1 + & + dPOLdOM1 + + eom2 = + & eps2der * eps2rt_om2 + & + 2.0D0 * alf2 * eps3der + & + sigder * sigsq_om2 + & + dCAVdOM2 + & + dGCLdOM2 + & + dPOLdOM2 + + eom12 = + & evdwij * eps1_om12 + & + eps2der * eps2rt_om12 + & - 2.0D0 * alf12 * eps3der + & + sigder *sigsq_om12 + & + dCAVdOM12 + & + dGCLdOM12 + +c! write (*,*) "evdwij=", evdwij +c! write (*,*) "eps1_om12=", eps1_om12 +c! write (*,*) "eps2der=", eps2rt_om12 +c! write (*,*) "alf12=", alf12 +c! write (*,*) "eps3der=", eps3der +c! write (*,*) "eom1=", eom1 +c! write (*,*) "eom2=", eom2 +c! write (*,*) "eom12=", eom12 +c! eom1 = 0.0d0 +c! eom2 = 0.0d0 +c! eom12 = 0.0d0 +c! write (*,*) "" + + DO k = 1, 3 +c! now some magical transformations to project gradient into +c! three cartesian vectors +c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) +c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) +c! write (*,*) "gg(",k,")=", gg(k) + dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k)) + dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) + gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k) +c! write (*,*) "gg(",k,")=", gg(k) +c! this acts on hydrophobic center of interaction + gvdwx(k,i)= gvdwx(k,i) - gg(k) + & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwx(k,j)= gvdwx(k,j) + gg(k) + & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv +c! this acts on Calpha + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) +c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) +c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) + END DO +c! write (*,*) "*************" +c! write (*,*) "" + RETURN + END SUBROUTINE sc_grad + + +C----------------------------------------------------------------------- + + + subroutine e_softsphere(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + parameter (accur=1.0d-10) + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.TORSION' + include 'COMMON.SBRIDGE' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.CONTACTS' + dimension gg(3) +cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=itype(i) + itypi1=itype(i+1) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=itype(j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + rij=xj*xj+yj*yj+zj*zj +c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj + r0ij=r0(itypi,itypj) + r0ijsq=r0ij*r0ij +c print *,i,j,r0ij,dsqrt(rij) + if (rij.lt.r0ijsq) then + evdwij=0.25d0*(rij-r0ijsq)**2 + fac=rij-r0ijsq + else + evdwij=0.0d0 + fac=0.0d0 + endif + evdw=evdw+evdwij +C +C Calculate the components of the gradient in DC and X +C + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwc(k,i)=gvdwc(k,i)-gg(k) + gvdwc(k,j)=gvdwc(k,j)+gg(k) + enddo +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) +cgrad enddo +cgrad enddo + enddo ! j + enddo ! iint + enddo ! i + return + end +C-------------------------------------------------------------------------- + subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, + & eello_turn4) +C +C Soft-sphere potential of p-p interaction +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + dimension ggg(3) +cd write(iout,*) 'In EELEC_soft_sphere' + ees=0.0D0 + evdw1=0.0D0 + eel_loc=0.0d0 + eello_turn3=0.0d0 + eello_turn4=0.0d0 + ind=0 + do i=iatel_s,iatel_e + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi + num_conti=0 +c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) + do j=ielstart(i),ielend(i) + ind=ind+1 + iteli=itel(i) + itelj=itel(j) + if (j.eq.i+2 .and. itelj.eq.2) iteli=2 + r0ij=rpp(iteli,itelj) + r0ijsq=r0ij*r0ij + dxj=dc(1,j) + dyj=dc(2,j) + dzj=dc(3,j) + xj=c(1,j)+0.5D0*dxj-xmedi + yj=c(2,j)+0.5D0*dyj-ymedi + zj=c(3,j)+0.5D0*dzj-zmedi + rij=xj*xj+yj*yj+zj*zj + if (rij.lt.r0ijsq) then + evdw1ij=0.25d0*(rij-r0ijsq)**2 + fac=rij-r0ijsq + else + evdw1ij=0.0d0 + fac=0.0d0 + endif + evdw1=evdw1+evdw1ij +C +C Calculate contributions to the Cartesian gradient. +C + ggg(1)=fac*xj + ggg(2)=fac*yj + ggg(3)=fac*zj + do k=1,3 + gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) + enddo +* +* Loop over residues i+1 thru j-1. +* +cgrad do k=i+1,j-1 +cgrad do l=1,3 +cgrad gelc(l,k)=gelc(l,k)+ggg(l) +cgrad enddo +cgrad enddo + enddo ! j + enddo ! i +cgrad do i=nnt,nct-1 +cgrad do k=1,3 +cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i) +cgrad enddo +cgrad do j=i+1,nct-1 +cgrad do k=1,3 +cgrad gelc(k,i)=gelc(k,i)+gelc(k,j) +cgrad enddo +cgrad enddo +cgrad enddo + return + end +c------------------------------------------------------------------------------ + subroutine vec_and_deriv + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.VECTORS' + include 'COMMON.SETUP' + include 'COMMON.TIME1' + dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2) +C Compute the local reference systems. For reference system (i), the +C X-axis points from CA(i) to CA(i+1), the Y axis is in the +C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane. +#ifdef PARVEC + do i=ivec_start,ivec_end +#else + do i=1,nres-1 +#endif + if (i.eq.nres-1) then +C Case of the last full residue +C Compute the Z-axis + call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i)) + costh=dcos(pi-theta(nres)) + fac=1.0d0/dsqrt(1.0d0-costh*costh) + do k=1,3 + uz(k,i)=fac*uz(k,i) + enddo +C Compute the derivatives of uz + uzder(1,1,1)= 0.0d0 + uzder(2,1,1)=-dc_norm(3,i-1) + uzder(3,1,1)= dc_norm(2,i-1) + uzder(1,2,1)= dc_norm(3,i-1) + uzder(2,2,1)= 0.0d0 + uzder(3,2,1)=-dc_norm(1,i-1) + uzder(1,3,1)=-dc_norm(2,i-1) + uzder(2,3,1)= dc_norm(1,i-1) + uzder(3,3,1)= 0.0d0 + uzder(1,1,2)= 0.0d0 + uzder(2,1,2)= dc_norm(3,i) + uzder(3,1,2)=-dc_norm(2,i) + uzder(1,2,2)=-dc_norm(3,i) + uzder(2,2,2)= 0.0d0 + uzder(3,2,2)= dc_norm(1,i) + uzder(1,3,2)= dc_norm(2,i) + uzder(2,3,2)=-dc_norm(1,i) + uzder(3,3,2)= 0.0d0 +C Compute the Y-axis + facy=fac + do k=1,3 + uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i)) + enddo +C Compute the derivatives of uy + do j=1,3 + do k=1,3 + uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) + & -dc_norm(k,i)*dc_norm(j,i-1) + uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) + enddo + uyder(j,j,1)=uyder(j,j,1)-costh + uyder(j,j,2)=1.0d0+uyder(j,j,2) + enddo + do j=1,2 + do k=1,3 + do l=1,3 + uygrad(l,k,j,i)=uyder(l,k,j) + uzgrad(l,k,j,i)=uzder(l,k,j) + enddo + enddo + enddo + call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) + call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) + call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) + call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) + else +C Other residues +C Compute the Z-axis + call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i)) + costh=dcos(pi-theta(i+2)) + fac=1.0d0/dsqrt(1.0d0-costh*costh) + do k=1,3 + uz(k,i)=fac*uz(k,i) + enddo +C Compute the derivatives of uz + uzder(1,1,1)= 0.0d0 + uzder(2,1,1)=-dc_norm(3,i+1) + uzder(3,1,1)= dc_norm(2,i+1) + uzder(1,2,1)= dc_norm(3,i+1) + uzder(2,2,1)= 0.0d0 + uzder(3,2,1)=-dc_norm(1,i+1) + uzder(1,3,1)=-dc_norm(2,i+1) + uzder(2,3,1)= dc_norm(1,i+1) + uzder(3,3,1)= 0.0d0 + uzder(1,1,2)= 0.0d0 + uzder(2,1,2)= dc_norm(3,i) + uzder(3,1,2)=-dc_norm(2,i) + uzder(1,2,2)=-dc_norm(3,i) + uzder(2,2,2)= 0.0d0 + uzder(3,2,2)= dc_norm(1,i) + uzder(1,3,2)= dc_norm(2,i) + uzder(2,3,2)=-dc_norm(1,i) + uzder(3,3,2)= 0.0d0 +C Compute the Y-axis + facy=fac + do k=1,3 + uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i)) + enddo +C Compute the derivatives of uy + do j=1,3 + do k=1,3 + uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) + & -dc_norm(k,i)*dc_norm(j,i+1) + uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i) + enddo + uyder(j,j,1)=uyder(j,j,1)-costh + uyder(j,j,2)=1.0d0+uyder(j,j,2) + enddo + do j=1,2 + do k=1,3 + do l=1,3 + uygrad(l,k,j,i)=uyder(l,k,j) + uzgrad(l,k,j,i)=uzder(l,k,j) + enddo + enddo + enddo + call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i)) + call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i)) + call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i)) + call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i)) + endif + enddo + do i=1,nres-1 + vbld_inv_temp(1)=vbld_inv(i+1) + if (i.lt.nres-1) then + vbld_inv_temp(2)=vbld_inv(i+2) + else + vbld_inv_temp(2)=vbld_inv(i) + endif + do j=1,2 + do k=1,3 + do l=1,3 + uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i) + uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i) + enddo + enddo + enddo + enddo +#if defined(PARVEC) && defined(MPI) + if (nfgtasks1.gt.1) then + time00=MPI_Wtime() +c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start, +c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1), +c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1) + call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1), + & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ, + & FG_COMM1,IERR) + call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1), + & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ, + & FG_COMM1,IERR) + call MPI_Allgatherv(uygrad(1,1,1,ivec_start), + & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0), + & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR) + call MPI_Allgatherv(uzgrad(1,1,1,ivec_start), + & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0), + & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR) + time_gather=time_gather+MPI_Wtime()-time00 + endif +c if (fg_rank.eq.0) then +c write (iout,*) "Arrays UY and UZ" +c do i=1,nres-1 +c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3), +c & (uz(k,i),k=1,3) +c enddo +c endif +#endif + return + end +C----------------------------------------------------------------------------- + subroutine check_vecgrad + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.VECTORS' + dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres) + dimension uyt(3,maxres),uzt(3,maxres) + dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3) + double precision delta /1.0d-7/ + call vec_and_deriv +cd do i=1,nres +crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i) +crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i) +crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i) +cd write(iout,'(2i5,2(3f10.5,5x))') i,1, +cd & (dc_norm(if90,i),if90=1,3) +cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3) +cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3) +cd write(iout,'(a)') +cd enddo + do i=1,nres + do j=1,2 + do k=1,3 + do l=1,3 + uygradt(l,k,j,i)=uygrad(l,k,j,i) + uzgradt(l,k,j,i)=uzgrad(l,k,j,i) + enddo + enddo + enddo + enddo + call vec_and_deriv + do i=1,nres + do j=1,3 + uyt(j,i)=uy(j,i) + uzt(j,i)=uz(j,i) + enddo + enddo + do i=1,nres +cd write (iout,*) 'i=',i + do k=1,3 + erij(k)=dc_norm(k,i) + enddo + do j=1,3 + do k=1,3 + dc_norm(k,i)=erij(k) + enddo + dc_norm(j,i)=dc_norm(j,i)+delta +c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))) +c do k=1,3 +c dc_norm(k,i)=dc_norm(k,i)/fac +c enddo +c write (iout,*) (dc_norm(k,i),k=1,3) +c write (iout,*) (erij(k),k=1,3) + call vec_and_deriv + do k=1,3 + uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta + uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta + uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta + uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta + enddo +c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') +c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3), +c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3) + enddo + do k=1,3 + dc_norm(k,i)=erij(k) + enddo +cd do k=1,3 +cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') +cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3), +cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3) +cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') +cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3), +cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3) +cd write (iout,'(a)') +cd enddo + enddo + return + end +C-------------------------------------------------------------------------- + subroutine set_matrices + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + include "COMMON.SETUP" + integer IERR + integer status(MPI_STATUS_SIZE) +#endif + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + double precision auxvec(2),auxmat(2,2) +C +C Compute the virtual-bond-torsional-angle dependent quantities needed +C to calculate the el-loc multibody terms of various order. +C +#ifdef PARMAT + do i=ivec_start+2,ivec_end+2 +#else + do i=3,nres+1 +#endif + if (i .lt. nres+1) then + sin1=dsin(phi(i)) + cos1=dcos(phi(i)) + sintab(i-2)=sin1 + costab(i-2)=cos1 + obrot(1,i-2)=cos1 + obrot(2,i-2)=sin1 + sin2=dsin(2*phi(i)) + cos2=dcos(2*phi(i)) + sintab2(i-2)=sin2 + costab2(i-2)=cos2 + obrot2(1,i-2)=cos2 + obrot2(2,i-2)=sin2 + Ug(1,1,i-2)=-cos1 + Ug(1,2,i-2)=-sin1 + Ug(2,1,i-2)=-sin1 + Ug(2,2,i-2)= cos1 + Ug2(1,1,i-2)=-cos2 + Ug2(1,2,i-2)=-sin2 + Ug2(2,1,i-2)=-sin2 + Ug2(2,2,i-2)= cos2 + else + costab(i-2)=1.0d0 + sintab(i-2)=0.0d0 + obrot(1,i-2)=1.0d0 + obrot(2,i-2)=0.0d0 + obrot2(1,i-2)=0.0d0 + obrot2(2,i-2)=0.0d0 + Ug(1,1,i-2)=1.0d0 + Ug(1,2,i-2)=0.0d0 + Ug(2,1,i-2)=0.0d0 + Ug(2,2,i-2)=1.0d0 + Ug2(1,1,i-2)=0.0d0 + Ug2(1,2,i-2)=0.0d0 + Ug2(2,1,i-2)=0.0d0 + Ug2(2,2,i-2)=0.0d0 + endif + if (i .gt. 3 .and. i .lt. nres+1) then + obrot_der(1,i-2)=-sin1 + obrot_der(2,i-2)= cos1 + Ugder(1,1,i-2)= sin1 + Ugder(1,2,i-2)=-cos1 + Ugder(2,1,i-2)=-cos1 + Ugder(2,2,i-2)=-sin1 + dwacos2=cos2+cos2 + dwasin2=sin2+sin2 + obrot2_der(1,i-2)=-dwasin2 + obrot2_der(2,i-2)= dwacos2 + Ug2der(1,1,i-2)= dwasin2 + Ug2der(1,2,i-2)=-dwacos2 + Ug2der(2,1,i-2)=-dwacos2 + Ug2der(2,2,i-2)=-dwasin2 + else + obrot_der(1,i-2)=0.0d0 + obrot_der(2,i-2)=0.0d0 + Ugder(1,1,i-2)=0.0d0 + Ugder(1,2,i-2)=0.0d0 + Ugder(2,1,i-2)=0.0d0 + Ugder(2,2,i-2)=0.0d0 + obrot2_der(1,i-2)=0.0d0 + obrot2_der(2,i-2)=0.0d0 + Ug2der(1,1,i-2)=0.0d0 + Ug2der(1,2,i-2)=0.0d0 + Ug2der(2,1,i-2)=0.0d0 + Ug2der(2,2,i-2)=0.0d0 + endif +c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then + if (i.gt. nnt+2 .and. i.lt.nct+2) then + iti = itortyp(itype(i-2)) + else + iti=ntortyp+1 + endif +c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then + if (i.gt. nnt+1 .and. i.lt.nct+1) then + iti1 = itortyp(itype(i-1)) + else + iti1=ntortyp+1 + endif +cd write (iout,*) '*******i',i,' iti1',iti +cd write (iout,*) 'b1',b1(:,iti) +cd write (iout,*) 'b2',b2(:,iti) +cd write (iout,*) 'Ug',Ug(:,:,i-2) +c if (i .gt. iatel_s+2) then + if (i .gt. nnt+2) then + call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2)) + call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2)) + if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) + & then + call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2)) + call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2)) + call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2)) + call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2)) + call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2)) + endif + else + do k=1,2 + Ub2(k,i-2)=0.0d0 + Ctobr(k,i-2)=0.0d0 + Dtobr2(k,i-2)=0.0d0 + do l=1,2 + EUg(l,k,i-2)=0.0d0 + CUg(l,k,i-2)=0.0d0 + DUg(l,k,i-2)=0.0d0 + DtUg2(l,k,i-2)=0.0d0 + enddo + enddo + endif + call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2)) + call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2)) + do k=1,2 + muder(k,i-2)=Ub2der(k,i-2) + enddo +c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then + if (i.gt. nnt+1 .and. i.lt.nct+1) then + iti1 = itortyp(itype(i-1)) + else + iti1=ntortyp+1 + endif + do k=1,2 + mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1) + enddo +cd write (iout,*) 'mu ',mu(:,i-2) +cd write (iout,*) 'mu1',mu1(:,i-2) +cd write (iout,*) 'mu2',mu2(:,i-2) + if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) + & then + call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2)) + call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2)) + call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2)) + call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2)) + call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2)) +C Vectors and matrices dependent on a single virtual-bond dihedral. + call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1)) + call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2)) + call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2)) + call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2)) + call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2)) + call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2)) + call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2)) + call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2)) + call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2)) + endif + enddo +C Matrices dependent on two consecutive virtual-bond dihedrals. +C The order of matrices is from left to right. + if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) + &then +c do i=max0(ivec_start,2),ivec_end + do i=2,nres-1 + call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i)) + call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i)) + call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i)) + call transpose2(DtUg2(1,1,i-1),auxmat(1,1)) + call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i)) + call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i)) + call transpose2(DtUg2der(1,1,i-1),auxmat(1,1)) + call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i)) + enddo + endif +#if defined(MPI) && defined(PARMAT) +#ifdef DEBUG +c if (fg_rank.eq.0) then + write (iout,*) "Arrays UG and UGDER before GATHER" + do i=1,nres-1 + write (iout,'(i5,4f10.5,5x,4f10.5)') i, + & ((ug(l,k,i),l=1,2),k=1,2), + & ((ugder(l,k,i),l=1,2),k=1,2) + enddo + write (iout,*) "Arrays UG2 and UG2DER" + do i=1,nres-1 + write (iout,'(i5,4f10.5,5x,4f10.5)') i, + & ((ug2(l,k,i),l=1,2),k=1,2), + & ((ug2der(l,k,i),l=1,2),k=1,2) + enddo + write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER" + do i=1,nres-1 + write (iout,'(i5,4f10.5,5x,4f10.5)') i, + & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2), + & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2) + enddo + write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2" + do i=1,nres-1 + write (iout,'(i5,4f10.5,5x,4f10.5)') i, + & costab(i),sintab(i),costab2(i),sintab2(i) + enddo + write (iout,*) "Array MUDER" + do i=1,nres-1 + write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i) + enddo +c endif +#endif + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start, +c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1), +c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1) +#ifdef MATGATHER + call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1), + & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1), + & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1), + & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1), + & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1), + & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1), + & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1), + & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0), + & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) + call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1), + & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0), + & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) + call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1), + & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0), + & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) + call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1), + & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0), + & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) + if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) + & then + call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1), + & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1), + & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1), + & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1), + & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1), + & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(Ug2Db1tder(1,ivec_start), + & ivec_count(fg_rank1), + & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1), + & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1), + & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU, + & FG_COMM1,IERR) + call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1), + & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1), + & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1), + & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1), + & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1), + & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(Dtug2der(1,1,ivec_start), + & ivec_count(fg_rank1), + & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1), + & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1), + & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1), + & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1), + & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start), + & ivec_count(fg_rank1), + & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start), + & ivec_count(fg_rank1), + & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1, + & FG_COMM1,IERR) + call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start), + & ivec_count(fg_rank1), + & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0), + & MPI_MAT2,FG_COMM1,IERR) + call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start), + & ivec_count(fg_rank1), + & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0), + & MPI_MAT2,FG_COMM1,IERR) + endif +#else +c Passes matrix info through the ring + isend=fg_rank1 + irecv=fg_rank1-1 + if (irecv.lt.0) irecv=nfgtasks1-1 + iprev=irecv + inext=fg_rank1+1 + if (inext.ge.nfgtasks1) inext=0 + do i=1,nfgtasks1-1 +c write (iout,*) "isend",isend," irecv",irecv +c call flush(iout) + lensend=lentyp(isend) + lenrecv=lentyp(irecv) +c write (iout,*) "lensend",lensend," lenrecv",lenrecv +c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1, +c & MPI_ROTAT1(lensend),inext,2200+isend, +c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv), +c & iprev,2200+irecv,FG_COMM,status,IERR) +c write (iout,*) "Gather ROTAT1" +c call flush(iout) +c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1, +c & MPI_ROTAT2(lensend),inext,3300+isend, +c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv), +c & iprev,3300+irecv,FG_COMM,status,IERR) +c write (iout,*) "Gather ROTAT2" +c call flush(iout) + call MPI_SENDRECV(costab(ivec_displ(isend)+1),1, + & MPI_ROTAT_OLD(lensend),inext,4400+isend, + & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv), + & iprev,4400+irecv,FG_COMM,status,IERR) +c write (iout,*) "Gather ROTAT_OLD" +c call flush(iout) + call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1, + & MPI_PRECOMP11(lensend),inext,5500+isend, + & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv), + & iprev,5500+irecv,FG_COMM,status,IERR) +c write (iout,*) "Gather PRECOMP11" +c call flush(iout) + call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1, + & MPI_PRECOMP12(lensend),inext,6600+isend, + & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv), + & iprev,6600+irecv,FG_COMM,status,IERR) +c write (iout,*) "Gather PRECOMP12" +c call flush(iout) + if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) + & then + call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1, + & MPI_ROTAT2(lensend),inext,7700+isend, + & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv), + & iprev,7700+irecv,FG_COMM,status,IERR) +c write (iout,*) "Gather PRECOMP21" +c call flush(iout) + call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1, + & MPI_PRECOMP22(lensend),inext,8800+isend, + & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv), + & iprev,8800+irecv,FG_COMM,status,IERR) +c write (iout,*) "Gather PRECOMP22" +c call flush(iout) + call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1, + & MPI_PRECOMP23(lensend),inext,9900+isend, + & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1, + & MPI_PRECOMP23(lenrecv), + & iprev,9900+irecv,FG_COMM,status,IERR) +c write (iout,*) "Gather PRECOMP23" +c call flush(iout) + endif + isend=irecv + irecv=irecv-1 + if (irecv.lt.0) irecv=nfgtasks1-1 + enddo +#endif + time_gather=time_gather+MPI_Wtime()-time00 + endif +#ifdef DEBUG +c if (fg_rank.eq.0) then + write (iout,*) "Arrays UG and UGDER" + do i=1,nres-1 + write (iout,'(i5,4f10.5,5x,4f10.5)') i, + & ((ug(l,k,i),l=1,2),k=1,2), + & ((ugder(l,k,i),l=1,2),k=1,2) + enddo + write (iout,*) "Arrays UG2 and UG2DER" + do i=1,nres-1 + write (iout,'(i5,4f10.5,5x,4f10.5)') i, + & ((ug2(l,k,i),l=1,2),k=1,2), + & ((ug2der(l,k,i),l=1,2),k=1,2) + enddo + write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER" + do i=1,nres-1 + write (iout,'(i5,4f10.5,5x,4f10.5)') i, + & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2), + & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2) + enddo + write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2" + do i=1,nres-1 + write (iout,'(i5,4f10.5,5x,4f10.5)') i, + & costab(i),sintab(i),costab2(i),sintab2(i) + enddo + write (iout,*) "Array MUDER" + do i=1,nres-1 + write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i) + enddo +c endif +#endif +#endif +cd do i=1,nres +cd iti = itortyp(itype(i)) +cd write (iout,*) i +cd do j=1,2 +cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)') +cd & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2) +cd enddo +cd enddo + return + end +C-------------------------------------------------------------------------- + subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) +C +C This subroutine calculates the average interaction energy and its gradient +C in the virtual-bond vectors between non-adjacent peptide groups, based on +C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. +C The potential depends both on the distance of peptide-group centers and on +C the orientation of the CA-CA virtual bonds. +C + implicit real*8 (a-h,o-z) +#ifdef MPI + include 'mpif.h' +#endif + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + include 'COMMON.TIME1' + dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), + & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) + double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), + & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) + common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, + & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, + & num_conti,j1,j2 +c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions +#ifdef MOMENT + double precision scal_el /1.0d0/ +#else + double precision scal_el /0.5d0/ +#endif +C 12/13/98 +C 13-go grudnia roku pamietnego... + double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, + & 0.0d0,1.0d0,0.0d0, + & 0.0d0,0.0d0,1.0d0/ +cd write(iout,*) 'In EELEC' +cd do i=1,nloctyp +cd write(iout,*) 'Type',i +cd write(iout,*) 'B1',B1(:,i) +cd write(iout,*) 'B2',B2(:,i) +cd write(iout,*) 'CC',CC(:,:,i) +cd write(iout,*) 'DD',DD(:,:,i) +cd write(iout,*) 'EE',EE(:,:,i) +cd enddo +cd call check_vecgrad +cd stop + if (icheckgrad.eq.1) then + do i=1,nres-1 + fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) + do k=1,3 + dc_norm(k,i)=dc(k,i)*fac + enddo +c write (iout,*) 'i',i,' fac',fac + enddo + endif + if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 + & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. + & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then +c call vec_and_deriv +#ifdef TIMING + time01=MPI_Wtime() +#endif + call set_matrices +#ifdef TIMING + time_mat=time_mat+MPI_Wtime()-time01 +#endif + endif +cd do i=1,nres-1 +cd write (iout,*) 'i=',i +cd do k=1,3 +cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) +cd enddo +cd do k=1,3 +cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') +cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) +cd enddo +cd enddo + t_eelecij=0.0d0 + ees=0.0D0 + evdw1=0.0D0 + eel_loc=0.0d0 + eello_turn3=0.0d0 + eello_turn4=0.0d0 + ind=0 + do i=1,nres + num_cont_hb(i)=0 + enddo +cd print '(a)','Enter EELEC' +cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e + do i=1,nres + gel_loc_loc(i)=0.0d0 + gcorr_loc(i)=0.0d0 + enddo +c +c +c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms +C +C Loop over i,i+2 and i,i+3 pairs of the peptide groups +C + do i=iturn3_start,iturn3_end + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi + num_conti=0 + call eelecij(i,i+2,ees,evdw1,eel_loc) + if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) + num_cont_hb(i)=num_conti + enddo + do i=iturn4_start,iturn4_end + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi + num_conti=num_cont_hb(i) + call eelecij(i,i+3,ees,evdw1,eel_loc) + if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4) + num_cont_hb(i)=num_conti + enddo ! i +c +c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 +c + do i=iatel_s,iatel_e + dxi=dc(1,i) + dyi=dc(2,i) + dzi=dc(3,i) + dx_normi=dc_norm(1,i) + dy_normi=dc_norm(2,i) + dz_normi=dc_norm(3,i) + xmedi=c(1,i)+0.5d0*dxi + ymedi=c(2,i)+0.5d0*dyi + zmedi=c(3,i)+0.5d0*dzi +c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) + num_conti=num_cont_hb(i) + do j=ielstart(i),ielend(i) + call eelecij(i,j,ees,evdw1,eel_loc) + enddo ! j + num_cont_hb(i)=num_conti + enddo ! i +c write (iout,*) "Number of loop steps in EELEC:",ind +cd do i=1,nres +cd write (iout,'(i3,3f10.5,5x,3f10.5)') +cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) +cd enddo +c 12/7/99 Adam eello_turn3 will be considered as a separate energy term +ccc eel_loc=eel_loc+eello_turn3 +cd print *,"Processor",fg_rank," t_eelecij",t_eelecij + return + end +C------------------------------------------------------------------------------- + subroutine eelecij(i,j,ees,evdw1,eel_loc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + include 'COMMON.TIME1' + dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), + & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) + double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), + & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4) + common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, + & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, + & num_conti,j1,j2 +c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions +#ifdef MOMENT + double precision scal_el /1.0d0/ +#else + double precision scal_el /0.5d0/ +#endif +C 12/13/98 +C 13-go grudnia roku pamietnego... + double precision unmat(3,3) /1.0d0,0.0d0,0.0d0, + & 0.0d0,1.0d0,0.0d0, + & 0.0d0,0.0d0,1.0d0/ +c time00=MPI_Wtime() +cd write (iout,*) "eelecij",i,j +c ind=ind+1 + iteli=itel(i) + itelj=itel(j) + if (j.eq.i+2 .and. itelj.eq.2) iteli=2 + aaa=app(iteli,itelj) + bbb=bpp(iteli,itelj) + ael6i=ael6(iteli,itelj) + ael3i=ael3(iteli,itelj) + dxj=dc(1,j) + dyj=dc(2,j) + dzj=dc(3,j) + dx_normj=dc_norm(1,j) + dy_normj=dc_norm(2,j) + dz_normj=dc_norm(3,j) + xj=c(1,j)+0.5D0*dxj-xmedi + yj=c(2,j)+0.5D0*dyj-ymedi + zj=c(3,j)+0.5D0*dzj-zmedi + rij=xj*xj+yj*yj+zj*zj + rrmij=1.0D0/rij + rij=dsqrt(rij) + rmij=1.0D0/rij + r3ij=rrmij*rmij + r6ij=r3ij*r3ij + cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj + cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij + cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij + fac=cosa-3.0D0*cosb*cosg + ev1=aaa*r6ij*r6ij +c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions + if (j.eq.i+2) ev1=scal_el*ev1 + ev2=bbb*r6ij + fac3=ael6i*r6ij + fac4=ael3i*r3ij + evdwij=ev1+ev2 + el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) + el2=fac4*fac + eesij=el1+el2 +C 12/26/95 - for the evaluation of multi-body H-bonding interactions + ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) + ees=ees+eesij + evdw1=evdw1+evdwij +cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, +cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, +cd & xmedi,ymedi,zmedi,xj,yj,zj + + if (energy_dec) then + write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij + write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij + endif + +C +C Calculate contributions to the Cartesian gradient. +C +#ifdef SPLITELE + facvdw=-6*rrmij*(ev1+evdwij) + facel=-3*rrmij*(el1+eesij) + fac1=fac + erij(1)=xj*rmij + erij(2)=yj*rmij + erij(3)=zj*rmij +* +* Radial derivatives. First process both termini of the fragment (i,j) +* + ggg(1)=facel*xj + ggg(2)=facel*yj + ggg(3)=facel*zj +c do k=1,3 +c ghalf=0.5D0*ggg(k) +c gelc(k,i)=gelc(k,i)+ghalf +c gelc(k,j)=gelc(k,j)+ghalf +c enddo +c 9/28/08 AL Gradient compotents will be summed only at the end + do k=1,3 + gelc_long(k,j)=gelc_long(k,j)+ggg(k) + gelc_long(k,i)=gelc_long(k,i)-ggg(k) + enddo +* +* Loop over residues i+1 thru j-1. +* +cgrad do k=i+1,j-1 +cgrad do l=1,3 +cgrad gelc(l,k)=gelc(l,k)+ggg(l) +cgrad enddo +cgrad enddo + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj +c do k=1,3 +c ghalf=0.5D0*ggg(k) +c gvdwpp(k,i)=gvdwpp(k,i)+ghalf +c gvdwpp(k,j)=gvdwpp(k,j)+ghalf +c enddo +c 9/28/08 AL Gradient compotents will be summed only at the end + do k=1,3 + gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) + gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + enddo +* +* Loop over residues i+1 thru j-1. +* +cgrad do k=i+1,j-1 +cgrad do l=1,3 +cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) +cgrad enddo +cgrad enddo +#else + facvdw=ev1+evdwij + facel=el1+eesij + fac1=fac + fac=-3*rrmij*(facvdw+facvdw+facel) + erij(1)=xj*rmij + erij(2)=yj*rmij + erij(3)=zj*rmij +* +* Radial derivatives. First process both termini of the fragment (i,j) +* + ggg(1)=fac*xj + ggg(2)=fac*yj + ggg(3)=fac*zj +c do k=1,3 +c ghalf=0.5D0*ggg(k) +c gelc(k,i)=gelc(k,i)+ghalf +c gelc(k,j)=gelc(k,j)+ghalf +c enddo +c 9/28/08 AL Gradient compotents will be summed only at the end + do k=1,3 + gelc_long(k,j)=gelc(k,j)+ggg(k) + gelc_long(k,i)=gelc(k,i)-ggg(k) + enddo +* +* Loop over residues i+1 thru j-1. +* +cgrad do k=i+1,j-1 +cgrad do l=1,3 +cgrad gelc(l,k)=gelc(l,k)+ggg(l) +cgrad enddo +cgrad enddo +c 9/28/08 AL Gradient compotents will be summed only at the end + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj + do k=1,3 + gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) + gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + enddo +#endif +* +* Angular part +* + ecosa=2.0D0*fac3*fac1+fac4 + fac4=-3.0D0*fac4 + fac3=-6.0D0*fac3 + ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) + ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) + do k=1,3 + dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) + dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) + enddo +cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), +cd & (dcosg(k),k=1,3) + do k=1,3 + ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) + enddo +c do k=1,3 +c ghalf=0.5D0*ggg(k) +c gelc(k,i)=gelc(k,i)+ghalf +c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) +c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) +c gelc(k,j)=gelc(k,j)+ghalf +c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) +c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) +c enddo +cgrad do k=i+1,j-1 +cgrad do l=1,3 +cgrad gelc(l,k)=gelc(l,k)+ggg(l) +cgrad enddo +cgrad enddo + do k=1,3 + gelc(k,i)=gelc(k,i) + & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gelc(k,j)=gelc(k,j) + & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + gelc_long(k,j)=gelc_long(k,j)+ggg(k) + gelc_long(k,i)=gelc_long(k,i)-ggg(k) + enddo + IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 + & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 + & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN +C +C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction +C energy of a peptide unit is assumed in the form of a second-order +C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. +C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms +C are computed for EVERY pair of non-contiguous peptide groups. +C + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + kkk=0 + do k=1,2 + do l=1,2 + kkk=kkk+1 + muij(kkk)=mu(k,i)*mu(l,j) + enddo + enddo +cd write (iout,*) 'EELEC: i',i,' j',j +cd write (iout,*) 'j',j,' j1',j1,' j2',j2 +cd write(iout,*) 'muij',muij + ury=scalar(uy(1,i),erij) + urz=scalar(uz(1,i),erij) + vry=scalar(uy(1,j),erij) + vrz=scalar(uz(1,j),erij) + a22=scalar(uy(1,i),uy(1,j))-3*ury*vry + a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz + a32=scalar(uz(1,i),uy(1,j))-3*urz*vry + a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz + fac=dsqrt(-ael6i)*r3ij + a22=a22*fac + a23=a23*fac + a32=a32*fac + a33=a33*fac +cd write (iout,'(4i5,4f10.5)') +cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 +cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij +cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i), +cd & uy(:,j),uz(:,j) +cd write (iout,'(4f10.5)') +cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), +cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) +cd write (iout,'(4f10.5)') ury,urz,vry,vrz +cd write (iout,'(9f10.5/)') +cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij +C Derivatives of the elements of A in virtual-bond vectors + call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) + do k=1,3 + uryg(k,1)=scalar(erder(1,k),uy(1,i)) + uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) + uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) + urzg(k,1)=scalar(erder(1,k),uz(1,i)) + urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) + urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) + vryg(k,1)=scalar(erder(1,k),uy(1,j)) + vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) + vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) + vrzg(k,1)=scalar(erder(1,k),uz(1,j)) + vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) + vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) + enddo +C Compute radial contributions to the gradient + facr=-3.0d0*rrmij + a22der=a22*facr + a23der=a23*facr + a32der=a32*facr + a33der=a33*facr + agg(1,1)=a22der*xj + agg(2,1)=a22der*yj + agg(3,1)=a22der*zj + agg(1,2)=a23der*xj + agg(2,2)=a23der*yj + agg(3,2)=a23der*zj + agg(1,3)=a32der*xj + agg(2,3)=a32der*yj + agg(3,3)=a32der*zj + agg(1,4)=a33der*xj + agg(2,4)=a33der*yj + agg(3,4)=a33der*zj +C Add the contributions coming from er + fac3=-3.0d0*fac + do k=1,3 + agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) + agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) + agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) + agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) + enddo + do k=1,3 +C Derivatives in DC(i) +cgrad ghalf1=0.5d0*agg(k,1) +cgrad ghalf2=0.5d0*agg(k,2) +cgrad ghalf3=0.5d0*agg(k,3) +cgrad ghalf4=0.5d0*agg(k,4) + aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) + & -3.0d0*uryg(k,2)*vry)!+ghalf1 + aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) + & -3.0d0*uryg(k,2)*vrz)!+ghalf2 + aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) + & -3.0d0*urzg(k,2)*vry)!+ghalf3 + aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) + & -3.0d0*urzg(k,2)*vrz)!+ghalf4 +C Derivatives in DC(i+1) + aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) + & -3.0d0*uryg(k,3)*vry)!+agg(k,1) + aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) + & -3.0d0*uryg(k,3)*vrz)!+agg(k,2) + aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) + & -3.0d0*urzg(k,3)*vry)!+agg(k,3) + aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) + & -3.0d0*urzg(k,3)*vrz)!+agg(k,4) +C Derivatives in DC(j) + aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) + & -3.0d0*vryg(k,2)*ury)!+ghalf1 + aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) + & -3.0d0*vrzg(k,2)*ury)!+ghalf2 + aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) + & -3.0d0*vryg(k,2)*urz)!+ghalf3 + aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) + & -3.0d0*vrzg(k,2)*urz)!+ghalf4 +C Derivatives in DC(j+1) or DC(nres-1) + aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) + & -3.0d0*vryg(k,3)*ury) + aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) + & -3.0d0*vrzg(k,3)*ury) + aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) + & -3.0d0*vryg(k,3)*urz) + aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) + & -3.0d0*vrzg(k,3)*urz) +cgrad if (j.eq.nres-1 .and. i.lt.j-2) then +cgrad do l=1,4 +cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l) +cgrad enddo +cgrad endif + enddo + acipa(1,1)=a22 + acipa(1,2)=a23 + acipa(2,1)=a32 + acipa(2,2)=a33 + a22=-a22 + a23=-a23 + do l=1,2 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + if (j.lt.nres-1) then + a22=-a22 + a32=-a32 + do l=1,3,2 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + else + a22=-a22 + a23=-a23 + a32=-a32 + a33=-a33 + do l=1,4 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) + enddo + enddo + endif + ENDIF ! WCORR + IF (wel_loc.gt.0.0d0) THEN +C Contribution to the local-electrostatic energy coming from the i-j pair + eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) + & +a33*muij(4) +cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij + + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'eelloc',i,j,eel_loc_ij + + eel_loc=eel_loc+eel_loc_ij +C Partial derivatives in virtual-bond dihedral angles gamma + if (i.gt.1) + & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ + & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) + & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) + gel_loc_loc(j-1)=gel_loc_loc(j-1)+ + & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) + & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) +C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) + do l=1,3 + ggg(l)=agg(l,1)*muij(1)+ + & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4) + gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) + gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) +cgrad ghalf=0.5d0*ggg(l) +cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf +cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf + enddo +cgrad do k=i+1,j2 +cgrad do l=1,3 +cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l) +cgrad enddo +cgrad enddo +C Remaining derivatives of eello + do l=1,3 + gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ + & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) + gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ + & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) + gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ + & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) + gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ + & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) + enddo + ENDIF +C Change 12/26/95 to calculate four-body contributions to H-bonding energy +c if (j.gt.i+1 .and. num_conti.le.maxconts) then + if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 + & .and. num_conti.le.maxconts) then +c write (iout,*) i,j," entered corr" +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +c r0ij=1.02D0*rpp(iteli,itelj) +c r0ij=1.11D0*rpp(iteli,itelj) + r0ij=2.20D0*rpp(iteli,itelj) +c r0ij=1.55D0*rpp(iteli,itelj) + call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) + if (fcont.gt.0.0D0) then + num_conti=num_conti+1 + if (num_conti.gt.maxconts) then + write (iout,*) 'WARNING - max. # of contacts exceeded;', + & ' will skip next contacts for this conf.' + else + jcont_hb(num_conti,i)=j +cd write (iout,*) "i",i," j",j," num_conti",num_conti, +cd & " jcont_hb",jcont_hb(num_conti,i) + IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. + & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN +C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el +C terms. + d_cont(num_conti,i)=rij +cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij +C --- Electrostatic-interaction matrix --- + a_chuj(1,1,num_conti,i)=a22 + a_chuj(1,2,num_conti,i)=a23 + a_chuj(2,1,num_conti,i)=a32 + a_chuj(2,2,num_conti,i)=a33 +C --- Gradient of rij + do kkk=1,3 + grij_hb_cont(kkk,num_conti,i)=erij(kkk) + enddo + kkll=0 + do k=1,2 + do l=1,2 + kkll=kkll+1 + do m=1,3 + a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) + a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) + a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) + a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) + a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) + enddo + enddo + enddo + ENDIF + IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN +C Calculate contact energies + cosa4=4.0D0*cosa + wij=cosa-3.0D0*cosb*cosg + cosbg1=cosb+cosg + cosbg2=cosb-cosg +c fac3=dsqrt(-ael6i)/r0ij**3 + fac3=dsqrt(-ael6i)*r3ij +c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) + ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 + if (ees0tmp.gt.0) then + ees0pij=dsqrt(ees0tmp) + else + ees0pij=0 + endif +c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) + ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 + if (ees0tmp.gt.0) then + ees0mij=dsqrt(ees0tmp) + else + ees0mij=0 + endif +c ees0mij=0.0D0 + ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) + ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) +C Diagnostics. Comment out or remove after debugging! +c ees0p(num_conti,i)=0.5D0*fac3*ees0pij +c ees0m(num_conti,i)=0.5D0*fac3*ees0mij +c ees0m(num_conti,i)=0.0D0 +C End diagnostics. +c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, +c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont +C Angular derivatives of the contact function + ees0pij1=fac3/ees0pij + ees0mij1=fac3/ees0mij + fac3p=-3.0D0*fac3*rrmij + ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) + ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) +c ees0mij1=0.0D0 + ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) + ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) + ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) + ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) + ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) + ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) + ecosap=ecosa1+ecosa2 + ecosbp=ecosb1+ecosb2 + ecosgp=ecosg1+ecosg2 + ecosam=ecosa1-ecosa2 + ecosbm=ecosb1-ecosb2 + ecosgm=ecosg1-ecosg2 +C Diagnostics +c ecosap=ecosa1 +c ecosbp=ecosb1 +c ecosgp=ecosg1 +c ecosam=0.0D0 +c ecosbm=0.0D0 +c ecosgm=0.0D0 +C End diagnostics + facont_hb(num_conti,i)=fcont + fprimcont=fprimcont/rij +cd facont_hb(num_conti,i)=1.0D0 +C Following line is for diagnostics. +cd fprimcont=0.0D0 + do k=1,3 + dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) + dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) + enddo + do k=1,3 + gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) + gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) + enddo + gggp(1)=gggp(1)+ees0pijp*xj + gggp(2)=gggp(2)+ees0pijp*yj + gggp(3)=gggp(3)+ees0pijp*zj + gggm(1)=gggm(1)+ees0mijp*xj + gggm(2)=gggm(2)+ees0mijp*yj + gggm(3)=gggm(3)+ees0mijp*zj +C Derivatives due to the contact function + gacont_hbr(1,num_conti,i)=fprimcont*xj + gacont_hbr(2,num_conti,i)=fprimcont*yj + gacont_hbr(3,num_conti,i)=fprimcont*zj + do k=1,3 +c +c 10/24/08 cgrad and ! comments indicate the parts of the code removed +c following the change of gradient-summation algorithm. +c +cgrad ghalfp=0.5D0*gggp(k) +cgrad ghalfm=0.5D0*gggm(k) + gacontp_hb1(k,num_conti,i)=!ghalfp + & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gacontp_hb2(k,num_conti,i)=!ghalfp + & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + gacontp_hb3(k,num_conti,i)=gggp(k) + gacontm_hb1(k,num_conti,i)=!ghalfm + & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + gacontm_hb2(k,num_conti,i)=!ghalfm + & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + gacontm_hb3(k,num_conti,i)=gggm(k) + enddo +C Diagnostics. Comment out or remove after debugging! +cdiag do k=1,3 +cdiag gacontp_hb1(k,num_conti,i)=0.0D0 +cdiag gacontp_hb2(k,num_conti,i)=0.0D0 +cdiag gacontp_hb3(k,num_conti,i)=0.0D0 +cdiag gacontm_hb1(k,num_conti,i)=0.0D0 +cdiag gacontm_hb2(k,num_conti,i)=0.0D0 +cdiag gacontm_hb3(k,num_conti,i)=0.0D0 +cdiag enddo + ENDIF ! wcorr + endif ! num_conti.le.maxconts + endif ! fcont.gt.0 + endif ! j.gt.i+1 + if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then + do k=1,4 + do l=1,3 + ghalf=0.5d0*agg(l,k) + aggi(l,k)=aggi(l,k)+ghalf + aggi1(l,k)=aggi1(l,k)+agg(l,k) + aggj(l,k)=aggj(l,k)+ghalf + enddo + enddo + if (j.eq.nres-1 .and. i.lt.j-2) then + do k=1,4 + do l=1,3 + aggj1(l,k)=aggj1(l,k)+agg(l,k) + enddo + enddo + endif + endif +c t_eelecij=t_eelecij+MPI_Wtime()-time00 + return + end +C----------------------------------------------------------------------------- + subroutine eturn3(i,eello_turn3) +C Third- and fourth-order contributions from turns + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + dimension ggg(3) + double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2), + & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2), + & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2) + double precision agg(3,4),aggi(3,4),aggi1(3,4), + & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2) + common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, + & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, + & num_conti,j1,j2 + j=i+2 +c write (iout,*) "eturn3",i,j,j1,j2 + a_temp(1,1)=a22 + a_temp(1,2)=a23 + a_temp(2,1)=a32 + a_temp(2,2)=a33 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Third-order contributions +C +C (i+2)o----(i+3) +C | | +C | | +C (i+1)o----i +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd call checkint_turn3(i,a_temp,eello_turn3_num) + call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1)) + call transpose2(auxmat(1,1),auxmat1(1,1)) + call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2)) +cd write (2,*) 'i,',i,' j',j,'eello_turn3', +cd & 0.5d0*(pizda(1,1)+pizda(2,2)), +cd & ' eello_turn3_num',4*eello_turn3_num +C Derivatives in gamma(i) + call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1)) + call transpose2(auxmat2(1,1),auxmat3(1,1)) + call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1)) + gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2)) +C Derivatives in gamma(i+1) + call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1)) + call transpose2(auxmat2(1,1),auxmat3(1,1)) + call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1)) + gel_loc_turn3(i+1)=gel_loc_turn3(i+1) + & +0.5d0*(pizda(1,1)+pizda(2,2)) +C Cartesian derivatives + do l=1,3 +c ghalf1=0.5d0*agg(l,1) +c ghalf2=0.5d0*agg(l,2) +c ghalf3=0.5d0*agg(l,3) +c ghalf4=0.5d0*agg(l,4) + a_temp(1,1)=aggi(l,1)!+ghalf1 + a_temp(1,2)=aggi(l,2)!+ghalf2 + a_temp(2,1)=aggi(l,3)!+ghalf3 + a_temp(2,2)=aggi(l,4)!+ghalf4 + call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + gcorr3_turn(l,i)=gcorr3_turn(l,i) + & +0.5d0*(pizda(1,1)+pizda(2,2)) + a_temp(1,1)=aggi1(l,1)!+agg(l,1) + a_temp(1,2)=aggi1(l,2)!+agg(l,2) + a_temp(2,1)=aggi1(l,3)!+agg(l,3) + a_temp(2,2)=aggi1(l,4)!+agg(l,4) + call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) + & +0.5d0*(pizda(1,1)+pizda(2,2)) + a_temp(1,1)=aggj(l,1)!+ghalf1 + a_temp(1,2)=aggj(l,2)!+ghalf2 + a_temp(2,1)=aggj(l,3)!+ghalf3 + a_temp(2,2)=aggj(l,4)!+ghalf4 + call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + gcorr3_turn(l,j)=gcorr3_turn(l,j) + & +0.5d0*(pizda(1,1)+pizda(2,2)) + a_temp(1,1)=aggj1(l,1) + a_temp(1,2)=aggj1(l,2) + a_temp(2,1)=aggj1(l,3) + a_temp(2,2)=aggj1(l,4) + call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + gcorr3_turn(l,j1)=gcorr3_turn(l,j1) + & +0.5d0*(pizda(1,1)+pizda(2,2)) + enddo + return + end +C------------------------------------------------------------------------------- + subroutine eturn4(i,eello_turn4) +C Third- and fourth-order contributions from turns + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VECTORS' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + dimension ggg(3) + double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2), + & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2), + & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2) + double precision agg(3,4),aggi(3,4),aggi1(3,4), + & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2) + common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, + & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, + & num_conti,j1,j2 + j=i+3 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Fourth-order contributions +C +C (i+3)o----(i+4) +C / | +C (i+2)o | +C \ | +C (i+1)o----i +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd call checkint_turn4(i,a_temp,eello_turn4_num) +c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2 + a_temp(1,1)=a22 + a_temp(1,2)=a23 + a_temp(2,1)=a32 + a_temp(2,2)=a33 + iti1=itortyp(itype(i+1)) + iti2=itortyp(itype(i+2)) + iti3=itortyp(itype(i+3)) +c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3 + call transpose2(EUg(1,1,i+1),e1t(1,1)) + call transpose2(Eug(1,1,i+2),e2t(1,1)) + call transpose2(Eug(1,1,i+3),e3t(1,1)) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + eello_turn4=eello_turn4-(s1+s2+s3) + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'eturn4',i,j,-(s1+s2+s3) +cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3), +cd & ' eello_turn4_num',8*eello_turn4_num +C Derivatives in gamma(i) + call transpose2(EUgder(1,1,i+1),e1tder(1,1)) + call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) +C Derivatives in gamma(i+1) + call transpose2(EUgder(1,1,i+2),e2tder(1,1)) + call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1)) + call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) +C Derivatives in gamma(i+2) + call transpose2(EUgder(1,1,i+3),e3tder(1,1)) + call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1)) + call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) +C Cartesian derivatives +C Derivatives of this turn contributions in DC(i+2) + if (j.lt.nres-1) then + do l=1,3 + a_temp(1,1)=agg(l,1) + a_temp(1,2)=agg(l,2) + a_temp(2,1)=agg(l,3) + a_temp(2,2)=agg(l,4) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + ggg(l)=-(s1+s2+s3) + gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3) + enddo + endif +C Remaining derivatives of this turn contribution + do l=1,3 + a_temp(1,1)=aggi(l,1) + a_temp(1,2)=aggi(l,2) + a_temp(2,1)=aggi(l,3) + a_temp(2,2)=aggi(l,4) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) + a_temp(1,1)=aggi1(l,1) + a_temp(1,2)=aggi1(l,2) + a_temp(2,1)=aggi1(l,3) + a_temp(2,2)=aggi1(l,4) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) + a_temp(1,1)=aggj(l,1) + a_temp(1,2)=aggj(l,2) + a_temp(2,1)=aggj(l,3) + a_temp(2,2)=aggj(l,4) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) + a_temp(1,1)=aggj1(l,1) + a_temp(1,2)=aggj1(l,2) + a_temp(2,1)=aggj1(l,3) + a_temp(2,2)=aggj1(l,4) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) + call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + s1=scalar2(b1(1,iti2),auxvec(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) + s2=scalar2(b1(1,iti1),auxvec(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) +c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3 + gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) + enddo + return + end +C----------------------------------------------------------------------------- + subroutine vecpr(u,v,w) + implicit real*8(a-h,o-z) + dimension u(3),v(3),w(3) + w(1)=u(2)*v(3)-u(3)*v(2) + w(2)=-u(1)*v(3)+u(3)*v(1) + w(3)=u(1)*v(2)-u(2)*v(1) + return + end +C----------------------------------------------------------------------------- + subroutine unormderiv(u,ugrad,unorm,ungrad) +C This subroutine computes the derivatives of a normalized vector u, given +C the derivatives computed without normalization conditions, ugrad. Returns +C ungrad. + implicit none + double precision u(3),ugrad(3,3),unorm,ungrad(3,3) + double precision vec(3) + double precision scalar + integer i,j +c write (2,*) 'ugrad',ugrad +c write (2,*) 'u',u + do i=1,3 + vec(i)=scalar(ugrad(1,i),u(1)) + enddo +c write (2,*) 'vec',vec + do i=1,3 + do j=1,3 + ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm + enddo + enddo +c write (2,*) 'ungrad',ungrad + return + end +C----------------------------------------------------------------------------- + subroutine escp_soft_sphere(evdw2,evdw2_14) +C +C This subroutine calculates the excluded-volume interaction energy between +C peptide-group centers and side chains and its gradient in virtual-bond and +C side-chain vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + dimension ggg(3) + evdw2=0.0D0 + evdw2_14=0.0d0 + r0_scp=4.5d0 +cd print '(a)','Enter ESCP' +cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e + do i=iatscp_s,iatscp_e + iteli=itel(i) + xi=0.5D0*(c(1,i)+c(1,i+1)) + yi=0.5D0*(c(2,i)+c(2,i+1)) + zi=0.5D0*(c(3,i)+c(3,i+1)) + + do iint=1,nscp_gr(i) + + do j=iscpstart(i,iint),iscpend(i,iint) + itypj=itype(j) +C Uncomment following three lines for SC-p interactions +c xj=c(1,nres+j)-xi +c yj=c(2,nres+j)-yi +c zj=c(3,nres+j)-zi +C Uncomment following three lines for Ca-p interactions + xj=c(1,j)-xi + yj=c(2,j)-yi + zj=c(3,j)-zi + rij=xj*xj+yj*yj+zj*zj + r0ij=r0_scp + r0ijsq=r0ij*r0ij + if (rij.lt.r0ijsq) then + evdwij=0.25d0*(rij-r0ijsq)**2 + fac=rij-r0ijsq + else + evdwij=0.0d0 + fac=0.0d0 + endif + evdw2=evdw2+evdwij +C +C Calculate contributions to the gradient in the virtual-bond and SC vectors. +C + ggg(1)=xj*fac + ggg(2)=yj*fac + ggg(3)=zj*fac +cgrad if (j.lt.i) then +cd write (iout,*) 'ji' +cgrad do k=1,3 +cgrad ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) +cgrad enddo +cgrad endif +cgrad do k=1,3 +cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) +cgrad enddo +cgrad kstart=min0(i+1,j) +cgrad kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) +cgrad do k=kstart,kend +cgrad do l=1,3 +cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) +cgrad enddo +cgrad enddo + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo + enddo + + enddo ! iint + enddo ! i + return + end +C----------------------------------------------------------------------------- + subroutine escp(evdw2,evdw2_14) +C +C This subroutine calculates the excluded-volume interaction energy between +C peptide-group centers and side chains and its gradient in virtual-bond and +C side-chain vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + dimension ggg(3) + evdw2=0.0D0 + evdw2_14=0.0d0 +cd print '(a)','Enter ESCP' +cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e + do i=iatscp_s,iatscp_e + iteli=itel(i) + xi=0.5D0*(c(1,i)+c(1,i+1)) + yi=0.5D0*(c(2,i)+c(2,i+1)) + zi=0.5D0*(c(3,i)+c(3,i+1)) + + do iint=1,nscp_gr(i) + + do j=iscpstart(i,iint),iscpend(i,iint) + itypj=itype(j) +C Uncomment following three lines for SC-p interactions +c xj=c(1,nres+j)-xi +c yj=c(2,nres+j)-yi +c zj=c(3,nres+j)-zi +C Uncomment following three lines for Ca-p interactions + xj=c(1,j)-xi + yj=c(2,j)-yi + zj=c(3,j)-zi + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + fac=rrij**expon2 + e1=fac*fac*aad(itypj,iteli) + e2=fac*bad(itypj,iteli) + if (iabs(j-i) .le. 2) then + e1=scal14*e1 + e2=scal14*e2 + evdw2_14=evdw2_14+e1+e2 + endif + evdwij=e1+e2 + evdw2=evdw2+evdwij + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'evdw2',i,j,evdwij +C +C Calculate contributions to the gradient in the virtual-bond and SC vectors. +C + fac=-(evdwij+e1)*rrij + ggg(1)=xj*fac + ggg(2)=yj*fac + ggg(3)=zj*fac +cgrad if (j.lt.i) then +cd write (iout,*) 'ji' +cgrad do k=1,3 +cgrad ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) +c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) +cgrad enddo +cgrad endif +cgrad do k=1,3 +cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) +cgrad enddo +cgrad kstart=min0(i+1,j) +cgrad kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) +cgrad do k=kstart,kend +cgrad do l=1,3 +cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) +cgrad enddo +cgrad enddo + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo + enddo + + enddo ! iint + enddo ! i + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C-------------------------------------------------------------------------- + subroutine edis(ehpb) +C +C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + dimension ggg(3) + ehpb=0.0D0 +cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr +cd write(iout,*)'link_start=',link_start,' link_end=',link_end + if (link_end.eq.0) return + do i=link_start,link_end +C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a +C CA-CA distance used in regularization of structure. + ii=ihpb(i) + jj=jhpb(i) +C iii and jjj point to the residues for which the distance is assigned. + if (ii.gt.nres) then + iii=ii-nres + jjj=jj-nres + else + iii=ii + jjj=jj + endif +c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, +c & dhpb(i),dhpb1(i),forcon(i) +C 24/11/03 AL: SS bridges handled separately because of introducing a specific +C distance and angle dependent SS bond potential. +cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then +C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds + if (.not.dyn_ss .and. i.le.nss) then +C 15/02/13 CC dynamic SSbond - additional check + if (ii.gt.nres + & .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then + call ssbond_ene(iii,jjj,eij) + ehpb=ehpb+2*eij + endif +cd write (iout,*) "eij",eij + else if (ii.gt.nres .and. jj.gt.nres) then +c Restraints from contact prediction + dd=dist(ii,jj) + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "beta nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else + dd=dist(ii,jj) + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +c write (iout,*) "beta reg",dd,waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + else +C Calculate the distance between the two points and its difference from the +C target distance. + dd=dist(ii,jj) + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "alph nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +c write (iout,*) "alpha reg",dd,waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif +cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, +cd & ' waga=',waga,' fac=',fac + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distance, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif +cgrad do j=iii,jjj-1 +cgrad do k=1,3 +cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k) +cgrad enddo +cgrad enddo + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + endif + enddo + ehpb=0.5D0*ehpb + return + end +C-------------------------------------------------------------------------- + subroutine ssbond_ene(i,j,eij) +C +C Calculate the distance and angle dependent SS-bond potential energy +C using a free-energy function derived based on RHF/6-31G** ab initio +C calculations of diethyl disulfide. +C +C A. Liwo and U. Kozlowska, 11/24/03 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + double precision erij(3),dcosom1(3),dcosom2(3),gg(3) + itypi=itype(i) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +c dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(nres+i) + itypj=itype(j) +c dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(nres+j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + rij=1.0d0/rij + deltad=rij-d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) + & +akct*deltad*deltat12+ebr + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi +c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, +c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, +c & " deltat12",deltat12," eij",eij + ed=2*akcm*deltad+akct*deltat12 + pom1=akct*deltad + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + do k=1,3 + ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + ghpbx(k,i)=ghpbx(k,i)-ggk + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + ghpbx(k,j)=ghpbx(k,j)+ggk + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + ghpbc(k,i)=ghpbc(k,i)-ggk + ghpbc(k,j)=ghpbc(k,j)+ggk + enddo +C +C Calculate the components of the gradient in DC and X +C +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l) +cgrad enddo +cgrad enddo + return + end +C-------------------------------------------------------------------------- + subroutine ebond(estr) +c +c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + double precision u(3),ud(3) + estr=0.0d0 + do i=ibondp_start,ibondp_end + diff = vbld(i)-vbldp0 +c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff + estr=estr+diff*diff + do j=1,3 + gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) + enddo +c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) + enddo + estr=0.5d0*AKP*estr +c +c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included +c + do i=ibond_start,ibond_end + iti=itype(i) + if (iti.ne.10) then + nbi=nbondterm(iti) + if (nbi.eq.1) then + diff=vbld(i+nres)-vbldsc0(1,iti) +c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, +c & AKSC(1,iti),AKSC(1,iti)*diff*diff + estr=estr+0.5d0*AKSC(1,iti)*diff*diff + do j=1,3 + gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) + enddo + else + do j=1,nbi + diff=vbld(i+nres)-vbldsc0(j,iti) + ud(j)=aksc(j,iti)*diff + u(j)=abond0(j,iti)+0.5d0*ud(j)*diff + enddo + uprod=u(1) + do j=2,nbi + uprod=uprod*u(j) + enddo + usum=0.0d0 + usumsqder=0.0d0 + do j=1,nbi + uprod1=1.0d0 + uprod2=1.0d0 + do k=1,nbi + if (k.ne.j) then + uprod1=uprod1*u(k) + uprod2=uprod2*u(k)*u(k) + endif + enddo + usum=usum+uprod1 + usumsqder=usumsqder+ud(j)*uprod2 + enddo + estr=estr+uprod/usum + do j=1,3 + gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) + enddo + endif + endif + enddo + return + end +#ifdef CRYST_THETA +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + double precision y(2),z(2) + delta=0.02d0*pi +c time11=dexp(-2*time) +c time12=1.0d0 + etheta=0.0D0 +c write (*,'(a,i2)') 'EBEND ICG=',icg + do i=ithet_start,ithet_end +C Zero the energy function and its derivative at 0 or pi. + call splinthet(theta(i),0.5d0*delta,ss,ssd) + it=itype(i-1) + if (i.gt.3) then +#ifdef OSF + phii=phi(i) + if (phii.ne.phii) phii=150.0 +#else + phii=phi(i) +#endif + y(1)=dcos(phii) + y(2)=dsin(phii) + else + y(1)=0.0D0 + y(2)=0.0D0 + endif + if (i.lt.nres) then +#ifdef OSF + phii1=phi(i+1) + if (phii1.ne.phii1) phii1=150.0 + phii1=pinorm(phii1) + z(1)=cos(phii1) +#else + phii1=phi(i+1) + z(1)=dcos(phii1) +#endif + z(2)=dsin(phii1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif +C Calculate the "mean" value of theta from the part of the distribution +C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). +C In following comments this theta will be referred to as t_c. + thet_pred_mean=0.0d0 + do k=1,2 + athetk=athet(k,it) + bthetk=bthet(k,it) + thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) + enddo + dthett=thet_pred_mean*ssd + thet_pred_mean=thet_pred_mean*ss+a0thet(it) +C Derivatives of the "mean" values in gamma1 and gamma2. + dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss + dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss + if (theta(i).gt.pi-delta) then + call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, + & E_tc0) + call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) + call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, + & E_theta) + call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else if (theta(i).lt.delta) then + call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) + call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, + & E_theta) + call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) + call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else + call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, + & E_theta,E_tc) + endif + etheta=etheta+ethetai + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + & 'ebend',i,ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 + gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) + enddo +C Ufff.... We've done all this!!! + return + end +C--------------------------------------------------------------------------- + subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, + & E_tc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it +C Calculate the contributions to both Gaussian lobes. +C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) +C The "polynomial part" of the "standard deviation" of this part of +C the distribution. + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo +C Derivative of the "interior part" of the "standard deviation of the" +C gamma-dependent Gaussian lobe in t_c. + sigtc=3*polthet(3,it) + do j=2,1,-1 + sigtc=sigtc*thet_pred_mean+j*polthet(j,it) + enddo + sigtc=sig*sigtc +C Set the parameters of both Gaussian lobes of the distribution. +C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) + fac=sig*sig+sigc0(it) + sigcsq=fac+fac + sigc=1.0D0/sigcsq +C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c + sigsqtc=-4.0D0*sigcsq*sigtc +c print *,i,sig,sigtc,sigsqtc +C Following variable (sigtc) is d[sigma(t_c)]/dt_c + sigtc=-sigtc/(fac*fac) +C Following variable is sigma(t_c)**(-2) + sigcsq=sigcsq*sigcsq + sig0i=sig0(it) + sig0inv=1.0D0/sig0i**2 + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i + term1=-0.5D0*sigcsq*delthec*delthec + term2=-0.5D0*sig0inv*delthe0*delthe0 +C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and +C NaNs in taking the logarithm. We extract the largest exponent which is added +C to the energy (this being the log of the distribution) at the end of energy +C term evaluation for this virtual-bond angle. + if (term1.gt.term2) then + termm=term1 + term2=dexp(term2-termm) + term1=1.0d0 + else + termm=term2 + term1=dexp(term1-termm) + term2=1.0d0 + endif +C The ratio between the gamma-independent and gamma-dependent lobes of +C the distribution is a Gaussian function of thet_pred_mean too. + diffak=gthet(2,it)-thet_pred_mean + ratak=diffak/gthet(3,it)**2 + ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) +C Let's differentiate it in thet_pred_mean NOW. + aktc=ak*ratak +C Now put together the distribution terms to make complete distribution. + termexp=term1+ak*term2 + termpre=sigc+ak*sig0i +C Contribution of the bending energy from this theta is just the -log of +C the sum of the contributions from the two lobes and the pre-exponential +C factor. Simple enough, isn't it? + ethetai=(-dlog(termexp)-termm+dlog(termpre)) +C NOW the derivatives!!! +C 6/6/97 Take into account the deformation. + E_theta=(delthec*sigcsq*term1 + & +ak*delthe0*sig0inv*term2)/termexp + E_tc=((sigtc+aktc*sig0i)/termpre + & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ + & aktc*term2)/termexp) + return + end +c----------------------------------------------------------------------------- + subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i +C "Thank you" to MAPLE (probably spared one day of hand-differentiation). + t3 = thetai-thet_pred_mean + t6 = t3**2 + t9 = term1 + t12 = t3*sigcsq + t14 = t12+t6*sigsqtc + t16 = 1.0d0 + t21 = thetai-theta0i + t23 = t21**2 + t26 = term2 + t27 = t21*t26 + t32 = termexp + t40 = t32**2 + E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 + & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 + & *(-t12*t9-ak*sig0inv*t27) + return + end +#else +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C ab initio-derived potentials from +c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), + & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), + & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), + & sinph1ph2(maxdouble,maxdouble) + logical lprn /.false./, lprn1 /.false./ + etheta=0.0D0 + do i=ithet_start,ithet_end + dethetai=0.0d0 + dephii=0.0d0 + dephii1=0.0d0 + theti2=0.5d0*theta(i) + ityp2=ithetyp(itype(i-1)) + do k=1,nntheterm + coskt(k)=dcos(k*theti2) + sinkt(k)=dsin(k*theti2) + enddo + if (i.gt.3) then +#ifdef OSF + phii=phi(i) + if (phii.ne.phii) phii=150.0 +#else + phii=phi(i) +#endif + ityp1=ithetyp(itype(i-2)) + do k=1,nsingle + cosph1(k)=dcos(k*phii) + sinph1(k)=dsin(k*phii) + enddo + else + phii=0.0d0 + ityp1=nthetyp+1 + do k=1,nsingle + cosph1(k)=0.0d0 + sinph1(k)=0.0d0 + enddo + endif + if (i.lt.nres) then +#ifdef OSF + phii1=phi(i+1) + if (phii1.ne.phii1) phii1=150.0 + phii1=pinorm(phii1) +#else + phii1=phi(i+1) +#endif + ityp3=ithetyp(itype(i)) + do k=1,nsingle + cosph2(k)=dcos(k*phii1) + sinph2(k)=dsin(k*phii1) + enddo + else + phii1=0.0d0 + ityp3=nthetyp+1 + do k=1,nsingle + cosph2(k)=0.0d0 + sinph2(k)=0.0d0 + enddo + endif + ethetai=aa0thet(ityp1,ityp2,ityp3) + do k=1,ndouble + do l=1,k-1 + ccl=cosph1(l)*cosph2(k-l) + ssl=sinph1(l)*sinph2(k-l) + scl=sinph1(l)*cosph2(k-l) + csl=cosph1(l)*sinph2(k-l) + cosph1ph2(l,k)=ccl-ssl + cosph1ph2(k,l)=ccl+ssl + sinph1ph2(l,k)=scl+csl + sinph1ph2(k,l)=scl-csl + enddo + enddo + if (lprn) then + write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, + & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 + write (iout,*) "coskt and sinkt" + do k=1,nntheterm + write (iout,*) k,coskt(k),sinkt(k) + enddo + endif + do k=1,ntheterm + ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k) + dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3) + & *coskt(k) + if (lprn) + & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), + & " ethetai",ethetai + enddo + if (lprn) then + write (iout,*) "cosph and sinph" + do k=1,nsingle + write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) + enddo + write (iout,*) "cosph1ph2 and sinph2ph2" + do k=2,ndouble + do l=1,k-1 + write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), + & sinph1ph2(l,k),sinph1ph2(k,l) + enddo + enddo + write(iout,*) "ethetai",ethetai + endif + do m=1,ntheterm2 + do k=1,nsingle + aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k) + & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k) + & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k) + & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k) + ethetai=ethetai+sinkt(m)*aux + dethetai=dethetai+0.5d0*m*aux*coskt(m) + dephii=dephii+k*sinkt(m)*( + & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- + & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) + dephii1=dephii1+k*sinkt(m)*( + & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- + & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) + if (lprn) + & write (iout,*) "m",m," k",k," bbthet", + & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", + & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", + & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", + & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai + enddo + enddo + if (lprn) + & write(iout,*) "ethetai",ethetai + do m=1,ntheterm3 + do k=2,ndouble + do l=1,k-1 + aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l) + ethetai=ethetai+sinkt(m)*aux + dethetai=dethetai+0.5d0*m*coskt(m)*aux + dephii=dephii+l*sinkt(m)*( + & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)- + & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) + dephii1=dephii1+(k-l)*sinkt(m)*( + & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)- + & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) + if (lprn) then + write (iout,*) "m",m," k",k," l",l," ffthet", + & ffthet(l,k,m,ityp1,ityp2,ityp3), + & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", + & ggthet(l,k,m,ityp1,ityp2,ityp3), + & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai + write (iout,*) cosph1ph2(l,k)*sinkt(m), + & cosph1ph2(k,l)*sinkt(m), + & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) + endif + enddo + enddo + enddo +10 continue + if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') + & i,theta(i)*rad2deg,phii*rad2deg, + & phii1*rad2deg,ethetai + etheta=etheta+ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 + gloc(nphi+i-2,icg)=wang*dethetai + enddo + return + end +#endif +#ifdef CRYST_SC +c----------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), + & ddersc0(3),ddummy(3),xtemp(3),temp(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 +c write (iout,'(a)') 'ESC' + do i=loc_start,loc_end + it=itype(i) + if (it.eq.10) goto 1 + nlobit=nlob(it) +c print *,'i=',i,' it=',it,' nlobit=',nlobit +c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad + theti=theta(i+1)-pipol + x(1)=dtan(theti) + x(2)=alph(i) + x(3)=omeg(i) + + if (x(2).gt.pi-delta) then + xtemp(1)=x(1) + xtemp(2)=pi-delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=pi + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=pi-delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=pi + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + call splinthet(x(2),0.5d0*delta,ss,ssd) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c escloci=esclocbi +c write (iout,*) escloci + else if (x(2).lt.delta) then + xtemp(1)=x(1) + xtemp(2)=delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=0.0d0 + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=0.0d0 + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + call splinthet(x(2),0.5d0*delta,ss,ssd) + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c write (iout,*) escloci + else + call enesc(x,escloci,dersc,ddummy,.false.) + endif + + escloc=escloc+escloci + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + & 'escloc',i,escloci +c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + & wscloc*dersc(1) + gloc(ialph(i,1),icg)=wscloc*dersc(2) + gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) + 1 continue + enddo + return + end +C--------------------------------------------------------------------------- + subroutine enesc(x,escloci,dersc,ddersc,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) + double precision contr(maxlob,-1:1) + logical mixed +c write (iout,*) 'it=',it,' nlobit=',nlobit + escloc_i=0.0D0 + do j=1,3 + dersc(j)=0.0D0 + if (mixed) ddersc(j)=0.0d0 + enddo + x3=x(3) + +C Because of periodicity of the dependence of the SC energy in omega we have +C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). +C To avoid underflows, first compute & store the exponents. + + do iii=-1,1 + + x(3)=x3+iii*dwapi + + do j=1,nlobit + do k=1,3 + z(k)=x(k)-censc(k,j,it) + enddo + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j,iii)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j,iii)*z(k) + enddo + contr(j,iii)=expfac + enddo ! j + + enddo ! iii + + x(3)=x3 +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1,-1) + do iii=-1,1 + do j=1,nlobit + if (emin.gt.contr(j,iii)) emin=contr(j,iii) + enddo + enddo + emin=0.5D0*emin +cd print *,'it=',it,' emin=',emin + +C Compute the contribution to SC energy and derivatives + do iii=-1,1 + + do j=1,nlobit +#ifdef OSF + adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin + if(adexp.ne.adexp) adexp=1.0 + expfac=dexp(adexp) +#else + expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) +#endif +cd print *,'j=',j,' expfac=',expfac + escloc_i=escloc_i+expfac + do k=1,3 + dersc(k)=dersc(k)+Ax(k,j,iii)*expfac + enddo + if (mixed) then + do k=1,3,2 + ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) + & +gaussc(k,2,j,it))*expfac + enddo + endif + enddo + + enddo ! iii + + dersc(1)=dersc(1)/cos(theti)**2 + ddersc(1)=ddersc(1)/cos(theti)**2 + ddersc(3)=ddersc(3) + + escloci=-(dlog(escloc_i)-emin) + do j=1,3 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) then + do j=1,3,2 + ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) + enddo + endif + return + end +C------------------------------------------------------------------------------ + subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob),dersc(3) + double precision contr(maxlob) + logical mixed + + escloc_i=0.0D0 + + do j=1,3 + dersc(j)=0.0D0 + enddo + + do j=1,nlobit + do k=1,2 + z(k)=x(k)-censc(k,j,it) + enddo + z(3)=dwapi + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j)*z(k) + enddo + contr(j)=expfac + enddo ! j + +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1) + do j=1,nlobit + if (emin.gt.contr(j)) emin=contr(j) + enddo + emin=0.5D0*emin + +C Compute the contribution to SC energy and derivatives + + dersc12=0.0d0 + do j=1,nlobit + expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin) + escloc_i=escloc_i+expfac + do k=1,2 + dersc(k)=dersc(k)+Ax(k,j)*expfac + enddo + if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) + & +gaussc(1,2,j,it))*expfac + dersc(3)=0.0d0 + enddo + + dersc(1)=dersc(1)/cos(theti)**2 + dersc12=dersc12/cos(theti)**2 + escloci=-(dlog(escloc_i)-emin) + do j=1,2 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) + return + end +#else +c---------------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA derived from AM1 all-atom calculations. +C added by Urszula Kozlowska. 07/11/2007 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.SCROT' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.VECTORS' + double precision x_prime(3),y_prime(3),z_prime(3) + & , sumene,dsc_i,dp2_i,x(65), + & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, + & de_dxx,de_dyy,de_dzz,de_dt + double precision s1_t,s1_6_t,s2_t,s2_6_t + double precision + & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), + & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), + & dt_dCi(3),dt_dCi1(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 + do i=loc_start,loc_end + costtab(i+1) =dcos(theta(i+1)) + sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) + cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) + sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) + cosfac2=0.5d0/(1.0d0+costtab(i+1)) + cosfac=dsqrt(cosfac2) + sinfac2=0.5d0/(1.0d0-costtab(i+1)) + sinfac=dsqrt(sinfac2) + it=itype(i) + if (it.eq.10) goto 1 +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo +C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), +C & dc_norm(3,i+nres) + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + do j = 1,3 + z_prime(j) = -uz(j,i-1) + enddo +c write (2,*) "i",i +c write (2,*) "x_prime",(x_prime(j),j=1,3) +c write (2,*) "y_prime",(y_prime(j),j=1,3) +c write (2,*) "z_prime",(z_prime(j),j=1,3) +c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), +c & " xy",scalar(x_prime(1),y_prime(1)), +c & " xz",scalar(x_prime(1),z_prime(1)), +c & " yy",scalar(y_prime(1),y_prime(1)), +c & " yz",scalar(y_prime(1),z_prime(1)), +c & " zz",scalar(z_prime(1),z_prime(1)) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxtab(i)=xx + yytab(i)=yy + zztab(i)=zz +C +C Compute the energy of the ith side cbain +C +c write (2,*) "xx",xx," yy",yy," zz",zz + it=itype(i) + do j = 1,65 + x(j) = sc_parmin(j,it) + enddo +#ifdef CHECK_COORD +Cc diagnostics - remove later + xx1 = dcos(alph(2)) + yy1 = dsin(alph(2))*dcos(omeg(2)) + zz1 = -dsin(alph(2))*dsin(omeg(2)) + write(2,'(3f8.1,3f9.3,1x,3f9.3)') + & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, + & xx1,yy1,zz1 +C," --- ", xx_w,yy_w,zz_w +c end diagnostics +#endif + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) + & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) +c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, +c & sumene4, +c & dscp1,dscp2,sumene +c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + escloc = escloc + sumene +c write (2,*) "i",i," escloc",sumene,escloc +#ifdef DEBUG +C +C This section to check the numerical derivatives of the energy of ith side +C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert +C #define DEBUG in the code to turn it on. +C + write (2,*) "sumene =",sumene + aincr=1.0d-7 + xxsave=xx + xx=xx+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dxx_num=(sumenep-sumene)/aincr + xx=xxsave + write (2,*) "xx+ sumene from enesc=",sumenep + yysave=yy + yy=yy+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dyy_num=(sumenep-sumene)/aincr + yy=yysave + write (2,*) "yy+ sumene from enesc=",sumenep + zzsave=zz + zz=zz+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dzz_num=(sumenep-sumene)/aincr + zz=zzsave + write (2,*) "zz+ sumene from enesc=",sumenep + costsave=cost2tab(i+1) + sintsave=sint2tab(i+1) + cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) + sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dt_num=(sumenep-sumene)/aincr + write (2,*) " t+ sumene from enesc=",sumenep + cost2tab(i+1)=costsave + sint2tab(i+1)=sintsave +C End of diagnostics section. +#endif +C +C Compute the gradient of esc +C + pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 + pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 + pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 + pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 + pom_dx=dsc_i*dp2_i*cost2tab(i+1) + pom_dy=dsc_i*dp2_i*sint2tab(i+1) + pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) + pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) + pom1=(sumene3*sint2tab(i+1)+sumene1) + & *(pom_s1/dscp1+pom_s16*dscp1**4) + pom2=(sumene4*cost2tab(i+1)+sumene2) + & *(pom_s2/dscp2+pom_s26*dscp2**4) + sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy + sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 + & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) + & +x(40)*yy*zz + sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy + sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 + & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) + & +x(60)*yy*zz + de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) + & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) + & +(pom1+pom2)*pom_dx +#ifdef DEBUG + write(2,*), "de_dxx = ", de_dxx,de_dxx_num +#endif +C + sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz + sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 + & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) + & +x(40)*xx*zz + sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz + sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz + & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz + & +x(59)*zz**2 +x(60)*xx*zz + de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) + & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) + & +(pom1-pom2)*pom_dy +#ifdef DEBUG + write(2,*), "de_dyy = ", de_dyy,de_dyy_num +#endif +C + de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy + & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx + & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) + & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) + & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 + & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy + & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) + & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) +#ifdef DEBUG + write(2,*), "de_dzz = ", de_dzz,de_dzz_num +#endif +C + de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) + & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) + & +pom1*pom_dt1+pom2*pom_dt2 +#ifdef DEBUG + write(2,*), "de_dt = ", de_dt,de_dt_num +#endif +c +C + cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + cosfac2xx=cosfac2*xx + sinfac2yy=sinfac2*yy + do k = 1,3 + dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* + & vbld_inv(i+1) + dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* + & vbld_inv(i) + pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) + pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) +c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, +c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) +c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), +c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) + dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx + dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx + dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy + dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy + dZZ_Ci1(k)=0.0d0 + dZZ_Ci(k)=0.0d0 + do j=1,3 + dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres) + dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) + enddo + + dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) + dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) + dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) +c + dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) + dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) + enddo + + do k=1,3 + dXX_Ctab(k,i)=dXX_Ci(k) + dXX_C1tab(k,i)=dXX_Ci1(k) + dYY_Ctab(k,i)=dYY_Ci(k) + dYY_C1tab(k,i)=dYY_Ci1(k) + dZZ_Ctab(k,i)=dZZ_Ci(k) + dZZ_C1tab(k,i)=dZZ_Ci1(k) + dXX_XYZtab(k,i)=dXX_XYZ(k) + dYY_XYZtab(k,i)=dYY_XYZ(k) + dZZ_XYZtab(k,i)=dZZ_XYZ(k) + enddo + + do k = 1,3 +c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", +c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) +c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", +c & dyy_ci(k)," dzz_ci",dzz_ci(k) +c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", +c & dt_dci(k) +c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", +c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) + gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) + & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) + gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) + & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) + gsclocx(k,i)= de_dxx*dxx_XYZ(k) + & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) + enddo +c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), +c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) + +C to check gradient call subroutine check_grad + + 1 continue + enddo + return + end +c------------------------------------------------------------------------------ + double precision function enesc(x,xx,yy,zz,cost2,sint2) + implicit none + double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2, + & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2+yy*sint2)) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2-yy*sint2)) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) + & + (sumene4*cost2 +sumene2)*(s2+s2_6) + enesc=sumene + return + end +#endif +c------------------------------------------------------------------------------ + subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) +C +C This procedure calculates two-body contact function g(rij) and its derivative: +C +C eps0ij ! x < -1 +C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 +C 0 ! x > 1 +C +C where x=(rij-r0ij)/delta +C +C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy +C + implicit none + double precision rij,r0ij,eps0ij,fcont,fprimcont + double precision x,x2,x4,delta +c delta=0.02D0*r0ij +c delta=0.2D0*r0ij + x=(rij-r0ij)/delta + if (x.lt.-1.0D0) then + fcont=eps0ij + fprimcont=0.0D0 + else if (x.le.1.0D0) then + x2=x*x + x4=x2*x2 + fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) + fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta + else + fcont=0.0D0 + fprimcont=0.0D0 + endif + return + end +c------------------------------------------------------------------------------ + subroutine splinthet(theti,delta,ss,ssder) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + thetup=pi-delta + thetlow=delta + if (theti.gt.pipol) then + call gcont(theti,thetup,1.0d0,delta,ss,ssder) + else + call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) + ssder=-ssder + endif + return + end +c------------------------------------------------------------------------------ + subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) + implicit none + double precision x,x0,delta,f0,f1,fprim0,f,fprim + double precision ksi,ksi2,ksi3,a1,a2,a3 + a1=fprim0*delta/(f1-f0) + a2=3.0d0-2.0d0*a1 + a3=a1-2.0d0 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) + fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) + return + end +c------------------------------------------------------------------------------ + subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) + implicit none + double precision x,x0,delta,f0x,f1x,fprim0x,fx + double precision ksi,ksi2,ksi3,a1,a2,a3 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + a1=fprim0x*delta + a2=3*(f1x-f0x)-2*fprim0x*delta + a3=fprim0x*delta-2*(f1x-f0x) + fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 + return + end +C----------------------------------------------------------------------------- +#ifdef CRYST_TOR +C----------------------------------------------------------------------------- + subroutine etor(etors,edihcnstr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + etors_ii=0.0D0 + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Proline-Proline pair is a special case... + if (itori.eq.3 .and. itori1.eq.3) then + if (phii.gt.-dwapi3) then + cosphi=dcos(3*phii) + fac=1.0D0/(1.0D0-cosphi) + etorsi=v1(1,3,3)*fac + etorsi=etorsi+etorsi + etors=etors+etorsi-v1(1,3,3) + if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) + gloci=gloci-3*fac*etorsi*dsin(3*phii) + endif + do j=1,3 + v1ij=v1(j+1,itori,itori1) + v2ij=v2(j+1,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + if (energy_dec) etors_ii=etors_ii+ + & v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + else + do j=1,nterm_old + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + if (energy_dec) etors_ii=etors_ii+ + & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + endif + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + & 'etor',i,etors_ii + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci + write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 + do i=1,ndih_constr + itori=idih_constr(i) + phii=phi(itori) + difi=phii-phi0(i) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + endif +! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, +! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +! write (iout,*) 'edihcnstr',edihcnstr + return + end +c------------------------------------------------------------------------------ + subroutine etor_d(etors_d) + etors_d=0.0d0 + return + end +c---------------------------------------------------------------------------- +#else + subroutine etor(etors,edihcnstr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + etors_ii=0.0D0 + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Regular cosine and sine terms + do j=1,nterm(itori,itori1) + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi + if (energy_dec) etors_ii=etors_ii+ + & v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C Lorentz terms +C v1 +C E = SUM ----------------------------------- - v1 +C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 +C + cosphi=dcos(0.5d0*phii) + sinphi=dsin(0.5d0*phii) + do j=1,nlor(itori,itori1) + vl1ij=vlor1(j,itori,itori1) + vl2ij=vlor2(j,itori,itori1) + vl3ij=vlor3(j,itori,itori1) + pom=vl2ij*cosphi+vl3ij*sinphi + pom1=1.0d0/(pom*pom+1.0d0) + etors=etors+vl1ij*pom1 + if (energy_dec) etors_ii=etors_ii+ + & vl1ij*pom1 + pom=-pom*pom1*pom1 + gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom + enddo +C Subtract the constant term + etors=etors-v0(itori,itori1) + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + & 'etor',i,etors_ii-v0(itori,itori1) + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 +c do i=1,ndih_constr + do i=idihconstr_start,idihconstr_end + itori=idih_constr(i) + phii=phi(itori) + difi=pinorm(phii-phi0(i)) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + else + difi=0.0 + endif +c write (iout,*) "gloci", gloc(i-3,icg) +cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, +cd & rad2deg*phi0(i), rad2deg*drange(i), +cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) + enddo +cd write (iout,*) 'edihcnstr',edihcnstr + return + end +c---------------------------------------------------------------------------- + subroutine etor_d(etors_d) +C 6/23/01 Compute double torsional energy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors_d=0.0D0 + do i=iphid_start,iphid_end + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + itori2=itortyp(itype(i)) + phii=phi(i) + phii1=phi(i+1) + gloci1=0.0D0 + gloci2=0.0D0 + do j=1,ntermd_1(itori,itori1,itori2) + v1cij=v1c(1,j,itori,itori1,itori2) + v1sij=v1s(1,j,itori,itori1,itori2) + v2cij=v1c(2,j,itori,itori1,itori2) + v2sij=v1s(2,j,itori,itori1,itori2) + cosphi1=dcos(j*phii) + sinphi1=dsin(j*phii) + cosphi2=dcos(j*phii1) + sinphi2=dsin(j*phii1) + etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ + & v2cij*cosphi2+v2sij*sinphi2 + gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) + gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) + enddo + do k=2,ntermd_2(itori,itori1,itori2) + do l=1,k-1 + v1cdij = v2c(k,l,itori,itori1,itori2) + v2cdij = v2c(l,k,itori,itori1,itori2) + v1sdij = v2s(k,l,itori,itori1,itori2) + v2sdij = v2s(l,k,itori,itori1,itori2) + cosphi1p2=dcos(l*phii+(k-l)*phii1) + cosphi1m2=dcos(l*phii-(k-l)*phii1) + sinphi1p2=dsin(l*phii+(k-l)*phii1) + sinphi1m2=dsin(l*phii-(k-l)*phii1) + etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ + & v1sdij*sinphi1p2+v2sdij*sinphi1m2 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 +c write (iout,*) "gloci", gloc(i-3,icg) + enddo + return + end +#endif +c------------------------------------------------------------------------------ + subroutine eback_sc_corr(esccor) +c 7/21/2007 Correlations between the backbone-local and side-chain-local +c conformational states; temporarily implemented as differences +c between UNRES torsional potentials (dependent on three types of +c residues) and the torsional potentials dependent on all 20 types +c of residues computed from AM1 energy surfaces of terminally-blocked +c amino-acid residues. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.SCCOR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. +c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor + esccor=0.0D0 + do i=itau_start,itau_end + esccor_ii=0.0D0 + isccori=isccortyp(itype(i-2)) + isccori1=isccortyp(itype(i-1)) + phii=phi(i) +cccc Added 9 May 2012 +cc Tauangle is torsional engle depending on the value of first digit +c(see comment below) +cc Omicron is flat angle depending on the value of first digit +c(see comment below) + + + do intertyp=1,3 !intertyp +cc Added 09 May 2012 (Adasko) +cc Intertyp means interaction type of backbone mainchain correlation: +c 1 = SC...Ca...Ca...Ca +c 2 = Ca...Ca...Ca...SC +c 3 = SC...Ca...Ca...SCi + gloci=0.0D0 + if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. + & (itype(i-1).eq.10).or.(itype(i-2).eq.21).or. + & (itype(i-1).eq.21))) + & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) + & .or.(itype(i-2).eq.21))) + & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. + & (itype(i-1).eq.21)))) cycle + if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle + if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21)) + & cycle + do j=1,nterm_sccor(isccori,isccori1) + v1ij=v1sccor(j,intertyp,isccori,isccori1) + v2ij=v2sccor(j,intertyp,isccori,isccori1) + cosphi=dcos(j*tauangle(intertyp,i)) + sinphi=dsin(j*tauangle(intertyp,i)) + esccor=esccor+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci +c write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi +c &gloc_sc(intertyp,i-3,icg) + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1sccor(j,intertyp,itori,itori1),j=1,6) + & ,(v2sccor(j,intertyp,itori,itori1),j=1,6) + gsccor_loc(i-3)=gsccor_loc(i-3)+gloci + enddo !intertyp + enddo +c do i=1,nres +c write (iout,*) "W@T@F", gloc_sc(1,i,icg),gloc(i,icg) +c enddo + return + end +c---------------------------------------------------------------------------- + subroutine multibody(ecorr) +C This subroutine calculates multi-body contributions to energy following +C the idea of Skolnick et al. If side chains I and J make a contact and +C at the same time side chains I+1 and J+1 make a contact, an extra +C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + +C Set lprn=.true. for debugging + lprn=.false. + + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(i2,20(1x,i2,f10.5))') + & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) + enddo + endif + ecorr=0.0D0 + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo + do i=nnt,nct-2 + + DO ISHIFT = 3,4 + + i1=i+ishift + num_conti=num_cont(i) + num_conti1=num_cont(i1) + do jj=1,num_conti + j=jcont(jj,i) + do kk=1,num_conti1 + j1=jcont(kk,i1) + if (j1.eq.j+ishift .or. j1.eq.j-ishift) then +cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, +cd & ' ishift=',ishift +C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) + endif ! j1==j+-ishift + enddo ! kk + enddo ! jj + + ENDDO ! ISHIFT + + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function esccorr(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont(jj,i) + ekl=facont(kk,k) +cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl +C Calculate the multi-body contribution to energy. +C Calculate multi-body contributions to the gradient. +cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), +cd & k,l,(gacont(m,kk,k),m=1,3) + do m=1,3 + gx(m) =ekl*gacont(m,jj,i) + gx1(m)=eij*gacont(m,kk,k) + gradxorr(m,i)=gradxorr(m,i)-gx(m) + gradxorr(m,j)=gradxorr(m,j)+gx(m) + gradxorr(m,k)=gradxorr(m,k)-gx1(m) + gradxorr(m,l)=gradxorr(m,l)+gx1(m) + enddo + do m=i,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) + enddo + enddo + do m=k,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) + enddo + enddo + esccorr=-eij*ekl + return + end +c------------------------------------------------------------------------------ + subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +#ifdef MPI + include "mpif.h" + parameter (max_cont=maxconts) + parameter (max_dim=26) + integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer status(MPI_STATUS_SIZE),req(maxconts*2), + & status_array(MPI_STATUS_SIZE,maxconts*2) +#endif + include 'COMMON.SETUP' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTROL' + include 'COMMON.LOCAL' + double precision gx(3),gx1(3),time00 + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. +#ifdef MPI + n_corr=0 + n_corr1=0 + if (nfgtasks.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values before RECEIVE:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + call flush(iout) + do i=1,ntask_cont_from + ncont_recv(i)=0 + enddo + do i=1,ntask_cont_to + ncont_sent(i)=0 + enddo +c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", +c & ntask_cont_to +C Make the list of contacts to send to send to other procesors +c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end +c call flush(iout) + do i=iturn3_start,iturn3_end +c write (iout,*) "make contact list turn3",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) + enddo + do i=iturn4_start,iturn4_end +c write (iout,*) "make contact list turn4",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) + enddo + do ii=1,nat_sent + i=iat_sent(ii) +c write (iout,*) "make contact list longrange",i,ii," num_cont", +c & num_cont_hb(i) + do j=1,num_cont_hb(i) + do k=1,4 + jjc=jcont_hb(j,i) + iproc=iint_sent_local(k,jjc,ii) +c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc + if (iproc.gt.0) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=i + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=facont_hb(j,i) + zapas(4,nn,iproc)=ees0p(j,i) + zapas(5,nn,iproc)=ees0m(j,i) + zapas(6,nn,iproc)=gacont_hbr(1,j,i) + zapas(7,nn,iproc)=gacont_hbr(2,j,i) + zapas(8,nn,iproc)=gacont_hbr(3,j,i) + zapas(9,nn,iproc)=gacontm_hb1(1,j,i) + zapas(10,nn,iproc)=gacontm_hb1(2,j,i) + zapas(11,nn,iproc)=gacontm_hb1(3,j,i) + zapas(12,nn,iproc)=gacontp_hb1(1,j,i) + zapas(13,nn,iproc)=gacontp_hb1(2,j,i) + zapas(14,nn,iproc)=gacontp_hb1(3,j,i) + zapas(15,nn,iproc)=gacontm_hb2(1,j,i) + zapas(16,nn,iproc)=gacontm_hb2(2,j,i) + zapas(17,nn,iproc)=gacontm_hb2(3,j,i) + zapas(18,nn,iproc)=gacontp_hb2(1,j,i) + zapas(19,nn,iproc)=gacontp_hb2(2,j,i) + zapas(20,nn,iproc)=gacontp_hb2(3,j,i) + zapas(21,nn,iproc)=gacontm_hb3(1,j,i) + zapas(22,nn,iproc)=gacontm_hb3(2,j,i) + zapas(23,nn,iproc)=gacontm_hb3(3,j,i) + zapas(24,nn,iproc)=gacontp_hb3(1,j,i) + zapas(25,nn,iproc)=gacontp_hb3(2,j,i) + zapas(26,nn,iproc)=gacontp_hb3(3,j,i) + endif + enddo + enddo + enddo + if (lprn) then + write (iout,*) + & "Numbers of contacts to be sent to other processors", + & (ncont_sent(i),i=1,ntask_cont_to) + write (iout,*) "Contacts sent" + do ii=1,ntask_cont_to + nn=ncont_sent(ii) + iproc=itask_cont_to(ii) + write (iout,*) nn," contacts to processor",iproc, + & " of CONT_TO_COMM group" + do i=1,nn + write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) + enddo + enddo + call flush(iout) + endif + CorrelType=477 + CorrelID=fg_rank+1 + CorrelType1=478 + CorrelID1=nfgtasks+fg_rank+1 + ireq=0 +C Receive the numbers of needed contacts from other processors + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + ireq=ireq+1 + call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "IRECV ended" +c call flush(iout) +C Send the number of contacts needed by other processors + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + ireq=ireq+1 + call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "ISEND ended" +c write (iout,*) "number of requests (nn)",ireq + call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) +c write (iout,*) +c & "Numbers of contacts to be received from other processors", +c & (ncont_recv(i),i=1,ntask_cont_from) +c call flush(iout) +C Receive contacts + ireq=0 + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + nn=ncont_recv(ii) +c write (iout,*) "Receiving",nn," contacts from processor",iproc, +c & " of CONT_TO_COMM group" + call flush(iout) + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, + & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) + endif + enddo +C Send the contacts to processors that need them + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + nn=ncont_sent(ii) +c write (iout,*) nn," contacts to processor",iproc, +c & " of CONT_TO_COMM group" + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, + & iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) +c do i=1,nn +c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) +c enddo + endif + enddo +c write (iout,*) "number of requests (contacts)",ireq +c write (iout,*) "req",(req(i),i=1,4) +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) + do iii=1,ntask_cont_from + iproc=itask_cont_from(iii) + nn=ncont_recv(iii) + if (lprn) then + write (iout,*) "Received",nn," contacts from processor",iproc, + & " of CONT_FROM_COMM group" + call flush(iout) + do i=1,nn + write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) + enddo + call flush(iout) + endif + do i=1,nn + ii=zapas_recv(1,i,iii) +c Flag the received contacts to prevent double-counting + jj=-zapas_recv(2,i,iii) +c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj +c call flush(iout) + nnn=num_cont_hb(ii)+1 + num_cont_hb(ii)=nnn + jcont_hb(nnn,ii)=jj + facont_hb(nnn,ii)=zapas_recv(3,i,iii) + ees0p(nnn,ii)=zapas_recv(4,i,iii) + ees0m(nnn,ii)=zapas_recv(5,i,iii) + gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii) + gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii) + gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii) + gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii) + gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii) + gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii) + gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii) + gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii) + gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii) + gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii) + gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii) + gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii) + gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii) + gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii) + gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii) + gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii) + gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii) + gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii) + gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii) + gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii) + gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii) + enddo + enddo + call flush(iout) + if (lprn) then + write (iout,'(a)') 'Contact function values after receive:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i3,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + call flush(iout) + endif + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i3,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the local-electrostatic correlation terms + do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end) + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 + & .or. j.lt.0 .and. j1.gt.0) .and. + & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) + n_corr=n_corr+1 + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + subroutine add_hb_contact(ii,jj,itask) + implicit real*8 (a-h,o-z) + include "DIMENSIONS" + include "COMMON.IOUNITS" + integer max_cont + integer max_dim + parameter (max_cont=maxconts) + parameter (max_dim=26) + include "COMMON.CONTACTS" + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer i,j,ii,jj,iproc,itask(4),nn +c write (iout,*) "itask",itask + do i=1,2 + iproc=itask(i) + if (iproc.gt.0) then + do j=1,num_cont_hb(ii) + jjc=jcont_hb(j,ii) +c write (iout,*) "i",ii," j",jj," jjc",jjc + if (jjc.eq.jj) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=ii + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=facont_hb(j,ii) + zapas(4,nn,iproc)=ees0p(j,ii) + zapas(5,nn,iproc)=ees0m(j,ii) + zapas(6,nn,iproc)=gacont_hbr(1,j,ii) + zapas(7,nn,iproc)=gacont_hbr(2,j,ii) + zapas(8,nn,iproc)=gacont_hbr(3,j,ii) + zapas(9,nn,iproc)=gacontm_hb1(1,j,ii) + zapas(10,nn,iproc)=gacontm_hb1(2,j,ii) + zapas(11,nn,iproc)=gacontm_hb1(3,j,ii) + zapas(12,nn,iproc)=gacontp_hb1(1,j,ii) + zapas(13,nn,iproc)=gacontp_hb1(2,j,ii) + zapas(14,nn,iproc)=gacontp_hb1(3,j,ii) + zapas(15,nn,iproc)=gacontm_hb2(1,j,ii) + zapas(16,nn,iproc)=gacontm_hb2(2,j,ii) + zapas(17,nn,iproc)=gacontm_hb2(3,j,ii) + zapas(18,nn,iproc)=gacontp_hb2(1,j,ii) + zapas(19,nn,iproc)=gacontp_hb2(2,j,ii) + zapas(20,nn,iproc)=gacontp_hb2(3,j,ii) + zapas(21,nn,iproc)=gacontm_hb3(1,j,ii) + zapas(22,nn,iproc)=gacontm_hb3(2,j,ii) + zapas(23,nn,iproc)=gacontm_hb3(3,j,ii) + zapas(24,nn,iproc)=gacontp_hb3(1,j,ii) + zapas(25,nn,iproc)=gacontp_hb3(2,j,ii) + zapas(26,nn,iproc)=gacontp_hb3(3,j,ii) + exit + endif + enddo + endif + enddo + return + end +c------------------------------------------------------------------------------ + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, + & n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +#ifdef MPI + include "mpif.h" + parameter (max_cont=maxconts) + parameter (max_dim=70) + integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer status(MPI_STATUS_SIZE),req(maxconts*2), + & status_array(MPI_STATUS_SIZE,maxconts*2) +#endif + include 'COMMON.SETUP' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CHAIN' + include 'COMMON.CONTROL' + double precision gx(3),gx1(3) + integer num_cont_hb_old(maxres) + logical lprn,ldone + double precision eello4,eello5,eelo6,eello_turn6 + external eello4,eello5,eello6,eello_turn6 +C Set lprn=.true. for debugging + lprn=.false. + eturn6=0.0d0 +#ifdef MPI + do i=1,nres + num_cont_hb_old(i)=num_cont_hb(i) + enddo + n_corr=0 + n_corr1=0 + if (nfgtasks.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values before RECEIVE:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + call flush(iout) + do i=1,ntask_cont_from + ncont_recv(i)=0 + enddo + do i=1,ntask_cont_to + ncont_sent(i)=0 + enddo +c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", +c & ntask_cont_to +C Make the list of contacts to send to send to other procesors + do i=iturn3_start,iturn3_end +c write (iout,*) "make contact list turn3",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) + enddo + do i=iturn4_start,iturn4_end +c write (iout,*) "make contact list turn4",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i)) + enddo + do ii=1,nat_sent + i=iat_sent(ii) +c write (iout,*) "make contact list longrange",i,ii," num_cont", +c & num_cont_hb(i) + do j=1,num_cont_hb(i) + do k=1,4 + jjc=jcont_hb(j,i) + iproc=iint_sent_local(k,jjc,ii) +c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc + if (iproc.ne.0) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=i + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=d_cont(j,i) + ind=3 + do kk=1,3 + ind=ind+1 + zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i) + enddo + enddo + enddo + enddo + endif + enddo + enddo + enddo + if (lprn) then + write (iout,*) + & "Numbers of contacts to be sent to other processors", + & (ncont_sent(i),i=1,ntask_cont_to) + write (iout,*) "Contacts sent" + do ii=1,ntask_cont_to + nn=ncont_sent(ii) + iproc=itask_cont_to(ii) + write (iout,*) nn," contacts to processor",iproc, + & " of CONT_TO_COMM group" + do i=1,nn + write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10) + enddo + enddo + call flush(iout) + endif + CorrelType=477 + CorrelID=fg_rank+1 + CorrelType1=478 + CorrelID1=nfgtasks+fg_rank+1 + ireq=0 +C Receive the numbers of needed contacts from other processors + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + ireq=ireq+1 + call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "IRECV ended" +c call flush(iout) +C Send the number of contacts needed by other processors + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + ireq=ireq+1 + call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "ISEND ended" +c write (iout,*) "number of requests (nn)",ireq + call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) +c write (iout,*) +c & "Numbers of contacts to be received from other processors", +c & (ncont_recv(i),i=1,ntask_cont_from) +c call flush(iout) +C Receive contacts + ireq=0 + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + nn=ncont_recv(ii) +c write (iout,*) "Receiving",nn," contacts from processor",iproc, +c & " of CONT_TO_COMM group" + call flush(iout) + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, + & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) + endif + enddo +C Send the contacts to processors that need them + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + nn=ncont_sent(ii) +c write (iout,*) nn," contacts to processor",iproc, +c & " of CONT_TO_COMM group" + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, + & iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) +c do i=1,nn +c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) +c enddo + endif + enddo +c write (iout,*) "number of requests (contacts)",ireq +c write (iout,*) "req",(req(i),i=1,4) +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) + do iii=1,ntask_cont_from + iproc=itask_cont_from(iii) + nn=ncont_recv(iii) + if (lprn) then + write (iout,*) "Received",nn," contacts from processor",iproc, + & " of CONT_FROM_COMM group" + call flush(iout) + do i=1,nn + write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10) + enddo + call flush(iout) + endif + do i=1,nn + ii=zapas_recv(1,i,iii) +c Flag the received contacts to prevent double-counting + jj=-zapas_recv(2,i,iii) +c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj +c call flush(iout) + nnn=num_cont_hb(ii)+1 + num_cont_hb(ii)=nnn + jcont_hb(nnn,ii)=jj + d_cont(nnn,ii)=zapas_recv(3,i,iii) + ind=3 + do kk=1,3 + ind=ind+1 + grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii) + enddo + enddo + enddo + enddo + enddo + enddo + call flush(iout) + if (lprn) then + write (iout,'(a)') 'Contact function values after receive:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i3,5f6.3))') + & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), + & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + call flush(iout) + endif + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,5f6.3))') + & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), + & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 + ecorr5=0.0d0 + ecorr6=0.0d0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the dipole-dipole interaction energies + if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then + do i=iatel_s,iatel_e+1 + num_conti=num_cont_hb(i) + do jj=1,num_conti + j=jcont_hb(jj,i) +#ifdef MOMENT + call dipole(i,j,jj) +#endif + enddo + enddo + endif +C Calculate the local-electrostatic correlation terms +c write (iout,*) "gradcorr5 in eello5 before loop" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) +c write (iout,*) "corr loop i",i + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk +c if (j1.eq.j+1 .or. j1.eq.j-1) then + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 + & .or. j.lt.0 .and. j1.gt.0) .and. + & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + n_corr=n_corr+1 + sqd1=dsqrt(d_cont(jj,i)) + sqd2=dsqrt(d_cont(kk,i1)) + sred_geom = sqd1*sqd2 + IF (sred_geom.lt.cutoff_corr) THEN + call gcont(sred_geom,r0_corr,1.0D0,delt_corr, + & ekont,fprimcont) +cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, +cd & ' jj=',jj,' kk=',kk + fac_prim1=0.5d0*sqd2/sqd1*fprimcont + fac_prim2=0.5d0*sqd1/sqd2*fprimcont + do l=1,3 + g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) + g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) + enddo + n_corr1=n_corr1+1 +cd write (iout,*) 'sred_geom=',sred_geom, +cd & ' ekont=',ekont,' fprim=',fprimcont, +cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 +cd write (iout,*) "g_contij",g_contij +cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) +cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) + call calc_eello(i,jp,i+1,jp1,jj,kk) + if (wcorr4.gt.0.0d0) + & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) + if (energy_dec.and.wcorr4.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 before eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (wcorr5.gt.0.0d0) + & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 after eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (energy_dec.and.wcorr5.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) +cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 +cd write(2,*)'ijkl',i,jp,i+1,jp1 + if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 + & .or. wturn6.eq.0.0d0))then +cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 + ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) +cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, +cd & 'ecorr6=',ecorr6 +cd write (iout,'(4e15.5)') sred_geom, +cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) + else if (wturn6.gt.0.0d0 + & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then +cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 + eturn6=eturn6+eello_turn6(i,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) +cd write (2,*) 'multibody_eello:eturn6',eturn6 + endif + ENDIF +1111 continue + endif + enddo ! kk + enddo ! jj + enddo ! i + do i=1,nres + num_cont_hb(i)=num_cont_hb_old(i) + enddo +c write (iout,*) "gradcorr5 in eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + return + end +c------------------------------------------------------------------------------ + subroutine add_hb_contact_eello(ii,jj,itask) + implicit real*8 (a-h,o-z) + include "DIMENSIONS" + include "COMMON.IOUNITS" + integer max_cont + integer max_dim + parameter (max_cont=maxconts) + parameter (max_dim=70) + include "COMMON.CONTACTS" + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer i,j,ii,jj,iproc,itask(4),nn +c write (iout,*) "itask",itask + do i=1,2 + iproc=itask(i) + if (iproc.gt.0) then + do j=1,num_cont_hb(ii) + jjc=jcont_hb(j,ii) +c write (iout,*) "send turns i",ii," j",jj," jjc",jjc + if (jjc.eq.jj) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=ii + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=d_cont(j,ii) + ind=3 + do kk=1,3 + ind=ind+1 + zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii) + enddo + enddo + enddo + enddo + exit + endif + enddo + endif + enddo + return + end +c------------------------------------------------------------------------------ + double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont_hb(jj,i) + ekl=facont_hb(kk,k) + ees0pij=ees0p(jj,i) + ees0pkl=ees0p(kk,k) + ees0mij=ees0m(jj,i) + ees0mkl=ees0m(kk,k) + ekont=eij*ekl + ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) +cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) +C Following 4 lines for diagnostics. +cd ees0pkl=0.0D0 +cd ees0pij=1.0D0 +cd ees0mkl=0.0D0 +cd ees0mij=1.0D0 +c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') +c & 'Contacts ',i,j, +c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l +c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, +c & 'gradcorr_long' +C Calculate the multi-body contribution to energy. +c ecorr=ecorr+ekont*ees +C Calculate multi-body contributions to the gradient. + coeffpees0pij=coeffp*ees0pij + coeffmees0mij=coeffm*ees0mij + coeffpees0pkl=coeffp*ees0pkl + coeffmees0mkl=coeffm*ees0mkl + do ll=1,3 +cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb1(ll,jj,i)) + gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb2(ll,jj,i)) +cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ + & coeffmees0mij*gacontm_hb1(ll,kk,k)) + gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ + & coeffmees0mij*gacontm_hb2(ll,kk,k)) + gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- + & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb3(ll,jj,i)) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij + gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- + & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ + & coeffmees0mij*gacontm_hb3(ll,kk,k)) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl +c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl + enddo +c write (iout,*) +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*ekl*gacont_hbr(ll,jj,i)- +cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ +cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*eij*gacont_hbr(ll,kk,k)- +cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ +cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) +cgrad enddo +cgrad enddo +c write (iout,*) "ehbcorr",ekont*ees + ehbcorr=ekont*ees + return + end +#ifdef MOMENT +C--------------------------------------------------------------------------- + subroutine dipole(i,j,jj) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), + & auxmat(2,2) + iti1 = itortyp(itype(i+1)) + if (j.lt.nres-1) then + itj1 = itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + do iii=1,2 + dipi(iii,1)=Ub2(iii,i) + dipderi(iii)=Ub2der(iii,i) + dipi(iii,2)=b1(iii,iti1) + dipj(iii,1)=Ub2(iii,j) + dipderj(iii)=Ub2der(iii,j) + dipj(iii,2)=b1(iii,itj1) + enddo + kkk=0 + do iii=1,2 + call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) + do jjj=1,2 + kkk=kkk+1 + dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + do kkk=1,5 + do lll=1,3 + mmm=0 + do iii=1,2 + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), + & auxvec(1)) + do jjj=1,2 + mmm=mmm+1 + dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + enddo + enddo + call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) + call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) + do iii=1,2 + dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) + enddo + call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) + do iii=1,2 + dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) + enddo + return + end +#endif +C--------------------------------------------------------------------------- + subroutine calc_eello(i,j,k,l,jj,kk) +C +C This subroutine computes matrices and vectors needed to calculate +C the fourth-, fifth-, and sixth-order local-electrostatic terms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), + & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) + logical lprn + common /kutas/ lprn +cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, +cd & ' jj=',jj,' kk=',kk +cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return +cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) +cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) + do iii=1,2 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) + enddo + enddo + call transpose2(aa1(1,1),aa1t(1,1)) + call transpose2(aa2(1,1),aa2t(1,1)) + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), + & aa1tder(1,1,lll,kkk)) + call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), + & aa2tder(1,1,lll,kkk)) + enddo + enddo + if (l.eq.j+1) then +C parallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itj=itortyp(itype(j)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +C A1 kernel(j+1) A2T +cd do iii=1,2 +cd write (iout,'(3f10.5,5x,3f10.5)') +cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) +cd enddo + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), + & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + lprn=.false. + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), + & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants +cd lprn=.false. +cd if (lprn) then +cd write (2,*) 'In calc_eello6' +cd do iii=1,2 +cd write (2,*) 'iii=',iii +cd do kkk=1,5 +cd write (2,*) 'kkk=',kkk +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) +cd enddo +cd enddo +cd enddo +cd endif + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A1T kernel(i+1) A2 + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + else +C Antiparallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i)) + else + iti=ntortyp+1 + endif + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif +C A2 kernel(j-1)T A1T + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), + & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), + & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A2T kernel(i+1)T A1 + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. + & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) + call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) + call transpose2(AEAderg(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) + call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) + call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) + call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) + call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) + call transpose2(AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) + call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) + call transpose2(AEAderg(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) + call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,iti), + & AEAb1derx(1,lll,kkk,iii,1,1)) + call matvec2(auxmat(1,1),Ub2(1,i), + & AEAb2derx(1,lll,kkk,iii,1,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & AEAb1derx(1,lll,kkk,iii,2,1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), + & AEAb2derx(1,lll,kkk,iii,2,1)) + call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,itl), + & AEAb1derx(1,lll,kkk,iii,1,2)) + call matvec2(auxmat(1,1),Ub2(1,l), + & AEAb2derx(1,lll,kkk,iii,1,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + endif + return + end +C--------------------------------------------------------------------------- + subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, + & KK,KKderg,AKA,AKAderg,AKAderx) + implicit none + integer nderg + logical transp + double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), + & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), + & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) + integer iii,kkk,lll + integer jjj,mmm + logical lprn + common /kutas/ lprn + call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) + do iii=1,nderg + call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, + & AKAderg(1,1,iii)) + enddo +cd if (lprn) write (2,*) 'In kernel' + do kkk=1,5 +cd if (lprn) write (2,*) 'kkk=',kkk + do lll=1,3 + call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=1' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) +cd enddo +cd endif + call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=2' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) +cd enddo +cd endif + enddo + enddo + return + end +C--------------------------------------------------------------------------- + double precision function eello4(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then +cd eello4=0.0d0 +cd return +cd endif +cd print *,'eello4:',i,j,k,l,jj,kk +cd write (2,*) 'i',i,' j',j,' k',k,' l',l +cd call checkint4(i,j,k,l,jj,kk,eel4_num) +cold eij=facont_hb(jj,i) +cold ekl=facont_hb(kk,k) +cold ekont=eij*ekl + eel4=-EAEA(1,1,1)-EAEA(2,2,1) +cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) + gcorr_loc(k-1)=gcorr_loc(k-1) + & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) + if (l.eq.j+1) then + gcorr_loc(l-1)=gcorr_loc(l-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + else + gcorr_loc(j-1)=gcorr_loc(j-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) + & -EAEAderx(2,2,lll,kkk,iii,1) +cd derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd gcorr_loc(l-1)=0.0d0 +cd gcorr_loc(j-1)=0.0d0 +cd gcorr_loc(k-1)=0.0d0 +cd eel4=1.0d0 +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l, +cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel4*g_contij(ll,1) +cgrad ggg2(ll)=eel4*g_contij(ll,2) + glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) + glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) +cgrad ghalf=0.5d0*ggg1(ll) + gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) + gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) + gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) + gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij +cgrad ghalf=0.5d0*ggg2(ll) + gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) + gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) + gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) + gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl + enddo +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,gcorr_loc(iii) +cd enddo + eello4=ekont*eel4 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello4',ekont*eel4 + return + end +C--------------------------------------------------------------------------- + double precision function eello5(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) + double precision ggg1(3),ggg2(3) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel chains C +C C +C o o o o C +C /l\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j| o |l1 | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C Antiparallel chains C +C C +C o o o o C +C /j\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j1| o |l | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C o denotes a local interaction, vertical lines an electrostatic interaction. C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then +cd eello5=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + itk=itortyp(itype(k)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) + eello5_1=0.0d0 + eello5_2=0.0d0 + eello5_3=0.0d0 + eello5_4=0.0d0 +cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, +cd & eel5_3_num,eel5_4_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l +cd goto 1111 +C Contribution from the graph I. +cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) +cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) +C Explicit gradient in virtual-dihedral angles. + if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + if (l.eq.j+1) then + if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + else + if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + enddo + enddo + enddo +c goto 1112 +c1111 continue +C Contribution from graph II + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + if (l.eq.j+1) then + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + else + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + enddo + enddo + enddo +cd goto 1112 +cd1111 continue + if (l.eq.j+1) then +cd goto 1110 +C Parallel orientation +C Contribution from graph III + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) + call transpose2(EUgder(1,1,l),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + enddo + enddo + enddo +cd goto 1112 +C Contribution from graph IV +cd1110 continue + call transpose2(EE(1,1,itl),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + enddo + enddo + enddo + else +C Antiparallel orientation +C Contribution from graph III +c goto 1110 + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) + call transpose2(EUgder(1,1,j),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + enddo + enddo + enddo +cd goto 1112 +C Contribution from graph IV +1110 continue + call transpose2(EE(1,1,itj),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + enddo + enddo + enddo + endif +1112 continue + eel5=eello5_1+eello5_2+eello5_3+eello5_4 +cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then +cd write (2,*) 'ijkl',i,j,k,l +cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, +cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 +cd endif +cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num +cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num +cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num +cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 +cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont +C 2/11/08 AL Gradients over DC's connecting interacting sites will be +C summed up outside the subrouine as for the other subroutines +C handling long-range interactions. The old code is commented out +C with "cgrad" to keep track of changes. + do ll=1,3 +cgrad ggg1(ll)=eel5*g_contij(ll,1) +cgrad ggg2(ll)=eel5*g_contij(ll,2) + gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) +c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') +c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), +c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), +c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont +c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') +c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), +c & gradcorr5ij, +c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl +cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) + gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) + gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) + gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) + gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij + gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij +cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) + gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) + gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) + gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) + gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl + gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +c1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr5_loc(iii) +cd enddo + eello5=ekont*eel5 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello5',ekont*eel5 + return + end +c-------------------------------------------------------------------------- + double precision function eello6(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + eello6_1=0.0d0 + eello6_2=0.0d0 + eello6_3=0.0d0 + eello6_4=0.0d0 + eello6_5=0.0d0 + eello6_6=0.0d0 +cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, +cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + if (l.eq.j+1) then + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(j,i,l,k,2,.false.) + eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) + eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) + else + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(l,k,j,i,2,.true.) + eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + if (wturn6.eq.0.0d0 .or. j.ne.i+4) then + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) + else + eello6_5=0.0d0 + endif + eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) + endif +C If turn contributions are considered, they will be handled separately. + eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 +cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num +cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num +cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num +cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num +cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num +cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel6*g_contij(ll,1) +cgrad ggg2(ll)=eel6*g_contij(ll,2) +cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) + gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) + gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) + gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) + gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) + gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij + gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij +cgrad ghalf=0.5d0*ggg2(ll) +cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) +cd ghalf=0.0d0 + gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) + gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) + gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) + gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) + gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl + gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + eello6=ekont*eel6 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello6',ekont*eel6 + return + end +c-------------------------------------------------------------------------- + double precision function eello6_graph1(i,j,k,l,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) + logical swap + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Parallel Antiparallel +C +C o o +C /l\ /j\ +C / \ / \ +C /| o | | o |\ +C \ j|/k\| / \ |/k\|l / +C \ / \ / \ / \ / +C o o o o +C i i +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itortyp(itype(k)) + s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) + vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) + & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) + & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) + & +scalar2(vv(1),Dtobr2der(1,i))) + call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) + vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) + if (l.eq.j+1) then + g_corr6_loc(l-1)=g_corr6_loc(l-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1) + & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) + & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) + endif + call transpose2(EUgCder(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) + & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) + & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) + do iii=1,2 + if (swap) then + ind=3-iii + else + ind=iii + endif + do kkk=1,5 + do lll=1,3 + s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) + & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) + vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) + & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) + s5=scalar2(vv(1),Dtobr2(1,i)) + derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph2(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + logical swap + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxvec2(2),auxmat1(2,2) + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C \ /l\ /j\ / C +C \ / \ / \ / C +C o| o | | o |o C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l +C AL 7/4/01 s1 would occur in the sixth-order moment, +C but not in a cluster cumulant +#ifdef MOMENT + s1=dip(1,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph2=-(s1+s2+s3+s4) +#else + eello6_graph2=-(s2+s3+s4) +#endif +c eello6_graph2=-s3 +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + s1=dipderg(1,jj,i)*dip(1,kk,k) +#endif + s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 +C Derivatives in gamma(j-1) or gamma(l-1) + if (j.gt.1) then +#ifdef MOMENT + s1=dipderg(3,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) + call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + endif +#endif + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) +c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 + endif +C Derivatives in gamma(l-1) or gamma(j-1) + if (l.gt.1) then +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(3,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + else + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + endif +#endif + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) +c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 + endif +C Cartesian derivatives. + if (lprn) then + write (2,*) 'In eello6_graph2' + do iii=1,2 + write (2,*) 'iii=',iii + do kkk=1,5 + write (2,*) 'kkk=',kkk + do jjj=1,2 + write (2,'(3(2f10.5),5x)') + & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) + enddo + enddo + enddo + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) + else + s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) + endif +#endif + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), + & auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), + & auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph3(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C j|/k\| / |/k\|l / C +C / \ / / \ / C +C / o / o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call transpose2(EE(1,1,itk),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, +cd & "sum",-(s2+s3+s4) +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else + eello6_graph3=-(s2+s3+s4) +#endif +c eello6_graph3=-s4 +C Derivatives in gamma(k-1) + call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) +C Derivatives in gamma(l-1) + call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) + else + s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), + & auxvec(1)) + s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) + call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), + & auxvec(1)) + s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) + call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif +c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxmat1(2,2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o \ o \ C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. +cd write (2,*) 'eello_graph4: wturn6',wturn6 + iti=itortyp(itype(i)) + itj=itortyp(itype(j)) + if (j.lt.nres-1) then + itj1=itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif + itk=itortyp(itype(k)) + if (k.lt.nres-1) then + itk1=itortyp(itype(k+1)) + else + itk1=ntortyp+1 + endif + itl=itortyp(itype(l)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1)) + else + itl1=ntortyp+1 + endif +cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l +cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, +cd & ' itl',itl,' itl1',itl1 +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dip(3,kk,k) + else + s1=dip(2,jj,j)*dip(2,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph4=-(s1+s2+s3+s4) +#else + eello6_graph4=-(s2+s3+s4) +#endif +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + if (imat.eq.1) then + s1=dipderg(2,jj,i)*dip(3,kk,k) + else + s1=dipderg(4,jj,j)*dip(2,kk,l) + endif +#endif + s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +cd write (2,*) 'turn6 derivatives' +#ifdef MOMENT + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif + endif + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderg(2,kk,k) + else + s1=dip(2,jj,j)*dipderg(4,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) + endif + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif + endif +C Derivatives in gamma(j-1) or gamma(l-1) + if (l.eq.j+1 .and. l.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) + else if (j.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then + gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) + endif + endif +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + if (imat.eq.1) then + s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) + else + s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) + endif + else + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) + else + s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) + endif + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), + & auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itj1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) + else + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,itl1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) + endif + call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (swap) then + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s1+s2+s4) +#else + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s2+s4) +#endif + derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 + else +#ifdef MOMENT + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) +#else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) +#endif + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + else +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (l.eq.j+1) then + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + endif + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello_turn6(i,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), + & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), + & ggg1(3),ggg2(3) + double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), + & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) +C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to +C the respective energy moment and not to the cluster cumulant. + s1=0.0d0 + s8=0.0d0 + s13=0.0d0 +c + eello_turn6=0.0d0 + j=i+4 + k=i+1 + l=i+3 + iti=itortyp(itype(i)) + itk=itortyp(itype(k)) + itk1=itortyp(itype(k+1)) + itl=itortyp(itype(l)) + itj=itortyp(itype(j)) +cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj +cd write (2,*) 'i',i,' k',k,' j',j,' l',l +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l +cd call checkint_turn6(i,jj,kk,eel_turn6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx_turn(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) +cd eello6_5=0.0d0 +cd write (2,*) 'eello6_5',eello6_5 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) + ss1=scalar2(Ub2(1,i+2),b1(1,itl)) + s1 = (auxmat(1,1)+auxmat(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) + s2 = scalar2(b1(1,itk),vtemp1(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atemp(1,1)) + call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) + call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) + s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) + call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) + s12 = scalar2(Ub2(1,i+2),vtemp3(1)) +#ifdef MOMENT + call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) + call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) + call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) + ss13 = scalar2(b1(1,itk),vtemp4(1)) + s13 = (gtemp(1,1)+gtemp(2,2))*ss13 +#endif +c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 +c s1=0.0d0 +c s2=0.0d0 +c s8=0.0d0 +c s12=0.0d0 +c s13=0.0d0 + eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) +C Derivatives in gamma(i+2) + s1d =0.0d0 + s8d =0.0d0 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 + call transpose2(AEAderg(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 + gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) +C Derivatives in gamma(i+3) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d +#endif + call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) + s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) +#endif + s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Derivatives in gamma(i+4) + call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +C s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) +#else + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) +#endif +C Derivatives in gamma(i+5) +#ifdef MOMENT + call transpose2(AEAderg(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) + call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEA(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Cartesian derivatives + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), + & vtemp1d(1)) + s2d = scalar2(b1(1,itk),vtemp1d(1)) +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))* + & scalar2(cc(1,1,itl),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), + & auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*(s1d+s2d) +#else + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*s2d +#endif +#ifdef MOMENT + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*(s8d+s12d) +#else + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*s12d +#endif + enddo + enddo + enddo +#ifdef MOMENT + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), + & achuj_tempd(1,1)) + call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d=(gtempd(1,1)+gtempd(2,2))*ss13 + derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), + & vtemp4d(1)) + ss13d = scalar2(b1(1,itk),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d + derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d + enddo + enddo +#endif +cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', +cd & 16*eel_turn6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel_turn6*g_contij(ll,1) +cgrad ggg2(ll)=eel_turn6*g_contij(ll,2) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) + gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) + gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf + & +ekont*derx_turn(ll,2,1) + gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) + gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf + & +ekont*derx_turn(ll,4,1) + gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) + gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij + gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf + & +ekont*derx_turn(ll,2,2) + gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) + gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf + & +ekont*derx_turn(ll,4,2) + gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) + gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl + gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + eello_turn6=ekont*eel_turn6 +cd write (2,*) 'ekont',ekont +cd write (2,*) 'eel_turn6',ekont*eel_turn6 + return + end + +C----------------------------------------------------------------------------- + double precision function scalar(u,v) +!DIR$ INLINEALWAYS scalar +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::scalar +#endif + implicit none + double precision u(3),v(3) +cd double precision sc +cd integer i +cd sc=0.0d0 +cd do i=1,3 +cd sc=sc+u(i)*v(i) +cd enddo +cd scalar=sc + + scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) + return + end +crc------------------------------------------------- + SUBROUTINE MATVEC2(A1,V1,V2) +!DIR$ INLINEALWAYS MATVEC2 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2 +#endif + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),V1(2),V2(2) +c DO 1 I=1,2 +c VI=0.0 +c DO 3 K=1,2 +c 3 VI=VI+A1(I,K)*V1(K) +c Vaux(I)=VI +c 1 CONTINUE + + vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) + vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) + + v2(1)=vaux1 + v2(2)=vaux2 + END +C--------------------------------------- + SUBROUTINE MATMAT2(A1,A2,A3) +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2 +#endif + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),A2(2,2),A3(2,2) +c DIMENSION AI3(2,2) +c DO J=1,2 +c A3IJ=0.0 +c DO K=1,2 +c A3IJ=A3IJ+A1(I,K)*A2(K,J) +c enddo +c A3(I,J)=A3IJ +c enddo +c enddo + + ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) + ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) + ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) + ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) + + A3(1,1)=AI3_11 + A3(2,1)=AI3_21 + A3(1,2)=AI3_12 + A3(2,2)=AI3_22 + END + +c------------------------------------------------------------------------- + double precision function scalar2(u,v) +!DIR$ INLINEALWAYS scalar2 + implicit none + double precision u(2),v(2) + double precision sc + integer i + scalar2=u(1)*v(1)+u(2)*v(2) + return + end + +C----------------------------------------------------------------------------- + + subroutine transpose2(a,at) +!DIR$ INLINEALWAYS transpose2 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::transpose2 +#endif + implicit none + double precision a(2,2),at(2,2) + at(1,1)=a(1,1) + at(1,2)=a(2,1) + at(2,1)=a(1,2) + at(2,2)=a(2,2) + return + end +c-------------------------------------------------------------------------- + subroutine transpose(n,a,at) + implicit none + integer n,i,j + double precision a(n,n),at(n,n) + do i=1,n + do j=1,n + at(j,i)=a(i,j) + enddo + enddo + return + end +C--------------------------------------------------------------------------- + subroutine prodmat3(a1,a2,kk,transp,prod) +!DIR$ INLINEALWAYS prodmat3 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::prodmat3 +#endif + implicit none + integer i,j + double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) + logical transp +crc double precision auxmat(2,2),prod_(2,2) + + if (transp) then +crc call transpose2(kk(1,1),auxmat(1,1)) +crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) + + else +crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) + + endif +c call transpose2(a2(1,1),a2t(1,1)) + +crc print *,transp +crc print *,((prod_(i,j),i=1,2),j=1,2) +crc print *,((prod(i,j),i=1,2),j=1,2) + + return + end +