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) ipot C Lennard-Jones potential. 101 call elj(evdw,evdw_p,evdw_m) cd print '(a)','Exit ELJ' goto 107 C Lennard-Jones-Kihara potential (shifted). 102 call eljk(evdw,evdw_p,evdw_m) goto 107 C Berne-Pechukas potential (dilated LJ, angular dependence). 103 call ebp(evdw,evdw_p,evdw_m) goto 107 C Gay-Berne potential (shifted LJ, angular dependence). 104 call egb(evdw,evdw_p,evdw_m) goto 107 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). 105 call egbv(evdw,evdw_p,evdw_m) goto 107 C Soft-sphere potential 106 call e_softsphere(evdw) C C Calculate electrostatic (H-bonding) energy of the main chain. C 107 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.6) 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.6) 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.6) 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.6) 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 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 (ri' 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 /.true./ etheta=0.0D0 do i=ithet_start,ithet_end if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. &(itype(i).eq.ntyp1)) cycle 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 c lprn1=.true. if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)') & 'ebe', i,theta(i)*rad2deg,phii*rad2deg, & phii1*rad2deg,ethetai c lprn1=.false. 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 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle 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) c do intertyp=1,3 !intertyp do intertyp=2,2 !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_sc(2,i,icg), c & gloc_sc(3,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