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