module energy !----------------------------------------------------------------------------- use io_units use names use math use MPI_data use energy_data use control_data use geometry_data use geometry ! implicit none !----------------------------------------------------------------------------- ! Max. number of contacts per residue ! integer :: maxconts !----------------------------------------------------------------------------- ! Max. number of derivatives of virtual-bond and side-chain vectors in theta ! or phi. ! integer :: maxdim !----------------------------------------------------------------------------- ! Max. number of SC contacts ! integer :: maxcont !----------------------------------------------------------------------------- ! Max. number of variables integer :: maxvar !----------------------------------------------------------------------------- ! Max number of torsional terms in SCCOR in control_data ! integer,parameter :: maxterm_sccor=6 !----------------------------------------------------------------------------- ! Maximum number of SC local term fitting function coefficiants integer,parameter :: maxsccoef=65 !----------------------------------------------------------------------------- ! commom.calc common/calc/ !----------------------------------------------------------------------------- ! commom.contacts ! common /contacts/ ! Change 12/1/95 - common block CONTACTS1 included. ! common /contacts1/ integer,dimension(:),allocatable :: num_cont !(maxres) integer,dimension(:,:),allocatable :: jcont !(maxconts,maxres) real(kind=8),dimension(:,:),allocatable :: facont !(maxconts,maxres) real(kind=8),dimension(:,:,:),allocatable :: gacont !(3,maxconts,maxres) ! ! 12/26/95 - H-bonding contacts ! common /contacts_hb/ real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,& gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont !(3,maxconts,maxres) real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,& ees0m,d_cont !(maxconts,maxres) integer,dimension(:),allocatable :: num_cont_hb !(maxres) integer,dimension(:,:),allocatable :: jcont_hb !(maxconts,maxres) ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole ! interactions ! 7/25/08 commented out; not needed when cumulants used ! Interactions of pseudo-dipoles generated by loc-el interactions. ! common /dipint/ real(kind=8),dimension(:,:,:),allocatable :: dip,& dipderg !(4,maxconts,maxres) real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres) ! 10/30/99 Added other pre-computed vectors and matrices needed ! to calculate three - six-order el-loc correlation terms ! common /rotat/ real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der !(2,2,maxres) real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,& obrot2_der !(2,maxres) ! ! This common block contains vectors and matrices dependent on a single ! amino-acid residue. ! common /precomp1/ real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,& Ctobr,Ctobrder,Dtobr2,Dtobr2der !(2,maxres) real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,& CUgder,DUg,Dugder,DtUg2,DtUg2der !(2,2,maxres) ! This common block contains vectors and matrices dependent on two ! consecutive amino-acid residues. ! common /precomp2/ real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,& CUgb2,CUgb2der !(2,maxres) real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,& EUgD,EUgDder,DtUg2EUg,Ug2DtEUg !(2,2,maxres) real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,& DtUg2EUgder !(2,2,2,maxres) ! common /rotat_old/ real(kind=8),dimension(:),allocatable :: costab,sintab,& costab2,sintab2 !(maxres) ! This common block contains dipole-interaction matrices and their ! Cartesian derivatives. ! common /dipmat/ real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj !(2,2,maxconts,maxres) real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der !(2,2,3,5,maxconts,maxres) ! common /diploc/ real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,& AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2 real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,& ADtEA1derg,AEAb2derg real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,& AECAderx,ADtEAderx,ADtEA1derx real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx real(kind=8),dimension(3,2) :: g_contij real(kind=8) :: ekont ! 12/13/2008 (again Poland-Jaruzel war anniversary) ! RE: Parallelization of 4th and higher order loc-el correlations ! common /contdistrib/ integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres) ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb !----------------------------------------------------------------------------- ! commom.deriv; ! common /derivat/ ! real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim) ! real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres) ! real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2) real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,& gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,& gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,& gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6 !(3,maxres) ! real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2) real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,& gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres) real(kind=8),dimension(:),allocatable :: gel_loc_loc,& gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,& g_corr6_loc !(maxvar) real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres) real(kind=8),dimension(:),allocatable :: gsccor_loc !(maxres) ! real(kind=8),dimension(:,:,:),allocatable :: dtheta !(3,2,maxres) real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres) ! real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres) ! integer :: nfl,icg ! common /deriv_loc/ real(kind=8),dimension(3,5,2) :: derx,derx_turn ! common /deriv_scloc/ real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,& dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,& dZZ_XYZtab !(3,maxres) !----------------------------------------------------------------------------- ! common.maxgrad ! common /maxgrad/ real(kind=8) :: 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 !----------------------------------------------------------------------------- ! common.MD ! common /back_constr/ real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres) real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres) ! common /qmeas/ real(kind=8) :: Ucdfrag,Ucdpair real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,& dqwol,dxqwol !(3,0:MAXRES) !----------------------------------------------------------------------------- ! common.sbridge ! common /dyn_ssbond/ real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres) !----------------------------------------------------------------------------- ! common.sccor ! Parameters of the SCCOR term ! common/sccor/ real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,& dcosomicron,domicron !(3,3,3,maxres2) !----------------------------------------------------------------------------- ! common.vectors ! common /vectors/ real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres) real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres) !----------------------------------------------------------------------------- ! common /przechowalnia/ real(kind=8),dimension(:,:,:),allocatable :: zapas !(max_dim,maxconts,max_fg_procs) real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2) !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! ! !----------------------------------------------------------------------------- contains !----------------------------------------------------------------------------- ! energy_p_new_barrier.F !----------------------------------------------------------------------------- subroutine etotal(energia) ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' use MD_data, only: totT #ifndef ISNAN external proc_proc #ifdef WINPGI !MS$ATTRIBUTES C :: proc_proc #endif #endif #ifdef MPI include "mpif.h" #endif ! include 'COMMON.SETUP' ! include 'COMMON.IOUNITS' real(kind=8),dimension(0:n_ene) :: energia ! 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' real(kind=8) :: time00 !el local variables integer :: n_corr,n_corr1,ierror real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc real(kind=8) :: eello_turn3,eello_turn4,estr,ebe real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6 #ifdef MPI real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw ! print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, ! & " nfgtasks",nfgtasks if (nfgtasks.gt.1) then time00=MPI_Wtime() ! 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) ! print *,"Processor",myrank," BROADCAST iorder" ! FG master sets up the WEIGHTS_ array which will be broadcast to the ! 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 ! FG Master broadcasts the WEIGHTS_ array call MPI_Bcast(weights_(1),n_ene,& MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) else ! 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) endif time_Bcast=time_Bcast+MPI_Wtime()-time00 time_Bcastw=time_Bcastw+MPI_Wtime()-time00 ! call chainbuild_cart endif ! print *,'Processor',myrank,' calling etotal ipot=',ipot ! print *,'Processor',myrank,' nnt=',nnt,' nct=',nct #else ! if (modecalc.eq.12.or.modecalc.eq.14) then ! call int_from_cart1(.false.) ! endif #endif #ifdef TIMING time00=MPI_Wtime() #endif ! ! Compute the side-chain and electrostatic interaction energy ! ! goto (101,102,103,104,105,106) ipot select case(ipot) ! Lennard-Jones potential. ! 101 call elj(evdw) case (1) call elj(evdw) !d print '(a)','Exit ELJcall el' ! goto 107 ! Lennard-Jones-Kihara potential (shifted). ! 102 call eljk(evdw) case (2) call eljk(evdw) ! goto 107 ! Berne-Pechukas potential (dilated LJ, angular dependence). ! 103 call ebp(evdw) case (3) call ebp(evdw) ! goto 107 ! Gay-Berne potential (shifted LJ, angular dependence). ! 104 call egb(evdw) case (4) call egb(evdw) ! goto 107 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). ! 105 call egbv(evdw) case (5) call egbv(evdw) ! goto 107 ! Soft-sphere potential ! 106 call e_softsphere(evdw) case (6) call e_softsphere(evdw) ! ! Calculate electrostatic (H-bonding) energy of the main chain. ! ! 107 continue case default write(iout,*)"Wrong ipot" ! return ! 50 continue end select ! continue !mc !mc Sep-06: egb takes care of dynamic ss bonds too !mc ! if (dyn_ss) call dyn_set_nss ! print *,"Processor",myrank," computed USCSC" #ifdef TIMING time01=MPI_Wtime() #endif call vec_and_deriv #ifdef TIMING time_vec=time_vec+MPI_Wtime()-time01 #endif ! 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) ! write (iout,*) "ELEC calc" else ees=0.0d0 evdw1=0.0d0 eel_loc=0.0d0 eello_turn3=0.0d0 eello_turn4=0.0d0 endif else ! write (iout,*) "Soft-spheer ELEC potential" call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,& eello_turn4) endif ! print *,"Processor",myrank," computed UELEC" ! ! Calculate excluded-volume interaction energy between peptide groups ! and side chains. ! !elwrite(iout,*) "in etotal calc exc;luded",ipot if (ipot.lt.6) then if(wscp.gt.0d0) then call escp(evdw2,evdw2_14) else evdw2=0 evdw2_14=0 endif else ! write (iout,*) "Soft-sphere SCP potential" call escp_soft_sphere(evdw2,evdw2_14) endif !elwrite(iout,*) "in etotal before ebond",ipot ! ! Calculate the bond-stretching energy ! call ebond(estr) !elwrite(iout,*) "in etotal afer ebond",ipot ! ! Calculate the disulfide-bridge and other energy and the contributions ! from other distance constraints. ! print *,'Calling EHPB' call edis(ehpb) !elwrite(iout,*) "in etotal afer edis",ipot ! print *,'EHPB exitted succesfully.' ! ! Calculate the virtual-bond-angle energy. ! if (wang.gt.0d0) then call ebend(ebe) else ebe=0 endif ! print *,"Processor",myrank," computed UB" ! ! Calculate the SC local energy. ! call esc(escloc) !elwrite(iout,*) "in etotal afer esc",ipot ! print *,"Processor",myrank," computed USC" ! ! Calculate the virtual-bond torsional energy. ! !d print *,'nterm=',nterm if (wtor.gt.0) then call etor(etors,edihcnstr) else etors=0 edihcnstr=0 endif ! print *,"Processor",myrank," computed Utor" ! ! 6/23/01 Calculate double-torsional energy ! !elwrite(iout,*) "in etotal",ipot if (wtor_d.gt.0) then call etor_d(etors_d) else etors_d=0 endif ! print *,"Processor",myrank," computed Utord" ! ! 21/5/07 Calculate local sicdechain correlation energy ! if (wsccor.gt.0.0d0) then call eback_sc_corr(esccor) else esccor=0.0d0 endif ! print *,"Processor",myrank," computed Usccorr" ! ! 12/1/95 Multi-body terms ! 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) !d write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1, !d &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 else ecorr=0.0d0 ecorr5=0.0d0 ecorr6=0.0d0 eturn6=0.0d0 endif !elwrite(iout,*) "in etotal",ipot 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) !d write (iout,*) "multibody_hb ecorr",ecorr endif !elwrite(iout,*) "afeter multibody hb" ! print *,"Processor",myrank," computed Ucorr" ! ! If performing constraint dynamics, call the constraint energy ! after the equilibration time if(usampl.and.totT.gt.eq_time) then !elwrite(iout,*) "afeter multibody hb" call EconstrQ !elwrite(iout,*) "afeter multibody hb" call Econstr_back !elwrite(iout,*) "afeter multibody hb" else Uconst=0.0d0 Uconst_back=0.0d0 endif !elwrite(iout,*) "after Econstr" #ifdef TIMING time_enecalc=time_enecalc+MPI_Wtime()-time00 #endif ! print *,"Processor",myrank," computed Uconstr" #ifdef TIMING time00=MPI_Wtime() #endif ! ! Sum the energies ! 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 ! Here are the energies showed per procesor if the are more processors ! per molecule then we sum it up in sum_energy subroutine ! print *," Processor",myrank," calls SUM_ENERGY" call sum_energy(energia,.true.) if (dyn_ss) call dyn_set_nss ! print *," Processor",myrank," left SUM_ENERGY" #ifdef TIMING time_sumene=time_sumene+MPI_Wtime()-time00 #endif !el call enerprint(energia) !elwrite(iout,*)"finish etotal" return end subroutine etotal !----------------------------------------------------------------------------- subroutine sum_energy(energia,reduce) ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' #ifndef ISNAN external proc_proc #ifdef WINPGI !MS$ATTRIBUTES C :: proc_proc #endif #endif #ifdef MPI include "mpif.h" #endif ! include 'COMMON.SETUP' ! include 'COMMON.IOUNITS' real(kind=8) :: 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 real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6 real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot integer :: i #ifdef MPI integer :: ierr real(kind=8) :: time00 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 evdw=energia(1) #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 ! 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 ! call enerprint(energia) call flush(iout) return end subroutine sum_energy !----------------------------------------------------------------------------- subroutine rescale_weights(t_bath) ! implicit real*8 (a-h,o-z) #ifdef MPI include 'mpif.h' #endif ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.FFIELD' ! include 'COMMON.SBRIDGE' real(kind=8) :: kfac=2.4d0 real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644 !el local variables real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6 real(kind=8) :: T0=3.0d2 integer :: ierror ! facT=temp0/t_bath ! facT=2*temp0/(t_bath+temp0) if (rescale_mode.eq.0) then facT(1)=1.0d0 facT(2)=1.0d0 facT(3)=1.0d0 facT(4)=1.0d0 facT(5)=1.0d0 facT(6)=1.0d0 else if (rescale_mode.eq.1) then facT(1)=kfac/(kfac-1.0d0+t_bath/temp0) facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) #ifdef WHAM_RUN !#if defined(WHAM_RUN) || defined(CLUSTER) #if defined(FUNCTH) ! tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3) facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0 #elif defined(FUNCT) facT(6)=t_bath/T0 #else facT(6)=1.0d0 #endif #endif else if (rescale_mode.eq.2) then x=t_bath/temp0 x2=x*x x3=x2*x x4=x3*x x5=x4*x facT(1)=licznik/dlog(dexp(x)+dexp(-x)) facT(2)=licznik/dlog(dexp(x2)+dexp(-x2)) facT(3)=licznik/dlog(dexp(x3)+dexp(-x3)) facT(4)=licznik/dlog(dexp(x4)+dexp(-x4)) facT(5)=licznik/dlog(dexp(x5)+dexp(-x5)) #ifdef WHAM_RUN !#if defined(WHAM_RUN) || defined(CLUSTER) #if defined(FUNCTH) facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0 #elif defined(FUNCT) facT(6)=t_bath/T0 #else facT(6)=1.0d0 #endif #endif 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(1) wcorr=weights(4)*fact(3) wcorr5=weights(5)*fact(4) wcorr6=weights(6)*fact(5) wel_loc=weights(7)*fact(2) wturn3=weights(8)*fact(2) wturn4=weights(9)*fact(3) wturn6=weights(10)*fact(5) wtor=weights(13)*fact(1) wtor_d=weights(14)*fact(2) wsccor=weights(21)*fact(1) return end subroutine rescale_weights !----------------------------------------------------------------------------- subroutine enerprint(energia) ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.FFIELD' ! include 'COMMON.SBRIDGE' ! include 'COMMON.MD' real(kind=8) :: energia(0:n_ene) !el local variables real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor etot=energia(0) evdw=energia(1) 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=',1pD16.6,' (SC-SC)'/ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, & ' (SS bridges & dist. cnstr.)'/ & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & '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,wsccor,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 subroutine enerprint !----------------------------------------------------------------------------- subroutine elj(evdw) ! ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the LJ potential of interaction. ! ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' real(kind=8),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' real(kind=8),dimension(3) :: gg integer :: num_conti !el local variables integer :: i,itypi,iint,j,itypi1,itypj,k real(kind=8) :: rij,rcut,fcont,fprimcont,rrij real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij ! write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 ! allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2 ! allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4) ! allocate(facont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) ! allocate(gacont(3,nres/4,iatsc_s:iatsc_e)) !(3,maxconts,maxres) do i=iatsc_s,iatsc_e itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) ! Change 12/1/95 num_conti=0 ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) !d write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), !d & 'iend=',iend(i,iint) do j=istart(i,iint),iend(i,iint) itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi ! Change 12/1/95 to calculate four-body interactions rij=xj*xj+yj*yj+zj*zj rrij=1.0D0/rij ! 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 !d sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) !d epsi=bb(itypi,itypj)**2/aa(itypi,itypj) !d write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') !d & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), !d & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, !d & (c(k,i),k=1,3),(c(k,j),k=1,3) evdw=evdw+evdwij ! ! Calculate the components of the gradient in DC and X ! fac=-rrij*(e1+evdwij) gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) gvdwx(k,j)=gvdwx(k,j)+gg(k) gvdwc(k,i)=gvdwc(k,i)-gg(k) gvdwc(k,j)=gvdwc(k,j)+gg(k) enddo !grad do k=i,j-1 !grad do l=1,3 !grad gvdwc(l,k)=gvdwc(l,k)+gg(l) !grad enddo !grad enddo ! ! 12/1/95, revised on 5/20/97 ! ! Calculate the contact function. The ith column of the array JCONT will ! contain the numbers of atoms that make contacts with the atom I (of numbers ! greater than I). The arrays FACONT and GACONT will contain the values of ! the contact function and its derivative. ! ! Uncomment next line, if the correlation interactions include EVDW explicitly. ! if (j.gt.i+1 .and. evdwij.le.0.0D0) then ! 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) ! ! Check whether the SC's are not too far to make a contact. ! rcut=1.5d0*r0ij call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) ! Add a new contact, if the SC's are close enough, but not too close (ri' !grad do k=1,3 !grad ggg(k)=-ggg(k) ! Uncomment following line for SC-p interactions ! gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) !grad enddo !grad endif !grad do k=1,3 !grad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) !grad enddo !grad kstart=min0(i+1,j) !grad kend=max0(i-1,j-1) !d write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend !d write (iout,*) ggg(1),ggg(2),ggg(3) !grad do k=kstart,kend !grad do l=1,3 !grad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) !grad enddo !grad 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 subroutine escp_soft_sphere !----------------------------------------------------------------------------- subroutine escp(evdw2,evdw2_14) ! ! This subroutine calculates the excluded-volume interaction energy between ! peptide-group centers and side chains and its gradient in virtual-bond and ! side-chain vectors. ! ! 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' real(kind=8),dimension(3) :: ggg !el local variables integer :: i,iint,j,k,iteli,itypj real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,& e1,e2,evdwij evdw2=0.0D0 evdw2_14=0.0d0 !d print '(a)','Enter ESCP' !d write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e do i=iatscp_s,iatscp_e if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle 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=iabs(itype(j)) if (itypj.eq.ntyp1) cycle ! Uncomment following three lines for SC-p interactions ! xj=c(1,nres+j)-xi ! yj=c(2,nres+j)-yi ! zj=c(3,nres+j)-zi ! 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,2i3,3e11.3)') & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),& bad(itypj,iteli) ! ! Calculate contributions to the gradient in the virtual-bond and SC vectors. ! fac=-(evdwij+e1)*rrij ggg(1)=xj*fac ggg(2)=yj*fac ggg(3)=zj*fac !grad if (j.lt.i) then !d write (iout,*) 'ji' !grad do k=1,3 !grad ggg(k)=-ggg(k) ! Uncomment following line for SC-p interactions !cgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) ! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) !grad enddo !grad endif !grad do k=1,3 !grad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) !grad enddo !grad kstart=min0(i+1,j) !grad kend=max0(i-1,j-1) !d write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend !d write (iout,*) ggg(1),ggg(2),ggg(3) !grad do k=kstart,kend !grad do l=1,3 !grad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) !grad enddo !grad 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 !****************************************************************************** ! ! N O T E !!! ! ! To save time the factor EXPON has been extracted from ALL components ! of GVDWC and GRADX. Remember to multiply them by this factor before further ! use! ! !****************************************************************************** return end subroutine escp !----------------------------------------------------------------------------- subroutine edis(ehpb) ! ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. ! ! 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' real(kind=8),dimension(3) :: ggg !el local variables integer :: i,j,ii,jj,iii,jjj,k real(kind=8) :: fac,eij,rdis,ehpb,dd,waga ehpb=0.0D0 !d write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr !d write(iout,*)'link_start=',link_start,' link_end=',link_end if (link_end.eq.0) return do i=link_start,link_end ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a ! CA-CA distance used in regularization of structure. ii=ihpb(i) jj=jhpb(i) ! 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 ! write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, ! & dhpb(i),dhpb1(i),forcon(i) ! 24/11/03 AL: SS bridges handled separately because of introducing a specific ! distance and angle dependent SS bond potential. !mc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds if (.not.dyn_ss .and. i.le.nss) then ! 15/02/13 CC dynamic SSbond - additional check if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. & iabs(itype(jjj)).eq.1) then call ssbond_ene(iii,jjj,eij) ehpb=ehpb+2*eij !d write (iout,*) "eij",eij endif else ! Calculate the distance between the two points and its difference from the ! target distance. dd=dist(ii,jj) rdis=dd-dhpb(i) ! Get the force constant corresponding to this distance. waga=forcon(i) ! Calculate the contribution to energy. ehpb=ehpb+waga*rdis*rdis ! ! Evaluate gradient. ! fac=waga*rdis/dd !d print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, !d & ' waga=',waga,' fac=',fac do j=1,3 ggg(j)=fac*(c(j,jj)-c(j,ii)) enddo !d print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) ! If this is a SC-SC distance, we need to calculate the contributions to the ! 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 !grad do j=iii,jjj-1 !grad do k=1,3 !grad ghpbc(k,j)=ghpbc(k,j)+ggg(k) !grad enddo !grad 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 subroutine edis !----------------------------------------------------------------------------- subroutine ssbond_ene(i,j,eij) ! ! Calculate the distance and angle dependent SS-bond potential energy ! using a free-energy function derived based on RHF/6-31G** ab initio ! calculations of diethyl disulfide. ! ! A. Liwo and U. Kozlowska, 11/24/03 ! ! 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' real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg !el local variables integer :: i,j,itypi,itypj,k real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,& xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,& deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,& cosphi,ggk itypi=iabs(itype(i)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) ! dsci_inv=dsc_inv(itypi) dsci_inv=vbld_inv(nres+i) itypj=iabs(itype(j)) ! 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 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr ! write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, ! & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, ! & " 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 ! ! Calculate the components of the gradient in DC and X ! !grad do k=i,j-1 !grad do l=1,3 !grad ghpbc(l,k)=ghpbc(l,k)+gg(l) !grad enddo !grad enddo return end subroutine ssbond_ene !----------------------------------------------------------------------------- subroutine ebond(estr) ! ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds ! ! 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' real(kind=8),dimension(3) :: u,ud !el local variables integer :: i,j,iti,nbi,k real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,& uprod1,uprod2 estr=0.0d0 estr1=0.0d0 ! if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres) ! if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres) do i=ibondp_start,ibondp_end if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) do j=1,3 gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) & *dc(j,i-1)/vbld(i) enddo if (energy_dec) write(iout,*) & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax) else diff = vbld(i)-vbldp0 if (energy_dec) write (iout,*) & "estr bb",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 ! write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) endif enddo estr=0.5d0*AKP*estr+estr1 ! ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included ! do i=ibond_start,ibond_end iti=iabs(itype(i)) if (iti.ne.10 .and. iti.ne.ntyp1) then nbi=nbondterm(iti) if (nbi.eq.1) then diff=vbld(i+nres)-vbldsc0(1,iti) if (energy_dec) write (iout,*) & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,& 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 subroutine ebond #ifdef CRYST_THETA !----------------------------------------------------------------------------- subroutine ebend(etheta) ! ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral ! angles gamma and its derivatives in consecutive thetas and gammas. ! use comm_calcthet ! 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' !el real(kind=8) :: term1,term2,termm,diffak,ratak,& !el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& !el delthe0,sig0inv,sigtc,sigsqtc,delthec !el integer :: it !el common /calcthet/ term1,term2,termm,diffak,ratak,& !el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& !el delthe0,sig0inv,sigtc,sigsqtc,delthec,it !el local variables integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,& ichir21,ichir22 real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,& athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,& f1,fprim1,E_tc1,ethetai,E_theta,E_tc real(kind=8),dimension(2) :: y,z delta=0.02d0*pi ! time11=dexp(-2*time) ! time12=1.0d0 etheta=0.0D0 ! write (*,'(a,i2)') 'EBEND ICG=',icg do i=ithet_start,ithet_end if (itype(i-1).eq.ntyp1) cycle ! Zero the energy function and its derivative at 0 or pi. call splinthet(theta(i),0.5d0*delta,ss,ssd) it=itype(i-1) ichir1=isign(1,itype(i-2)) ichir2=isign(1,itype(i)) if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1)) if (itype(i).eq.10) ichir2=isign(1,itype(i-1)) if (itype(i-1).eq.10) then itype1=isign(10,itype(i-2)) ichir11=isign(1,itype(i-2)) ichir12=isign(1,itype(i-2)) itype2=isign(10,itype(i)) ichir21=isign(1,itype(i)) ichir22=isign(1,itype(i)) endif if (i.gt.3 .and. itype(i-2).ne.ntyp1) 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 .and. itype(i).ne.ntyp1) 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 ! Calculate the "mean" value of theta from the part of the distribution ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). ! 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,ichir1,ichir2) bthetk=bthet(k,it,ichir1,ichir2) if (it.eq.10) then athetk=athet(k,itype1,ichir11,ichir12) bthetk=bthet(k,itype2,ichir21,ichir22) endif 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) ! Derivatives of the "mean" values in gamma1 and gamma2. dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) & +athet(2,it,ichir1,ichir2)*y(1))*ss dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) & +bthet(2,it,ichir1,ichir2)*z(1))*ss if (it.eq.10) then dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) & +athet(2,itype1,ichir11,ichir12)*y(1))*ss dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss endif 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 ! Ufff.... We've done all this!!! return end subroutine ebend !----------------------------------------------------------------------------- subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc) use comm_calcthet ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.LOCAL' ! include 'COMMON.IOUNITS' !el real(kind=8) :: term1,term2,termm,diffak,ratak,& !el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& !el delthe0,sig0inv,sigtc,sigsqtc,delthec integer :: i,j,k real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc !el integer :: it !el common /calcthet/ term1,term2,termm,diffak,ratak,& !el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& !el delthe0,sig0inv,sigtc,sigsqtc,delthec,it !el local variables real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,& esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd ! Calculate the contributions to both Gaussian lobes. ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) ! The "polynomial part" of the "standard deviation" of this part of ! the distribution. sig=polthet(3,it) do j=2,0,-1 sig=sig*thet_pred_mean+polthet(j,it) enddo ! Derivative of the "interior part" of the "standard deviation of the" ! 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 ! Set the parameters of both Gaussian lobes of the distribution. ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) fac=sig*sig+sigc0(it) sigcsq=fac+fac sigc=1.0D0/sigcsq ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c sigsqtc=-4.0D0*sigcsq*sigtc ! print *,i,sig,sigtc,sigsqtc ! Following variable (sigtc) is d[sigma(t_c)]/dt_c sigtc=-sigtc/(fac*fac) ! 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 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and ! NaNs in taking the logarithm. We extract the largest exponent which is added ! to the energy (this being the log of the distribution) at the end of energy ! 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 ! The ratio between the gamma-independent and gamma-dependent lobes of ! 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) ! Let's differentiate it in thet_pred_mean NOW. aktc=ak*ratak ! Now put together the distribution terms to make complete distribution. termexp=term1+ak*term2 termpre=sigc+ak*sig0i ! Contribution of the bending energy from this theta is just the -log of ! the sum of the contributions from the two lobes and the pre-exponential ! factor. Simple enough, isn't it? ethetai=(-dlog(termexp)-termm+dlog(termpre)) ! NOW the derivatives!!! ! 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 subroutine theteng #else !----------------------------------------------------------------------------- subroutine ebend(etheta) ! ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral ! angles gamma and its derivatives in consecutive thetas and gammas. ! ab initio-derived potentials from ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 ! ! 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' real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble logical :: lprn=.false., lprn1=.false. !el local variables integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai real(kind=8) :: aux,etheta,ccl,ssl,scl,csl etheta=0.0D0 do i=ithet_start,ithet_end if (itype(i-1).eq.ntyp1) cycle if (iabs(itype(i+1)).eq.20) iblock=2 if (iabs(itype(i+1)).ne.20) iblock=1 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 .and. itype(i-2).ne.ntyp1) then #ifdef OSF phii=phi(i) if (phii.ne.phii) phii=150.0 #else phii=phi(i) #endif ityp1=ithetyp((itype(i-2))) ! propagation of chirality for glycine type 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 .and. itype(i).ne.ntyp1) 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,iblock) 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,iblock)*sinkt(k) dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) & *coskt(k) if (lprn) & write (iout,*) "k",k,& "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),& " 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,iblock)*cosph1(k) & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*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,iblock)*cosph1(k)- & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)) dephii1=dephii1+k*sinkt(m)* & (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)) if (lprn) & write (iout,*) "m",m," k",k," bbthet", & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", & eethet(k,m,ityp1,ityp2,ityp3,iblock)," 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,iblock)*cosph1ph2(l,k)+ & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*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,iblock)*sinph1ph2(l,k)- & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) dephii1=dephii1+(k-l)*sinkt(m)* & (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) if (lprn) then write (iout,*) "m",m," k",k," l",l," ffthet",& ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),& ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",& ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),& ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),& " 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 ! lprn1=.true. if (lprn1) & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') & i,theta(i)*rad2deg,phii*rad2deg,& phii1*rad2deg,ethetai ! 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 subroutine ebend #endif #ifdef CRYST_SC !----------------------------------------------------------------------------- subroutine esc(escloc) ! Calculate the local energy of a side chain and its derivatives in the ! corresponding virtual-bond valence angles THETA and the spherical angles ! ALPHA and OMEGA. ! use comm_sccalc ! 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' real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,& ddersc0,ddummy,xtemp,temp !el real(kind=8) :: time11,time12,time112,theti real(kind=8) :: escloc,delta !el integer :: it,nlobit !el common /sccalc/ time11,time12,time112,theti,it,nlobit !el local variables integer :: i,k real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,& dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd delta=0.02d0*pi escloc=0.0D0 ! write (iout,'(a)') 'ESC' do i=loc_start,loc_end it=itype(i) if (it.eq.ntyp1) cycle if (it.eq.10) goto 1 nlobit=nlob(iabs(it)) ! print *,'i=',i,' it=',it,' nlobit=',nlobit ! 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) ! write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, ! & esclocbi,ss,ssd escloci=ss*escloci+(1.0d0-ss)*esclocbi ! escloci=esclocbi ! 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) ! write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, ! & esclocbi,ss,ssd escloci=ss*escloci+(1.0d0-ss)*esclocbi ! 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 ! 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 subroutine esc !----------------------------------------------------------------------------- subroutine enesc(x,escloci,dersc,ddersc,mixed) use comm_sccalc ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.LOCAL' ! include 'COMMON.IOUNITS' !el common /sccalc/ time11,time12,time112,theti,it,nlobit real(kind=8),dimension(3) :: x,z,dersc,ddersc real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1) real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1) real(kind=8) :: escloci logical :: mixed !el local variables integer :: j,iii,l,k !el,it,nlobit real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,& !el time11,time12,time112 ! 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) ! Because of periodicity of the dependence of the SC energy in omega we have ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). ! 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 ! As in the case of ebend, we want to avoid underflows in exponentiation and ! subsequent NaNs and INFs in energy calculation. ! 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 !d print *,'it=',it,' emin=',emin ! Compute the contribution to SC energy and derivatives do iii=-1,1 do j=1,nlobit #ifdef OSF adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin if(adexp.ne.adexp) adexp=1.0 expfac=dexp(adexp) #else expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) #endif !d 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 subroutine enesc !----------------------------------------------------------------------------- subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) use comm_sccalc ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.LOCAL' ! include 'COMMON.IOUNITS' !el common /sccalc/ time11,time12,time112,theti,it,nlobit real(kind=8),dimension(3) :: x,z,dersc real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob) real(kind=8),dimension(nlobit) :: contr !(maxlob) real(kind=8) :: escloci,dersc12,emin logical :: mixed !el local varables integer :: j,k,l !el,it,nlobit real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti 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 ! As in the case of ebend, we want to avoid underflows in exponentiation and ! subsequent NaNs and INFs in energy calculation. ! Find the largest exponent emin=contr(1) do j=1,nlobit if (emin.gt.contr(j)) emin=contr(j) enddo emin=0.5D0*emin ! Compute the contribution to SC energy and derivatives dersc12=0.0d0 do j=1,nlobit expfac=dexp(bsc(j,iabs(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 subroutine enesc_bound #else !----------------------------------------------------------------------------- subroutine esc(escloc) ! Calculate the local energy of a side chain and its derivatives in the ! corresponding virtual-bond valence angles THETA and the spherical angles ! ALPHA and OMEGA derived from AM1 all-atom calculations. ! added by Urszula Kozlowska. 07/11/2007 ! use comm_sccalc ! 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' real(kind=8),dimension(3) :: x_prime,y_prime,z_prime real(kind=8),dimension(65) :: x real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,& sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,& dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1 !el local variables integer :: i,j,k !el,it,nlobit real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta !el real(kind=8) :: time11,time12,time112,theti !el common /sccalc/ time11,time12,time112,theti,it,nlobit real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,& pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,& sumene1x,sumene2x,sumene3x,sumene4x,& sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,& cosfac2xx,sinfac2yy #ifdef DEBUG real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,& de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,& de_dt_num #endif ! if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres) delta=0.02d0*pi escloc=0.0D0 do i=loc_start,loc_end if (itype(i).eq.ntyp1) cycle 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=iabs(itype(i)) if (it.eq.10) goto 1 ! ! Compute the axes of tghe local cartesian coordinates system; store in ! x_prime, y_prime and z_prime ! do j=1,3 x_prime(j) = 0.00 y_prime(j) = 0.00 z_prime(j) = 0.00 enddo ! write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), ! & 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)*dsign(1.0d0,dfloat(itype(i))) enddo ! write (2,*) "i",i ! write (2,*) "x_prime",(x_prime(j),j=1,3) ! write (2,*) "y_prime",(y_prime(j),j=1,3) ! write (2,*) "z_prime",(z_prime(j),j=1,3) ! write (2,*) "xx",scalar(x_prime(1),x_prime(1)), ! & " xy",scalar(x_prime(1),y_prime(1)), ! & " xz",scalar(x_prime(1),z_prime(1)), ! & " yy",scalar(y_prime(1),y_prime(1)), ! & " yz",scalar(y_prime(1),z_prime(1)), ! & " zz",scalar(z_prime(1),z_prime(1)) ! ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), ! to local coordinate system. Store in xx, yy, zz. ! 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 ! ! Compute the energy of the ith side cbain ! ! write (2,*) "xx",xx," yy",yy," zz",zz it=iabs(itype(i)) do j = 1,65 x(j) = sc_parmin(j,it) enddo #ifdef CHECK_COORD !c diagnostics - remove later xx1 = dcos(alph(2)) yy1 = dsin(alph(2))*dcos(omeg(2)) zz1 = -dsign(1.0,dfloat(itype(i)))*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 !," --- ", xx_w,yy_w,zz_w ! 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) ! write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, ! & sumene4, ! & dscp1,dscp2,sumene ! sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) escloc = escloc + sumene ! write (2,*) "i",i," escloc",sumene,escloc,it,itype(i) ! & ,zz,xx,yy !#define DEBUG #ifdef DEBUG ! ! This section to check the numerical derivatives of the energy of ith side ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert ! #define DEBUG in the code to turn it on. ! 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 ! End of diagnostics section. #endif ! ! Compute the gradient of esc ! ! zz=zz*dsign(1.0,dfloat(itype(i))) 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,itype(i) #endif ! 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,itype(i) #endif ! 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,itype(i) #endif ! 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,itype(i) #endif ! ! 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) ! write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, ! & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) ! write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), ! & (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) & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) & *dsign(1.0d0,dfloat(itype(i)))*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)) ! 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 ! write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", ! & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) ! write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", ! & dyy_ci(k)," dzz_ci",dzz_ci(k) ! write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", ! & dt_dci(k) ! write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", ! & 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 ! write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), ! & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) ! to check gradient call subroutine check_grad 1 continue enddo return end subroutine esc !----------------------------------------------------------------------------- real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2) ! implicit none real(kind=8),dimension(65) :: x real(kind=8) :: 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 function enesc #endif !----------------------------------------------------------------------------- subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) ! ! This procedure calculates two-body contact function g(rij) and its derivative: ! ! eps0ij ! x < -1 ! g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 ! 0 ! x > 1 ! ! where x=(rij-r0ij)/delta ! ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy ! ! implicit none real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont real(kind=8) :: x,x2,x4,delta ! delta=0.02D0*r0ij ! 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 subroutine gcont !----------------------------------------------------------------------------- subroutine splinthet(theti,delta,ss,ssder) ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.VAR' ! include 'COMMON.GEO' real(kind=8) :: theti,delta,ss,ssder real(kind=8) :: thetup,thetlow 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 subroutine splinthet !----------------------------------------------------------------------------- subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) ! implicit none real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim real(kind=8) :: 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 subroutine spline1 !----------------------------------------------------------------------------- subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) ! implicit none real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx real(kind=8) :: 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 subroutine spline2 !----------------------------------------------------------------------------- #ifdef CRYST_TOR !----------------------------------------------------------------------------- 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' real(kind=8) :: etors,edihcnstr logical :: lprn !el local variables integer :: i,j, real(kind=8) :: phii,fac,etors_ii ! Set lprn=.true. for debugging lprn=.false. ! lprn=.true. etors=0.0D0 do i=iphi_start,iphi_end etors_ii=0.0D0 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 & .or. itype(i).eq.ntyp1) cycle itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) phii=phi(i) gloci=0.0D0 ! 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 subroutine etor !----------------------------------------------------------------------------- subroutine etor_d(etors_d) real(kind=8) :: etors_d etors_d=0.0d0 return end subroutine etor_d #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' real(kind=8) :: etors,edihcnstr logical :: lprn !el local variables integer :: i,j,iblock,itori,itori1 real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,& vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom ! Set lprn=.true. for debugging lprn=.false. ! lprn=.true. etors=0.0D0 do i=iphi_start,iphi_end if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 & .or. itype(i).eq.ntyp1) cycle etors_ii=0.0D0 if (iabs(itype(i)).eq.20) then iblock=2 else iblock=1 endif itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) phii=phi(i) gloci=0.0D0 ! Regular cosine and sine terms do j=1,nterm(itori,itori1,iblock) v1ij=v1(j,itori,itori1,iblock) v2ij=v2(j,itori,itori1,iblock) 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 ! Lorentz terms ! v1 ! E = SUM ----------------------------------- - v1 ! [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 ! cosphi=dcos(0.5d0*phii) sinphi=dsin(0.5d0*phii) do j=1,nlor(itori,itori1,iblock) 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 ! Subtract the constant term etors=etors-v0(itori,itori1,iblock) if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & 'etor',i,etors_ii-v0(itori,itori1,iblock) 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,iblock),j=1,6),& (v2(j,itori,itori1,iblock),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 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 !d write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, !d & rad2deg*phi0(i), rad2deg*drange(i), !d & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) enddo !d write (iout,*) 'edihcnstr',edihcnstr return end subroutine etor !----------------------------------------------------------------------------- subroutine etor_d(etors_d) ! 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' real(kind=8) :: etors_d logical :: lprn !el local variables integer :: i,j,k,l,itori,itori1,itori2,iblock real(kind=8) :: phii,phii1,gloci1,gloci2,& v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,& sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,& cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2 ! Set lprn=.true. for debugging lprn=.false. ! lprn=.true. etors_d=0.0D0 ! write(iout,*) "a tu??" do i=iphid_start,iphid_end if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 & .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle 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 iblock=1 if (iabs(itype(i+1)).eq.20) iblock=2 ! Regular cosine and sine terms do j=1,ntermd_1(itori,itori1,itori2,iblock) v1cij=v1c(1,j,itori,itori1,itori2,iblock) v1sij=v1s(1,j,itori,itori1,itori2,iblock) v2cij=v1c(2,j,itori,itori1,itori2,iblock) v2sij=v1s(2,j,itori,itori1,itori2,iblock) 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,iblock) do l=1,k-1 v1cdij = v2c(k,l,itori,itori1,itori2,iblock) v2cdij = v2c(l,k,itori,itori1,itori2,iblock) v1sdij = v2s(k,l,itori,itori1,itori2,iblock) v2sdij = v2s(l,k,itori,itori1,itori2,iblock) 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 enddo return end subroutine etor_d #endif !----------------------------------------------------------------------------- subroutine eback_sc_corr(esccor) ! 7/21/2007 Correlations between the backbone-local and side-chain-local ! conformational states; temporarily implemented as differences ! between UNRES torsional potentials (dependent on three types of ! residues) and the torsional potentials dependent on all 20 types ! of residues computed from AM1 energy surfaces of terminally-blocked ! 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' real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,& cosphi,sinphi logical :: lprn integer :: i,interty,j,isccori,isccori1,intertyp ! Set lprn=.true. for debugging lprn=.false. ! lprn=.true. ! write (iout,*) "EBACK_SC_COR",itau_start,itau_end esccor=0.0D0 do i=itau_start,itau_end if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle esccor_ii=0.0D0 isccori=isccortyp(itype(i-2)) isccori1=isccortyp(itype(i-1)) ! write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1) phii=phi(i) do intertyp=1,3 !intertyp !c Added 09 May 2012 (Adasko) !c Intertyp means interaction type of backbone mainchain correlation: ! 1 = SC...Ca...Ca...Ca ! 2 = Ca...Ca...Ca...SC ! 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.ntyp1).or. & (itype(i-1).eq.ntyp1))) & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) & .or.(itype(i).eq.ntyp1))) & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. & (itype(i-3).eq.ntyp1)))) cycle if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) & 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 ! write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci 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,isccori,isccori1,& (v1sccor(j,intertyp,isccori,isccori1),j=1,6),& (v2sccor(j,intertyp,isccori,isccori1),j=1,6) gsccor_loc(i-3)=gsccor_loc(i-3)+gloci enddo !intertyp enddo return end subroutine eback_sc_corr !----------------------------------------------------------------------------- subroutine multibody(ecorr) ! This subroutine calculates multi-body contributions to energy following ! the idea of Skolnick et al. If side chains I and J make a contact and ! at the same time side chains I+1 and J+1 make a contact, an extra ! 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' real(kind=8),dimension(3) :: gx,gx1 logical :: lprn real(kind=8) :: ecorr integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk ! 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 ! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) ! if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres)) 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 !d write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, !d & ' ishift=',ishift ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. ! 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 subroutine multibody !----------------------------------------------------------------------------- real(kind=8) 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' real(kind=8),dimension(3) :: gx,gx1 logical :: lprn integer :: i,j,k,l,jj,kk,m,ll real(kind=8) :: eij,ekl lprn=.false. eij=facont(jj,i) ekl=facont(kk,k) !d write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl ! Calculate the multi-body contribution to energy. ! Calculate multi-body contributions to the gradient. !d write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), !d & 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 function esccorr !----------------------------------------------------------------------------- subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) ! 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" ! integer :: maxconts !max_cont=maxconts =nres/4 integer,parameter :: max_dim=26 integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) !el real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !el common /przechowalnia/ zapas integer :: status(MPI_STATUS_SIZE) integer,dimension((nres/4)*2) :: req !maxconts*2 integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr #endif ! include 'COMMON.SETUP' ! include 'COMMON.FFIELD' ! include 'COMMON.DERIV' ! include 'COMMON.INTERACT' ! include 'COMMON.CONTACTS' ! include 'COMMON.CONTROL' ! include 'COMMON.LOCAL' real(kind=8),dimension(3) :: gx,gx1 real(kind=8) :: time00,ecorr,ecorr5,ecorr6 logical :: lprn,ldone !el local variables integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,& jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc ! Set lprn=.true. for debugging lprn=.false. #ifdef MPI ! maxconts=nres/4 if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks)) 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 ! write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", ! & ntask_cont_to ! Make the list of contacts to send to send to other procesors ! write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end ! call flush(iout) do i=iturn3_start,iturn3_end ! write (iout,*) "make contact list turn3",i," num_cont", ! & num_cont_hb(i) call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) enddo do i=iturn4_start,iturn4_end ! write (iout,*) "make contact list turn4",i," num_cont", ! & 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) ! write (iout,*) "make contact list longrange",i,ii," num_cont", ! & 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) ! 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 ! 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 ! write (iout,*) "IRECV ended" ! call flush(iout) ! 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 ! write (iout,*) "ISEND ended" ! write (iout,*) "number of requests (nn)",ireq call flush(iout) if (ireq.gt.0) & call MPI_Waitall(ireq,req,status_array,ierr) ! write (iout,*) ! & "Numbers of contacts to be received from other processors", ! & (ncont_recv(i),i=1,ntask_cont_from) ! call flush(iout) ! Receive contacts ireq=0 do ii=1,ntask_cont_from iproc=itask_cont_from(ii) nn=ncont_recv(ii) ! write (iout,*) "Receiving",nn," contacts from processor",iproc, ! & " 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) ! write (iout,*) "ireq,req",ireq,req(ireq) endif enddo ! Send the contacts to processors that need them do ii=1,ntask_cont_to iproc=itask_cont_to(ii) nn=ncont_sent(ii) ! write (iout,*) nn," contacts to processor",iproc, ! & " 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) ! write (iout,*) "ireq,req",ireq,req(ireq) ! do i=1,nn ! write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) ! enddo endif enddo ! write (iout,*) "number of requests (contacts)",ireq ! write (iout,*) "req",(req(i),i=1,4) ! 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) ! Flag the received contacts to prevent double-counting jj=-zapas_recv(2,i,iii) ! write (iout,*) "iii",iii," i",i," ii",ii," jj",jj ! 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 ! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) ! if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres)) ! 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 ! 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) ! write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,& ! ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1 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 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. ! 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,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) n_corr=n_corr+1 else if (j1.eq.j) then ! Contacts I-J and I-(J+1) occur simultaneously. ! The system loses extra energy. ! 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) ! write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, ! & ' jj=',jj,' kk=',kk if (j1.eq.j+1) then ! Contacts I-J and (I+1)-J occur simultaneously. ! The system loses extra energy. ! 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 subroutine multibody_hb !----------------------------------------------------------------------------- subroutine add_hb_contact(ii,jj,itask) ! implicit real*8 (a-h,o-z) ! include "DIMENSIONS" ! include "COMMON.IOUNITS" ! include "COMMON.CONTACTS" ! integer,parameter :: maxconts=nres/4 integer,parameter :: max_dim=26 real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) ! real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) ! common /przechowalnia/ zapas integer :: i,j,ii,jj,iproc,nn,jjc integer,dimension(4) :: itask ! 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) ! 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 subroutine add_hb_contact !----------------------------------------------------------------------------- subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) ! This subroutine calculates multi-body contributions to hydrogen-bonding ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' integer,parameter :: max_dim=70 #ifdef MPI include "mpif.h" ! integer :: maxconts !max_cont=maxconts=nres/4 integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) ! real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) ! common /przechowalnia/ zapas integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),& status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,& ierr,iii,nnn #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' real(kind=8),dimension(3) :: gx,gx1 integer,dimension(nres) :: num_cont_hb_old logical :: lprn,ldone !EL double precision eello4,eello5,eelo6,eello_turn6 !EL external eello4,eello5,eello6,eello_turn6 !el local variables integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,& j1,jp1,i1,num_conti1 real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6 ! Set lprn=.true. for debugging lprn=.false. eturn6=0.0d0 #ifdef MPI ! maxconts=nres/4 if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks)) 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 ! write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", ! & ntask_cont_to ! Make the list of contacts to send to send to other procesors do i=iturn3_start,iturn3_end ! write (iout,*) "make contact list turn3",i," num_cont", ! & num_cont_hb(i) call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) enddo do i=iturn4_start,iturn4_end ! write (iout,*) "make contact list turn4",i," num_cont", ! & 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) ! write (iout,*) "make contact list longrange",i,ii," num_cont", ! & 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) ! 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 ! 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 ! write (iout,*) "IRECV ended" ! call flush(iout) ! 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 ! write (iout,*) "ISEND ended" ! write (iout,*) "number of requests (nn)",ireq call flush(iout) if (ireq.gt.0) & call MPI_Waitall(ireq,req,status_array,ierr) ! write (iout,*) ! & "Numbers of contacts to be received from other processors", ! & (ncont_recv(i),i=1,ntask_cont_from) ! call flush(iout) ! Receive contacts ireq=0 do ii=1,ntask_cont_from iproc=itask_cont_from(ii) nn=ncont_recv(ii) ! write (iout,*) "Receiving",nn," contacts from processor",iproc, ! & " 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) ! write (iout,*) "ireq,req",ireq,req(ireq) endif enddo ! Send the contacts to processors that need them do ii=1,ntask_cont_to iproc=itask_cont_to(ii) nn=ncont_sent(ii) ! write (iout,*) nn," contacts to processor",iproc, ! & " 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) ! write (iout,*) "ireq,req",ireq,req(ireq) ! do i=1,nn ! write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) ! enddo endif enddo ! write (iout,*) "number of requests (contacts)",ireq ! write (iout,*) "req",(req(i),i=1,4) ! 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) ! Flag the received contacts to prevent double-counting jj=-zapas_recv(2,i,iii) ! write (iout,*) "iii",iii," i",i," ii",ii," jj",jj ! 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 ! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) ! if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres)) ! 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 ! 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 ! Calculate the local-electrostatic correlation terms ! write (iout,*) "gradcorr5 in eello5 before loop" ! do iii=1,nres ! write (iout,'(i5,3f10.5)') ! & iii,(gradcorr5(jjj,iii),jjj=1,3) ! enddo do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) ! 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) ! write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, ! & ' jj=',jj,' kk=',kk ! 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 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. ! 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) !d write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, !d & ' 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 !d write (iout,*) 'sred_geom=',sred_geom, !d & ' ekont=',ekont,' fprim=',fprimcont, !d & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 !d write (iout,*) "g_contij",g_contij !d write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) !d 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) & write (iout,'(a6,4i5,0pf7.3)') & 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) ! write (iout,*) "gradcorr5 before eello5" ! do iii=1,nres ! write (iout,'(i5,3f10.5)') ! & iii,(gradcorr5(jjj,iii),jjj=1,3) ! enddo if (wcorr5.gt.0.0d0) & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) ! write (iout,*) "gradcorr5 after eello5" ! do iii=1,nres ! write (iout,'(i5,3f10.5)') ! & iii,(gradcorr5(jjj,iii),jjj=1,3) ! enddo if (energy_dec.and.wcorr5.gt.0.0d0) & write (iout,'(a6,4i5,0pf7.3)') & 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) !d write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 !d 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 !d 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)') & 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) !d write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, !d & 'ecorr6=',ecorr6 !d write (iout,'(4e15.5)') sred_geom, !d & dabs(eello4(i,jp,i+1,jp1,jj,kk)), !d & dabs(eello5(i,jp,i+1,jp1,jj,kk)), !d & 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 !d 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)') & 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) !d 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 ! write (iout,*) "gradcorr5 in eello5" ! do iii=1,nres ! write (iout,'(i5,3f10.5)') ! & iii,(gradcorr5(jjj,iii),jjj=1,3) ! enddo return end subroutine multibody_eello !----------------------------------------------------------------------------- subroutine add_hb_contact_eello(ii,jj,itask) ! implicit real*8 (a-h,o-z) ! include "DIMENSIONS" ! include "COMMON.IOUNITS" ! include "COMMON.CONTACTS" ! integer,parameter :: maxconts=nres/4 integer,parameter :: max_dim=70 real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) ! real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs) ! common /przechowalnia/ zapas integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm integer,dimension(4) ::itask ! 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) ! 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 subroutine add_hb_contact_eello !----------------------------------------------------------------------------- real(kind=8) 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' real(kind=8),dimension(3) :: gx,gx1 logical :: lprn !el local variables integer :: i,j,k,l,jj,kk,ll real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,& ees0mkl,ees,coeffpees0pij,coeffmees0mij,& coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl 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) !d ees=-(coeffp*ees0pkl+coeffm*ees0mkl) ! Following 4 lines for diagnostics. !d ees0pkl=0.0D0 !d ees0pij=1.0D0 !d ees0mkl=0.0D0 !d ees0mij=1.0D0 ! write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') ! & 'Contacts ',i,j, ! & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l ! & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, ! & 'gradcorr_long' ! Calculate the multi-body contribution to energy. ! ecorr=ecorr+ekont*ees ! Calculate multi-body contributions to the gradient. coeffpees0pij=coeffp*ees0pij coeffmees0mij=coeffm*ees0mij coeffpees0pkl=coeffp*ees0pkl coeffmees0mkl=coeffm*ees0mkl do ll=1,3 !grad 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)) !grad 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 ! write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl enddo ! write (iout,*) !grad do m=i+1,j-1 !grad do ll=1,3 !grad gradcorr(ll,m)=gradcorr(ll,m)+ !grad & ees*ekl*gacont_hbr(ll,jj,i)- !grad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ !grad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) !grad enddo !grad enddo !grad do m=k+1,l-1 !grad do ll=1,3 !grad gradcorr(ll,m)=gradcorr(ll,m)+ !grad & ees*eij*gacont_hbr(ll,kk,k)- !grad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ !grad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) !grad enddo !grad enddo ! write (iout,*) "ehbcorr",ekont*ees ehbcorr=ekont*ees return end function ehbcorr #ifdef MOMENT !----------------------------------------------------------------------------- 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' real(kind=8),dimension(2,2) :: dipi,dipj,auxmat real(kind=8),dimension(2) :: dipderi,dipderj,auxvec integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1 allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres)) allocate(dipderx(3,5,4,maxconts,nres)) ! 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 subroutine dipole #endif !----------------------------------------------------------------------------- subroutine calc_eello(i,j,k,l,jj,kk) ! ! This subroutine computes matrices and vectors needed to calculate ! the fourth-, fifth-, and sixth-order local-electrostatic terms. ! use comm_kut ! 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' real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,& itj1 !el logical :: lprn !el common /kutas/ lprn !d write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, !d & ' jj=',jj,' kk=',kk !d if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return !d write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) !d 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 ! 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 ! A1 kernel(j+1) A2T !d do iii=1,2 !d write (iout,'(3f10.5,5x,3f10.5)') !d & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) !d 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)) ! 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 ! End 6-th order cumulants !d lprn=.false. !d if (lprn) then !d write (2,*) 'In calc_eello6' !d do iii=1,2 !d write (2,*) 'iii=',iii !d do kkk=1,5 !d write (2,*) 'kkk=',kkk !d do jjj=1,2 !d write (2,'(3(2f10.5),5x)') !d & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) !d enddo !d enddo !d enddo !d 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 ! 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)) ! 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 ! 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 ! AEAb1 and AEAb2 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles. ! They are needed only when the fifth- or the sixth-order cumulants are ! 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)) ! 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 ! End vectors else ! 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 ! 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)) ! 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 ! 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 ! 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)) ! 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 ! 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 ! AEAb1 and AEAb2 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles. ! They are needed only when the fifth- or the sixth-order cumulants are ! 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)) ! 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 ! End vectors endif return end subroutine calc_eello !----------------------------------------------------------------------------- subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx) use comm_kut implicit none integer :: nderg logical :: transp real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx real(kind=8),dimension(2,2,3,5,2) :: AKAderx real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg integer :: iii,kkk,lll integer :: jjj,mmm !el logical :: lprn !el 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 !d if (lprn) write (2,*) 'In kernel' do kkk=1,5 !d 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)) !d if (lprn) then !d write (2,*) 'lll=',lll !d write (2,*) 'iii=1' !d do jjj=1,2 !d write (2,'(3(2f10.5),5x)') !d & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) !d enddo !d endif call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),& KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) !d if (lprn) then !d write (2,*) 'lll=',lll !d write (2,*) 'iii=2' !d do jjj=1,2 !d write (2,'(3(2f10.5),5x)') !d & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) !d enddo !d endif enddo enddo return end subroutine kernel !----------------------------------------------------------------------------- real(kind=8) 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' real(kind=8),dimension(2,2) :: pizda real(kind=8),dimension(3) :: ggg1,ggg2 real(kind=8) :: eel4,glongij,glongkl integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll !d if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then !d eello4=0.0d0 !d return !d endif !d print *,'eello4:',i,j,k,l,jj,kk !d write (2,*) 'i',i,' j',j,' k',k,' l',l !d call checkint4(i,j,k,l,jj,kk,eel4_num) !old eij=facont_hb(jj,i) !old ekl=facont_hb(kk,k) !old ekont=eij*ekl eel4=-EAEA(1,1,1)-EAEA(2,2,1) !d 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) !d derx(lll,kkk,iii)=0.0d0 enddo enddo enddo !d gcorr_loc(l-1)=0.0d0 !d gcorr_loc(j-1)=0.0d0 !d gcorr_loc(k-1)=0.0d0 !d eel4=1.0d0 !d write (iout,*)'Contacts have occurred for peptide groups', !d & i,j,' fcont:',eij,' eij',' and ',k,l, !d & ' 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 !grad ggg1(ll)=eel4*g_contij(ll,1) !grad 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) !grad 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 !grad 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 !grad do m=i+1,j-1 !grad do ll=1,3 !grad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) !grad enddo !grad enddo !grad do m=k+1,l-1 !grad do ll=1,3 !grad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) !grad enddo !grad enddo !grad do m=i+2,j2 !grad do ll=1,3 !grad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) !grad enddo !grad enddo !grad do m=k+2,l2 !grad do ll=1,3 !grad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) !grad enddo !grad enddo !d do iii=1,nres-3 !d write (2,*) iii,gcorr_loc(iii) !d enddo eello4=ekont*eel4 !d write (2,*) 'ekont',ekont !d write (iout,*) 'eello4',ekont*eel4 return end function eello4 !----------------------------------------------------------------------------- real(kind=8) 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' real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1 real(kind=8),dimension(2) :: vv real(kind=8),dimension(3) :: ggg1,ggg2 real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5 real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! C ! Parallel chains C ! C ! o o o o C ! /l\ / \ \ / \ / \ / C ! / \ / \ \ / \ / \ / C ! j| o |l1 | o | o| o | | o |o C ! \ |/k\| |/ \| / |/ \| |/ \| C ! \i/ \ / \ / / \ / \ C ! o k1 o C ! (I) (II) (III) (IV) C ! C ! eello5_1 eello5_2 eello5_3 eello5_4 C ! C ! Antiparallel chains C ! C ! o o o o C ! /j\ / \ \ / \ / \ / C ! / \ / \ \ / \ / \ / C ! j1| o |l | o | o| o | | o |o C ! \ |/k\| |/ \| / |/ \| |/ \| C ! \i/ \ / \ / / \ / \ C ! o k1 o C ! (I) (II) (III) (IV) C ! C ! eello5_1 eello5_2 eello5_3 eello5_4 C ! C ! o denotes a local interaction, vertical lines an electrostatic interaction. C ! C !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC !d if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then !d eello5=0.0d0 !d return !d endif !d write (iout,*) !d & 'EELLO5: Contacts have occurred for peptide groups',i,j, !d & ' 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 !d call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, !d & 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 !d eij=facont_hb(jj,i) !d ekl=facont_hb(kk,k) !d ekont=eij*ekl !d write (iout,*)'Contacts have occurred for peptide groups', !d & i,j,' fcont:',eij,' eij',' and ',k,l !d goto 1111 ! Contribution from the graph I. !d write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) !d 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)) ! 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 ! 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 ! goto 1112 !1111 continue ! 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)) ! 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 ! 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 !d goto 1112 !d1111 continue if (l.eq.j+1) then !d goto 1110 ! Parallel orientation ! 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)) ! 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))) ! 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 !d goto 1112 ! Contribution from graph IV !d1110 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)) ! 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))) ! 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 ! Antiparallel orientation ! Contribution from graph III ! 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)) ! 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))) ! 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 !d goto 1112 ! 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)) ! 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))) ! 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 !d if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then !d write (2,*) 'ijkl',i,j,k,l !d write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, !d & ' eello5_3',eello5_3,' eello5_4',eello5_4 !d endif !d write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num !d write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num !d write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num !d 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 !d eij=1.0d0 !d ekl=1.0d0 !d ekont=1.0d0 !d write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont ! 2/11/08 AL Gradients over DC's connecting interacting sites will be ! summed up outside the subrouine as for the other subroutines ! handling long-range interactions. The old code is commented out ! with "cgrad" to keep track of changes. do ll=1,3 !grad ggg1(ll)=eel5*g_contij(ll,1) !grad 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) ! write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') ! & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), ! & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), ! & derx(ll,4,2),derx(ll,5,2)," ekont",ekont ! write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') ! & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), ! & gradcorr5ij, ! & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl !old ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) !grad ghalf=0.5d0*ggg1(ll) !d 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 !old ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) !grad ghalf=0.5d0*ggg2(ll) 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 !d goto 1112 !grad do m=i+1,j-1 !grad do ll=1,3 !old gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) !grad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) !grad enddo !grad enddo !grad do m=k+1,l-1 !grad do ll=1,3 !old gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) !grad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) !grad enddo !grad enddo !1112 continue !grad do m=i+2,j2 !grad do ll=1,3 !grad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) !grad enddo !grad enddo !grad do m=k+2,l2 !grad do ll=1,3 !grad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) !grad enddo !grad enddo !d do iii=1,nres-3 !d write (2,*) iii,g_corr5_loc(iii) !d enddo eello5=ekont*eel5 !d write (2,*) 'ekont',ekont !d write (iout,*) 'eello5',ekont*eel5 return end function eello5 !----------------------------------------------------------------------------- real(kind=8) 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' real(kind=8),dimension(3) :: ggg1,ggg2 real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,& eello6_6,eel6 real(kind=8) :: gradcorr6ij,gradcorr6kl integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll !d if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then !d eello6=0.0d0 !d return !d endif !d write (iout,*) !d & 'EELLO6: Contacts have occurred for peptide groups',i,j, !d & ' 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 !d call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, !d & 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 !d eij=facont_hb(jj,i) !d ekl=facont_hb(kk,k) !d ekont=eij*ekl !d eij=1.0d0 !d ekl=1.0d0 !d 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 ! If turn contributions are considered, they will be handled separately. eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 !d write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num !d write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num !d write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num !d write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num !d write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num !d write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num !d 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 !grad ggg1(ll)=eel6*g_contij(ll,1) !grad ggg2(ll)=eel6*g_contij(ll,2) !old ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) !grad ghalf=0.5d0*ggg1(ll) !d 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 !grad ghalf=0.5d0*ggg2(ll) !old ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) !d 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 !d goto 1112 !grad do m=i+1,j-1 !grad do ll=1,3 !old gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) !grad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) !grad enddo !grad enddo !grad do m=k+1,l-1 !grad do ll=1,3 !old gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) !grad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) !grad enddo !grad enddo !grad1112 continue !grad do m=i+2,j2 !grad do ll=1,3 !grad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) !grad enddo !grad enddo !grad do m=k+2,l2 !grad do ll=1,3 !grad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) !grad enddo !grad enddo !d do iii=1,nres-3 !d write (2,*) iii,g_corr6_loc(iii) !d enddo eello6=ekont*eel6 !d write (2,*) 'ekont',ekont !d write (iout,*) 'eello6',ekont*eel6 return end function eello6 !----------------------------------------------------------------------------- real(kind=8) function eello6_graph1(i,j,k,l,imat,swap) use comm_kut ! 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' real(kind=8),dimension(2) :: vv,vv1 real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1 logical :: swap !el logical :: lprn !el common /kutas/ lprn integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind real(kind=8) :: s1,s2,s3,s4,s5 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! 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 ! C !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 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)) !d 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 function eello6_graph1 !----------------------------------------------------------------------------- real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap) use comm_kut ! 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 real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2 real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1 !el logical :: lprn !el common /kutas/ lprn integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm real(kind=8) :: s2,s3,s4 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! C ! Parallel Antiparallel C ! C ! o o C ! \ /l\ /j\ / C ! \ / \ / \ / C ! o| o | | o |o C ! \ j|/k\| \ |/k\|l C ! \ / \ \ / \ C ! o o C ! i i C ! C !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC !d write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l ! AL 7/4/01 s1 would occur in the sixth-order moment, ! 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)) !d 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 ! eello6_graph2=-s3 ! 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 ! g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 endif ! 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 ! g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 ! 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) ! g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 endif ! 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) ! g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 endif ! 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)) !d 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 function eello6_graph2 !----------------------------------------------------------------------------- real(kind=8) 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' real(kind=8),dimension(2) :: vv,auxvec real(kind=8),dimension(2,2) :: pizda,auxmat logical :: swap integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1 real(kind=8) :: s1,s2,s3,s4 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! C ! Parallel Antiparallel C ! C ! o o C ! /l\ / \ /j\ C ! / \ / \ / \ C ! /| o |o o| o |\ C ! j|/k\| / |/k\|l / C ! / \ / / \ / C ! / o / o C ! i i C ! C !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! ! 4/7/01 AL Component s1 was removed, because it pertains to the respective ! 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)) !d write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, !d & "sum",-(s2+s3+s4) #ifdef MOMENT eello6_graph3=-(s1+s2+s3+s4) #else eello6_graph3=-(s2+s3+s4) #endif ! eello6_graph3=-s4 ! 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) ! 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) ! 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 ! derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 enddo enddo enddo return end function eello6_graph3 !----------------------------------------------------------------------------- real(kind=8) 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' real(kind=8),dimension(2) :: vv,auxvec,auxvec1 real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1 logical :: swap integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,& iii,kkk,lll real(kind=8) :: s1,s2,s3,s4 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! C ! Parallel Antiparallel C ! C ! o o C ! /l\ / \ /j\ C ! / \ / \ / \ C ! /| o |o o| o |\ C ! \ j|/k\| \ |/k\|l C ! \ / \ \ / \ C ! o \ o \ C ! i i C ! C !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! ! 4/7/01 AL Component s1 was removed, because it pertains to the respective ! energy moment and not to the cluster cumulant. !d 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 !d write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l !d write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, !d & ' 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)) !d 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 ! 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 !d 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 ! 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 ! 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 ! 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 function eello6_graph4 !----------------------------------------------------------------------------- real(kind=8) 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' real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp real(kind=8),dimension(3) :: ggg1,ggg2 real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to ! the respective energy moment and not to the cluster cumulant. !el local variables integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll integer :: j1,j2,l1,l2,ll real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6 real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl s1=0.0d0 s8=0.0d0 s13=0.0d0 ! 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)) !d write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj !d write (2,*) 'i',i,' k',k,' j',j,' l',l !d if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then !d eello6=0.0d0 !d return !d endif !d write (iout,*) !d & 'EELLO6: Contacts have occurred for peptide groups',i,j, !d & ' and',k,l !d 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 !d eij=1.0d0 !d ekl=1.0d0 !d ekont=1.0d0 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) !d eello6_5=0.0d0 !d 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 ! write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 ! s1=0.0d0 ! s2=0.0d0 ! s8=0.0d0 ! s12=0.0d0 ! s13=0.0d0 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) ! 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)) ! s1d=0.0d0 ! s2d=0.0d0 ! s8d=0.0d0 ! s12d=0.0d0 ! s13d=0.0d0 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) ! 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 ! s1d=0.0d0 ! s2d=0.0d0 ! s8d=0.0d0 ! s12d=0.0d0 ! 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 ! 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 ! s1d=0.0d0 ! s2d=0.0d0 ! s8d=0.0d0 ! s12d=0.0d0 ! 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 ! 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 ! s1d=0.0d0 ! s2d=0.0d0 ! s8d=0.0d0 ! s12d=0.0d0 ! 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 ! 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)) ! s1d=0.0d0 ! s2d=0.0d0 ! s8d=0.0d0 ! s12d=0.0d0 ! 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 !d write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', !d & 16*eel_turn6_num !d 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 !grad ggg1(ll)=eel_turn6*g_contij(ll,1) !grad ggg2(ll)=eel_turn6*g_contij(ll,2) !grad ghalf=0.5d0*ggg1(ll) !d 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 !grad ghalf=0.5d0*ggg2(ll) !d 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 !d goto 1112 !grad do m=i+1,j-1 !grad do ll=1,3 !grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) !grad enddo !grad enddo !grad do m=k+1,l-1 !grad do ll=1,3 !grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) !grad enddo !grad enddo !grad1112 continue !grad do m=i+2,j2 !grad do ll=1,3 !grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) !grad enddo !grad enddo !grad do m=k+2,l2 !grad do ll=1,3 !grad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) !grad enddo !grad enddo !d do iii=1,nres-3 !d write (2,*) iii,g_corr6_loc(iii) !d enddo eello_turn6=ekont*eel_turn6 !d write (2,*) 'ekont',ekont !d write (2,*) 'eel_turn6',ekont*eel_turn6 return end function eello_turn6 !----------------------------------------------------------------------------- subroutine MATVEC2(A1,V1,V2) !DIR$ INLINEALWAYS MATVEC2 #ifndef OSF !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2 #endif ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' real(kind=8),dimension(2) :: V1,V2 real(kind=8),dimension(2,2) :: A1 real(kind=8) :: vaux1,vaux2 ! DO 1 I=1,2 ! VI=0.0 ! DO 3 K=1,2 ! 3 VI=VI+A1(I,K)*V1(K) ! Vaux(I)=VI ! 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 subroutine MATVEC2 !----------------------------------------------------------------------------- subroutine MATMAT2(A1,A2,A3) #ifndef OSF !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2 #endif ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' real(kind=8),dimension(2,2) :: A1,A2,A3 real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22 ! DIMENSION AI3(2,2) ! DO J=1,2 ! A3IJ=0.0 ! DO K=1,2 ! A3IJ=A3IJ+A1(I,K)*A2(K,J) ! enddo ! A3(I,J)=A3IJ ! enddo ! 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 subroutine MATMAT2 !----------------------------------------------------------------------------- real(kind=8) function scalar2(u,v) !DIR$ INLINEALWAYS scalar2 implicit none real(kind=8),dimension(2) :: u,v real(kind=8) :: sc integer :: i scalar2=u(1)*v(1)+u(2)*v(2) return end function scalar2 !----------------------------------------------------------------------------- subroutine transpose2(a,at) !DIR$ INLINEALWAYS transpose2 #ifndef OSF !DEC$ ATTRIBUTES FORCEINLINE::transpose2 #endif implicit none real(kind=8),dimension(2,2) :: a,at 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 subroutine transpose2 !----------------------------------------------------------------------------- subroutine transpose(n,a,at) implicit none integer :: n,i,j real(kind=8),dimension(n,n) :: a,at do i=1,n do j=1,n at(j,i)=a(i,j) enddo enddo return end subroutine transpose !----------------------------------------------------------------------------- subroutine prodmat3(a1,a2,kk,transp,prod) !DIR$ INLINEALWAYS prodmat3 #ifndef OSF !DEC$ ATTRIBUTES FORCEINLINE::prodmat3 #endif implicit none integer :: i,j real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod logical :: transp !rc double precision auxmat(2,2),prod_(2,2) if (transp) then !rc call transpose2(kk(1,1),auxmat(1,1)) !rc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) !rc 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 !rc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) !rc 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 ! call transpose2(a2(1,1),a2t(1,1)) !rc print *,transp !rc print *,((prod_(i,j),i=1,2),j=1,2) !rc print *,((prod(i,j),i=1,2),j=1,2) return end subroutine prodmat3 !----------------------------------------------------------------------------- ! energy_p_new_barrier.F !----------------------------------------------------------------------------- subroutine sum_gradient ! implicit real*8 (a-h,o-z) use io_base, only: pdbout ! include 'DIMENSIONS' #ifndef ISNAN external proc_proc #ifdef WINPGI !MS$ATTRIBUTES C :: proc_proc #endif #endif #ifdef MPI include 'mpif.h' #endif real(kind=8),dimension(3,nres) :: gradbufc,gradbufx,gradbufc_sum,& gloc_scbuf !(3,maxres) real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres) !#endif !el local variables integer :: i,j,k,ierror,ierr real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,& gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,& gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,& gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,& gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,& gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,& gsccorr_max,gsccorrx_max,time00 ! 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 time01=MPI_Wtime() #endif #ifdef DEBUG write (iout,*) "sum_gradient gvdwc, gvdwx" do i=1,nres write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3) enddo call flush(iout) #endif #ifdef MPI gradbufc=0.0d0 gradbufx=0.0d0 gradbufc_sum=0.0d0 gloc_scbuf=0.0d0 glocbuf=0.0d0 ! 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 ! ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient ! in virtual-bond-vector coordinates ! #ifdef DEBUG ! write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" ! do i=1,nres-1 ! write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') ! & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) ! enddo ! write (iout,*) "gel_loc_tur3 gel_loc_turn4" ! do i=1,nres-1 ! write (iout,'(i5,3f10.5,2x,f10.5)') ! & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) ! enddo write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp" do i=1,nres write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),& (gvdwc_scpp(j,i),j=1,3) enddo write (iout,*) "gelc_long gvdwpp gel_loc_long" do i=1,nres write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),& (gelc_loc_long(j,i),j=1,3) enddo call flush(iout) #endif #ifdef SPLITELE 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 #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 ! call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, ! & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) ! time_reduce=time_reduce+MPI_Wtime()-time00 #ifdef DEBUG ! write (iout,*) "gradbufc_sum after allreduce" ! do i=1,nres ! write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) ! enddo ! call flush(iout) #endif #ifdef TIMING ! 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 ! ! Obsolete and inefficient code; we can make the effort O(n) and, therefore, ! do not parallelize this part. ! ! do i=igrad_start,igrad_end ! do j=jgrad_start(i),jgrad_end(i) ! do k=1,3 ! gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) ! enddo ! 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 #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 !el#define DEBUG #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 !el#undef DEBUG 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 ! do i=nnt,nres-1 ! do k=1,3 ! gradbufc(k,i)=0.0d0 ! enddo ! do j=i+1,nres ! do k=1,3 ! gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) ! enddo ! enddo ! enddo !el#define DEBUG #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 !el#undef DEBUG #ifdef MPI endif #endif do k=1,3 gradbufc(k,nres)=0.0d0 enddo !el---------------- !el if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2) !el if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2) !el----------------- 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)+ & !el wcorr*gcorr_long(j,i)+ & !el gcorr_long- brak deklaracji 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 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) 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 !#define DEBUG #ifdef DEBUG write (iout,*) "gloc_sc before reduce" do i=1,nres do j=1,1 write (iout,*) i,j,gloc_sc(j,i,icg) enddo enddo #endif !#undef DEBUG 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) time_reduce=time_reduce+MPI_Wtime()-time00 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 !#define DEBUG #ifdef DEBUG write (iout,*) "gloc_sc after reduce" do i=1,nres do j=1,1 write (iout,*) i,j,gloc_sc(j,i,icg) enddo enddo #endif !#undef DEBUG #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 ! ! Compute the maximum elements of the gradient ! 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 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 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 !el#define DEBUG #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 !el#undef DEBUG #ifdef TIMING time_sumgradient=time_sumgradient+MPI_Wtime()-time01 #endif return end subroutine sum_gradient !----------------------------------------------------------------------------- subroutine sc_grad ! implicit real*8 (a-h,o-z) use calc_data ! include 'DIMENSIONS' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.CALC' ! include 'COMMON.IOUNITS' real(kind=8), dimension(3) :: dcosom1,dcosom2 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 & -2.0D0*alf12*eps3der+sigder*sigsq_om12 ! diagnostics only ! eom1=0.0d0 ! eom2=0.0d0 ! eom12=evdwij*eps1_om12 ! end diagnostics ! write (iout,*) "eps2der",eps2der," eps3der",eps3der,& ! " sigder",sigder ! write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 ! write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 do k=1,3 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) enddo do k=1,3 gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k) enddo ! write (iout,*) "gg",(gg(k),k=1,3) do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv gvdwx(k,j)=gvdwx(k,j)+gg(k) & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv ! write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & ! +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv ! write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & ! +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv enddo ! ! Calculate the components of the gradient in DC and X ! !grad do k=i,j-1 !grad do l=1,3 !grad gvdwc(l,k)=gvdwc(l,k)+gg(l) !grad enddo !grad enddo do l=1,3 gvdwc(l,i)=gvdwc(l,i)-gg(l) gvdwc(l,j)=gvdwc(l,j)+gg(l) enddo return end subroutine sc_grad #ifdef CRYST_THETA !----------------------------------------------------------------------------- subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) use comm_calcthet ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.LOCAL' ! include 'COMMON.IOUNITS' !el real(kind=8) :: term1,term2,termm,diffak,ratak,& !el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& !el delthe0,sig0inv,sigtc,sigsqtc,delthec, real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40 !el integer :: it !el common /calcthet/ term1,term2,termm,diffak,ratak,& !el ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,& !el delthe0,sig0inv,sigtc,sigsqtc,delthec,it !el local variables delthec=thetai-thet_pred_mean delthe0=thetai-theta0i ! "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 subroutine mixder #endif !----------------------------------------------------------------------------- ! cartder.F !----------------------------------------------------------------------------- subroutine cartder !----------------------------------------------------------------------------- ! This subroutine calculates the derivatives of the consecutive virtual ! bond vectors and the SC vectors in the virtual-bond angles theta and ! virtual-torsional angles phi, as well as the derivatives of SC vectors ! in the angles alpha and omega, describing the location of a side chain ! in its local coordinate system. ! ! The derivatives are stored in the following arrays: ! ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi. ! The structure is as follows: ! ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0, 0, 0 ! dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4) ! . . . . . . . . . . . . . . . . . . ! dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4) ! . ! . ! . ! dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N) ! ! DXDV - the derivatives of the side-chain vectors in theta and phi. ! The structure is same as above. ! ! DCDS - the derivatives of the side chain vectors in the local spherical ! andgles alph and omega: ! ! dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2) ! dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3) ! . ! . ! . ! dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1) ! ! Version of March '95, based on an early version of November '91. ! !********************************************************************** ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.VAR' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.GEO' ! include 'COMMON.LOCAL' ! include 'COMMON.INTERACT' real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres) real(kind=8),dimension(3,3) :: dp,temp !el real(kind=8) :: fromto(3,3,maxdim) !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2) real(kind=8),dimension(3) :: xx,xx1 !el local variables integer :: i,k,l,j,m,ind,ind1,jjj real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,& tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,& sint2,xp,yp,xxp,yyp,zzp,dj ! common /przechowalnia/ fromto if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim)) ! get the position of the jth ijth fragment of the chain coordinate system ! in the fromto array. ! indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 ! ! maxdim=(nres-1)*(nres-2)/2 ! allocate(dcdv(6,maxdim),dxds(6,nres)) ! calculate the derivatives of transformation matrix elements in theta ! !el call flush(iout) !el do i=1,nres-2 rdt(1,1,i)=-rt(1,2,i) rdt(1,2,i)= rt(1,1,i) rdt(1,3,i)= 0.0d0 rdt(2,1,i)=-rt(2,2,i) rdt(2,2,i)= rt(2,1,i) rdt(2,3,i)= 0.0d0 rdt(3,1,i)=-rt(3,2,i) rdt(3,2,i)= rt(3,1,i) rdt(3,3,i)= 0.0d0 enddo ! ! derivatives in phi ! do i=2,nres-2 drt(1,1,i)= 0.0d0 drt(1,2,i)= 0.0d0 drt(1,3,i)= 0.0d0 drt(2,1,i)= rt(3,1,i) drt(2,2,i)= rt(3,2,i) drt(2,3,i)= rt(3,3,i) drt(3,1,i)=-rt(2,1,i) drt(3,2,i)=-rt(2,2,i) drt(3,3,i)=-rt(2,3,i) enddo ! ! generate the matrix products of type r(i)t(i)...r(j)t(j) ! do i=2,nres-2 ind=indmat(i,i+1) do k=1,3 do l=1,3 temp(k,l)=rt(k,l,i) enddo enddo do k=1,3 do l=1,3 fromto(k,l,ind)=temp(k,l) enddo enddo do j=i+1,nres-2 ind=indmat(i,j+1) do k=1,3 do l=1,3 dpkl=0.0d0 do m=1,3 dpkl=dpkl+temp(k,m)*rt(m,l,j) enddo dp(k,l)=dpkl fromto(k,l,ind)=dpkl enddo enddo do k=1,3 do l=1,3 temp(k,l)=dp(k,l) enddo enddo enddo enddo ! ! Calculate derivatives. ! ind1=0 do i=1,nres-2 ind1=ind1+1 ! ! Derivatives of DC(i+1) in theta(i+2) ! do j=1,3 do k=1,2 dpjk=0.0D0 do l=1,3 dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) enddo dp(j,k)=dpjk prordt(j,k,i)=dp(j,k) enddo dp(j,3)=0.0D0 dcdv(j,ind1)=vbld(i+1)*dp(j,1) enddo ! ! Derivatives of SC(i+1) in theta(i+2) ! xx1(1)=-0.5D0*xloc(2,i+1) xx1(2)= 0.5D0*xloc(1,i+1) do j=1,3 xj=0.0D0 do k=1,2 xj=xj+r(j,k,i)*xx1(k) enddo xx(j)=xj enddo do j=1,3 rj=0.0D0 do k=1,3 rj=rj+prod(j,k,i)*xx(k) enddo dxdv(j,ind1)=rj enddo ! ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently ! than the other off-diagonal derivatives. ! do j=1,3 dxoiij=0.0D0 do k=1,3 dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) enddo dxdv(j,ind1+1)=dxoiij enddo !d print *,ind1+1,(dxdv(j,ind1+1),j=1,3) ! ! Derivatives of DC(i+1) in phi(i+2) ! do j=1,3 do k=1,3 dpjk=0.0 do l=2,3 dpjk=dpjk+prod(j,l,i)*drt(l,k,i) enddo dp(j,k)=dpjk prodrt(j,k,i)=dp(j,k) enddo dcdv(j+3,ind1)=vbld(i+1)*dp(j,1) enddo ! ! Derivatives of SC(i+1) in phi(i+2) ! xx(1)= 0.0D0 xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i) xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i) do j=1,3 rj=0.0D0 do k=2,3 rj=rj+prod(j,k,i)*xx(k) enddo dxdv(j+3,ind1)=-rj enddo ! ! Derivatives of SC(i+1) in phi(i+3). ! do j=1,3 dxoiij=0.0D0 do k=1,3 dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) enddo dxdv(j+3,ind1+1)=dxoiij enddo ! ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru ! theta(nres) and phi(i+3) thru phi(nres). ! do j=i+1,nres-2 ind1=ind1+1 ind=indmat(i+1,j+1) !d print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 do k=1,3 do l=1,3 tempkl=0.0D0 do m=1,2 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind) enddo temp(k,l)=tempkl enddo enddo !d print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) !d print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) !d print '(9f8.3)',((temp(k,l),l=1,3),k=1,3) ! Derivatives of virtual-bond vectors in theta do k=1,3 dcdv(k,ind1)=vbld(i+1)*temp(k,1) enddo !d print '(3f8.3)',(dcdv(k,ind1),k=1,3) ! Derivatives of SC vectors in theta do k=1,3 dxoijk=0.0D0 do l=1,3 dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) enddo dxdv(k,ind1+1)=dxoijk enddo ! !--- Calculate the derivatives in phi ! do k=1,3 do l=1,3 tempkl=0.0D0 do m=1,3 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind) enddo temp(k,l)=tempkl enddo enddo do k=1,3 dcdv(k+3,ind1)=vbld(i+1)*temp(k,1) enddo do k=1,3 dxoijk=0.0D0 do l=1,3 dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) enddo dxdv(k+3,ind1+1)=dxoijk enddo enddo enddo ! ! Derivatives in alpha and omega: ! do i=2,nres-1 ! dsci=dsc(itype(i)) dsci=vbld(i+nres) #ifdef OSF alphi=alph(i) omegi=omeg(i) if(alphi.ne.alphi) alphi=100.0 if(omegi.ne.omegi) omegi=-100.0 #else alphi=alph(i) omegi=omeg(i) #endif !d print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi cosalphi=dcos(alphi) sinalphi=dsin(alphi) cosomegi=dcos(omegi) sinomegi=dsin(omegi) temp(1,1)=-dsci*sinalphi temp(2,1)= dsci*cosalphi*cosomegi temp(3,1)=-dsci*cosalphi*sinomegi temp(1,2)=0.0D0 temp(2,2)=-dsci*sinalphi*sinomegi temp(3,2)=-dsci*sinalphi*cosomegi theta2=pi-0.5D0*theta(i+1) cost2=dcos(theta2) sint2=dsin(theta2) jjj=0 !d print *,((temp(l,k),l=1,3),k=1,2) do j=1,2 xp=temp(1,j) yp=temp(2,j) xxp= xp*cost2+yp*sint2 yyp=-xp*sint2+yp*cost2 zzp=temp(3,j) xx(1)=xxp xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) do k=1,3 dj=0.0D0 do l=1,3 dj=dj+prod(k,l,i-1)*xx(l) enddo dxds(jjj+k,i)=dj enddo jjj=jjj+3 enddo enddo return end subroutine cartder !----------------------------------------------------------------------------- ! checkder_p.F !----------------------------------------------------------------------------- subroutine check_cartgrad ! Check the gradient of Cartesian coordinates in internal coordinates. ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.VAR' ! include 'COMMON.CHAIN' ! include 'COMMON.GEO' ! include 'COMMON.LOCAL' ! include 'COMMON.DERIV' real(kind=8),dimension(6,nres) :: temp real(kind=8),dimension(3) :: xx,gg integer :: i,k,j,ii real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii ! indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 ! ! Check the gradient of the virtual-bond and SC vectors in the internal ! coordinates. ! aincr=1.0d-7 aincr2=5.0d-8 call cartder write (iout,'(a)') '**************** dx/dalpha' write (iout,'(a)') do i=2,nres-1 alphi=alph(i) alph(i)=alph(i)+aincr do k=1,3 temp(k,i)=dc(k,nres+i) enddo call chainbuild do k=1,3 gg(k)=(dc(k,nres+i)-temp(k,i))/aincr xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr)) enddo write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') & i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3) write (iout,'(a)') alph(i)=alphi call chainbuild enddo write (iout,'(a)') write (iout,'(a)') '**************** dx/domega' write (iout,'(a)') do i=2,nres-1 omegi=omeg(i) omeg(i)=omeg(i)+aincr do k=1,3 temp(k,i)=dc(k,nres+i) enddo call chainbuild do k=1,3 gg(k)=(dc(k,nres+i)-temp(k,i))/aincr xx(k)=dabs((gg(k)-dxds(k+3,i))/ & (aincr*dabs(dxds(k+3,i))+aincr)) enddo write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') & i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3) write (iout,'(a)') omeg(i)=omegi call chainbuild enddo write (iout,'(a)') write (iout,'(a)') '**************** dx/dtheta' write (iout,'(a)') do i=3,nres theti=theta(i) theta(i)=theta(i)+aincr do j=i-1,nres-1 do k=1,3 temp(k,j)=dc(k,nres+j) enddo enddo call chainbuild do j=i-1,nres-1 ii = indmat(i-2,j) ! print *,'i=',i-2,' j=',j-1,' ii=',ii do k=1,3 gg(k)=(dc(k,nres+j)-temp(k,j))/aincr xx(k)=dabs((gg(k)-dxdv(k,ii))/ & (aincr*dabs(dxdv(k,ii))+aincr)) enddo write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3) write(iout,'(a)') enddo write (iout,'(a)') theta(i)=theti call chainbuild enddo write (iout,'(a)') '***************** dx/dphi' write (iout,'(a)') do i=4,nres phi(i)=phi(i)+aincr do j=i-1,nres-1 do k=1,3 temp(k,j)=dc(k,nres+j) enddo enddo call chainbuild do j=i-1,nres-1 ii = indmat(i-2,j) ! print *,'ii=',ii do k=1,3 gg(k)=(dc(k,nres+j)-temp(k,j))/aincr xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ & (aincr*dabs(dxdv(k+3,ii))+aincr)) enddo write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3) write(iout,'(a)') enddo phi(i)=phi(i)-aincr call chainbuild enddo write (iout,'(a)') '****************** ddc/dtheta' do i=1,nres-2 thet=theta(i+2) theta(i+2)=thet+aincr do j=i,nres do k=1,3 temp(k,j)=dc(k,j) enddo enddo call chainbuild do j=i+1,nres-1 ii = indmat(i,j) ! print *,'ii=',ii do k=1,3 gg(k)=(dc(k,j)-temp(k,j))/aincr xx(k)=dabs((gg(k)-dcdv(k,ii))/ & (aincr*dabs(dcdv(k,ii))+aincr)) enddo write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3) write (iout,'(a)') enddo do j=1,nres do k=1,3 dc(k,j)=temp(k,j) enddo enddo theta(i+2)=thet enddo write (iout,'(a)') '******************* ddc/dphi' do i=1,nres-3 phii=phi(i+3) phi(i+3)=phii+aincr do j=1,nres do k=1,3 temp(k,j)=dc(k,j) enddo enddo call chainbuild do j=i+2,nres-1 ii = indmat(i+1,j) ! print *,'ii=',ii do k=1,3 gg(k)=(dc(k,j)-temp(k,j))/aincr xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ & (aincr*dabs(dcdv(k+3,ii))+aincr)) enddo write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') & i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3) write (iout,'(a)') enddo do j=1,nres do k=1,3 dc(k,j)=temp(k,j) enddo enddo phi(i+3)=phii enddo return end subroutine check_cartgrad !----------------------------------------------------------------------------- subroutine check_ecart ! Check the gradient of the energy in Cartesian coordinates. ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.IOUNITS' ! include 'COMMON.VAR' ! include 'COMMON.CONTACTS' use comm_srutu !el integer :: icall !el common /srutu/ icall real(kind=8),dimension(6) :: ggg real(kind=8),dimension(3) :: cc,xx,ddc,ddx real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) real(kind=8),dimension(6,nres) :: grad_s real(kind=8),dimension(0:n_ene) :: energia,energia1 integer :: uiparm(1) real(kind=8) :: urparm(1) !EL external fdum integer :: nf,i,j,k real(kind=8) :: aincr,etot,etot1 icg=1 nf=0 nfl=0 call zerograd aincr=1.0D-7 print '(a)','CG processor',me,' calling CHECK_CART.' nf=0 icall=0 call geom_to_var(nvar,x) call etotal(energia) etot=energia(0) !el call enerprint(energia) call gradient(nvar,x,nf,g,uiparm,urparm,fdum) icall =1 do i=1,nres write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) enddo do i=1,nres do j=1,3 grad_s(j,i)=gradc(j,i,icg) grad_s(j+3,i)=gradx(j,i,icg) enddo enddo call flush(iout) write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' do i=1,nres do j=1,3 xx(j)=c(j,i+nres) ddc(j)=dc(j,i) ddx(j)=dc(j,i+nres) enddo do j=1,3 dc(j,i)=dc(j,i)+aincr do k=i+1,nres c(j,k)=c(j,k)+aincr c(j,k+nres)=c(j,k+nres)+aincr enddo call etotal(energia1) etot1=energia1(0) ggg(j)=(etot1-etot)/aincr dc(j,i)=ddc(j) do k=i+1,nres c(j,k)=c(j,k)-aincr c(j,k+nres)=c(j,k+nres)-aincr enddo enddo do j=1,3 c(j,i+nres)=c(j,i+nres)+aincr dc(j,i+nres)=dc(j,i+nres)+aincr call etotal(energia1) etot1=energia1(0) ggg(j+3)=(etot1-etot)/aincr c(j,i+nres)=xx(j) dc(j,i+nres)=ddx(j) enddo write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6) enddo return end subroutine check_ecart !----------------------------------------------------------------------------- subroutine check_ecartint ! Check the gradient of the energy in Cartesian coordinates. use io_base, only: intout ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.CONTROL' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.IOUNITS' ! include 'COMMON.VAR' ! include 'COMMON.CONTACTS' ! include 'COMMON.MD' ! include 'COMMON.LOCAL' ! include 'COMMON.SPLITELE' use comm_srutu !el integer :: icall !el common /srutu/ icall real(kind=8),dimension(6) :: ggg,ggg1 real(kind=8),dimension(3) :: cc,xx,ddc,ddx real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres) real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres) real(kind=8),dimension(0:n_ene) :: energia,energia1 integer :: uiparm(1) real(kind=8) :: urparm(1) !EL external fdum integer :: i,j,k,nf real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,& etot21,etot22 r_cut=2.0d0 rlambd=0.3d0 icg=1 nf=0 nfl=0 call intout ! call intcartderiv ! call checkintcartgrad call zerograd aincr=1.0D-5 write(iout,*) 'Calling CHECK_ECARTINT.' nf=0 icall=0 call geom_to_var(nvar,x) if (.not.split_ene) then call etotal(energia) etot=energia(0) !el call enerprint(energia) call flush(iout) write (iout,*) "enter cartgrad" call flush(iout) call cartgrad write (iout,*) "exit cartgrad" call flush(iout) icall =1 do i=1,nres write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) enddo do j=1,3 grad_s(j,0)=gcart(j,0) enddo do i=1,nres do j=1,3 grad_s(j,i)=gcart(j,i) grad_s(j+3,i)=gxcart(j,i) enddo enddo else !- split gradient check call zerograd call etotal_long(energia) !el call enerprint(energia) call flush(iout) write (iout,*) "enter cartgrad" call flush(iout) call cartgrad write (iout,*) "exit cartgrad" call flush(iout) icall =1 write (iout,*) "longrange grad" do i=1,nres write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),& (gxcart(j,i),j=1,3) enddo do j=1,3 grad_s(j,0)=gcart(j,0) enddo do i=1,nres do j=1,3 grad_s(j,i)=gcart(j,i) grad_s(j+3,i)=gxcart(j,i) enddo enddo call zerograd call etotal_short(energia) !el call enerprint(energia) call flush(iout) write (iout,*) "enter cartgrad" call flush(iout) call cartgrad write (iout,*) "exit cartgrad" call flush(iout) icall =1 write (iout,*) "shortrange grad" do i=1,nres write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),& (gxcart(j,i),j=1,3) enddo do j=1,3 grad_s1(j,0)=gcart(j,0) enddo do i=1,nres do j=1,3 grad_s1(j,i)=gcart(j,i) grad_s1(j+3,i)=gxcart(j,i) enddo enddo endif write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' do i=0,nres do j=1,3 xx(j)=c(j,i+nres) ddc(j)=dc(j,i) ddx(j)=dc(j,i+nres) do k=1,3 dcnorm_safe(k)=dc_norm(k,i) dxnorm_safe(k)=dc_norm(k,i+nres) enddo enddo do j=1,3 dc(j,i)=ddc(j)+aincr call chainbuild_cart #ifdef MPI ! Broadcast the order to compute internal coordinates to the slaves. ! if (nfgtasks.gt.1) ! & call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR) #endif ! call int_from_cart1(.false.) if (.not.split_ene) then call etotal(energia1) etot1=energia1(0) else !- split gradient call etotal_long(energia1) etot11=energia1(0) call etotal_short(energia1) etot12=energia1(0) ! write (iout,*) "etot11",etot11," etot12",etot12 endif !- end split gradient ! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 dc(j,i)=ddc(j)-aincr call chainbuild_cart ! call int_from_cart1(.false.) if (.not.split_ene) then call etotal(energia1) etot2=energia1(0) ggg(j)=(etot1-etot2)/(2*aincr) else !- split gradient call etotal_long(energia1) etot21=energia1(0) ggg(j)=(etot11-etot21)/(2*aincr) call etotal_short(energia1) etot22=energia1(0) ggg1(j)=(etot12-etot22)/(2*aincr) !- end split gradient ! write (iout,*) "etot21",etot21," etot22",etot22 endif ! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 dc(j,i)=ddc(j) call chainbuild_cart enddo do j=1,3 dc(j,i+nres)=ddx(j)+aincr call chainbuild_cart ! write (iout,*) "i",i," j",j," dxnorm+ and dxnorm" ! write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) ! write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) ! write (iout,*) "dxnormnorm",dsqrt( ! & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) ! write (iout,*) "dxnormnormsafe",dsqrt( ! & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) ! write (iout,*) if (.not.split_ene) then call etotal(energia1) etot1=energia1(0) else !- split gradient call etotal_long(energia1) etot11=energia1(0) call etotal_short(energia1) etot12=energia1(0) endif !- end split gradient ! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1 dc(j,i+nres)=ddx(j)-aincr call chainbuild_cart ! write (iout,*) "i",i," j",j," dxnorm- and dxnorm" ! write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3) ! write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3) ! write (iout,*) ! write (iout,*) "dxnormnorm",dsqrt( ! & dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2) ! write (iout,*) "dxnormnormsafe",dsqrt( ! & dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2) if (.not.split_ene) then call etotal(energia1) etot2=energia1(0) ggg(j+3)=(etot1-etot2)/(2*aincr) else !- split gradient call etotal_long(energia1) etot21=energia1(0) ggg(j+3)=(etot11-etot21)/(2*aincr) call etotal_short(energia1) etot22=energia1(0) ggg1(j+3)=(etot12-etot22)/(2*aincr) !- end split gradient endif ! write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 dc(j,i+nres)=ddx(j) call chainbuild_cart enddo write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') & i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6) if (split_ene) then write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') & i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),& k=1,6) write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') & i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),& ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6) endif enddo return end subroutine check_ecartint !----------------------------------------------------------------------------- subroutine check_eint ! Check the gradient of energy in internal coordinates. ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.IOUNITS' ! include 'COMMON.VAR' ! include 'COMMON.GEO' use comm_srutu !el integer :: icall !el common /srutu/ icall real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres) integer :: uiparm(1) real(kind=8) :: urparm(1) real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2 character(len=6) :: key !EL external fdum integer :: i,ii,nf real(kind=8) :: xi,aincr,etot,etot1,etot2 call zerograd aincr=1.0D-7 print '(a)','Calling CHECK_INT.' nf=0 nfl=0 icg=1 call geom_to_var(nvar,x) call var_to_geom(nvar,x) call chainbuild icall=1 print *,'ICG=',ICG call etotal(energia) etot = energia(0) !el call enerprint(energia) print *,'ICG=',ICG #ifdef MPL if (MyID.ne.BossID) then call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID) nf=x(nvar+1) nfl=x(nvar+2) icg=x(nvar+3) endif #endif nf=1 nfl=3 !d write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar) call gradient(nvar,x,nf,gana,uiparm,urparm,fdum) !d write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp icall=1 do i=1,nvar xi=x(i) x(i)=xi-0.5D0*aincr call var_to_geom(nvar,x) call chainbuild call etotal(energia1) etot1=energia1(0) x(i)=xi+0.5D0*aincr call var_to_geom(nvar,x) call chainbuild call etotal(energia2) etot2=energia2(0) gg(i)=(etot2-etot1)/aincr write (iout,*) i,etot1,etot2 x(i)=xi enddo write (iout,'(/2a)')' Variable Numerical Analytical',& ' RelDiff*100% ' do i=1,nvar if (i.le.nphi) then ii=i key = ' phi' else if (i.le.nphi+ntheta) then ii=i-nphi key=' theta' else if (i.le.nphi+ntheta+nside) then ii=i-(nphi+ntheta) key=' alpha' else ii=i-(nphi+ntheta+nside) key=' omega' endif write (iout,'(i3,a,i3,3(1pd16.6))') & i,key,ii,gg(i),gana(i),& 100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr) enddo return end subroutine check_eint !----------------------------------------------------------------------------- ! econstr_local.F !----------------------------------------------------------------------------- subroutine Econstr_back ! MD with umbrella_sampling using Wolyne's distance measure as a constraint ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.CONTROL' ! include 'COMMON.VAR' ! include 'COMMON.MD' use MD_data !#ifndef LANG0 ! include 'COMMON.LANGEVIN' !#else ! include 'COMMON.LANGEVIN.lang0' !#endif ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.GEO' ! include 'COMMON.LOCAL' ! include 'COMMON.INTERACT' ! include 'COMMON.IOUNITS' ! include 'COMMON.NAMES' ! include 'COMMON.TIME1' integer :: i,j,ii,k real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz if(.not.allocated(utheta)) allocate(utheta(nfrag_back)) if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back)) if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back)) Uconst_back=0.0d0 do i=1,nres dutheta(i)=0.0d0 dugamma(i)=0.0d0 do j=1,3 duscdiff(j,i)=0.0d0 duscdiffx(j,i)=0.0d0 enddo enddo do i=1,nfrag_back ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) ! ! Deviations from theta angles ! utheta_i=0.0d0 do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) dtheta_i=theta(j)-thetaref(j) utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) enddo utheta(i)=utheta_i/(ii-1) ! ! Deviations from gamma angles ! ugamma_i=0.0d0 do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset) dgamma_i=pinorm(phi(j)-phiref(j)) ! write (iout,*) j,phi(j),phi(j)-phiref(j) ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2) ! write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3) enddo ugamma(i)=ugamma_i/(ii-2) ! ! Deviations from local SC geometry ! uscdiff(i)=0.0d0 do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 dxx=xxtab(j)-xxref(j) dyy=yytab(j)-yyref(j) dzz=zztab(j)-zzref(j) uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz do k=1,3 duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* & (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ & (ii-1) duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* & (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ & (ii-1) duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* & (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) & /(ii-1) enddo ! write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), ! & xxref(j),yyref(j),zzref(j) enddo uscdiff(i)=0.5d0*uscdiff(i)/(ii-1) ! write (iout,*) i," uscdiff",uscdiff(i) ! ! Put together deviations from local geometry ! Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ & wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i) ! write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i), ! & " uconst_back",uconst_back utheta(i)=dsqrt(utheta(i)) ugamma(i)=dsqrt(ugamma(i)) uscdiff(i)=dsqrt(uscdiff(i)) enddo return end subroutine Econstr_back !----------------------------------------------------------------------------- ! energy_p_new-sep_barrier.F !----------------------------------------------------------------------------- real(kind=8) function sscale(r) ! include "COMMON.SPLITELE" real(kind=8) :: r,gamm if(r.lt.r_cut-rlamb) then sscale=1.0d0 else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then gamm=(r-(r_cut-rlamb))/rlamb sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) else sscale=0d0 endif return end function sscale !----------------------------------------------------------------------------- subroutine elj_long(evdw) ! ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the LJ potential of interaction. ! ! 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.TORSION' ! include 'COMMON.SBRIDGE' ! include 'COMMON.NAMES' ! include 'COMMON.IOUNITS' ! include 'COMMON.CONTACTS' real(kind=8),parameter :: accur=1.0d-10 real(kind=8),dimension(3) :: gg !el local variables integer :: i,iint,j,k,itypi,itypi1,itypj real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij real(kind=8) :: e1,e2,evdwij,evdw ! write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e itypi=itype(i) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) !d write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), !d & 'iend=',iend(i,iint) do j=istart(i,iint),iend(i,iint) itypj=itype(j) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi rij=xj*xj+yj*yj+zj*zj sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) if (sss.lt.1.0d0) then rrij=1.0D0/rij eps0ij=eps(itypi,itypj) fac=rrij**expon2 e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) evdwij=e1+e2 evdw=evdw+(1.0d0-sss)*evdwij ! ! Calculate the components of the gradient in DC and X ! fac=-rrij*(e1+evdwij)*(1.0d0-sss) gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) gvdwx(k,j)=gvdwx(k,j)+gg(k) gvdwc(k,i)=gvdwc(k,i)-gg(k) gvdwc(k,j)=gvdwc(k,j)+gg(k) enddo endif enddo ! j enddo ! iint enddo ! i do i=1,nct do j=1,3 gvdwc(j,i)=expon*gvdwc(j,i) gvdwx(j,i)=expon*gvdwx(j,i) enddo enddo !****************************************************************************** ! ! N O T E !!! ! ! To save time, the factor of EXPON has been extracted from ALL components ! of GVDWC and GRADX. Remember to multiply them by this factor before further ! use! ! !****************************************************************************** return end subroutine elj_long !----------------------------------------------------------------------------- subroutine elj_short(evdw) ! ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the LJ potential of interaction. ! ! 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.TORSION' ! include 'COMMON.SBRIDGE' ! include 'COMMON.NAMES' ! include 'COMMON.IOUNITS' ! include 'COMMON.CONTACTS' real(kind=8),parameter :: accur=1.0d-10 real(kind=8),dimension(3) :: gg !el local variables integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij real(kind=8) :: e1,e2,evdwij,evdw ! write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e itypi=itype(i) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) ! Change 12/1/95 num_conti=0 ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) !d write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), !d & 'iend=',iend(i,iint) do j=istart(i,iint),iend(i,iint) itypj=itype(j) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi ! Change 12/1/95 to calculate four-body interactions rij=xj*xj+yj*yj+zj*zj sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) if (sss.gt.0.0d0) then rrij=1.0D0/rij eps0ij=eps(itypi,itypj) fac=rrij**expon2 e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) evdwij=e1+e2 evdw=evdw+sss*evdwij ! ! Calculate the components of the gradient in DC and X ! fac=-rrij*(e1+evdwij)*sss gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) gvdwx(k,j)=gvdwx(k,j)+gg(k) gvdwc(k,i)=gvdwc(k,i)-gg(k) gvdwc(k,j)=gvdwc(k,j)+gg(k) enddo endif enddo ! j enddo ! iint enddo ! i do i=1,nct do j=1,3 gvdwc(j,i)=expon*gvdwc(j,i) gvdwx(j,i)=expon*gvdwx(j,i) enddo enddo !****************************************************************************** ! ! N O T E !!! ! ! To save time, the factor of EXPON has been extracted from ALL components ! of GVDWC and GRADX. Remember to multiply them by this factor before further ! use! ! !****************************************************************************** return end subroutine elj_short !----------------------------------------------------------------------------- subroutine eljk_long(evdw) ! ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the LJK potential of interaction. ! ! 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.IOUNITS' ! include 'COMMON.NAMES' real(kind=8),dimension(3) :: gg logical :: scheck !el local variables integer :: i,iint,j,k,itypi,itypi1,itypj real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,& fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij ! print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e itypi=itype(i) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) itypj=itype(j) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi rrij=1.0D0/(xj*xj+yj*yj+zj*zj) fac_augm=rrij**expon e_augm=augm(itypi,itypj)*fac_augm r_inv_ij=dsqrt(rrij) rij=1.0D0/r_inv_ij sss=sscale(rij/sigma(itypi,itypj)) if (sss.lt.1.0d0) then r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) fac=r_shift_inv**expon e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) evdwij=e_augm+e1+e2 !d sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) !d epsi=bb(itypi,itypj)**2/aa(itypi,itypj) !d write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') !d & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), !d & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, !d & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, !d & (c(k,i),k=1,3),(c(k,j),k=1,3) evdw=evdw+(1.0d0-sss)*evdwij ! ! Calculate the components of the gradient in DC and X ! fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) fac=fac*(1.0d0-sss) gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) gvdwx(k,j)=gvdwx(k,j)+gg(k) gvdwc(k,i)=gvdwc(k,i)-gg(k) gvdwc(k,j)=gvdwc(k,j)+gg(k) enddo endif enddo ! j enddo ! iint enddo ! i do i=1,nct do j=1,3 gvdwc(j,i)=expon*gvdwc(j,i) gvdwx(j,i)=expon*gvdwx(j,i) enddo enddo return end subroutine eljk_long !----------------------------------------------------------------------------- subroutine eljk_short(evdw) ! ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the LJK potential of interaction. ! ! 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.IOUNITS' ! include 'COMMON.NAMES' real(kind=8),dimension(3) :: gg logical :: scheck !el local variables integer :: i,iint,j,k,itypi,itypi1,itypj real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,& fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij ! print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e itypi=itype(i) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) itypj=itype(j) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi rrij=1.0D0/(xj*xj+yj*yj+zj*zj) fac_augm=rrij**expon e_augm=augm(itypi,itypj)*fac_augm r_inv_ij=dsqrt(rrij) rij=1.0D0/r_inv_ij sss=sscale(rij/sigma(itypi,itypj)) if (sss.gt.0.0d0) then r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) fac=r_shift_inv**expon e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) evdwij=e_augm+e1+e2 !d sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) !d epsi=bb(itypi,itypj)**2/aa(itypi,itypj) !d write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)') !d & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), !d & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, !d & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, !d & (c(k,i),k=1,3),(c(k,j),k=1,3) evdw=evdw+sss*evdwij ! ! Calculate the components of the gradient in DC and X ! fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) fac=fac*sss gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) gvdwx(k,j)=gvdwx(k,j)+gg(k) gvdwc(k,i)=gvdwc(k,i)-gg(k) gvdwc(k,j)=gvdwc(k,j)+gg(k) enddo endif enddo ! j enddo ! iint enddo ! i do i=1,nct do j=1,3 gvdwc(j,i)=expon*gvdwc(j,i) gvdwx(j,i)=expon*gvdwx(j,i) enddo enddo return end subroutine eljk_short !----------------------------------------------------------------------------- subroutine ebp_long(evdw) ! ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the Berne-Pechukas potential of interaction. ! use calc_data ! 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.NAMES' ! include 'COMMON.INTERACT' ! include 'COMMON.IOUNITS' ! include 'COMMON.CALC' use comm_srutu !el integer :: icall !el common /srutu/ icall ! double precision rrsave(maxdim) logical :: lprn !el local variables integer :: iint,itypi,itypi1,itypj real(kind=8) :: rrij,xi,yi,zi,fac real(kind=8) :: sss,e1,e2,evdw,sigm,epsi evdw=0.0D0 ! print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 ! if (icall.eq.0) then ! lprn=.true. ! else lprn=.false. ! endif !el ind=0 do i=iatsc_s,iatsc_e itypi=itype(i) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) ! dsci_inv=dsc_inv(itypi) dsci_inv=vbld_inv(i+nres) ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) !el ind=ind+1 itypj=itype(j) if (itypj.eq.ntyp1) cycle ! dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) chi1=chi(itypi,itypj) chi2=chi(itypj,itypi) chi12=chi1*chi2 chip1=chip(itypi) chip2=chip(itypj) chip12=chip1*chip2 alf1=alp(itypi) alf2=alp(itypj) alf12=0.5D0*(alf1+alf2) 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) sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) if (sss.lt.1.0d0) then ! Calculate the angle-dependent terms of energy & contributions to derivatives. call sc_angular ! Calculate whole angle-dependent part of epsilon and contributions ! to its derivatives fac=(rrij*sigsq)**expon2 e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt evdwij=evdwij*eps2rt*eps3rt evdw=evdw+evdwij*(1.0d0-sss) if (lprn) then sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) epsi=bb(itypi,itypj)**2/aa(itypi,itypj) !d write (iout,'(2(a3,i3,2x),15(0pf7.3))') !d & restyp(itypi),i,restyp(itypj),j, !d & epsi,sigm,chi1,chi2,chip1,chip2, !d & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), !d & om1,om2,om12,1.0D0/dsqrt(rrij), !d & evdwij endif ! Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij) sigder=fac/sigsq fac=rrij*fac ! Calculate radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac ! Calculate the angular part of the gradient and sum add the contributions ! to the appropriate components of the Cartesian gradient. call sc_grad_scale(1.0d0-sss) endif enddo ! j enddo ! iint enddo ! i ! stop return end subroutine ebp_long !----------------------------------------------------------------------------- subroutine ebp_short(evdw) ! ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the Berne-Pechukas potential of interaction. ! use calc_data ! 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.NAMES' ! include 'COMMON.INTERACT' ! include 'COMMON.IOUNITS' ! include 'COMMON.CALC' use comm_srutu !el integer :: icall !el common /srutu/ icall ! double precision rrsave(maxdim) logical :: lprn !el local variables integer :: iint,itypi,itypi1,itypj real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi real(kind=8) :: sss,e1,e2,evdw evdw=0.0D0 ! print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 ! if (icall.eq.0) then ! lprn=.true. ! else lprn=.false. ! endif !el ind=0 do i=iatsc_s,iatsc_e itypi=itype(i) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) ! dsci_inv=dsc_inv(itypi) dsci_inv=vbld_inv(i+nres) ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) !el ind=ind+1 itypj=itype(j) if (itypj.eq.ntyp1) cycle ! dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) chi1=chi(itypi,itypj) chi2=chi(itypj,itypi) chi12=chi1*chi2 chip1=chip(itypi) chip2=chip(itypj) chip12=chip1*chip2 alf1=alp(itypi) alf2=alp(itypj) alf12=0.5D0*(alf1+alf2) 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) sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) if (sss.gt.0.0d0) then ! Calculate the angle-dependent terms of energy & contributions to derivatives. call sc_angular ! Calculate whole angle-dependent part of epsilon and contributions ! to its derivatives fac=(rrij*sigsq)**expon2 e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt evdwij=evdwij*eps2rt*eps3rt evdw=evdw+evdwij*sss if (lprn) then sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) epsi=bb(itypi,itypj)**2/aa(itypi,itypj) !d write (iout,'(2(a3,i3,2x),15(0pf7.3))') !d & restyp(itypi),i,restyp(itypj),j, !d & epsi,sigm,chi1,chi2,chip1,chip2, !d & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq), !d & om1,om2,om12,1.0D0/dsqrt(rrij), !d & evdwij endif ! Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij) sigder=fac/sigsq fac=rrij*fac ! Calculate radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac ! Calculate the angular part of the gradient and sum add the contributions ! to the appropriate components of the Cartesian gradient. call sc_grad_scale(sss) endif enddo ! j enddo ! iint enddo ! i ! stop return end subroutine ebp_short !----------------------------------------------------------------------------- subroutine egb_long(evdw) ! ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the Gay-Berne potential of interaction. ! use calc_data ! 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.NAMES' ! include 'COMMON.INTERACT' ! include 'COMMON.IOUNITS' ! include 'COMMON.CALC' ! include 'COMMON.CONTROL' logical :: lprn !el local variables integer :: iint,itypi,itypi1,itypj real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift real(kind=8) :: sss,e1,e2,evdw evdw=0.0D0 !cccc energy_dec=.false. ! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 lprn=.false. ! if (icall.eq.0) lprn=.false. !el ind=0 do i=iatsc_s,iatsc_e itypi=itype(i) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) ! dsci_inv=dsc_inv(itypi) dsci_inv=vbld_inv(i+nres) ! write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) ! write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) !el ind=ind+1 itypj=itype(j) if (itypj.eq.ntyp1) cycle ! dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) ! write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, ! & 1.0d0/vbld(j+nres) ! write (iout,*) "i",i," j", j," itype",itype(i),itype(j) sig0ij=sigma(itypi,itypj) chi1=chi(itypi,itypj) chi2=chi(itypj,itypi) chi12=chi1*chi2 chip1=chip(itypi) chip2=chip(itypj) chip12=chip1*chip2 alf1=alp(itypi) alf2=alp(itypj) alf12=0.5D0*(alf1+alf2) 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) sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) if (sss.lt.1.0d0) then ! Calculate angle-dependent terms of energy and contributions to their ! derivatives. call sc_angular sigsq=1.0D0/sigsq sig=sig0ij*dsqrt(sigsq) rij_shift=1.0D0/rij-sig+sig0ij ! for diagnostics; uncomment ! rij_shift=1.2*sig0ij ! I hate to put IF's in the loops, but here don't have another choice!!!! if (rij_shift.le.0.0D0) then evdw=1.0D20 !d write (iout,'(2(a3,i3,2x),17(0pf7.3))') !d & restyp(itypi),i,restyp(itypj),j, !d & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) return endif sigder=-sig*sigsq !--------------------------------------------------------------- rij_shift=1.0D0/rij_shift fac=rij_shift**expon e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt ! write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, ! & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 evdwij=evdwij*eps2rt*eps3rt evdw=evdw+evdwij*(1.0d0-sss) if (lprn) then sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) epsi=bb(itypi,itypj)**2/aa(itypi,itypj) write (iout,'(2(a3,i3,2x),17(0pf7.3))') & restyp(itypi),i,restyp(itypj),j,& epsi,sigm,chi1,chi2,chip1,chip2,& eps1,eps2rt**2,eps3rt**2,sig,sig0ij,& om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& evdwij endif if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & 'evdw',i,j,evdwij ! if (energy_dec) write (iout,*) & ! 'evdw',i,j,evdwij,"egb_long" ! Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac ! fac=0.0d0 ! Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac ! Calculate angular part of the gradient. call sc_grad_scale(1.0d0-sss) endif enddo ! j enddo ! iint enddo ! i ! write (iout,*) "Number of loop steps in EGB:",ind !ccc energy_dec=.false. return end subroutine egb_long !----------------------------------------------------------------------------- subroutine egb_short(evdw) ! ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the Gay-Berne potential of interaction. ! use calc_data ! 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.NAMES' ! include 'COMMON.INTERACT' ! include 'COMMON.IOUNITS' ! include 'COMMON.CALC' ! include 'COMMON.CONTROL' logical :: lprn !el local variables integer :: iint,itypi,itypi1,itypj real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig real(kind=8) :: sss,e1,e2,evdw,rij_shift evdw=0.0D0 !cccc energy_dec=.false. ! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 lprn=.false. ! if (icall.eq.0) lprn=.false. !el ind=0 do i=iatsc_s,iatsc_e itypi=itype(i) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) ! dsci_inv=dsc_inv(itypi) dsci_inv=vbld_inv(i+nres) ! write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) ! write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) !el ind=ind+1 itypj=itype(j) if (itypj.eq.ntyp1) cycle ! dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) ! write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, ! & 1.0d0/vbld(j+nres) ! write (iout,*) "i",i," j", j," itype",itype(i),itype(j) sig0ij=sigma(itypi,itypj) chi1=chi(itypi,itypj) chi2=chi(itypj,itypi) chi12=chi1*chi2 chip1=chip(itypi) chip2=chip(itypj) chip12=chip1*chip2 alf1=alp(itypi) alf2=alp(itypj) alf12=0.5D0*(alf1+alf2) 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) sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) if (sss.gt.0.0d0) then ! Calculate angle-dependent terms of energy and contributions to their ! derivatives. call sc_angular sigsq=1.0D0/sigsq sig=sig0ij*dsqrt(sigsq) rij_shift=1.0D0/rij-sig+sig0ij ! for diagnostics; uncomment ! rij_shift=1.2*sig0ij ! I hate to put IF's in the loops, but here don't have another choice!!!! if (rij_shift.le.0.0D0) then evdw=1.0D20 !d write (iout,'(2(a3,i3,2x),17(0pf7.3))') !d & restyp(itypi),i,restyp(itypj),j, !d & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) return endif sigder=-sig*sigsq !--------------------------------------------------------------- rij_shift=1.0D0/rij_shift fac=rij_shift**expon e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt ! write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, ! & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 evdwij=evdwij*eps2rt*eps3rt evdw=evdw+evdwij*sss if (lprn) then sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) epsi=bb(itypi,itypj)**2/aa(itypi,itypj) write (iout,'(2(a3,i3,2x),17(0pf7.3))') & restyp(itypi),i,restyp(itypj),j,& epsi,sigm,chi1,chi2,chip1,chip2,& eps1,eps2rt**2,eps3rt**2,sig,sig0ij,& om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& evdwij endif if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & 'evdw',i,j,evdwij ! if (energy_dec) write (iout,*) & ! 'evdw',i,j,evdwij,"egb_short" ! Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac ! fac=0.0d0 ! Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac ! Calculate angular part of the gradient. call sc_grad_scale(sss) endif enddo ! j enddo ! iint enddo ! i ! write (iout,*) "Number of loop steps in EGB:",ind !ccc energy_dec=.false. return end subroutine egb_short !----------------------------------------------------------------------------- subroutine egbv_long(evdw) ! ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the Gay-Berne-Vorobjev potential of interaction. ! use calc_data ! 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.NAMES' ! include 'COMMON.INTERACT' ! include 'COMMON.IOUNITS' ! include 'COMMON.CALC' use comm_srutu !el integer :: icall !el common /srutu/ icall logical :: lprn !el local variables integer :: iint,itypi,itypi1,itypj real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift evdw=0.0D0 ! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 lprn=.false. ! if (icall.eq.0) lprn=.true. !el ind=0 do i=iatsc_s,iatsc_e itypi=itype(i) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) ! dsci_inv=dsc_inv(itypi) dsci_inv=vbld_inv(i+nres) ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) !el ind=ind+1 itypj=itype(j) if (itypj.eq.ntyp1) cycle ! dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) sig0ij=sigma(itypi,itypj) r0ij=r0(itypi,itypj) chi1=chi(itypi,itypj) chi2=chi(itypj,itypi) chi12=chi1*chi2 chip1=chip(itypi) chip2=chip(itypj) chip12=chip1*chip2 alf1=alp(itypi) alf2=alp(itypj) alf12=0.5D0*(alf1+alf2) 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) sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) if (sss.lt.1.0d0) then ! Calculate angle-dependent terms of energy and contributions to their ! derivatives. call sc_angular sigsq=1.0D0/sigsq sig=sig0ij*dsqrt(sigsq) rij_shift=1.0D0/rij-sig+r0ij ! I hate to put IF's in the loops, but here don't have another choice!!!! if (rij_shift.le.0.0D0) then evdw=1.0D20 return endif sigder=-sig*sigsq !--------------------------------------------------------------- rij_shift=1.0D0/rij_shift fac=rij_shift**expon e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt fac_augm=rrij**expon e_augm=augm(itypi,itypj)*fac_augm evdwij=evdwij*eps2rt*eps3rt evdw=evdw+(evdwij+e_augm)*(1.0d0-sss) if (lprn) then sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) epsi=bb(itypi,itypj)**2/aa(itypi,itypj) write (iout,'(2(a3,i3,2x),17(0pf7.3))') & restyp(itypi),i,restyp(itypj),j,& epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),& chi1,chi2,chip1,chip2,& eps1,eps2rt**2,eps3rt**2,& om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& evdwij+e_augm endif ! Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac-2*expon*rrij*e_augm ! Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac ! Calculate angular part of the gradient. call sc_grad_scale(1.0d0-sss) endif enddo ! j enddo ! iint enddo ! i end subroutine egbv_long !----------------------------------------------------------------------------- subroutine egbv_short(evdw) ! ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the Gay-Berne-Vorobjev potential of interaction. ! use calc_data ! 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.NAMES' ! include 'COMMON.INTERACT' ! include 'COMMON.IOUNITS' ! include 'COMMON.CALC' use comm_srutu !el integer :: icall !el common /srutu/ icall logical :: lprn !el local variables integer :: iint,itypi,itypi1,itypj real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm evdw=0.0D0 ! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 lprn=.false. ! if (icall.eq.0) lprn=.true. !el ind=0 do i=iatsc_s,iatsc_e itypi=itype(i) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) ! dsci_inv=dsc_inv(itypi) dsci_inv=vbld_inv(i+nres) ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) !el ind=ind+1 itypj=itype(j) if (itypj.eq.ntyp1) cycle ! dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) sig0ij=sigma(itypi,itypj) r0ij=r0(itypi,itypj) chi1=chi(itypi,itypj) chi2=chi(itypj,itypi) chi12=chi1*chi2 chip1=chip(itypi) chip2=chip(itypj) chip12=chip1*chip2 alf1=alp(itypi) alf2=alp(itypj) alf12=0.5D0*(alf1+alf2) 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) sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) if (sss.gt.0.0d0) then ! Calculate angle-dependent terms of energy and contributions to their ! derivatives. call sc_angular sigsq=1.0D0/sigsq sig=sig0ij*dsqrt(sigsq) rij_shift=1.0D0/rij-sig+r0ij ! I hate to put IF's in the loops, but here don't have another choice!!!! if (rij_shift.le.0.0D0) then evdw=1.0D20 return endif sigder=-sig*sigsq !--------------------------------------------------------------- rij_shift=1.0D0/rij_shift fac=rij_shift**expon e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt fac_augm=rrij**expon e_augm=augm(itypi,itypj)*fac_augm evdwij=evdwij*eps2rt*eps3rt evdw=evdw+(evdwij+e_augm)*sss if (lprn) then sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) epsi=bb(itypi,itypj)**2/aa(itypi,itypj) write (iout,'(2(a3,i3,2x),17(0pf7.3))') & restyp(itypi),i,restyp(itypj),j,& epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),& chi1,chi2,chip1,chip2,& eps1,eps2rt**2,eps3rt**2,& om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& evdwij+e_augm endif ! Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac-2*expon*rrij*e_augm ! Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac ! Calculate angular part of the gradient. call sc_grad_scale(sss) endif enddo ! j enddo ! iint enddo ! i end subroutine egbv_short !----------------------------------------------------------------------------- subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) ! ! This subroutine calculates the average interaction energy and its gradient ! in the virtual-bond vectors between non-adjacent peptide groups, based on ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. ! The potential depends both on the distance of peptide-group centers and on ! the orientation of the CA-CA virtual bonds. ! ! implicit real*8 (a-h,o-z) use comm_locel #ifdef MPI include 'mpif.h' #endif ! include 'DIMENSIONS' ! include 'COMMON.CONTROL' ! include 'COMMON.SETUP' ! include 'COMMON.IOUNITS' ! include 'COMMON.GEO' ! include 'COMMON.VAR' ! include 'COMMON.LOCAL' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.INTERACT' ! include 'COMMON.CONTACTS' ! include 'COMMON.TORSION' ! include 'COMMON.VECTORS' ! include 'COMMON.FFIELD' ! include 'COMMON.TIME1' real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg real(kind=8),dimension(2,2) :: acipa !el,a_temp !el real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1 real(kind=8),dimension(4) :: muij !el integer :: num_conti,j1,j2 !el real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,& !el dz_normi,xmedi,ymedi,zmedi !el common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,& !el dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,& !el num_conti,j1,j2 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions #ifdef MOMENT real(kind=8) :: scal_el=1.0d0 #else real(kind=8) :: scal_el=0.5d0 #endif ! 12/13/98 ! 13-go grudnia roku pamietnego... real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,& 0.0d0,1.0d0,0.0d0,& 0.0d0,0.0d0,1.0d0/),shape(unmat)) !el local variables integer :: i,j,k real(kind=8) :: fac real(kind=8) :: dxj,dyj,dzj real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4 ! allocate(num_cont_hb(nres)) !(maxres) !d write(iout,*) 'In EELEC' !d do i=1,nloctyp !d write(iout,*) 'Type',i !d write(iout,*) 'B1',B1(:,i) !d write(iout,*) 'B2',B2(:,i) !d write(iout,*) 'CC',CC(:,:,i) !d write(iout,*) 'DD',DD(:,:,i) !d write(iout,*) 'EE',EE(:,:,i) !d enddo !d call check_vecgrad !d stop if (icheckgrad.eq.1) then do i=1,nres-1 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i))) do k=1,3 dc_norm(k,i)=dc(k,i)*fac enddo ! write (iout,*) 'i',i,' fac',fac enddo endif if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then ! call vec_and_deriv #ifdef TIMING time01=MPI_Wtime() #endif call set_matrices #ifdef TIMING time_mat=time_mat+MPI_Wtime()-time01 #endif endif !d do i=1,nres-1 !d write (iout,*) 'i=',i !d do k=1,3 !d write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i) !d enddo !d do k=1,3 !d write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') !d & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3) !d enddo !d enddo t_eelecij=0.0d0 ees=0.0D0 evdw1=0.0D0 eel_loc=0.0d0 eello_turn3=0.0d0 eello_turn4=0.0d0 !el ind=0 do i=1,nres num_cont_hb(i)=0 enddo !d print '(a)','Enter EELEC' !d write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e ! if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres) ! if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres) do i=1,nres gel_loc_loc(i)=0.0d0 gcorr_loc(i)=0.0d0 enddo ! ! ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms ! ! Loop over i,i+2 and i,i+3 pairs of the peptide groups ! do i=iturn3_start,iturn3_end if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 & .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle dxi=dc(1,i) dyi=dc(2,i) dzi=dc(3,i) dx_normi=dc_norm(1,i) dy_normi=dc_norm(2,i) dz_normi=dc_norm(3,i) xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi num_conti=0 call eelecij_scale(i,i+2,ees,evdw1,eel_loc) if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) num_cont_hb(i)=num_conti enddo do i=iturn4_start,iturn4_end if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 & .or. itype(i+3).eq.ntyp1 & .or. itype(i+4).eq.ntyp1) cycle dxi=dc(1,i) dyi=dc(2,i) dzi=dc(3,i) dx_normi=dc_norm(1,i) dy_normi=dc_norm(2,i) dz_normi=dc_norm(3,i) xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi num_conti=num_cont_hb(i) call eelecij_scale(i,i+3,ees,evdw1,eel_loc) if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) & call eturn4(i,eello_turn4) num_cont_hb(i)=num_conti enddo ! i ! ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 ! do i=iatel_s,iatel_e if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle dxi=dc(1,i) dyi=dc(2,i) dzi=dc(3,i) dx_normi=dc_norm(1,i) dy_normi=dc_norm(2,i) dz_normi=dc_norm(3,i) xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi ! write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) num_conti=num_cont_hb(i) do j=ielstart(i),ielend(i) if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle call eelecij_scale(i,j,ees,evdw1,eel_loc) enddo ! j num_cont_hb(i)=num_conti enddo ! i ! write (iout,*) "Number of loop steps in EELEC:",ind !d do i=1,nres !d write (iout,'(i3,3f10.5,5x,3f10.5)') !d & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i) !d enddo ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term !cc eel_loc=eel_loc+eello_turn3 !d print *,"Processor",fg_rank," t_eelecij",t_eelecij return end subroutine eelec_scale !----------------------------------------------------------------------------- subroutine eelecij_scale(i,j,ees,evdw1,eel_loc) ! implicit real*8 (a-h,o-z) use comm_locel ! include 'DIMENSIONS' #ifdef MPI include "mpif.h" #endif ! include 'COMMON.CONTROL' ! include 'COMMON.IOUNITS' ! include 'COMMON.GEO' ! include 'COMMON.VAR' ! include 'COMMON.LOCAL' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.INTERACT' ! include 'COMMON.CONTACTS' ! include 'COMMON.TORSION' ! include 'COMMON.VECTORS' ! include 'COMMON.FFIELD' ! include 'COMMON.TIME1' real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg real(kind=8),dimension(2,2) :: acipa !el,a_temp !el real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1 real(kind=8),dimension(4) :: muij !el integer :: num_conti,j1,j2 !el real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,& !el dz_normi,xmedi,ymedi,zmedi !el common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,& !el dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,& !el num_conti,j1,j2 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions #ifdef MOMENT real(kind=8) :: scal_el=1.0d0 #else real(kind=8) :: scal_el=0.5d0 #endif ! 12/13/98 ! 13-go grudnia roku pamietnego... real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,& 0.0d0,1.0d0,0.0d0,& 0.0d0,0.0d0,1.0d0/),shape(unmat)) !el local variables integer :: i,j,k,l,iteli,itelj,kkk,kkll,m real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,& dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,& ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,& wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,& ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,& ecosam,ecosbm,ecosgm,ghalf,time00 ! integer :: maxconts ! maxconts = nres/4 ! allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) ! allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) ! allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) ! allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) ! allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) ! allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) ! allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) ! allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres) ! (maxconts=maxres/4) ! allocate(facont_hb(maxconts,nres)) !(maxconts,maxres) ! allocate(ees0p(maxconts,nres)) !(maxconts,maxres) ! allocate(ees0m(maxconts,nres)) !(maxconts,maxres) ! allocate(d_cont(maxconts,nres)) !(maxconts,maxres) ! allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres) ! allocate(a_chuj(2,2,maxconts,nres)) !(2,2,maxconts,maxres) ! allocate(a_chuj_der(2,2,3,5,maxconts,nres)) !(2,2,3,5,maxconts,maxres) #ifdef MPI time00=MPI_Wtime() #endif !d write (iout,*) "eelecij",i,j !el ind=ind+1 iteli=itel(i) itelj=itel(j) if (j.eq.i+2 .and. itelj.eq.2) iteli=2 aaa=app(iteli,itelj) bbb=bpp(iteli,itelj) ael6i=ael6(iteli,itelj) ael3i=ael3(iteli,itelj) dxj=dc(1,j) dyj=dc(2,j) dzj=dc(3,j) dx_normj=dc_norm(1,j) dy_normj=dc_norm(2,j) dz_normj=dc_norm(3,j) xj=c(1,j)+0.5D0*dxj-xmedi yj=c(2,j)+0.5D0*dyj-ymedi zj=c(3,j)+0.5D0*dzj-zmedi rij=xj*xj+yj*yj+zj*zj rrmij=1.0D0/rij rij=dsqrt(rij) rmij=1.0D0/rij ! For extracting the short-range part of Evdwpp sss=sscale(rij/rpp(iteli,itelj)) r3ij=rrmij*rmij r6ij=r3ij*r3ij cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij fac=cosa-3.0D0*cosb*cosg ev1=aaa*r6ij*r6ij ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions if (j.eq.i+2) ev1=scal_el*ev1 ev2=bbb*r6ij fac3=ael6i*r6ij fac4=ael3i*r3ij evdwij=ev1+ev2 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) el2=fac4*fac eesij=el1+el2 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) ees=ees+eesij evdw1=evdw1+evdwij*(1.0d0-sss) !d write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') !d & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, !d & 1.0D0/dsqrt(rrmij),evdwij,eesij, !d & xmedi,ymedi,zmedi,xj,yj,zj if (energy_dec) then write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij endif ! ! Calculate contributions to the Cartesian gradient. ! #ifdef SPLITELE facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss) facel=-3*rrmij*(el1+eesij) fac1=fac erij(1)=xj*rmij erij(2)=yj*rmij erij(3)=zj*rmij ! ! Radial derivatives. First process both termini of the fragment (i,j) ! ggg(1)=facel*xj ggg(2)=facel*yj ggg(3)=facel*zj ! do k=1,3 ! ghalf=0.5D0*ggg(k) ! gelc(k,i)=gelc(k,i)+ghalf ! gelc(k,j)=gelc(k,j)+ghalf ! enddo ! 9/28/08 AL Gradient compotents will be summed only at the end do k=1,3 gelc_long(k,j)=gelc_long(k,j)+ggg(k) gelc_long(k,i)=gelc_long(k,i)-ggg(k) enddo ! ! Loop over residues i+1 thru j-1. ! !grad do k=i+1,j-1 !grad do l=1,3 !grad gelc(l,k)=gelc(l,k)+ggg(l) !grad enddo !grad enddo ggg(1)=facvdw*xj ggg(2)=facvdw*yj ggg(3)=facvdw*zj ! do k=1,3 ! ghalf=0.5D0*ggg(k) ! gvdwpp(k,i)=gvdwpp(k,i)+ghalf ! gvdwpp(k,j)=gvdwpp(k,j)+ghalf ! enddo ! 9/28/08 AL Gradient compotents will be summed only at the end do k=1,3 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) enddo ! ! Loop over residues i+1 thru j-1. ! !grad do k=i+1,j-1 !grad do l=1,3 !grad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) !grad enddo !grad enddo #else facvdw=ev1+evdwij*(1.0d0-sss) facel=el1+eesij fac1=fac fac=-3*rrmij*(facvdw+facvdw+facel) erij(1)=xj*rmij erij(2)=yj*rmij erij(3)=zj*rmij ! ! Radial derivatives. First process both termini of the fragment (i,j) ! ggg(1)=fac*xj ggg(2)=fac*yj ggg(3)=fac*zj ! do k=1,3 ! ghalf=0.5D0*ggg(k) ! gelc(k,i)=gelc(k,i)+ghalf ! gelc(k,j)=gelc(k,j)+ghalf ! enddo ! 9/28/08 AL Gradient compotents will be summed only at the end do k=1,3 gelc_long(k,j)=gelc(k,j)+ggg(k) gelc_long(k,i)=gelc(k,i)-ggg(k) enddo ! ! Loop over residues i+1 thru j-1. ! !grad do k=i+1,j-1 !grad do l=1,3 !grad gelc(l,k)=gelc(l,k)+ggg(l) !grad enddo !grad enddo ! 9/28/08 AL Gradient compotents will be summed only at the end ggg(1)=facvdw*xj ggg(2)=facvdw*yj ggg(3)=facvdw*zj do k=1,3 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) enddo #endif ! ! Angular part ! ecosa=2.0D0*fac3*fac1+fac4 fac4=-3.0D0*fac4 fac3=-6.0D0*fac3 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) do k=1,3 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) enddo !d print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), !d & (dcosg(k),k=1,3) do k=1,3 ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) enddo ! do k=1,3 ! ghalf=0.5D0*ggg(k) ! gelc(k,i)=gelc(k,i)+ghalf ! & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) ! & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) ! gelc(k,j)=gelc(k,j)+ghalf ! & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) ! & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) ! enddo !grad do k=i+1,j-1 !grad do l=1,3 !grad gelc(l,k)=gelc(l,k)+ggg(l) !grad enddo !grad enddo do k=1,3 gelc(k,i)=gelc(k,i) & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) gelc(k,j)=gelc(k,j) & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) gelc_long(k,j)=gelc_long(k,j)+ggg(k) gelc_long(k,i)=gelc_long(k,i)-ggg(k) enddo IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN ! ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction ! energy of a peptide unit is assumed in the form of a second-order ! Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. ! Macromolecules, 1974, 7, 797-806 for definition). This correlation terms ! are computed for EVERY pair of non-contiguous peptide groups. ! if (j.lt.nres-1) then j1=j+1 j2=j-1 else j1=j-1 j2=j-2 endif kkk=0 do k=1,2 do l=1,2 kkk=kkk+1 muij(kkk)=mu(k,i)*mu(l,j) enddo enddo !d write (iout,*) 'EELEC: i',i,' j',j !d write (iout,*) 'j',j,' j1',j1,' j2',j2 !d write(iout,*) 'muij',muij ury=scalar(uy(1,i),erij) urz=scalar(uz(1,i),erij) vry=scalar(uy(1,j),erij) vrz=scalar(uz(1,j),erij) a22=scalar(uy(1,i),uy(1,j))-3*ury*vry a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz a32=scalar(uz(1,i),uy(1,j))-3*urz*vry a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz fac=dsqrt(-ael6i)*r3ij a22=a22*fac a23=a23*fac a32=a32*fac a33=a33*fac !d write (iout,'(4i5,4f10.5)') !d & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 !d write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij !d write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i), !d & uy(:,j),uz(:,j) !d write (iout,'(4f10.5)') !d & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)), !d & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j)) !d write (iout,'(4f10.5)') ury,urz,vry,vrz !d write (iout,'(9f10.5/)') !d & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij ! Derivatives of the elements of A in virtual-bond vectors call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) do k=1,3 uryg(k,1)=scalar(erder(1,k),uy(1,i)) uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) urzg(k,1)=scalar(erder(1,k),uz(1,i)) urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) vryg(k,1)=scalar(erder(1,k),uy(1,j)) vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) vrzg(k,1)=scalar(erder(1,k),uz(1,j)) vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) enddo ! Compute radial contributions to the gradient facr=-3.0d0*rrmij a22der=a22*facr a23der=a23*facr a32der=a32*facr a33der=a33*facr agg(1,1)=a22der*xj agg(2,1)=a22der*yj agg(3,1)=a22der*zj agg(1,2)=a23der*xj agg(2,2)=a23der*yj agg(3,2)=a23der*zj agg(1,3)=a32der*xj agg(2,3)=a32der*yj agg(3,3)=a32der*zj agg(1,4)=a33der*xj agg(2,4)=a33der*yj agg(3,4)=a33der*zj ! Add the contributions coming from er fac3=-3.0d0*fac do k=1,3 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) enddo do k=1,3 ! Derivatives in DC(i) !grad ghalf1=0.5d0*agg(k,1) !grad ghalf2=0.5d0*agg(k,2) !grad ghalf3=0.5d0*agg(k,3) !grad ghalf4=0.5d0*agg(k,4) aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) & -3.0d0*uryg(k,2)*vry)!+ghalf1 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) & -3.0d0*uryg(k,2)*vrz)!+ghalf2 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) & -3.0d0*urzg(k,2)*vry)!+ghalf3 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) & -3.0d0*urzg(k,2)*vrz)!+ghalf4 ! Derivatives in DC(i+1) aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) & -3.0d0*uryg(k,3)*vry)!+agg(k,1) aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) & -3.0d0*uryg(k,3)*vrz)!+agg(k,2) aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) & -3.0d0*urzg(k,3)*vry)!+agg(k,3) aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) & -3.0d0*urzg(k,3)*vrz)!+agg(k,4) ! Derivatives in DC(j) aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) & -3.0d0*vryg(k,2)*ury)!+ghalf1 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) & -3.0d0*vrzg(k,2)*ury)!+ghalf2 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) & -3.0d0*vryg(k,2)*urz)!+ghalf3 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) & -3.0d0*vrzg(k,2)*urz)!+ghalf4 ! Derivatives in DC(j+1) or DC(nres-1) aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) & -3.0d0*vryg(k,3)*ury) aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) & -3.0d0*vrzg(k,3)*ury) aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) & -3.0d0*vryg(k,3)*urz) aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) & -3.0d0*vrzg(k,3)*urz) !grad if (j.eq.nres-1 .and. i.lt.j-2) then !grad do l=1,4 !grad aggj1(k,l)=aggj1(k,l)+agg(k,l) !grad enddo !grad endif enddo acipa(1,1)=a22 acipa(1,2)=a23 acipa(2,1)=a32 acipa(2,2)=a33 a22=-a22 a23=-a23 do l=1,2 do k=1,3 agg(k,l)=-agg(k,l) aggi(k,l)=-aggi(k,l) aggi1(k,l)=-aggi1(k,l) aggj(k,l)=-aggj(k,l) aggj1(k,l)=-aggj1(k,l) enddo enddo if (j.lt.nres-1) then a22=-a22 a32=-a32 do l=1,3,2 do k=1,3 agg(k,l)=-agg(k,l) aggi(k,l)=-aggi(k,l) aggi1(k,l)=-aggi1(k,l) aggj(k,l)=-aggj(k,l) aggj1(k,l)=-aggj1(k,l) enddo enddo else a22=-a22 a23=-a23 a32=-a32 a33=-a33 do l=1,4 do k=1,3 agg(k,l)=-agg(k,l) aggi(k,l)=-aggi(k,l) aggi1(k,l)=-aggi1(k,l) aggj(k,l)=-aggj(k,l) aggj1(k,l)=-aggj1(k,l) enddo enddo endif ENDIF ! WCORR IF (wel_loc.gt.0.0d0) THEN ! Contribution to the local-electrostatic energy coming from the i-j pair eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) & +a33*muij(4) ! write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & 'eelloc',i,j,eel_loc_ij ! write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d eel_loc=eel_loc+eel_loc_ij ! Partial derivatives in virtual-bond dihedral angles gamma if (i.gt.1) & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) gel_loc_loc(j-1)=gel_loc_loc(j-1)+ & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) do l=1,3 ggg(l)=agg(l,1)*muij(1)+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4) gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) !grad ghalf=0.5d0*ggg(l) !grad gel_loc(l,i)=gel_loc(l,i)+ghalf !grad gel_loc(l,j)=gel_loc(l,j)+ghalf enddo !grad do k=i+1,j2 !grad do l=1,3 !grad gel_loc(l,k)=gel_loc(l,k)+ggg(l) !grad enddo !grad enddo ! Remaining derivatives of eello do l=1,3 gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) enddo ENDIF ! Change 12/26/95 to calculate four-body contributions to H-bonding energy ! if (j.gt.i+1 .and. num_conti.le.maxconts) then if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 & .and. num_conti.le.maxconts) then ! write (iout,*) i,j," entered corr" ! ! Calculate the contact function. The ith column of the array JCONT will ! contain the numbers of atoms that make contacts with the atom I (of numbers ! greater than I). The arrays FACONT and GACONT will contain the values of ! the contact function and its derivative. ! r0ij=1.02D0*rpp(iteli,itelj) ! r0ij=1.11D0*rpp(iteli,itelj) r0ij=2.20D0*rpp(iteli,itelj) ! r0ij=1.55D0*rpp(iteli,itelj) call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts if (fcont.gt.0.0D0) then num_conti=num_conti+1 if (num_conti.gt.maxconts) then !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts write (iout,*) 'WARNING - max. # of contacts exceeded;',& ' will skip next contacts for this conf.',num_conti else jcont_hb(num_conti,i)=j !d write (iout,*) "i",i," j",j," num_conti",num_conti, !d & " jcont_hb",jcont_hb(num_conti,i) IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el ! terms. d_cont(num_conti,i)=rij !d write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij ! --- Electrostatic-interaction matrix --- a_chuj(1,1,num_conti,i)=a22 a_chuj(1,2,num_conti,i)=a23 a_chuj(2,1,num_conti,i)=a32 a_chuj(2,2,num_conti,i)=a33 ! --- Gradient of rij do kkk=1,3 grij_hb_cont(kkk,num_conti,i)=erij(kkk) enddo kkll=0 do k=1,2 do l=1,2 kkll=kkll+1 do m=1,3 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) enddo enddo enddo ENDIF IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN ! Calculate contact energies cosa4=4.0D0*cosa wij=cosa-3.0D0*cosb*cosg cosbg1=cosb+cosg cosbg2=cosb-cosg ! fac3=dsqrt(-ael6i)/r0ij**3 fac3=dsqrt(-ael6i)*r3ij ! ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 if (ees0tmp.gt.0) then ees0pij=dsqrt(ees0tmp) else ees0pij=0 endif ! ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 if (ees0tmp.gt.0) then ees0mij=dsqrt(ees0tmp) else ees0mij=0 endif ! ees0mij=0.0D0 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) ! Diagnostics. Comment out or remove after debugging! ! ees0p(num_conti,i)=0.5D0*fac3*ees0pij ! ees0m(num_conti,i)=0.5D0*fac3*ees0mij ! ees0m(num_conti,i)=0.0D0 ! End diagnostics. ! write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, ! & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont ! Angular derivatives of the contact function ees0pij1=fac3/ees0pij ees0mij1=fac3/ees0mij fac3p=-3.0D0*fac3*rrmij ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) ! ees0mij1=0.0D0 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) ecosap=ecosa1+ecosa2 ecosbp=ecosb1+ecosb2 ecosgp=ecosg1+ecosg2 ecosam=ecosa1-ecosa2 ecosbm=ecosb1-ecosb2 ecosgm=ecosg1-ecosg2 ! Diagnostics ! ecosap=ecosa1 ! ecosbp=ecosb1 ! ecosgp=ecosg1 ! ecosam=0.0D0 ! ecosbm=0.0D0 ! ecosgm=0.0D0 ! End diagnostics facont_hb(num_conti,i)=fcont fprimcont=fprimcont/rij !d facont_hb(num_conti,i)=1.0D0 ! Following line is for diagnostics. !d fprimcont=0.0D0 do k=1,3 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) enddo do k=1,3 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) enddo gggp(1)=gggp(1)+ees0pijp*xj gggp(2)=gggp(2)+ees0pijp*yj gggp(3)=gggp(3)+ees0pijp*zj gggm(1)=gggm(1)+ees0mijp*xj gggm(2)=gggm(2)+ees0mijp*yj gggm(3)=gggm(3)+ees0mijp*zj ! Derivatives due to the contact function gacont_hbr(1,num_conti,i)=fprimcont*xj gacont_hbr(2,num_conti,i)=fprimcont*yj gacont_hbr(3,num_conti,i)=fprimcont*zj do k=1,3 ! ! 10/24/08 cgrad and ! comments indicate the parts of the code removed ! following the change of gradient-summation algorithm. ! !grad ghalfp=0.5D0*gggp(k) !grad ghalfm=0.5D0*gggm(k) gacontp_hb1(k,num_conti,i)= & !ghalfp +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) gacontp_hb2(k,num_conti,i)= & !ghalfp +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) gacontp_hb3(k,num_conti,i)=gggp(k) gacontm_hb1(k,num_conti,i)= &!ghalfm +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) gacontm_hb2(k,num_conti,i)= & !ghalfm +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) gacontm_hb3(k,num_conti,i)=gggm(k) enddo ENDIF ! wcorr endif ! num_conti.le.maxconts endif ! fcont.gt.0 endif ! j.gt.i+1 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then do k=1,4 do l=1,3 ghalf=0.5d0*agg(l,k) aggi(l,k)=aggi(l,k)+ghalf aggi1(l,k)=aggi1(l,k)+agg(l,k) aggj(l,k)=aggj(l,k)+ghalf enddo enddo if (j.eq.nres-1 .and. i.lt.j-2) then do k=1,4 do l=1,3 aggj1(l,k)=aggj1(l,k)+agg(l,k) enddo enddo endif endif ! t_eelecij=t_eelecij+MPI_Wtime()-time00 return end subroutine eelecij_scale !----------------------------------------------------------------------------- subroutine evdwpp_short(evdw1) ! ! Compute Evdwpp ! ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.CONTROL' ! include 'COMMON.IOUNITS' ! include 'COMMON.GEO' ! include 'COMMON.VAR' ! include 'COMMON.LOCAL' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.INTERACT' ! include 'COMMON.CONTACTS' ! include 'COMMON.TORSION' ! include 'COMMON.VECTORS' ! include 'COMMON.FFIELD' real(kind=8),dimension(3) :: ggg ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions #ifdef MOMENT real(kind=8) :: scal_el=1.0d0 #else real(kind=8) :: scal_el=0.5d0 #endif !el local variables integer :: i,j,k,iteli,itelj,num_conti real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,& dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,& dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw evdw1=0.0D0 ! write (iout,*) "iatel_s_vdw",iatel_s_vdw, ! & " iatel_e_vdw",iatel_e_vdw call flush(iout) do i=iatel_s_vdw,iatel_e_vdw if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1) cycle dxi=dc(1,i) dyi=dc(2,i) dzi=dc(3,i) dx_normi=dc_norm(1,i) dy_normi=dc_norm(2,i) dz_normi=dc_norm(3,i) xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi num_conti=0 ! write (iout,*) 'i',i,' ielstart',ielstart_vdw(i), ! & ' ielend',ielend_vdw(i) call flush(iout) do j=ielstart_vdw(i),ielend_vdw(i) if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle !el ind=ind+1 iteli=itel(i) itelj=itel(j) if (j.eq.i+2 .and. itelj.eq.2) iteli=2 aaa=app(iteli,itelj) bbb=bpp(iteli,itelj) dxj=dc(1,j) dyj=dc(2,j) dzj=dc(3,j) dx_normj=dc_norm(1,j) dy_normj=dc_norm(2,j) dz_normj=dc_norm(3,j) xj=c(1,j)+0.5D0*dxj-xmedi yj=c(2,j)+0.5D0*dyj-ymedi zj=c(3,j)+0.5D0*dzj-zmedi rij=xj*xj+yj*yj+zj*zj rrmij=1.0D0/rij rij=dsqrt(rij) sss=sscale(rij/rpp(iteli,itelj)) if (sss.gt.0.0d0) then rmij=1.0D0/rij r3ij=rrmij*rmij r6ij=r3ij*r3ij ev1=aaa*r6ij*r6ij ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions if (j.eq.i+2) ev1=scal_el*ev1 ev2=bbb*r6ij evdwij=ev1+ev2 if (energy_dec) then write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss endif evdw1=evdw1+evdwij*sss ! ! Calculate contributions to the Cartesian gradient. ! facvdw=-6*rrmij*(ev1+evdwij)*sss ggg(1)=facvdw*xj ggg(2)=facvdw*yj ggg(3)=facvdw*zj do k=1,3 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) enddo endif enddo ! j enddo ! i return end subroutine evdwpp_short !----------------------------------------------------------------------------- subroutine escp_long(evdw2,evdw2_14) ! ! This subroutine calculates the excluded-volume interaction energy between ! peptide-group centers and side chains and its gradient in virtual-bond and ! side-chain vectors. ! ! 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' real(kind=8),dimension(3) :: ggg !el local variables integer :: i,iint,j,k,iteli,itypj real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2 real(kind=8) :: evdw2,evdw2_14,evdwij evdw2=0.0D0 evdw2_14=0.0d0 !d print '(a)','Enter ESCP' !d write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e do i=iatscp_s,iatscp_e if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle 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) if (itypj.eq.ntyp1) cycle ! Uncomment following three lines for SC-p interactions ! xj=c(1,nres+j)-xi ! yj=c(2,nres+j)-yi ! zj=c(3,nres+j)-zi ! 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) sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) if (sss.lt.1.0d0) then 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)*(1.0d0-sss) endif evdwij=e1+e2 evdw2=evdw2+evdwij*(1.0d0-sss) if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') & 'evdw2',i,j,sss,evdwij ! ! Calculate contributions to the gradient in the virtual-bond and SC vectors. ! fac=-(evdwij+e1)*rrij*(1.0d0-sss) ggg(1)=xj*fac ggg(2)=yj*fac ggg(3)=zj*fac ! Uncomment following three lines for SC-p interactions ! do k=1,3 ! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) ! enddo ! Uncomment following line for SC-p interactions ! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) 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 endif 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 !****************************************************************************** ! ! N O T E !!! ! ! To save time the factor EXPON has been extracted from ALL components ! of GVDWC and GRADX. Remember to multiply them by this factor before further ! use! ! !****************************************************************************** return end subroutine escp_long !----------------------------------------------------------------------------- subroutine escp_short(evdw2,evdw2_14) ! ! This subroutine calculates the excluded-volume interaction energy between ! peptide-group centers and side chains and its gradient in virtual-bond and ! side-chain vectors. ! ! 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' real(kind=8),dimension(3) :: ggg !el local variables integer :: i,iint,j,k,iteli,itypj real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2 real(kind=8) :: evdw2,evdw2_14,evdwij evdw2=0.0D0 evdw2_14=0.0d0 !d print '(a)','Enter ESCP' !d write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e do i=iatscp_s,iatscp_e if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle 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) if (itypj.eq.ntyp1) cycle ! Uncomment following three lines for SC-p interactions ! xj=c(1,nres+j)-xi ! yj=c(2,nres+j)-yi ! zj=c(3,nres+j)-zi ! 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) sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) if (sss.gt.0.0d0) then 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)*sss endif evdwij=e1+e2 evdw2=evdw2+evdwij*sss if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') & 'evdw2',i,j,sss,evdwij ! ! Calculate contributions to the gradient in the virtual-bond and SC vectors. ! fac=-(evdwij+e1)*rrij*sss ggg(1)=xj*fac ggg(2)=yj*fac ggg(3)=zj*fac ! Uncomment following three lines for SC-p interactions ! do k=1,3 ! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) ! enddo ! Uncomment following line for SC-p interactions ! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) 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 endif 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 !****************************************************************************** ! ! N O T E !!! ! ! To save time the factor EXPON has been extracted from ALL components ! of GVDWC and GRADX. Remember to multiply them by this factor before further ! use! ! !****************************************************************************** return end subroutine escp_short !----------------------------------------------------------------------------- ! energy_p_new-sep_barrier.F !----------------------------------------------------------------------------- subroutine sc_grad_scale(scalfac) ! implicit real*8 (a-h,o-z) use calc_data ! include 'DIMENSIONS' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.CALC' ! include 'COMMON.IOUNITS' real(kind=8),dimension(3) :: dcosom1,dcosom2 real(kind=8) :: scalfac !el local variables ! integer :: i,j,k,l eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 & -2.0D0*alf12*eps3der+sigder*sigsq_om12 ! diagnostics only ! eom1=0.0d0 ! eom2=0.0d0 ! eom12=evdwij*eps1_om12 ! end diagnostics ! write (iout,*) "eps2der",eps2der," eps3der",eps3der, ! & " sigder",sigder ! write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12 ! write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12 do k=1,3 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) enddo do k=1,3 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac enddo ! write (iout,*) "gg",(gg(k),k=1,3) do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac gvdwx(k,j)=gvdwx(k,j)+gg(k) & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac ! write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) ! & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv ! write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) ! & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv enddo ! ! Calculate the components of the gradient in DC and X ! do l=1,3 gvdwc(l,i)=gvdwc(l,i)-gg(l) gvdwc(l,j)=gvdwc(l,j)+gg(l) enddo return end subroutine sc_grad_scale !----------------------------------------------------------------------------- ! energy_split-sep.F !----------------------------------------------------------------------------- subroutine etotal_long(energia) ! ! Compute the long-range slow-varying contributions to the energy ! ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' use MD_data, only: totT #ifndef ISNAN external proc_proc #ifdef WINPGI !MS$ATTRIBUTES C :: proc_proc #endif #endif #ifdef MPI include "mpif.h" real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw #endif ! 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.LOCAL' ! include 'COMMON.MD' real(kind=8),dimension(0:n_ene) :: energia !el local variables integer :: i,n_corr,n_corr1,ierror,ierr real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,& evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,& ecorr,ecorr5,ecorr6,eturn6,time00 ! write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot !elwrite(iout,*)"in etotal long" if (modecalc.eq.12.or.modecalc.eq.14) then #ifdef MPI ! if (fg_rank.eq.0) call int_from_cart1(.false.) #else call int_from_cart1(.false.) #endif endif !elwrite(iout,*)"in etotal long" #ifdef MPI ! write(iout,*) "ETOTAL_LONG Processor",fg_rank, ! & " absolute rank",myrank," nfgtasks",nfgtasks call flush(iout) if (nfgtasks.gt.1) then time00=MPI_Wtime() ! FG slaves call the following matching MPI_Bcast in ERGASTULUM if (fg_rank.eq.0) then call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR) ! write (iout,*) "Processor",myrank," BROADCAST iorder" ! call flush(iout) ! FG master sets up the WEIGHTS_ array which will be broadcast to the ! 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 ! FG Master broadcasts the WEIGHTS_ array call MPI_Bcast(weights_(1),n_ene,& MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) else ! 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) endif call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,& king,FG_COMM,IERR) time_Bcast=time_Bcast+MPI_Wtime()-time00 time_Bcastw=time_Bcastw+MPI_Wtime()-time00 ! call chainbuild_cart ! call int_from_cart1(.false.) endif ! write (iout,*) 'Processor',myrank, ! & ' calling etotal_short ipot=',ipot ! call flush(iout) ! print *,'Processor',myrank,' nnt=',nnt,' nct=',nct #endif !d print *,'nnt=',nnt,' nct=',nct ! !elwrite(iout,*)"in etotal long" ! Compute the side-chain and electrostatic interaction energy ! goto (101,102,103,104,105,106) ipot ! Lennard-Jones potential. 101 call elj_long(evdw) !d print '(a)','Exit ELJ' goto 107 ! Lennard-Jones-Kihara potential (shifted). 102 call eljk_long(evdw) goto 107 ! Berne-Pechukas potential (dilated LJ, angular dependence). 103 call ebp_long(evdw) goto 107 ! Gay-Berne potential (shifted LJ, angular dependence). 104 call egb_long(evdw) goto 107 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). 105 call egbv_long(evdw) goto 107 ! Soft-sphere potential 106 call e_softsphere(evdw) ! ! Calculate electrostatic (H-bonding) energy of the main chain. ! 107 continue call 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_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) else ees=0 evdw1=0 eel_loc=0 eello_turn3=0 eello_turn4=0 endif else ! write (iout,*) "Soft-spheer ELEC potential" call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,& eello_turn4) endif ! ! Calculate excluded-volume interaction energy between peptide groups ! and side chains. ! if (ipot.lt.6) then if(wscp.gt.0d0) then call escp_long(evdw2,evdw2_14) else evdw2=0 evdw2_14=0 endif else call escp_soft_sphere(evdw2,evdw2_14) endif ! ! 12/1/95 Multi-body terms ! 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) ! write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1, ! &" 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) endif ! ! If performing constraint dynamics, call the constraint energy ! 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 ! ! Sum the energies ! do i=1,n_ene energia(i)=0.0d0 enddo 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(20)=Uconst+Uconst_back call sum_energy(energia,.true.) ! write (iout,*) "Exit ETOTAL_LONG" call flush(iout) return end subroutine etotal_long !----------------------------------------------------------------------------- subroutine etotal_short(energia) ! ! Compute the short-range fast-varying contributions to the energy ! ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' #ifndef ISNAN external proc_proc #ifdef WINPGI !MS$ATTRIBUTES C :: proc_proc #endif #endif #ifdef MPI include "mpif.h" integer :: ierror,ierr real(kind=8),dimension(n_ene) :: weights_ real(kind=8) :: time00 #endif ! 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.LOCAL' real(kind=8),dimension(0:n_ene) :: energia !el local variables integer :: i,nres6 real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr nres6=6*nres ! write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot ! call flush(iout) if (modecalc.eq.12.or.modecalc.eq.14) then #ifdef MPI if (fg_rank.eq.0) call int_from_cart1(.false.) #else call int_from_cart1(.false.) #endif endif #ifdef MPI ! write(iout,*) "ETOTAL_SHORT Processor",fg_rank, ! & " absolute rank",myrank," nfgtasks",nfgtasks ! call flush(iout) if (nfgtasks.gt.1) then time00=MPI_Wtime() ! FG slaves call the following matching MPI_Bcast in ERGASTULUM if (fg_rank.eq.0) then call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR) ! write (iout,*) "Processor",myrank," BROADCAST iorder" ! call flush(iout) ! FG master sets up the WEIGHTS_ array which will be broadcast to the ! 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 ! FG Master broadcasts the WEIGHTS_ array call MPI_Bcast(weights_(1),n_ene,& MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) else ! 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) endif ! write (iout,*),"Processor",myrank," BROADCAST weights" call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,& king,FG_COMM,IERR) ! write (iout,*) "Processor",myrank," BROADCAST c" call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,& king,FG_COMM,IERR) ! write (iout,*) "Processor",myrank," BROADCAST dc" call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,& king,FG_COMM,IERR) ! write (iout,*) "Processor",myrank," BROADCAST dc_norm" call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,& king,FG_COMM,IERR) ! write (iout,*) "Processor",myrank," BROADCAST theta" call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,& king,FG_COMM,IERR) ! write (iout,*) "Processor",myrank," BROADCAST phi" call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,& king,FG_COMM,IERR) ! write (iout,*) "Processor",myrank," BROADCAST alph" call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,& king,FG_COMM,IERR) ! write (iout,*) "Processor",myrank," BROADCAST omeg" call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,& king,FG_COMM,IERR) ! write (iout,*) "Processor",myrank," BROADCAST vbld" call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,& king,FG_COMM,IERR) time_Bcast=time_Bcast+MPI_Wtime()-time00 ! write (iout,*) "Processor",myrank," BROADCAST vbld_inv" endif ! write (iout,*) 'Processor',myrank, ! & ' calling etotal_short ipot=',ipot ! call flush(iout) ! print *,'Processor',myrank,' nnt=',nnt,' nct=',nct #endif ! call int_from_cart1(.false.) ! ! Compute the side-chain and electrostatic interaction energy ! goto (101,102,103,104,105,106) ipot ! Lennard-Jones potential. 101 call elj_short(evdw) !d print '(a)','Exit ELJ' goto 107 ! Lennard-Jones-Kihara potential (shifted). 102 call eljk_short(evdw) goto 107 ! Berne-Pechukas potential (dilated LJ, angular dependence). 103 call ebp_short(evdw) goto 107 ! Gay-Berne potential (shifted LJ, angular dependence). 104 call egb_short(evdw) goto 107 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). 105 call egbv_short(evdw) goto 107 ! Soft-sphere potential - already dealt with in the long-range part 106 evdw=0.0d0 ! 106 call e_softsphere_short(evdw) ! ! Calculate electrostatic (H-bonding) energy of the main chain. ! 107 continue ! ! Calculate the short-range part of Evdwpp ! call evdwpp_short(evdw1) ! ! Calculate the short-range part of ESCp ! if (ipot.lt.6) then call escp_short(evdw2,evdw2_14) endif ! ! Calculate the bond-stretching energy ! call ebond(estr) ! ! Calculate the disulfide-bridge and other energy and the contributions ! from other distance constraints. call edis(ehpb) ! ! Calculate the virtual-bond-angle energy. ! call ebend(ebe) ! ! Calculate the SC local energy. ! call vec_and_deriv call esc(escloc) ! ! Calculate the virtual-bond torsional energy. ! call etor(etors,edihcnstr) ! ! 6/23/01 Calculate double-torsional energy ! call etor_d(etors_d) ! ! 21/5/07 Calculate local sicdechain correlation energy ! if (wsccor.gt.0.0d0) then call eback_sc_corr(esccor) else esccor=0.0d0 endif ! ! Put energy components into an array ! do i=1,n_ene energia(i)=0.0d0 enddo 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(16)=evdw1 #else energia(3)=evdw1 #endif energia(11)=ebe energia(12)=escloc energia(13)=etors energia(14)=etors_d energia(15)=ehpb energia(17)=estr energia(19)=edihcnstr energia(21)=esccor ! write (iout,*) "ETOTAL_SHORT before SUM_ENERGY" call flush(iout) call sum_energy(energia,.true.) ! write (iout,*) "Exit ETOTAL_SHORT" call flush(iout) return end subroutine etotal_short !----------------------------------------------------------------------------- ! gnmr1.f !----------------------------------------------------------------------------- real(kind=8) function gnmr1(y,ymin,ymax) ! implicit none real(kind=8) :: y,ymin,ymax real(kind=8) :: wykl=4.0d0 if (y.lt.ymin) then gnmr1=(ymin-y)**wykl/wykl else if (y.gt.ymax) then gnmr1=(y-ymax)**wykl/wykl else gnmr1=0.0d0 endif return end function gnmr1 !----------------------------------------------------------------------------- real(kind=8) function gnmr1prim(y,ymin,ymax) ! implicit none real(kind=8) :: y,ymin,ymax real(kind=8) :: wykl=4.0d0 if (y.lt.ymin) then gnmr1prim=-(ymin-y)**(wykl-1) else if (y.gt.ymax) then gnmr1prim=(y-ymax)**(wykl-1) else gnmr1prim=0.0d0 endif return end function gnmr1prim !----------------------------------------------------------------------------- real(kind=8) function harmonic(y,ymax) ! implicit none real(kind=8) :: y,ymax real(kind=8) :: wykl=2.0d0 harmonic=(y-ymax)**wykl return end function harmonic !----------------------------------------------------------------------------- real(kind=8) function harmonicprim(y,ymax) real(kind=8) :: y,ymin,ymax real(kind=8) :: wykl=2.0d0 harmonicprim=(y-ymax)*wykl return end function harmonicprim !----------------------------------------------------------------------------- ! gradient_p.F !----------------------------------------------------------------------------- subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) use io_base, only:intout,briefout ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.VAR' ! include 'COMMON.INTERACT' ! include 'COMMON.FFIELD' ! include 'COMMON.MD' ! include 'COMMON.IOUNITS' real(kind=8),external :: ufparm integer :: uiparm(1) real(kind=8) :: urparm(1) real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) real(kind=8) :: f,gthetai,gphii,galphai,gomegai integer :: n,nf,ind,ind1,i,k,j ! ! This subroutine calculates total internal coordinate gradient. ! Depending on the number of function evaluations, either whole energy ! is evaluated beforehand, Cartesian coordinates and their derivatives in ! internal coordinates are reevaluated or only the cartesian-in-internal ! coordinate derivatives are evaluated. The subroutine was designed to work ! with SUMSL. ! ! icg=mod(nf,2)+1 !d print *,'grad',nf,icg if (nf-nfl+1) 20,30,40 20 call func(n,x,nf,f,uiparm,urparm,ufparm) ! write (iout,*) 'grad 20' if (nf.eq.0) return goto 40 30 call var_to_geom(n,x) call chainbuild ! write (iout,*) 'grad 30' ! ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables. ! 40 call cartder ! write (iout,*) 'grad 40' ! print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon ! ! Convert the Cartesian gradient into internal-coordinate gradient. ! ind=0 ind1=0 do i=1,nres-2 gthetai=0.0D0 gphii=0.0D0 do j=i+1,nres-1 ind=ind+1 ! ind=indmat(i,j) ! print *,'GRAD: i=',i,' jc=',j,' ind=',ind do k=1,3 gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) enddo do k=1,3 gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) enddo enddo do j=i+1,nres-1 ind1=ind1+1 ! ind1=indmat(i,j) ! print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 do k=1,3 gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) enddo enddo if (i.gt.1) g(i-1)=gphii if (n.gt.nphi) g(nphi+i)=gthetai enddo if (n.le.nphi+ntheta) goto 10 do i=2,nres-1 if (itype(i).ne.10) then galphai=0.0D0 gomegai=0.0D0 do k=1,3 galphai=galphai+dxds(k,i)*gradx(k,i,icg) enddo do k=1,3 gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) enddo g(ialph(i,1))=galphai g(ialph(i,1)+nside)=gomegai endif enddo ! ! Add the components corresponding to local energy terms. ! 10 continue do i=1,nvar !d write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) g(i)=g(i)+gloc(i,icg) enddo ! Uncomment following three lines for diagnostics. !d call intout !elwrite(iout,*) "in gradient after calling intout" !d call briefout(0,0.0d0) !d write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) return end subroutine gradient !----------------------------------------------------------------------------- subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F use comm_chu ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.DERIV' ! include 'COMMON.IOUNITS' ! include 'COMMON.GEO' integer :: n,nf !el integer :: jjj !el common /chuju/ jjj real(kind=8) :: energia(0:n_ene) integer :: uiparm(1) real(kind=8) :: urparm(1) real(kind=8) :: f real(kind=8),external :: ufparm real(kind=8),dimension(6*nres) :: x !(maxvar) (maxvar=6*maxres) ! if (jjj.gt.0) then ! write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) ! endif nfl=nf icg=mod(nf,2)+1 !d print *,'func',nf,nfl,icg call var_to_geom(n,x) call zerograd call chainbuild !d write (iout,*) 'ETOTAL called from FUNC' call etotal(energia) call sum_gradient f=energia(0) ! if (jjj.gt.0) then ! write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) ! write (iout,*) 'f=',etot ! jjj=0 ! endif return end subroutine func !----------------------------------------------------------------------------- subroutine cartgrad ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' use energy_data use MD_data, only: totT #ifdef MPI include 'mpif.h' #endif ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.VAR' ! include 'COMMON.INTERACT' ! include 'COMMON.FFIELD' ! include 'COMMON.MD' ! include 'COMMON.IOUNITS' ! include 'COMMON.TIME1' ! integer :: i,j ! This subrouting calculates total Cartesian coordinate gradient. ! The subroutine chainbuild_cart and energy MUST be called beforehand. ! !el#define DEBUG #ifdef TIMING time00=MPI_Wtime() #endif icg=1 call sum_gradient #ifdef TIMING #endif !el write (iout,*) "After sum_gradient" #ifdef DEBUG !el write (iout,*) "After sum_gradient" do i=1,nres-1 write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) enddo #endif ! If performing constraint dynamics, add the gradients of the constraint energy if(usampl.and.totT.gt.eq_time) then do i=1,nct do j=1,3 gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i) gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i) enddo enddo do i=1,nres-3 gloc(i,icg)=gloc(i,icg)+dugamma(i) enddo do i=1,nres-2 gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) enddo endif !elwrite (iout,*) "After sum_gradient" #ifdef TIMING time01=MPI_Wtime() #endif call intcartderiv !elwrite (iout,*) "After sum_gradient" #ifdef TIMING time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 #endif ! call checkintcartgrad ! write(iout,*) 'calling int_to_cart' #ifdef DEBUG write (iout,*) "gcart, gxcart, gloc before int_to_cart" #endif do i=1,nct do j=1,3 gcart(j,i)=gradc(j,i,icg) gxcart(j,i)=gradx(j,i,icg) enddo #ifdef DEBUG write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),& (gxcart(j,i),j=1,3),gloc(i,icg) #endif enddo #ifdef TIMING time01=MPI_Wtime() #endif call int_to_cart #ifdef TIMING time_inttocart=time_inttocart+MPI_Wtime()-time01 #endif #ifdef DEBUG write (iout,*) "gcart and gxcart after int_to_cart" do i=0,nres-1 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),& (gxcart(j,i),j=1,3) enddo #endif #ifdef TIMING time_cartgrad=time_cartgrad+MPI_Wtime()-time00 #endif !el#undef DEBUG return end subroutine cartgrad !----------------------------------------------------------------------------- subroutine zerograd ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.DERIV' ! include 'COMMON.CHAIN' ! include 'COMMON.VAR' ! include 'COMMON.MD' ! include 'COMMON.SCCOR' ! !el local variables integer :: i,j,intertyp ! Initialize Cartesian-coordinate gradient ! ! if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2) ! if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2) ! allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres)) ! allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres)) ! allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres)) ! allocate(gradcorr_long(3,nres)) ! allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres)) ! allocate(gcorr6_turn_long(3,nres)) ! allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres) ! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres) ! allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres)) ! allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres)) ! if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres) ! if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres) ! allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres) ! allocate(gscloc(3,nres)) !(3,maxres) ! if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres) ! common /deriv_scloc/ ! allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres)) ! allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres)) ! allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres)) !(3,maxres) ! common /mpgrad/ ! allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres) ! gradc(j,i,icg)=0.0d0 ! gradx(j,i,icg)=0.0d0 ! allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres !elwrite(iout,*) "icg",icg do i=1,nres do j=1,3 gvdwx(j,i)=0.0D0 gradx_scp(j,i)=0.0D0 gvdwc(j,i)=0.0D0 gvdwc_scp(j,i)=0.0D0 gvdwc_scpp(j,i)=0.0d0 gelc(j,i)=0.0D0 gelc_long(j,i)=0.0D0 gradb(j,i)=0.0d0 gradbx(j,i)=0.0d0 gvdwpp(j,i)=0.0d0 gel_loc(j,i)=0.0d0 gel_loc_long(j,i)=0.0d0 ghpbc(j,i)=0.0D0 ghpbx(j,i)=0.0D0 gcorr3_turn(j,i)=0.0d0 gcorr4_turn(j,i)=0.0d0 gradcorr(j,i)=0.0d0 gradcorr_long(j,i)=0.0d0 gradcorr5_long(j,i)=0.0d0 gradcorr6_long(j,i)=0.0d0 gcorr6_turn_long(j,i)=0.0d0 gradcorr5(j,i)=0.0d0 gradcorr6(j,i)=0.0d0 gcorr6_turn(j,i)=0.0d0 gsccorc(j,i)=0.0d0 gsccorx(j,i)=0.0d0 gradc(j,i,icg)=0.0d0 gradx(j,i,icg)=0.0d0 gscloc(j,i)=0.0d0 gsclocx(j,i)=0.0d0 do intertyp=1,3 gloc_sc(intertyp,i,icg)=0.0d0 enddo enddo enddo ! ! Initialize the gradient of local energy terms. ! ! allocate(gloc(4*nres,2)) !!(maxvar,2)(maxvar=6*maxres) ! if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres) ! if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres) ! allocate(g_corr5_loc(nres),g_corr6_loc(nres)) !(maxvar)(maxvar=6*maxres) ! allocate(gel_loc_turn3(nres)) ! allocate(gel_loc_turn4(nres),gel_loc_turn6(nres)) !(maxvar)(maxvar=6*maxres) ! allocate(gsccor_loc(nres)) !(maxres) do i=1,4*nres gloc(i,icg)=0.0D0 enddo do i=1,nres gel_loc_loc(i)=0.0d0 gcorr_loc(i)=0.0d0 g_corr5_loc(i)=0.0d0 g_corr6_loc(i)=0.0d0 gel_loc_turn3(i)=0.0d0 gel_loc_turn4(i)=0.0d0 gel_loc_turn6(i)=0.0d0 gsccor_loc(i)=0.0d0 enddo ! initialize gcart and gxcart ! allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES) do i=0,nres do j=1,3 gcart(j,i)=0.0d0 gxcart(j,i)=0.0d0 enddo enddo return end subroutine zerograd !----------------------------------------------------------------------------- real(kind=8) function fdum() fdum=0.0D0 return end function fdum !----------------------------------------------------------------------------- ! intcartderiv.F !----------------------------------------------------------------------------- subroutine intcartderiv ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' #ifdef MPI include 'mpif.h' #endif ! include 'COMMON.SETUP' ! include 'COMMON.CHAIN' ! include 'COMMON.VAR' ! include 'COMMON.GEO' ! include 'COMMON.INTERACT' ! include 'COMMON.DERIV' ! include 'COMMON.IOUNITS' ! include 'COMMON.LOCAL' ! include 'COMMON.SCCOR' real(kind=8) :: pi4,pi34 real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres) real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,& dcosomega,dsinomega !(3,3,maxres) real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n integer :: i,j,k real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,& fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,& fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,& fac17,coso_inv,fac10,fac11,fac12,fac13,fac14 integer :: nres2 nres2=2*nres !el from module energy------------- !el allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres !el allocate(dsintau(3,3,3,itau_start:itau_end)) !el allocate(dtauangle(3,3,3,itau_start:itau_end)) !el allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres !el allocate(dsintau(3,3,3,0:nres2)) !el allocate(dtauangle(3,3,3,0:nres2)) !el allocate(domicron(3,2,2,0:nres2)) !el allocate(dcosomicron(3,2,2,0:nres2)) #if defined(MPI) && defined(PARINTDER) if (nfgtasks.gt.1 .and. me.eq.king) & call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR) #endif pi4 = 0.5d0*pipol pi34 = 3*pi4 ! allocate(dtheta(3,2,nres)) !(3,2,maxres) ! allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres) ! write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end do i=1,nres do j=1,3 dtheta(j,1,i)=0.0d0 dtheta(j,2,i)=0.0d0 dphi(j,1,i)=0.0d0 dphi(j,2,i)=0.0d0 dphi(j,3,i)=0.0d0 enddo enddo ! Derivatives of theta's #if defined(MPI) && defined(PARINTDER) ! We need dtheta(:,:,i-1) to compute dphi(:,:,i) do i=max0(ithet_start-1,3),ithet_end #else do i=3,nres #endif cost=dcos(theta(i)) sint=sqrt(1-cost*cost) do j=1,3 dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/& vbld(i-1) if (itype(i-1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/& vbld(i) if (itype(i-1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint enddo enddo #if defined(MPI) && defined(PARINTDER) ! We need dtheta(:,:,i-1) to compute dphi(:,:,i) do i=max0(ithet_start-1,3),ithet_end #else do i=3,nres #endif if ((itype(i-1).ne.10).and.(itype(i-1).ne.ntyp1)) then cost1=dcos(omicron(1,i)) sint1=sqrt(1-cost1*cost1) cost2=dcos(omicron(2,i)) sint2=sqrt(1-cost2*cost2) do j=1,3 !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1) dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ & cost1*dc_norm(j,i-2))/ & vbld(i-1) domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i) dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) & +cost1*(dc_norm(j,i-1+nres)))/ & vbld(i-1+nres) domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i) !C Calculate derivative over second omicron Sci-1,Cai-1 Cai !C Looks messy but better than if in loop dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) & +cost2*dc_norm(j,i-1))/ & vbld(i) domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i) dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) & +cost2*(-dc_norm(j,i-1+nres)))/ & vbld(i-1+nres) ! write(iout,*) "vbld", i,itype(i),vbld(i-1+nres) domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i) enddo endif enddo !elwrite(iout,*) "after vbld write" ! Derivatives of phi: ! If phi is 0 or 180 degrees, then the formulas ! have to be derived by power series expansion of the ! conventional formulas around 0 and 180. #ifdef PARINTDER do i=iphi1_start,iphi1_end #else do i=4,nres #endif ! if (itype(i-1).eq.21 .or. itype(i-2).eq.21 ) cycle ! the conventional case sint=dsin(theta(i)) sint1=dsin(theta(i-1)) sing=dsin(phi(i)) cost=dcos(theta(i)) cost1=dcos(theta(i-1)) cosg=dcos(phi(i)) scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1)) fac0=1.0d0/(sint1*sint) fac1=cost*fac0 fac2=cost1*fac0 fac3=cosg*cost1/(sint1*sint1) fac4=cosg*cost/(sint*sint) ! Obtaining the gamma derivatives from sine derivative if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. & phi(i).gt.pi34.and.phi(i).le.pi.or. & phi(i).gt.-pi.and.phi(i).le.-pi34) then call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2) call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) do j=1,3 ctgt=cost/sint ctgt1=cost1/sint1 cosg_inv=1.0d0/cosg if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) & -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2) dphi(j,1,i)=cosg_inv*dsinphi(j,1,i) dsinphi(j,2,i)= & -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) dphi(j,2,i)=cosg_inv*dsinphi(j,2,i) dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) ! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) dphi(j,3,i)=cosg_inv*dsinphi(j,3,i) endif ! Bug fixed 3/24/05 (AL) enddo ! Obtaining the gamma derivatives from cosine derivative else do j=1,3 if (itype(i-1).ne.ntyp1 .and. itype(i-2).ne.ntyp1) then dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* & dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* & dc_norm(j,i-3))/vbld(i-2) dphi(j,1,i)=-1/sing*dcosphi(j,1,i) dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* & dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* & dcostheta(j,1,i) dphi(j,2,i)=-1/sing*dcosphi(j,2,i) dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* & dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* & dc_norm(j,i-1))/vbld(i) dphi(j,3,i)=-1/sing*dcosphi(j,3,i) endif enddo endif enddo !alculate derivative of Tauangle #ifdef PARINTDER do i=itau_start,itau_end #else do i=3,nres !elwrite(iout,*) " vecpr",i,nres #endif if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle ! if ((itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10).or. ! & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle !c dtauangle(j,intertyp,dervityp,residue number) !c INTERTYP=1 SC...Ca...Ca..Ca ! the conventional case sint=dsin(theta(i)) sint1=dsin(omicron(2,i-1)) sing=dsin(tauangle(1,i)) cost=dcos(theta(i)) cost1=dcos(omicron(2,i-1)) cosg=dcos(tauangle(1,i)) !elwrite(iout,*) " vecpr5",i,nres do j=1,3 !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres !elwrite(iout,*) " vecpr5",dc_norm2(1,1) dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) ! write(iout,*) dc_norm2(j,i-2+nres),"dcnorm" enddo scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1)) fac0=1.0d0/(sint1*sint) fac1=cost*fac0 fac2=cost1*fac0 fac3=cosg*cost1/(sint1*sint1) fac4=cosg*cost/(sint*sint) ! write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4 ! Obtaining the gamma derivatives from sine derivative if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. & tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. & tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1) call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2) call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) do j=1,3 ctgt=cost/sint ctgt1=cost1/sint1 cosg_inv=1.0d0/cosg dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) & -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) & *vbld_inv(i-2+nres) dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i) dsintau(j,1,2,i)= & -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) ! write(iout,*) "dsintau", dsintau(j,1,2,i) dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i) ! Bug fixed 3/24/05 (AL) dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i) ! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i) enddo ! Obtaining the gamma derivatives from cosine derivative else do j=1,3 dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* & dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* & (dc_norm2(j,i-2+nres)))/vbld(i-2+nres) dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i) dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* & dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* & dcostheta(j,1,i) dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i) dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* & dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* & dc_norm(j,i-1))/vbld(i) dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i) ! write (iout,*) "else",i enddo endif ! do k=1,3 ! write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3) ! enddo enddo !C Second case Ca...Ca...Ca...SC #ifdef PARINTDER do i=itau_start,itau_end #else do i=4,nres #endif if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. & (itype(i-2).eq.ntyp1).or.(itype(i-3).eq.ntyp1)) cycle ! the conventional case sint=dsin(omicron(1,i)) sint1=dsin(theta(i-1)) sing=dsin(tauangle(2,i)) cost=dcos(omicron(1,i)) cost1=dcos(theta(i-1)) cosg=dcos(tauangle(2,i)) ! do j=1,3 ! dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) ! enddo scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres)) fac0=1.0d0/(sint1*sint) fac1=cost*fac0 fac2=cost1*fac0 fac3=cosg*cost1/(sint1*sint1) fac4=cosg*cost/(sint*sint) ! Obtaining the gamma derivatives from sine derivative if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. & tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. & tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1) call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2) call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3) do j=1,3 ctgt=cost/sint ctgt1=cost1/sint1 cosg_inv=1.0d0/cosg dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) & +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2) ! write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1), ! &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)" dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i) dsintau(j,2,2,i)= & -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) ! write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1), ! & sing*ctgt*domicron(j,1,2,i), ! & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i) ! Bug fixed 3/24/05 (AL) dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) & +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres) ! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i) enddo ! Obtaining the gamma derivatives from cosine derivative else do j=1,3 dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* & dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* & dc_norm(j,i-3))/vbld(i-2) dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i) dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* & dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* & dcosomicron(j,1,1,i) dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i) dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* & dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* & dc_norm(j,i-1+nres))/vbld(i-1+nres) dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i) ! write(iout,*) i,j,"else", dtauangle(j,2,3,i) enddo endif enddo !CC third case SC...Ca...Ca...SC #ifdef PARINTDER do i=itau_start,itau_end #else do i=3,nres #endif ! the conventional case if ((itype(i-1).eq.ntyp1).or.(itype(i-1).eq.10).or. & (itype(i-2).eq.ntyp1).or.(itype(i-2).eq.10)) cycle sint=dsin(omicron(1,i)) sint1=dsin(omicron(2,i-1)) sing=dsin(tauangle(3,i)) cost=dcos(omicron(1,i)) cost1=dcos(omicron(2,i-1)) cosg=dcos(tauangle(3,i)) do j=1,3 dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres) ! dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres) enddo scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres)) fac0=1.0d0/(sint1*sint) fac1=cost*fac0 fac2=cost1*fac0 fac3=cosg*cost1/(sint1*sint1) fac4=cosg*cost/(sint*sint) ! Obtaining the gamma derivatives from sine derivative if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. & tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. & tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1) call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2) call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3) do j=1,3 ctgt=cost/sint ctgt1=cost1/sint1 cosg_inv=1.0d0/cosg dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) & -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) & *vbld_inv(i-2+nres) dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i) dsintau(j,3,2,i)= & -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) & -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1) dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i) ! Bug fixed 3/24/05 (AL) dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) & +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) & *vbld_inv(i-1+nres) ! & +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1) dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i) enddo ! Obtaining the gamma derivatives from cosine derivative else do j=1,3 dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* & dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* & dc_norm2(j,i-2+nres))/vbld(i-2+nres) dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i) dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* & dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* & dcosomicron(j,1,1,i) dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i) dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* & dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* & dc_norm(j,i-1+nres))/vbld(i-1+nres) dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i) ! write(iout,*) "else",i enddo endif enddo #ifdef CRYST_SC ! Derivatives of side-chain angles alpha and omega #if defined(MPI) && defined(PARINTDER) do i=ibond_start,ibond_end #else do i=2,nres-1 #endif if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1)))) fac6=fac5/vbld(i) fac7=fac5*fac5 fac8=fac5/vbld(i+1) fac9=fac5/vbld(i+nres) scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres)) cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* & (scalar(dC_norm(1,i),dC_norm(1,i+nres)) & -scalar(dC_norm(1,i-1),dC_norm(1,i+nres))) sina=sqrt(1-cosa*cosa) sino=dsin(omeg(i)) ! write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino do j=1,3 dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- & dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1) dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i) dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- & scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1) dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i) dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- & dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ & vbld(i+nres)) dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i) enddo ! obtaining the derivatives of omega from sines if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. & omeg(i).gt.pi34.and.omeg(i).le.pi.or. & omeg(i).gt.-pi.and.omeg(i).le.-pi34) then fac15=dcos(theta(i+1))/(dsin(theta(i+1))* & dsin(theta(i+1))) fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i))) fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i))) call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1) call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2) call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3) coso_inv=1.0d0/dcos(omeg(i)) do j=1,3 dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) & +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- & (sino*dc_norm(j,i-1))/vbld(i) domega(j,1,i)=coso_inv*dsinomega(j,1,i) dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) & +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) & -sino*dc_norm(j,i)/vbld(i+1) domega(j,2,i)=coso_inv*dsinomega(j,2,i) dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- & fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ & vbld(i+nres) domega(j,3,i)=coso_inv*dsinomega(j,3,i) enddo else ! obtaining the derivatives of omega from cosines fac10=sqrt(0.5d0*(1-dcos(theta(i+1)))) fac11=sqrt(0.5d0*(1+dcos(theta(i+1)))) fac12=fac10*sina fac13=fac12*fac12 fac14=sina*sina do j=1,3 dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* & dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ & (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* & fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13 domega(j,1,i)=-1/sino*dcosomega(j,1,i) dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* & dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* & dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ & (scala2-fac11*cosa)*(0.25d0*sina/fac10* & dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13 domega(j,2,i)=-1/sino*dcosomega(j,2,i) dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- & scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ & (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14 domega(j,3,i)=-1/sino*dcosomega(j,3,i) enddo endif else do j=1,3 do k=1,3 dalpha(k,j,i)=0.0d0 domega(k,j,i)=0.0d0 enddo enddo endif enddo #endif #if defined(MPI) && defined(PARINTDER) if (nfgtasks.gt.1) then #ifdef DEBUG !d write (iout,*) "Gather dtheta" !d call flush(iout) write (iout,*) "dtheta before gather" do i=1,nres write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2) enddo #endif call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),& MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,& king,FG_COMM,IERROR) #ifdef DEBUG !d write (iout,*) "Gather dphi" !d call flush(iout) write (iout,*) "dphi before gather" do i=1,nres write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3) enddo #endif call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),& MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,& king,FG_COMM,IERROR) !d write (iout,*) "Gather dalpha" !d call flush(iout) #ifdef CRYST_SC call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),& MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,& king,FG_COMM,IERROR) !d write (iout,*) "Gather domega" !d call flush(iout) call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),& MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,& king,FG_COMM,IERROR) #endif endif #endif #ifdef DEBUG write (iout,*) "dtheta after gather" do i=1,nres write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2) enddo write (iout,*) "dphi after gather" do i=1,nres write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3) enddo write (iout,*) "dalpha after gather" do i=1,nres write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3) enddo write (iout,*) "domega after gather" do i=1,nres write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3) enddo #endif return end subroutine intcartderiv !----------------------------------------------------------------------------- subroutine checkintcartgrad ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' #ifdef MPI include 'mpif.h' #endif ! include 'COMMON.CHAIN' ! include 'COMMON.VAR' ! include 'COMMON.GEO' ! include 'COMMON.INTERACT' ! include 'COMMON.DERIV' ! include 'COMMON.IOUNITS' ! include 'COMMON.SETUP' real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres) real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres) real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres) real(kind=8),dimension(3) :: dc_norm_s real(kind=8) :: aincr=1.0d-5 integer :: i,j real(kind=8) :: dcji do i=1,nres phi_s(i)=phi(i) theta_s(i)=theta(i) alph_s(i)=alph(i) omeg_s(i)=omeg(i) enddo ! Check theta gradient write (iout,*) & "Analytical (upper) and numerical (lower) gradient of theta" write (iout,*) do i=3,nres do j=1,3 dcji=dc(j,i-2) dc(j,i-2)=dcji+aincr call chainbuild_cart call int_from_cart1(.false.) dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr dc(j,i-2)=dcji dcji=dc(j,i-1) dc(j,i-1)=dc(j,i-1)+aincr call chainbuild_cart dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr dc(j,i-1)=dcji enddo !el write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),& !el (dtheta(j,2,i),j=1,3) !el write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),& !el (dthetanum(j,2,i),j=1,3) !el write (iout,'(5x,3f10.5,5x,3f10.5)') & !el (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),& !el (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3) !el write (iout,*) enddo ! Check gamma gradient write (iout,*) & "Analytical (upper) and numerical (lower) gradient of gamma" do i=4,nres do j=1,3 dcji=dc(j,i-3) dc(j,i-3)=dcji+aincr call chainbuild_cart dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr dc(j,i-3)=dcji dcji=dc(j,i-2) dc(j,i-2)=dcji+aincr call chainbuild_cart dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr dc(j,i-2)=dcji dcji=dc(j,i-1) dc(j,i-1)=dc(j,i-1)+aincr call chainbuild_cart dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr dc(j,i-1)=dcji enddo !el write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),& !el (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3) !el write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),& !el (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3) !el write (iout,'(5x,3(3f10.5,5x))') & !el (dphinum(j,1,i)/dphi(j,1,i),j=1,3),& !el (dphinum(j,2,i)/dphi(j,2,i),j=1,3),& !el (dphinum(j,3,i)/dphi(j,3,i),j=1,3) !el write (iout,*) enddo ! Check alpha gradient write (iout,*) & "Analytical (upper) and numerical (lower) gradient of alpha" do i=2,nres-1 if(itype(i).ne.10) then do j=1,3 dcji=dc(j,i-1) dc(j,i-1)=dcji+aincr call chainbuild_cart dalphanum(j,1,i)=(alph(i)-alph_s(i)) & /aincr dc(j,i-1)=dcji dcji=dc(j,i) dc(j,i)=dcji+aincr call chainbuild_cart dalphanum(j,2,i)=(alph(i)-alph_s(i)) & /aincr dc(j,i)=dcji dcji=dc(j,i+nres) dc(j,i+nres)=dc(j,i+nres)+aincr call chainbuild_cart dalphanum(j,3,i)=(alph(i)-alph_s(i)) & /aincr dc(j,i+nres)=dcji enddo endif !el write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),& !el (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3) !el write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),& !el (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3) !el write (iout,'(5x,3(3f10.5,5x))') & !el (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),& !el (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),& !el (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3) !el write (iout,*) enddo ! Check omega gradient write (iout,*) & "Analytical (upper) and numerical (lower) gradient of omega" do i=2,nres-1 if(itype(i).ne.10) then do j=1,3 dcji=dc(j,i-1) dc(j,i-1)=dcji+aincr call chainbuild_cart domeganum(j,1,i)=(omeg(i)-omeg_s(i)) & /aincr dc(j,i-1)=dcji dcji=dc(j,i) dc(j,i)=dcji+aincr call chainbuild_cart domeganum(j,2,i)=(omeg(i)-omeg_s(i)) & /aincr dc(j,i)=dcji dcji=dc(j,i+nres) dc(j,i+nres)=dc(j,i+nres)+aincr call chainbuild_cart domeganum(j,3,i)=(omeg(i)-omeg_s(i)) & /aincr dc(j,i+nres)=dcji enddo endif !el write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),& !el (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3) !el write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),& !el (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3) !el write (iout,'(5x,3(3f10.5,5x))') & !el (domeganum(j,1,i)/domega(j,1,i),j=1,3),& !el (domeganum(j,2,i)/domega(j,2,i),j=1,3),& !el (domeganum(j,3,i)/domega(j,3,i),j=1,3) !el write (iout,*) enddo return end subroutine checkintcartgrad !----------------------------------------------------------------------------- ! q_measure.F !----------------------------------------------------------------------------- real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4) ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.CHAIN' ! include 'COMMON.INTERACT' ! include 'COMMON.VAR' integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg integer :: kkk,nsep=3 real(kind=8) :: qm !dist, real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax logical :: lprn=.false. logical :: flag ! real(kind=8) :: sigm,x !el sigm(x)=0.25d0*x ! local function qqmax=1.0d10 do kkk=1,nperm qq = 0.0d0 nl=0 if(flag) then do il=seg1+nsep,seg2 do jl=seg1,il-nsep nl=nl+1 d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + & (cref(2,jl,kkk)-cref(2,il,kkk))**2 + & (cref(3,jl,kkk)-cref(3,il,kkk))**2) dij=dist(il,jl) qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) if (itype(il).ne.10 .or. itype(jl).ne.10) then nl=nl+1 d0ijCM=dsqrt( & (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) dijCM=dist(il+nres,jl+nres) qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) endif qq = qq+qqij+qqijCM enddo enddo qq = qq/nl else do il=seg1,seg2 if((seg3-il).lt.3) then secseg=il+3 else secseg=seg3 endif do jl=secseg,seg4 nl=nl+1 d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & (cref(3,jl,kkk)-cref(3,il,kkk))**2) dij=dist(il,jl) qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2) if (itype(il).ne.10 .or. itype(jl).ne.10) then nl=nl+1 d0ijCM=dsqrt( & (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) dijCM=dist(il+nres,jl+nres) qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2) endif qq = qq+qqij+qqijCM enddo enddo qq = qq/nl endif if (qqmax.le.qq) qqmax=qq enddo qwolynes=1.0d0-qqmax return end function qwolynes !----------------------------------------------------------------------------- subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4) ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.CHAIN' ! include 'COMMON.INTERACT' ! include 'COMMON.VAR' ! include 'COMMON.MD' integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg integer :: nsep=3, kkk !el real(kind=8) :: dist real(kind=8) :: dij,d0ij,dijCM,d0ijCM logical :: lprn=.false. logical :: flag real(kind=8) :: sim,dd0,fac,ddqij !el sigm(x)=0.25d0*x ! local function do kkk=1,nperm do i=0,nres do j=1,3 dqwol(j,i)=0.0d0 dxqwol(j,i)=0.0d0 enddo enddo nl=0 if(flag) then do il=seg1+nsep,seg2 do jl=seg1,il-nsep nl=nl+1 d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & (cref(3,jl,kkk)-cref(3,il,kkk))**2) dij=dist(il,jl) sim = 1.0d0/sigm(d0ij) sim = sim*sim dd0 = dij-d0ij fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) do k=1,3 ddqij = (c(k,il)-c(k,jl))*fac dqwol(k,il)=dqwol(k,il)+ddqij dqwol(k,jl)=dqwol(k,jl)-ddqij enddo if (itype(il).ne.10 .or. itype(jl).ne.10) then nl=nl+1 d0ijCM=dsqrt( & (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) dijCM=dist(il+nres,jl+nres) sim = 1.0d0/sigm(d0ijCM) sim = sim*sim dd0=dijCM-d0ijCM fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) do k=1,3 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac dxqwol(k,il)=dxqwol(k,il)+ddqij dxqwol(k,jl)=dxqwol(k,jl)-ddqij enddo endif enddo enddo else do il=seg1,seg2 if((seg3-il).lt.3) then secseg=il+3 else secseg=seg3 endif do jl=secseg,seg4 nl=nl+1 d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ & (cref(2,jl,kkk)-cref(2,il,kkk))**2+ & (cref(3,jl,kkk)-cref(3,il,kkk))**2) dij=dist(il,jl) sim = 1.0d0/sigm(d0ij) sim = sim*sim dd0 = dij-d0ij fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim) do k=1,3 ddqij = (c(k,il)-c(k,jl))*fac dqwol(k,il)=dqwol(k,il)+ddqij dqwol(k,jl)=dqwol(k,jl)-ddqij enddo if (itype(il).ne.10 .or. itype(jl).ne.10) then nl=nl+1 d0ijCM=dsqrt( & (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ & (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ & (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2) dijCM=dist(il+nres,jl+nres) sim = 1.0d0/sigm(d0ijCM) sim=sim*sim dd0 = dijCM-d0ijCM fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim) do k=1,3 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac dxqwol(k,il)=dxqwol(k,il)+ddqij dxqwol(k,jl)=dxqwol(k,jl)-ddqij enddo endif enddo enddo endif enddo do i=0,nres do j=1,3 dqwol(j,i)=dqwol(j,i)/nl dxqwol(j,i)=dxqwol(j,i)/nl enddo enddo return end subroutine qwolynes_prim !----------------------------------------------------------------------------- subroutine qwol_num(seg1,seg2,flag,seg3,seg4) ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.CHAIN' ! include 'COMMON.INTERACT' ! include 'COMMON.VAR' integer :: seg1,seg2,seg3,seg4 logical :: flag real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan real(kind=8),dimension(3,0:2*nres) :: cdummy real(kind=8) :: q1,q2 real(kind=8) :: delta=1.0d-10 integer :: i,j do i=0,nres do j=1,3 q1=qwolynes(seg1,seg2,flag,seg3,seg4) cdummy(j,i)=c(j,i) c(j,i)=c(j,i)+delta q2=qwolynes(seg1,seg2,flag,seg3,seg4) qwolan(j,i)=(q2-q1)/delta c(j,i)=cdummy(j,i) enddo enddo do i=0,nres do j=1,3 q1=qwolynes(seg1,seg2,flag,seg3,seg4) cdummy(j,i+nres)=c(j,i+nres) c(j,i+nres)=c(j,i+nres)+delta q2=qwolynes(seg1,seg2,flag,seg3,seg4) qwolxan(j,i)=(q2-q1)/delta c(j,i+nres)=cdummy(j,i+nres) enddo enddo ! write(iout,*) "Numerical Q carteisan gradients backbone: " ! do i=0,nct ! write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3) ! enddo ! write(iout,*) "Numerical Q carteisan gradients side-chain: " ! do i=0,nct ! write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3) ! enddo return end subroutine qwol_num !----------------------------------------------------------------------------- subroutine EconstrQ ! MD with umbrella_sampling using Wolyne's distance measure as a constraint ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.CONTROL' ! include 'COMMON.VAR' ! include 'COMMON.MD' use MD_data !#ifndef LANG0 ! include 'COMMON.LANGEVIN' !#else ! include 'COMMON.LANGEVIN.lang0' !#endif ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.GEO' ! include 'COMMON.LOCAL' ! include 'COMMON.INTERACT' ! include 'COMMON.IOUNITS' ! include 'COMMON.NAMES' ! include 'COMMON.TIME1' real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,& duconst,duxconst integer :: kstart,kend,lstart,lend,idummy real(kind=8) :: delta=1.0d-7 integer :: i,j,k,ii do i=0,nres do j=1,3 duconst(j,i)=0.0d0 dudconst(j,i)=0.0d0 duxconst(j,i)=0.0d0 dudxconst(j,i)=0.0d0 enddo enddo Uconst=0.0d0 do i=1,nfrag qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,& idummy,idummy) Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset)) ! Calculating the derivatives of Constraint energy with respect to Q Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),& qinfrag(i,iset)) ! hm1=harmonic(qfrag(i,iset),qinfrag(i,iset)) ! hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset)) ! hmnum=(hm2-hm1)/delta ! write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset), ! & qinfrag(i,iset)) ! write(iout,*) "harmonicnum frag", hmnum ! Calculating the derivatives of Q with respect to cartesian coordinates call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,& idummy,idummy) ! write(iout,*) "dqwol " ! do ii=1,nres ! write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) ! enddo ! write(iout,*) "dxqwol " ! do ii=1,nres ! write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) ! enddo ! Calculating numerical gradients of dU/dQi and dQi/dxi ! call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true. ! & ,idummy,idummy) ! The gradients of Uconst in Cs do ii=0,nres do j=1,3 duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii) dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii) enddo enddo enddo do i=1,npair kstart=ifrag(1,ipair(1,i,iset),iset) kend=ifrag(2,ipair(1,i,iset),iset) lstart=ifrag(1,ipair(2,i,iset),iset) lend=ifrag(2,ipair(2,i,iset),iset) qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend) Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset)) ! Calculating dU/dQ Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset)) ! hm1=harmonic(qpair(i),qinpair(i,iset)) ! hm2=harmonic(qpair(i)+delta,qinpair(i,iset)) ! hmnum=(hm2-hm1)/delta ! write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i), ! & qinpair(i,iset)) ! write(iout,*) "harmonicnum pair ", hmnum ! Calculating dQ/dXi call qwolynes_prim(kstart,kend,.false.,& lstart,lend) ! write(iout,*) "dqwol " ! do ii=1,nres ! write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3) ! enddo ! write(iout,*) "dxqwol " ! do ii=1,nres ! write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) ! enddo ! Calculating numerical gradients ! call qwol_num(kstart,kend,.false. ! & ,lstart,lend) ! The gradients of Uconst in Cs do ii=0,nres do j=1,3 duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii) dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii) enddo enddo enddo ! write(iout,*) "Uconst inside subroutine ", Uconst ! Transforming the gradients from Cs to dCs for the backbone do i=0,nres do j=i+1,nres do k=1,3 dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j) enddo enddo enddo ! Transforming the gradients from Cs to dCs for the side chains do i=1,nres do j=1,3 dudxconst(j,i)=duxconst(j,i) enddo enddo ! write(iout,*) "dU/ddc backbone " ! do ii=0,nres ! write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3) ! enddo ! write(iout,*) "dU/ddX side chain " ! do ii=1,nres ! write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) ! enddo ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx ! call dEconstrQ_num return end subroutine EconstrQ !----------------------------------------------------------------------------- subroutine dEconstrQ_num ! Calculating numerical dUconst/ddc and dUconst/ddx ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.CONTROL' ! include 'COMMON.VAR' ! include 'COMMON.MD' use MD_data !#ifndef LANG0 ! include 'COMMON.LANGEVIN' !#else ! include 'COMMON.LANGEVIN.lang0' !#endif ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.GEO' ! include 'COMMON.LOCAL' ! include 'COMMON.INTERACT' ! include 'COMMON.IOUNITS' ! include 'COMMON.NAMES' ! include 'COMMON.TIME1' real(kind=8) :: uzap1,uzap2 real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy integer :: kstart,kend,lstart,lend,idummy real(kind=8) :: delta=1.0d-7 !el local variables integer :: i,ii,j ! real(kind=8) :: ! For the backbone do i=0,nres-1 do j=1,3 dUcartan(j,i)=0.0d0 cdummy(j,i)=dc(j,i) dc(j,i)=dc(j,i)+delta call chainbuild_cart uzap2=0.0d0 do ii=1,nfrag qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,& idummy,idummy) uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),& qinfrag(ii,iset)) enddo do ii=1,npair kstart=ifrag(1,ipair(1,ii,iset),iset) kend=ifrag(2,ipair(1,ii,iset),iset) lstart=ifrag(1,ipair(2,ii,iset),iset) lend=ifrag(2,ipair(2,ii,iset),iset) qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),& qinpair(ii,iset)) enddo dc(j,i)=cdummy(j,i) call chainbuild_cart uzap1=0.0d0 do ii=1,nfrag qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,& idummy,idummy) uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),& qinfrag(ii,iset)) enddo do ii=1,npair kstart=ifrag(1,ipair(1,ii,iset),iset) kend=ifrag(2,ipair(1,ii,iset),iset) lstart=ifrag(1,ipair(2,ii,iset),iset) lend=ifrag(2,ipair(2,ii,iset),iset) qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),& qinpair(ii,iset)) enddo ducartan(j,i)=(uzap2-uzap1)/(delta) enddo enddo ! Calculating numerical gradients for dU/ddx do i=0,nres-1 duxcartan(j,i)=0.0d0 do j=1,3 cdummy(j,i)=dc(j,i+nres) dc(j,i+nres)=dc(j,i+nres)+delta call chainbuild_cart uzap2=0.0d0 do ii=1,nfrag qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,& idummy,idummy) uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),& qinfrag(ii,iset)) enddo do ii=1,npair kstart=ifrag(1,ipair(1,ii,iset),iset) kend=ifrag(2,ipair(1,ii,iset),iset) lstart=ifrag(1,ipair(2,ii,iset),iset) lend=ifrag(2,ipair(2,ii,iset),iset) qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),& qinpair(ii,iset)) enddo dc(j,i+nres)=cdummy(j,i) call chainbuild_cart uzap1=0.0d0 do ii=1,nfrag qfrag(ii)=qwolynes(ifrag(1,ii,iset),& ifrag(2,ii,iset),.true.,idummy,idummy) uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),& qinfrag(ii,iset)) enddo do ii=1,npair kstart=ifrag(1,ipair(1,ii,iset),iset) kend=ifrag(2,ipair(1,ii,iset),iset) lstart=ifrag(1,ipair(2,ii,iset),iset) lend=ifrag(2,ipair(2,ii,iset),iset) qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),& qinpair(ii,iset)) enddo duxcartan(j,i)=(uzap2-uzap1)/(delta) enddo enddo write(iout,*) "Numerical dUconst/ddc backbone " do ii=0,nres write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) enddo ! write(iout,*) "Numerical dUconst/ddx side-chain " ! do ii=1,nres ! write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) ! enddo return end subroutine dEconstrQ_num !----------------------------------------------------------------------------- ! ssMD.F !----------------------------------------------------------------------------- subroutine check_energies ! use random, only: ran_number ! implicit none ! Includes ! include 'DIMENSIONS' ! include 'COMMON.CHAIN' ! include 'COMMON.VAR' ! include 'COMMON.IOUNITS' ! include 'COMMON.SBRIDGE' ! include 'COMMON.LOCAL' ! include 'COMMON.GEO' ! External functions !EL double precision ran_number !EL external ran_number ! Local variables integer :: i,j,k,l,lmax,p,pmax real(kind=8) :: rmin,rmax real(kind=8) :: eij real(kind=8) :: d real(kind=8) :: wi,rij,tj,pj ! return i=5 j=14 d=dsc(1) rmin=2.0D0 rmax=12.0D0 lmax=10000 pmax=1 do k=1,3 c(k,i)=0.0D0 c(k,j)=0.0D0 c(k,nres+i)=0.0D0 c(k,nres+j)=0.0D0 enddo do l=1,lmax !t wi=ran_number(0.0D0,pi) ! wi=ran_number(0.0D0,pi/6.0D0) ! wi=0.0D0 !t tj=ran_number(0.0D0,pi) !t pj=ran_number(0.0D0,pi) ! pj=ran_number(0.0D0,pi/6.0D0) ! pj=0.0D0 do p=1,pmax !t rij=ran_number(rmin,rmax) c(1,j)=d*sin(pj)*cos(tj) c(2,j)=d*sin(pj)*sin(tj) c(3,j)=d*cos(pj) c(3,nres+i)=-rij c(1,i)=d*sin(wi) c(3,i)=-rij-d*cos(wi) do k=1,3 dc(k,nres+i)=c(k,nres+i)-c(k,i) dc_norm(k,nres+i)=dc(k,nres+i)/d dc(k,nres+j)=c(k,nres+j)-c(k,j) dc_norm(k,nres+j)=dc(k,nres+j)/d enddo call dyn_ssbond_ene(i,j,eij) enddo enddo call exit(1) return end subroutine check_energies !----------------------------------------------------------------------------- subroutine dyn_ssbond_ene(resi,resj,eij) ! implicit none ! Includes use calc_data use comm_sschecks ! include 'DIMENSIONS' ! include 'COMMON.SBRIDGE' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.LOCAL' ! include 'COMMON.INTERACT' ! include 'COMMON.VAR' ! include 'COMMON.IOUNITS' ! include 'COMMON.CALC' #ifndef CLUST #ifndef WHAM use MD_data ! include 'COMMON.MD' ! use MD, only: totT,t_bath #endif #endif ! External functions !EL double precision h_base !EL external h_base ! Input arguments integer :: resi,resj ! Output arguments real(kind=8) :: eij ! Local variables logical :: havebond integer itypi,itypj real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2 real(kind=8),dimension(3) :: dcosom1,dcosom2 real(kind=8) :: ed real(kind=8) :: pom1,pom2 real(kind=8) :: ljA,ljB,ljXs real(kind=8),dimension(1:3) :: d_ljB real(kind=8) :: ssA,ssB,ssC,ssXs real(kind=8) :: ssxm,ljxm,ssm,ljm real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm real(kind=8) :: f1,f2,h1,h2,hd1,hd2 real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2 !-------FIRST METHOD real(kind=8) :: xm real(kind=8),dimension(1:3) :: d_xm !-------END FIRST METHOD !-------SECOND METHOD !$$$ double precision ss,d_ss(0:3),ljf,d_ljf(0:3) !-------END SECOND METHOD !-------TESTING CODE !el logical :: checkstop,transgrad !el common /sschecks/ checkstop,transgrad integer :: icheck,nicheck,jcheck,njcheck real(kind=8),dimension(-1:1) :: echeck real(kind=8) :: deps,ssx0,ljx0 !-------END TESTING CODE eij=0.0d0 i=resi j=resj !el allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres)) !el allocate(dyn_ssbond_ij(0:nres+4,nres)) itypi=itype(i) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) dsci_inv=vbld_inv(i+nres) itypj=itype(j) xj=c(1,nres+j)-c(1,nres+i) yj=c(2,nres+j)-c(2,nres+i) zj=c(3,nres+j)-c(3,nres+i) dxj=dc_norm(1,nres+j) dyj=dc_norm(2,nres+j) dzj=dc_norm(3,nres+j) dscj_inv=vbld_inv(j+nres) chi1=chi(itypi,itypj) chi2=chi(itypj,itypi) chi12=chi1*chi2 chip1=chip(itypi) chip2=chip(itypj) chip12=chip1*chip2 alf1=alp(itypi) alf2=alp(itypj) alf12=0.5D0*(alf1+alf2) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse ! The following are set in sc_angular ! 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 call sc_angular rij=1.0D0/rij ! Reset this so it makes sense sig0ij=sigma(itypi,itypj) sig=sig0ij*dsqrt(1.0D0/sigsq) ljXs=sig-sig0ij ljA=eps1*eps2rt**2*eps3rt**2 ljB=ljA*bb(itypi,itypj) ljA=ljA*aa(itypi,itypj) ljxm=ljXs+(-2.0D0*aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) ssXs=d0cm deltat1=1.0d0-om1 deltat2=1.0d0+om2 deltat12=om2-om1+2.0d0 cosphi=om12-om1*om2 ssA=akcm ssB=akct*deltat12 ssC=ss_depth & +akth*(deltat1*deltat1+deltat2*deltat2) & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi ssxm=ssXs-0.5D0*ssB/ssA !-------TESTING CODE !$$$c Some extra output !$$$ ssm=ssC-0.25D0*ssB*ssB/ssA !$$$ ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) !$$$ ssx0=ssB*ssB-4.0d0*ssA*ssC !$$$ if (ssx0.gt.0.0d0) then !$$$ ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA !$$$ else !$$$ ssx0=ssxm !$$$ endif !$$$ ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) !$$$ write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ", !$$$ & ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12 !$$$ return !-------END TESTING CODE !-------TESTING CODE ! Stop and plot energy and derivative as a function of distance if (checkstop) then ssm=ssC-0.25D0*ssB*ssB/ssA ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) if (ssm.lt.ljm .and. & dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then nicheck=1000 njcheck=1 deps=0.5d-7 else checkstop=.false. endif endif if (.not.checkstop) then nicheck=0 njcheck=-1 endif do icheck=0,nicheck do jcheck=-1,njcheck if (checkstop) rij=(ssxm-1.0d0)+ & ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps !-------END TESTING CODE if (rij.gt.ljxm) then havebond=.false. ljd=rij-ljXs fac=(1.0D0/ljd)**expon e1=fac*fac*aa(itypi,itypj) e2=fac*bb(itypi,itypj) eij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=eij*eps3rt eps3der=eij*eps2rt eij=eij*eps2rt*eps3rt sigder=-sig/sigsq e1=e1*eps1*eps2rt**2*eps3rt**2 ed=-expon*(e1+eij)/ljd sigder=ed*sigder eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 eom12=eij*eps1_om12+eps2der*eps2rt_om12 & -2.0D0*alf12*eps3der+sigder*sigsq_om12 else if (rij.lt.ssxm) then havebond=.true. ssd=rij-ssXs eij=ssA*ssd*ssd+ssB*ssd+ssC ed=2*akcm*ssd+akct*deltat12 pom1=akct*ssd 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 else omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi d_ssxm(1)=0.5D0*akct/ssA d_ssxm(2)=-d_ssxm(1) d_ssxm(3)=0.0D0 d_ljxm(1)=sig0ij/sqrt(sigsq**3) d_ljxm(2)=d_ljxm(1)*sigsq_om2 d_ljxm(3)=d_ljxm(1)*sigsq_om12 d_ljxm(1)=d_ljxm(1)*sigsq_om1 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE xm=0.5d0*(ssxm+ljxm) do k=1,3 d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k)) enddo if (rij.lt.xm) then havebond=.true. ssm=ssC-0.25D0*ssB*ssB/ssA d_ssm(1)=0.5D0*akct*ssB/ssA d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) d_ssm(3)=omega f1=(rij-xm)/(ssxm-xm) f2=(rij-ssxm)/(xm-ssxm) h1=h_base(f1,hd1) h2=h_base(f2,hd2) eij=ssm*h1+Ht*h2 delta_inv=1.0d0/(xm-ssxm) deltasq_inv=delta_inv*delta_inv fac=ssm*hd1-Ht*hd2 fac1=deltasq_inv*fac*(xm-rij) fac2=deltasq_inv*fac*(rij-ssxm) ed=delta_inv*(Ht*hd2-ssm*hd1) eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1) eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2) eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3) else havebond=.false. ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) d_ljm(1)=-0.5D0*bb(itypi,itypj)/aa(itypi,itypj)*ljB d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt) d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- & alf12/eps3rt) d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt) f1=(rij-ljxm)/(xm-ljxm) f2=(rij-xm)/(ljxm-xm) h1=h_base(f1,hd1) h2=h_base(f2,hd2) eij=Ht*h1+ljm*h2 delta_inv=1.0d0/(ljxm-xm) deltasq_inv=delta_inv*delta_inv fac=Ht*hd1-ljm*hd2 fac1=deltasq_inv*fac*(ljxm-rij) fac2=deltasq_inv*fac*(rij-xm) ed=delta_inv*(ljm*hd2-Ht*hd1) eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1) eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2) eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3) endif !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE !$$$ ssd=rij-ssXs !$$$ ljd=rij-ljXs !$$$ fac1=rij-ljxm !$$$ fac2=rij-ssxm !$$$ !$$$ d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt) !$$$ d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt) !$$$ d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt) !$$$ !$$$ ssm=ssC-0.25D0*ssB*ssB/ssA !$$$ d_ssm(1)=0.5D0*akct*ssB/ssA !$$$ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) !$$$ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) !$$$ d_ssm(3)=omega !$$$ !$$$ ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj) !$$$ do k=1,3 !$$$ d_ljm(k)=ljm*d_ljB(k) !$$$ enddo !$$$ ljm=ljm*ljB !$$$ !$$$ ss=ssA*ssd*ssd+ssB*ssd+ssC !$$$ d_ss(0)=2.0d0*ssA*ssd+ssB !$$$ d_ss(2)=akct*ssd !$$$ d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega !$$$ d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega !$$$ d_ss(3)=omega !$$$ !$$$ ljf=bb(itypi,itypj)/aa(itypi,itypj) !$$$ ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0) !$$$ d_ljf(0)=ljf*2.0d0*ljB*fac1 !$$$ do k=1,3 !$$$ d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1- !$$$ & 2.0d0*ljB*fac1*d_ljxm(k)) !$$$ enddo !$$$ ljf=ljm+ljf*ljB*fac1*fac1 !$$$ !$$$ f1=(rij-ljxm)/(ssxm-ljxm) !$$$ f2=(rij-ssxm)/(ljxm-ssxm) !$$$ h1=h_base(f1,hd1) !$$$ h2=h_base(f2,hd2) !$$$ eij=ss*h1+ljf*h2 !$$$ delta_inv=1.0d0/(ljxm-ssxm) !$$$ deltasq_inv=delta_inv*delta_inv !$$$ fac=ljf*hd2-ss*hd1 !$$$ ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac !$$$ eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac* !$$$ & (fac1*d_ssxm(1)-fac2*(d_ljxm(1))) !$$$ eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac* !$$$ & (fac1*d_ssxm(2)-fac2*(d_ljxm(2))) !$$$ eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac* !$$$ & (fac1*d_ssxm(3)-fac2*(d_ljxm(3))) !$$$ !$$$ havebond=.false. !$$$ if (ed.gt.0.0d0) havebond=.true. !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE endif if (havebond) then !#ifndef CLUST !#ifndef WHAM ! if (dyn_ssbond_ij(i,j).eq.1.0d300) then ! write(iout,'(a15,f12.2,f8.1,2i5)') ! & "SSBOND_E_FORM",totT,t_bath,i,j ! endif !#endif !#endif dyn_ssbond_ij(i,j)=eij else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then dyn_ssbond_ij(i,j)=1.0d300 !#ifndef CLUST !#ifndef WHAM ! write(iout,'(a15,f12.2,f8.1,2i5)') ! & "SSBOND_E_BREAK",totT,t_bath,i,j !#endif !#endif endif !-------TESTING CODE !el if (checkstop) then if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') & "CHECKSTOP",rij,eij,ed echeck(jcheck)=eij !el endif enddo if (checkstop) then write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps endif enddo if (checkstop) then transgrad=.true. checkstop=.false. endif !-------END TESTING CODE do k=1,3 dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij enddo do k=1,3 gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) enddo do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv gvdwx(k,j)=gvdwx(k,j)+gg(k) & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv enddo !grad do k=i,j-1 !grad do l=1,3 !grad gvdwc(l,k)=gvdwc(l,k)+gg(l) !grad enddo !grad enddo do l=1,3 gvdwc(l,i)=gvdwc(l,i)-gg(l) gvdwc(l,j)=gvdwc(l,j)+gg(l) enddo return end subroutine dyn_ssbond_ene !----------------------------------------------------------------------------- real(kind=8) function h_base(x,deriv) ! A smooth function going 0->1 in range [0,1] ! It should NOT be called outside range [0,1], it will not work there. implicit none ! Input arguments real(kind=8) :: x ! Output arguments real(kind=8) :: deriv ! Local variables real(kind=8) :: xsq ! Two parabolas put together. First derivative zero at extrema !$$$ if (x.lt.0.5D0) then !$$$ h_base=2.0D0*x*x !$$$ deriv=4.0D0*x !$$$ else !$$$ deriv=1.0D0-x !$$$ h_base=1.0D0-2.0D0*deriv*deriv !$$$ deriv=4.0D0*deriv !$$$ endif ! Third degree polynomial. First derivative zero at extrema h_base=x*x*(3.0d0-2.0d0*x) deriv=6.0d0*x*(1.0d0-x) ! Fifth degree polynomial. First and second derivatives zero at extrema !$$$ xsq=x*x !$$$ h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0) !$$$ deriv=x-1.0d0 !$$$ deriv=deriv*deriv !$$$ deriv=30.0d0*xsq*deriv return end function h_base !----------------------------------------------------------------------------- subroutine dyn_set_nss ! Adjust nss and other relevant variables based on dyn_ssbond_ij ! implicit none use MD_data, only: totT,t_bath ! Includes ! include 'DIMENSIONS' #ifdef MPI include "mpif.h" #endif ! include 'COMMON.SBRIDGE' ! include 'COMMON.CHAIN' ! include 'COMMON.IOUNITS' ! include 'COMMON.SETUP' ! include 'COMMON.MD' ! Local variables real(kind=8) :: emin integer :: i,j,imin,ierr integer :: diff,allnss,newnss integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2) newihpb,newjhpb logical :: found integer,dimension(0:nfgtasks) :: i_newnss integer,dimension(0:nfgtasks) :: displ integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2) integer :: g_newnss allnss=0 do i=1,nres-1 do j=i+1,nres if (dyn_ssbond_ij(i,j).lt.1.0d300) then allnss=allnss+1 allflag(allnss)=0 allihpb(allnss)=i alljhpb(allnss)=j endif enddo enddo !mc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) 1 emin=1.0d300 do i=1,allnss if (allflag(i).eq.0 .and. & dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then emin=dyn_ssbond_ij(allihpb(i),alljhpb(i)) imin=i endif enddo if (emin.lt.1.0d300) then allflag(imin)=1 do i=1,allnss if (allflag(i).eq.0 .and. & (allihpb(i).eq.allihpb(imin) .or. & alljhpb(i).eq.allihpb(imin) .or. & allihpb(i).eq.alljhpb(imin) .or. & alljhpb(i).eq.alljhpb(imin))) then allflag(i)=-1 endif enddo goto 1 endif !mc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) newnss=0 do i=1,allnss if (allflag(i).eq.1) then newnss=newnss+1 newihpb(newnss)=allihpb(i) newjhpb(newnss)=alljhpb(i) endif enddo #ifdef MPI if (nfgtasks.gt.1)then call MPI_Reduce(newnss,g_newnss,1,& MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) call MPI_Gather(newnss,1,MPI_INTEGER,& i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR) displ(0)=0 do i=1,nfgtasks-1,1 displ(i)=i_newnss(i-1)+displ(i-1) enddo call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,& g_newihpb,i_newnss,displ,MPI_INTEGER,& king,FG_COMM,IERR) call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,& g_newjhpb,i_newnss,displ,MPI_INTEGER,& king,FG_COMM,IERR) if(fg_rank.eq.0) then ! print *,'g_newnss',g_newnss ! print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss) ! print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss) newnss=g_newnss do i=1,newnss newihpb(i)=g_newihpb(i) newjhpb(i)=g_newjhpb(i) enddo endif endif #endif diff=newnss-nss !mc write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss) do i=1,nss found=.false. do j=1,newnss if (idssb(i).eq.newihpb(j) .and. & jdssb(i).eq.newjhpb(j)) found=.true. enddo #ifndef CLUST #ifndef WHAM if (.not.found.and.fg_rank.eq.0) & write(iout,'(a15,f12.2,f8.1,2i5)') & "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i) #endif #endif enddo do i=1,newnss found=.false. do j=1,nss if (newihpb(i).eq.idssb(j) .and. & newjhpb(i).eq.jdssb(j)) found=.true. enddo #ifndef CLUST #ifndef WHAM if (.not.found.and.fg_rank.eq.0) & write(iout,'(a15,f12.2,f8.1,2i5)') & "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i) #endif #endif enddo nss=newnss do i=1,nss idssb(i)=newihpb(i) jdssb(i)=newjhpb(i) enddo return end subroutine dyn_set_nss !----------------------------------------------------------------------------- #ifdef WHAM subroutine read_ssHist ! implicit none ! Includes ! include 'DIMENSIONS' ! include "DIMENSIONS.FREE" ! include 'COMMON.FREE' ! Local variables integer :: i,j character(len=80) :: controlcard do i=1,dyn_nssHist call card_concat(controlcard,.true.) read(controlcard,*) & dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0)) enddo return end subroutine read_ssHist #endif !----------------------------------------------------------------------------- integer function indmat(i,j) !el ! get the position of the jth ijth fragment of the chain coordinate system ! in the fromto array. integer :: i,j indmat=((2*(nres-2)-i)*(i-1))/2+j-1 return end function indmat !----------------------------------------------------------------------------- real(kind=8) function sigm(x) !el real(kind=8) :: x sigm=0.25d0*x return end function sigm !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- subroutine alloc_ener_arrays !EL Allocation of arrays used by module energy !el local variables integer :: i,j if(nres.lt.100) then maxconts=nres elseif(nres.lt.200) then maxconts=0.8*nres ! Max. number of contacts per residue else maxconts=0.6*nres ! (maxconts=maxres/4) endif maxcont=12*nres ! Max. number of SC contacts maxvar=6*nres ! Max. number of variables !el maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond !---------------------- ! arrays in subroutine init_int_table !el#ifdef MPI !el allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1) !el allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1) !el#endif allocate(nint_gr(nres)) allocate(nscp_gr(nres)) allocate(ielstart(nres)) allocate(ielend(nres)) !(maxres) allocate(istart(nres,maxint_gr)) allocate(iend(nres,maxint_gr)) !(maxres,maxint_gr) allocate(iscpstart(nres,maxint_gr)) allocate(iscpend(nres,maxint_gr)) !(maxres,maxint_gr) allocate(ielstart_vdw(nres)) allocate(ielend_vdw(nres)) !(maxres) allocate(lentyp(0:nfgtasks-1)) !(0:maxprocs-1) !---------------------- ! commom.contacts ! common /contacts/ if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont)) allocate(icont(2,maxcont)) !(2,maxcont) ! common /contacts1/ allocate(num_cont(0:nres+4)) !(maxres) allocate(jcont(maxconts,nres)) !(maxconts,maxres) allocate(facont(maxconts,nres)) !(maxconts,maxres) allocate(gacont(3,maxconts,nres)) !(3,maxconts,maxres) ! common /contacts_hb/ allocate(gacontp_hb1(3,maxconts,nres)) allocate(gacontp_hb2(3,maxconts,nres)) allocate(gacontp_hb3(3,maxconts,nres)) allocate(gacontm_hb1(3,maxconts,nres)) allocate(gacontm_hb2(3,maxconts,nres)) allocate(gacontm_hb3(3,maxconts,nres)) allocate(gacont_hbr(3,maxconts,nres)) allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres) allocate(facont_hb(maxconts,nres)) allocate(ees0p(maxconts,nres)) allocate(ees0m(maxconts,nres)) allocate(d_cont(maxconts,nres)) !(maxconts,maxres) allocate(num_cont_hb(nres)) !(maxres) allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres) ! common /rotat/ allocate(Ug(2,2,nres)) allocate(Ugder(2,2,nres)) allocate(Ug2(2,2,nres)) allocate(Ug2der(2,2,nres)) !(2,2,maxres) allocate(obrot(2,nres)) allocate(obrot2(2,nres)) allocate(obrot_der(2,nres)) allocate(obrot2_der(2,nres)) !(2,maxres) ! common /precomp1/ allocate(mu(2,nres)) allocate(muder(2,nres)) allocate(Ub2(2,nres)) do i=1,nres Ub2(1,i)=0.0d0 Ub2(2,i)=0.0d0 enddo allocate(Ub2der(2,nres)) allocate(Ctobr(2,nres)) allocate(Ctobrder(2,nres)) allocate(Dtobr2(2,nres)) allocate(Dtobr2der(2,nres)) !(2,maxres) allocate(EUg(2,2,nres)) allocate(EUgder(2,2,nres)) allocate(CUg(2,2,nres)) allocate(CUgder(2,2,nres)) allocate(DUg(2,2,nres)) allocate(Dugder(2,2,nres)) allocate(DtUg2(2,2,nres)) allocate(DtUg2der(2,2,nres)) !(2,2,maxres) ! common /precomp2/ allocate(Ug2Db1t(2,nres)) allocate(Ug2Db1tder(2,nres)) allocate(CUgb2(2,nres)) allocate(CUgb2der(2,nres)) !(2,maxres) allocate(EUgC(2,2,nres)) allocate(EUgCder(2,2,nres)) allocate(EUgD(2,2,nres)) allocate(EUgDder(2,2,nres)) allocate(DtUg2EUg(2,2,nres)) allocate(Ug2DtEUg(2,2,nres)) !(2,2,maxres) allocate(Ug2DtEUgder(2,2,2,nres)) allocate(DtUg2EUgder(2,2,2,nres)) !(2,2,2,maxres) ! common /rotat_old/ allocate(costab(nres)) allocate(sintab(nres)) allocate(costab2(nres)) allocate(sintab2(nres)) !(maxres) ! common /dipmat/ allocate(a_chuj(2,2,maxconts,nres)) !(2,2,maxconts,maxres)(maxconts=maxres/4) allocate(a_chuj_der(2,2,3,5,maxconts,nres)) !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4) ! common /contdistrib/ allocate(ncont_sent(nres)) allocate(ncont_recv(nres)) allocate(iat_sent(nres)) !(maxres) allocate(iint_sent(4,nres,nres)) allocate(iint_sent_local(4,nres,nres)) !(4,maxres,maxres) allocate(iturn3_sent(4,0:nres+4)) allocate(iturn4_sent(4,0:nres+4)) allocate(iturn3_sent_local(4,nres)) allocate(iturn4_sent_local(4,nres)) !(4,maxres) allocate(itask_cont_from(0:nfgtasks-1)) allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1) !---------------------- ! commom.deriv; ! common /derivat/ allocate(dcdv(6,maxdim)) allocate(dxdv(6,maxdim)) !(6,maxdim) allocate(dxds(6,nres)) !(6,maxres) allocate(gradx(3,nres,0:2)) allocate(gradc(3,nres,0:2)) !(3,maxres,2) allocate(gvdwx(3,nres)) allocate(gvdwc(3,nres)) allocate(gelc(3,nres)) allocate(gelc_long(3,nres)) allocate(gvdwpp(3,nres)) allocate(gvdwc_scpp(3,nres)) allocate(gradx_scp(3,nres)) allocate(gvdwc_scp(3,nres)) allocate(ghpbx(3,nres)) allocate(ghpbc(3,nres)) allocate(gradcorr(3,nres)) allocate(gradcorr_long(3,nres)) allocate(gradcorr5_long(3,nres)) allocate(gradcorr6_long(3,nres)) allocate(gcorr6_turn_long(3,nres)) allocate(gradxorr(3,nres)) allocate(gradcorr5(3,nres)) allocate(gradcorr6(3,nres)) !(3,maxres) allocate(gloc(0:maxvar,0:2)) allocate(gloc_x(0:maxvar,2)) !(maxvar,2) allocate(gel_loc(3,nres)) allocate(gel_loc_long(3,nres)) allocate(gcorr3_turn(3,nres)) allocate(gcorr4_turn(3,nres)) allocate(gcorr6_turn(3,nres)) allocate(gradb(3,nres)) allocate(gradbx(3,nres)) !(3,maxres) allocate(gel_loc_loc(maxvar)) allocate(gel_loc_turn3(maxvar)) allocate(gel_loc_turn4(maxvar)) allocate(gel_loc_turn6(maxvar)) allocate(gcorr_loc(maxvar)) allocate(g_corr5_loc(maxvar)) allocate(g_corr6_loc(maxvar)) !(maxvar) allocate(gsccorc(3,nres)) allocate(gsccorx(3,nres)) !(3,maxres) allocate(gsccor_loc(nres)) !(maxres) allocate(dtheta(3,2,nres)) !(3,2,maxres) allocate(gscloc(3,nres)) allocate(gsclocx(3,nres)) !(3,maxres) allocate(dphi(3,3,nres)) allocate(dalpha(3,3,nres)) allocate(domega(3,3,nres)) !(3,3,maxres) ! common /deriv_scloc/ allocate(dXX_C1tab(3,nres)) allocate(dYY_C1tab(3,nres)) allocate(dZZ_C1tab(3,nres)) allocate(dXX_Ctab(3,nres)) allocate(dYY_Ctab(3,nres)) allocate(dZZ_Ctab(3,nres)) allocate(dXX_XYZtab(3,nres)) allocate(dYY_XYZtab(3,nres)) allocate(dZZ_XYZtab(3,nres)) !(3,maxres) ! common /mpgrad/ allocate(jgrad_start(nres)) allocate(jgrad_end(nres)) !(maxres) !---------------------- ! common /indices/ allocate(ibond_displ(0:nfgtasks-1)) allocate(ibond_count(0:nfgtasks-1)) allocate(ithet_displ(0:nfgtasks-1)) allocate(ithet_count(0:nfgtasks-1)) allocate(iphi_displ(0:nfgtasks-1)) allocate(iphi_count(0:nfgtasks-1)) allocate(iphi1_displ(0:nfgtasks-1)) allocate(iphi1_count(0:nfgtasks-1)) allocate(ivec_displ(0:nfgtasks-1)) allocate(ivec_count(0:nfgtasks-1)) allocate(iset_displ(0:nfgtasks-1)) allocate(iset_count(0:nfgtasks-1)) allocate(iint_count(0:nfgtasks-1)) allocate(iint_displ(0:nfgtasks-1)) !(0:max_fg_procs-1) !---------------------- ! common.MD ! common /mdgrad/ allocate(gcart(3,0:nres)) allocate(gxcart(3,0:nres)) !(3,0:MAXRES) allocate(gradcag(3,nres)) allocate(gradxag(3,nres)) !(3,MAXRES) ! common /back_constr/ !el in energy:Econstr_back allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back) allocate(dutheta(nres)) allocate(dugamma(nres)) !(maxres) allocate(duscdiff(3,nres)) allocate(duscdiffx(3,nres)) !(3,maxres) !el i io:read_fragments ! allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20) ! allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20) ! common /qmeas/ ! allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20) ! allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20) allocate(mset(0:nprocs)) !(maxprocs/20) do i=0,nprocs mset(i)=0 enddo ! allocate(ifrag(2,50,nprocs/20)) !(2,50,maxprocs/20) ! allocate(ipair(2,100,nprocs/20)) !(2,100,maxprocs/20) allocate(dUdconst(3,0:nres)) allocate(dUdxconst(3,0:nres)) allocate(dqwol(3,0:nres)) allocate(dxqwol(3,0:nres)) !(3,0:MAXRES) !---------------------- ! common.sbridge ! common /sbridge/ in io_common: read_bridge !el allocate((:),allocatable :: iss !(maxss) ! common /links/ in io_common: read_bridge !el real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane !el integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane ! common /dyn_ssbond/ ! and side-chain vectors in theta or phi. allocate(dyn_ssbond_ij(0:nres+4,0:nres+4)) !(maxres,maxres) do i=1,nres do j=i+1,nres dyn_ssbond_ij(i,j)=1.0d300 enddo enddo if (nss.gt.0) then allocate(idssb(nss),jdssb(nss)) !(maxdim) endif allocate(dyn_ss_mask(nres)) !(maxres) do i=1,nres dyn_ss_mask(i)=.false. enddo !---------------------- ! common.sccor ! Parameters of the SCCOR term ! common/sccor/ !el in io_conf: parmread ! allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) ! allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) ! allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) ! allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp) ! allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp)) ! allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp) ! allocate(vlor1sccor(maxterm_sccor,20,20)) ! allocate(vlor2sccor(maxterm_sccor,20,20)) ! allocate(vlor3sccor(maxterm_sccor,20,20)) !(maxterm_sccor,20,20) !---------------- allocate(gloc_sc(3,0:2*nres,0:10)) !(3,0:maxres2,10)maxres2=2*maxres allocate(dcostau(3,3,3,2*nres)) allocate(dsintau(3,3,3,2*nres)) allocate(dtauangle(3,3,3,2*nres)) allocate(dcosomicron(3,3,3,2*nres)) allocate(domicron(3,3,3,2*nres)) !(3,3,3,maxres2)maxres2=2*maxres !---------------------- ! common.var ! common /restr/ allocate(varall(maxvar)) !(maxvar)(maxvar=6*maxres) allocate(mask_theta(nres)) allocate(mask_phi(nres)) allocate(mask_side(nres)) !(maxres) !---------------------- ! common.vectors ! common /vectors/ allocate(uy(3,nres)) allocate(uz(3,nres)) !(3,maxres) allocate(uygrad(3,3,2,nres)) allocate(uzgrad(3,3,2,nres)) !(3,3,2,maxres) return end subroutine alloc_ener_arrays !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- end module energy