--- /dev/null
+ 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 (r<sigma).
+!
+ if (fcont.gt.0.0D0) then
+! If the SC-SC distance if close to sigma, apply spline.
+!Adam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
+!Adam & fcont1,fprimcont1)
+!Adam fcont1=1.0d0-fcont1
+!Adam if (fcont1.gt.0.0d0) then
+!Adam fprimcont=fprimcont*fcont1+fcont*fprimcont1
+!Adam fcont=fcont*fcont1
+!Adam endif
+! Uncomment following 4 lines to have the geometric average of the epsilon0's
+!ga eps0ij=1.0d0/dsqrt(eps0ij)
+!ga do k=1,3
+!ga gg(k)=gg(k)*eps0ij
+!ga enddo
+!ga eps0ij=-evdwij*eps0ij
+! Uncomment for AL's type of SC correlation interactions.
+!adam eps0ij=-evdwij
+ num_conti=num_conti+1
+ jcont(num_conti,i)=j
+ facont(num_conti,i)=fcont*eps0ij
+ fprimcont=eps0ij*fprimcont/rij
+ fcont=expon*fcont
+!Adam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
+!Adam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
+!Adam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
+! Uncomment following 3 lines for Skolnick's type of SC correlation.
+ gacont(1,num_conti,i)=-fprimcont*xj
+ gacont(2,num_conti,i)=-fprimcont*yj
+ gacont(3,num_conti,i)=-fprimcont*zj
+!d write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
+!d write (iout,'(2i3,3f10.5)')
+!d & i,j,(gacont(kk,num_conti,i),kk=1,3)
+ endif
+ endif
+ enddo ! j
+ enddo ! iint
+! Change 12/1/95
+ num_cont(i)=num_conti
+ 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
+!-----------------------------------------------------------------------------
+ subroutine eljk(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,itypi,itypi1,k,itypj
+ real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
+ real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
+
+! print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ 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)
+!
+! Calculate SC interaction energy.
+!
+ do iint=1,nint_gr(i)
+ 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
+ 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
+ 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+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)
+ 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
+ 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
+!-----------------------------------------------------------------------------
+ subroutine ebp(evdw)
+!
+! This subroutine calculates the interaction energy of nonbonded side chains
+! assuming the Berne-Pechukas potential of interaction.
+!
+ use comm_srutu
+ 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
+ real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
+
+! 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=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)
+ 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=iabs(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)
+! For diagnostics only!!!
+! chi1=0.0D0
+! chi2=0.0D0
+! chi12=0.0D0
+! chip1=0.0D0
+! chip2=0.0D0
+! chip12=0.0D0
+! alf1=0.0D0
+! alf2=0.0D0
+! alf12=0.0D0
+ 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)
+!d if (icall.eq.0) then
+!d rrsave(ind)=rrij
+!d else
+!d rrij=rrsave(ind)
+!d endif
+ rij=dsqrt(rrij)
+! 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
+ 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
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+! stop
+ return
+ end subroutine ebp
+!-----------------------------------------------------------------------------
+ subroutine egb(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'
+! include 'COMMON.SBRIDGE'
+ logical :: lprn
+!el local variables
+ integer :: iint,itypi,itypi1,itypj
+ real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
+ real(kind=8) :: evdw,sig0ij
+ integer :: ii
+!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=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)
+ 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)
+ IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
+ call dyn_ssbond_ene(i,j,evdwij)
+ evdw=evdw+evdwij
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
+ 'evdw',i,j,evdwij,' ss'
+! if (energy_dec) write (iout,*) &
+! 'evdw',i,j,evdwij,' ss'
+ ELSE
+!el ind=ind+1
+ itypj=iabs(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) !d
+! 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)
+! For diagnostics only!!!
+! chi1=0.0D0
+! chi2=0.0D0
+! chi12=0.0D0
+! chip1=0.0D0
+! chip2=0.0D0
+! chip12=0.0D0
+! alf1=0.0D0
+! alf2=0.0D0
+! alf12=0.0D0
+ 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)
+! write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
+! write (iout,*) "j",j," dc_norm",& !d
+! dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
+! write(iout,*)"rrij ",rrij
+! write(iout,*)"xj yj zj ", xj, yj, zj
+! write(iout,*)"xi yi zi ", xi, yi, zi
+! write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij)
+! 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
+! write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
+! "sig0ij",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,*)"aa, bb ",aa(:,:),bb(:,:)
+! write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
+! " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij
+ 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 !,"egb"
+! if (energy_dec) write (iout,*) &
+! 'evdw',i,j,evdwij
+
+! 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
+ ENDIF ! dyn_ss
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+! write (iout,*) "Number of loop steps in EGB:",ind
+!ccc energy_dec=.false.
+ return
+ end subroutine egb
+!-----------------------------------------------------------------------------
+ subroutine egbv(evdw)
+!
+! This subroutine calculates the interaction energy of nonbonded side chains
+! assuming the Gay-Berne-Vorobjev potential of interaction.
+!
+ use comm_srutu
+ 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,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
+ real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
+
+! 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=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)
+ 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=iabs(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)
+! For diagnostics only!!!
+! chi1=0.0D0
+! chi2=0.0D0
+! chi12=0.0D0
+! chip1=0.0D0
+! chip2=0.0D0
+! chip12=0.0D0
+! alf1=0.0D0
+! alf2=0.0D0
+! alf12=0.0D0
+ 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)
+! 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
+ 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
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ end subroutine egbv
+!-----------------------------------------------------------------------------
+!el subroutine sc_angular in module geometry
+!-----------------------------------------------------------------------------
+ subroutine e_softsphere(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
+!d print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
+!el local variables
+ integer :: i,iint,j,itypi,itypi1,itypj,k
+ real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
+ real(kind=8) :: fac
+
+ evdw=0.0D0
+ 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)
+!
+! 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
+ rij=xj*xj+yj*yj+zj*zj
+! write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
+ r0ij=r0(itypi,itypj)
+ r0ijsq=r0ij*r0ij
+! print *,i,j,r0ij,dsqrt(rij)
+ if (rij.lt.r0ijsq) then
+ evdwij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdwij=0.0d0
+ fac=0.0d0
+ endif
+ evdw=evdw+evdwij
+!
+! Calculate the components of the gradient in DC and X
+!
+ 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
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ return
+ end subroutine e_softsphere
+!-----------------------------------------------------------------------------
+ subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
+!
+! Soft-sphere potential of p-p interaction
+!
+! 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
+!d write(iout,*) 'In EELEC_soft_sphere'
+!el local variables
+ integer :: i,j,k,num_conti,iteli,itelj
+ real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
+ real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
+ real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
+
+ ees=0.0D0
+ evdw1=0.0D0
+ eel_loc=0.0d0
+ eello_turn3=0.0d0
+ eello_turn4=0.0d0
+!el ind=0
+ 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)
+ 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(i),' ielend',ielend(i)
+ do j=ielstart(i),ielend(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
+ r0ij=rpp(iteli,itelj)
+ r0ijsq=r0ij*r0ij
+ dxj=dc(1,j)
+ dyj=dc(2,j)
+ dzj=dc(3,j)
+ xj=c(1,j)+0.5D0*dxj-xmedi
+ yj=c(2,j)+0.5D0*dyj-ymedi
+ zj=c(3,j)+0.5D0*dzj-zmedi
+ rij=xj*xj+yj*yj+zj*zj
+ if (rij.lt.r0ijsq) then
+ evdw1ij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdw1ij=0.0d0
+ fac=0.0d0
+ endif
+ evdw1=evdw1+evdw1ij
+!
+! Calculate contributions to the Cartesian gradient.
+!
+ ggg(1)=fac*xj
+ ggg(2)=fac*yj
+ ggg(3)=fac*zj
+ do k=1,3
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ enddo
+!
+! Loop over residues i+1 thru j-1.
+!
+!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
+ enddo ! j
+ enddo ! i
+!grad do i=nnt,nct-1
+!grad do k=1,3
+!grad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
+!grad enddo
+!grad do j=i+1,nct-1
+!grad do k=1,3
+!grad gelc(k,i)=gelc(k,i)+gelc(k,j)
+!grad enddo
+!grad enddo
+!grad enddo
+ return
+ end subroutine eelec_soft_sphere
+!-----------------------------------------------------------------------------
+ subroutine vec_and_deriv
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+! include 'COMMON.IOUNITS'
+! include 'COMMON.GEO'
+! include 'COMMON.VAR'
+! include 'COMMON.LOCAL'
+! include 'COMMON.CHAIN'
+! include 'COMMON.VECTORS'
+! include 'COMMON.SETUP'
+! include 'COMMON.TIME1'
+ real(kind=8),dimension(3,3,2) :: uyder,uzder
+ real(kind=8),dimension(2) :: vbld_inv_temp
+! Compute the local reference systems. For reference system (i), the
+! X-axis points from CA(i) to CA(i+1), the Y axis is in the
+! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
+!el local variables
+ integer :: i,j,k,l
+ real(kind=8) :: facy,fac,costh
+
+#ifdef PARVEC
+ do i=ivec_start,ivec_end
+#else
+ do i=1,nres-1
+#endif
+ if (i.eq.nres-1) then
+! Case of the last full residue
+! Compute the Z-axis
+ call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
+ costh=dcos(pi-theta(nres))
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)
+ do k=1,3
+ uz(k,i)=fac*uz(k,i)
+ enddo
+! Compute the derivatives of uz
+ uzder(1,1,1)= 0.0d0
+ uzder(2,1,1)=-dc_norm(3,i-1)
+ uzder(3,1,1)= dc_norm(2,i-1)
+ uzder(1,2,1)= dc_norm(3,i-1)
+ uzder(2,2,1)= 0.0d0
+ uzder(3,2,1)=-dc_norm(1,i-1)
+ uzder(1,3,1)=-dc_norm(2,i-1)
+ uzder(2,3,1)= dc_norm(1,i-1)
+ uzder(3,3,1)= 0.0d0
+ uzder(1,1,2)= 0.0d0
+ uzder(2,1,2)= dc_norm(3,i)
+ uzder(3,1,2)=-dc_norm(2,i)
+ uzder(1,2,2)=-dc_norm(3,i)
+ uzder(2,2,2)= 0.0d0
+ uzder(3,2,2)= dc_norm(1,i)
+ uzder(1,3,2)= dc_norm(2,i)
+ uzder(2,3,2)=-dc_norm(1,i)
+ uzder(3,3,2)= 0.0d0
+! Compute the Y-axis
+ facy=fac
+ do k=1,3
+ uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
+ enddo
+! Compute the derivatives of uy
+ do j=1,3
+ do k=1,3
+ uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
+ -dc_norm(k,i)*dc_norm(j,i-1)
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
+ enddo
+ uyder(j,j,1)=uyder(j,j,1)-costh
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)
+ enddo
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=uyder(l,k,j)
+ uzgrad(l,k,j,i)=uzder(l,k,j)
+ enddo
+ enddo
+ enddo
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
+ else
+! Other residues
+! Compute the Z-axis
+ call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
+ costh=dcos(pi-theta(i+2))
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)
+ do k=1,3
+ uz(k,i)=fac*uz(k,i)
+ enddo
+! Compute the derivatives of uz
+ uzder(1,1,1)= 0.0d0
+ uzder(2,1,1)=-dc_norm(3,i+1)
+ uzder(3,1,1)= dc_norm(2,i+1)
+ uzder(1,2,1)= dc_norm(3,i+1)
+ uzder(2,2,1)= 0.0d0
+ uzder(3,2,1)=-dc_norm(1,i+1)
+ uzder(1,3,1)=-dc_norm(2,i+1)
+ uzder(2,3,1)= dc_norm(1,i+1)
+ uzder(3,3,1)= 0.0d0
+ uzder(1,1,2)= 0.0d0
+ uzder(2,1,2)= dc_norm(3,i)
+ uzder(3,1,2)=-dc_norm(2,i)
+ uzder(1,2,2)=-dc_norm(3,i)
+ uzder(2,2,2)= 0.0d0
+ uzder(3,2,2)= dc_norm(1,i)
+ uzder(1,3,2)= dc_norm(2,i)
+ uzder(2,3,2)=-dc_norm(1,i)
+ uzder(3,3,2)= 0.0d0
+! Compute the Y-axis
+ facy=fac
+ do k=1,3
+ uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
+ enddo
+! Compute the derivatives of uy
+ do j=1,3
+ do k=1,3
+ uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
+ -dc_norm(k,i)*dc_norm(j,i+1)
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
+ enddo
+ uyder(j,j,1)=uyder(j,j,1)-costh
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)
+ enddo
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=uyder(l,k,j)
+ uzgrad(l,k,j,i)=uzder(l,k,j)
+ enddo
+ enddo
+ enddo
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
+ endif
+ enddo
+ do i=1,nres-1
+ vbld_inv_temp(1)=vbld_inv(i+1)
+ if (i.lt.nres-1) then
+ vbld_inv_temp(2)=vbld_inv(i+2)
+ else
+ vbld_inv_temp(2)=vbld_inv(i)
+ endif
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
+ uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
+ enddo
+ enddo
+ enddo
+ enddo
+#if defined(PARVEC) && defined(MPI)
+ if (nfgtasks1.gt.1) then
+ time00=MPI_Wtime()
+! print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
+! & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
+! & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
+ call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
+ ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
+ ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
+ call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
+ ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
+ ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
+ time_gather=time_gather+MPI_Wtime()-time00
+ endif
+! if (fg_rank.eq.0) then
+! write (iout,*) "Arrays UY and UZ"
+! do i=1,nres-1
+! write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
+! & (uz(k,i),k=1,3)
+! enddo
+! endif
+#endif
+ return
+ end subroutine vec_and_deriv
+!-----------------------------------------------------------------------------
+ subroutine check_vecgrad
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+! include 'COMMON.IOUNITS'
+! include 'COMMON.GEO'
+! include 'COMMON.VAR'
+! include 'COMMON.LOCAL'
+! include 'COMMON.CHAIN'
+! include 'COMMON.VECTORS'
+ real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt !(3,3,2,maxres)
+ real(kind=8),dimension(3,nres) :: uyt,uzt !(3,maxres)
+ real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
+ real(kind=8),dimension(3) :: erij
+ real(kind=8) :: delta=1.0d-7
+!el local variables
+ integer :: i,j,k,l
+
+ call vec_and_deriv
+!d do i=1,nres
+!rc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
+!rc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
+!rc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
+!d write(iout,'(2i5,2(3f10.5,5x))') i,1,
+!d & (dc_norm(if90,i),if90=1,3)
+!d write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
+!d write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
+!d write(iout,'(a)')
+!d enddo
+ do i=1,nres
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygradt(l,k,j,i)=uygrad(l,k,j,i)
+ uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
+ enddo
+ enddo
+ enddo
+ enddo
+ call vec_and_deriv
+ do i=1,nres
+ do j=1,3
+ uyt(j,i)=uy(j,i)
+ uzt(j,i)=uz(j,i)
+ enddo
+ enddo
+ do i=1,nres
+!d write (iout,*) 'i=',i
+ do k=1,3
+ erij(k)=dc_norm(k,i)
+ enddo
+ do j=1,3
+ do k=1,3
+ dc_norm(k,i)=erij(k)
+ enddo
+ dc_norm(j,i)=dc_norm(j,i)+delta
+! fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
+! do k=1,3
+! dc_norm(k,i)=dc_norm(k,i)/fac
+! enddo
+! write (iout,*) (dc_norm(k,i),k=1,3)
+! write (iout,*) (erij(k),k=1,3)
+ call vec_and_deriv
+ do k=1,3
+ uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
+ uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
+ uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
+ uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
+ enddo
+! write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
+! & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
+! & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
+ enddo
+ do k=1,3
+ dc_norm(k,i)=erij(k)
+ enddo
+!d do k=1,3
+!d write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
+!d & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
+!d & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
+!d write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
+!d & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
+!d & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
+!d write (iout,'(a)')
+!d enddo
+ enddo
+ return
+ end subroutine check_vecgrad
+!-----------------------------------------------------------------------------
+ subroutine set_matrices
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+! include "COMMON.SETUP"
+ integer :: IERR
+ integer :: status(MPI_STATUS_SIZE)
+#endif
+! include 'COMMON.IOUNITS'
+! include 'COMMON.GEO'
+! include 'COMMON.VAR'
+! include 'COMMON.LOCAL'
+! include 'COMMON.CHAIN'
+! include 'COMMON.DERIV'
+! include 'COMMON.INTERACT'
+! include 'COMMON.CONTACTS'
+! include 'COMMON.TORSION'
+! include 'COMMON.VECTORS'
+! include 'COMMON.FFIELD'
+ real(kind=8) :: auxvec(2),auxmat(2,2)
+ integer :: i,iti1,iti,k,l
+ real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
+
+!
+! Compute the virtual-bond-torsional-angle dependent quantities needed
+! to calculate the el-loc multibody terms of various order.
+!
+!AL el mu=0.0d0
+#ifdef PARMAT
+ do i=ivec_start+2,ivec_end+2
+#else
+ do i=3,nres+1
+#endif
+ if (i .lt. nres+1) then
+ sin1=dsin(phi(i))
+ cos1=dcos(phi(i))
+ sintab(i-2)=sin1
+ costab(i-2)=cos1
+ obrot(1,i-2)=cos1
+ obrot(2,i-2)=sin1
+ sin2=dsin(2*phi(i))
+ cos2=dcos(2*phi(i))
+ sintab2(i-2)=sin2
+ costab2(i-2)=cos2
+ obrot2(1,i-2)=cos2
+ obrot2(2,i-2)=sin2
+ Ug(1,1,i-2)=-cos1
+ Ug(1,2,i-2)=-sin1
+ Ug(2,1,i-2)=-sin1
+ Ug(2,2,i-2)= cos1
+ Ug2(1,1,i-2)=-cos2
+ Ug2(1,2,i-2)=-sin2
+ Ug2(2,1,i-2)=-sin2
+ Ug2(2,2,i-2)= cos2
+ else
+ costab(i-2)=1.0d0
+ sintab(i-2)=0.0d0
+ obrot(1,i-2)=1.0d0
+ obrot(2,i-2)=0.0d0
+ obrot2(1,i-2)=0.0d0
+ obrot2(2,i-2)=0.0d0
+ Ug(1,1,i-2)=1.0d0
+ Ug(1,2,i-2)=0.0d0
+ Ug(2,1,i-2)=0.0d0
+ Ug(2,2,i-2)=1.0d0
+ Ug2(1,1,i-2)=0.0d0
+ Ug2(1,2,i-2)=0.0d0
+ Ug2(2,1,i-2)=0.0d0
+ Ug2(2,2,i-2)=0.0d0
+ endif
+ if (i .gt. 3 .and. i .lt. nres+1) then
+ obrot_der(1,i-2)=-sin1
+ obrot_der(2,i-2)= cos1
+ Ugder(1,1,i-2)= sin1
+ Ugder(1,2,i-2)=-cos1
+ Ugder(2,1,i-2)=-cos1
+ Ugder(2,2,i-2)=-sin1
+ dwacos2=cos2+cos2
+ dwasin2=sin2+sin2
+ obrot2_der(1,i-2)=-dwasin2
+ obrot2_der(2,i-2)= dwacos2
+ Ug2der(1,1,i-2)= dwasin2
+ Ug2der(1,2,i-2)=-dwacos2
+ Ug2der(2,1,i-2)=-dwacos2
+ Ug2der(2,2,i-2)=-dwasin2
+ else
+ obrot_der(1,i-2)=0.0d0
+ obrot_der(2,i-2)=0.0d0
+ Ugder(1,1,i-2)=0.0d0
+ Ugder(1,2,i-2)=0.0d0
+ Ugder(2,1,i-2)=0.0d0
+ Ugder(2,2,i-2)=0.0d0
+ obrot2_der(1,i-2)=0.0d0
+ obrot2_der(2,i-2)=0.0d0
+ Ug2der(1,1,i-2)=0.0d0
+ Ug2der(1,2,i-2)=0.0d0
+ Ug2der(2,1,i-2)=0.0d0
+ Ug2der(2,2,i-2)=0.0d0
+ endif
+! if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
+ if (i.gt. nnt+2 .and. i.lt.nct+2) then
+ iti = itortyp(itype(i-2))
+ else
+ iti=ntortyp+1
+ endif
+! if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ iti1 = itortyp(itype(i-1))
+ else
+ iti1=ntortyp+1
+ endif
+!d write (iout,*) '*******i',i,' iti1',iti
+!d write (iout,*) 'b1',b1(:,iti)
+!d write (iout,*) 'b2',b2(:,iti)
+!d write (iout,*) 'Ug',Ug(:,:,i-2)
+! if (i .gt. iatel_s+2) then
+ if (i .gt. nnt+2) then
+ call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
+ call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
+ then
+ call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
+ call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
+ call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
+ call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
+ call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
+ endif
+ else
+ do k=1,2
+ Ub2(k,i-2)=0.0d0
+ Ctobr(k,i-2)=0.0d0
+ Dtobr2(k,i-2)=0.0d0
+ do l=1,2
+ EUg(l,k,i-2)=0.0d0
+ CUg(l,k,i-2)=0.0d0
+ DUg(l,k,i-2)=0.0d0
+ DtUg2(l,k,i-2)=0.0d0
+ enddo
+ enddo
+ endif
+ call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
+ call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
+ do k=1,2
+ muder(k,i-2)=Ub2der(k,i-2)
+ enddo
+! if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ if (itype(i-1).le.ntyp) then
+ iti1 = itortyp(itype(i-1))
+ else
+ iti1=ntortyp+1
+ endif
+ else
+ iti1=ntortyp+1
+ endif
+ do k=1,2
+ mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
+ enddo
+! if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
+! if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
+! if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
+!d write (iout,*) 'mu1',mu1(:,i-2)
+!d write (iout,*) 'mu2',mu2(:,i-2)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
+ then
+ call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
+ call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
+ call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
+ call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
+ call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
+! Vectors and matrices dependent on a single virtual-bond dihedral.
+ call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
+ call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
+ call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
+ call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
+ call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
+ call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
+ call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
+ call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
+ call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
+ endif
+ enddo
+! Matrices dependent on two consecutive virtual-bond dihedrals.
+! The order of matrices is from left to right.
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
+ then
+! do i=max0(ivec_start,2),ivec_end
+ do i=2,nres-1
+ call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
+ call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
+ call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
+ call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
+ call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
+ call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
+ call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
+ call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
+ enddo
+ endif
+#if defined(MPI) && defined(PARMAT)
+#ifdef DEBUG
+! if (fg_rank.eq.0) then
+ write (iout,*) "Arrays UG and UGDER before GATHER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
+ ((ug(l,k,i),l=1,2),k=1,2),&
+ ((ugder(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays UG2 and UG2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
+ ((ug2(l,k,i),l=1,2),k=1,2),&
+ ((ug2der(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
+ (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
+ (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
+ enddo
+ write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
+ costab(i),sintab(i),costab2(i),sintab2(i)
+ enddo
+ write (iout,*) "Array MUDER"
+ do i=1,nres-1
+ write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
+ enddo
+! endif
+#endif
+ if (nfgtasks.gt.1) then
+ time00=MPI_Wtime()
+! write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
+! & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
+! & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
+#ifdef MATGATHER
+ call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
+ MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
+ MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
+ MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
+ MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
+ MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
+ MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
+ MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
+ MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
+ then
+ call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
+ ivec_count(fg_rank1),&
+ MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
+ ivec_count(fg_rank1),&
+ MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
+ MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
+ ivec_count(fg_rank1),&
+ MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
+ ivec_count(fg_rank1),&
+ MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
+ FG_COMM1,IERR)
+ call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
+ ivec_count(fg_rank1),&
+ MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
+ MPI_MAT2,FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
+ ivec_count(fg_rank1),&
+ MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
+ MPI_MAT2,FG_COMM1,IERR)
+ endif
+#else
+! Passes matrix info through the ring
+ isend=fg_rank1
+ irecv=fg_rank1-1
+ if (irecv.lt.0) irecv=nfgtasks1-1
+ iprev=irecv
+ inext=fg_rank1+1
+ if (inext.ge.nfgtasks1) inext=0
+ do i=1,nfgtasks1-1
+! write (iout,*) "isend",isend," irecv",irecv
+! call flush(iout)
+ lensend=lentyp(isend)
+ lenrecv=lentyp(irecv)
+! write (iout,*) "lensend",lensend," lenrecv",lenrecv
+! call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
+! & MPI_ROTAT1(lensend),inext,2200+isend,
+! & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
+! & iprev,2200+irecv,FG_COMM,status,IERR)
+! write (iout,*) "Gather ROTAT1"
+! call flush(iout)
+! call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
+! & MPI_ROTAT2(lensend),inext,3300+isend,
+! & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
+! & iprev,3300+irecv,FG_COMM,status,IERR)
+! write (iout,*) "Gather ROTAT2"
+! call flush(iout)
+ call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
+ MPI_ROTAT_OLD(lensend),inext,4400+isend,&
+ costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
+ iprev,4400+irecv,FG_COMM,status,IERR)
+! write (iout,*) "Gather ROTAT_OLD"
+! call flush(iout)
+ call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
+ MPI_PRECOMP11(lensend),inext,5500+isend,&
+ mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
+ iprev,5500+irecv,FG_COMM,status,IERR)
+! write (iout,*) "Gather PRECOMP11"
+! call flush(iout)
+ call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
+ MPI_PRECOMP12(lensend),inext,6600+isend,&
+ Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
+ iprev,6600+irecv,FG_COMM,status,IERR)
+! write (iout,*) "Gather PRECOMP12"
+! call flush(iout)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
+ then
+ call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
+ MPI_ROTAT2(lensend),inext,7700+isend,&
+ ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
+ iprev,7700+irecv,FG_COMM,status,IERR)
+! write (iout,*) "Gather PRECOMP21"
+! call flush(iout)
+ call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
+ MPI_PRECOMP22(lensend),inext,8800+isend,&
+ EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
+ iprev,8800+irecv,FG_COMM,status,IERR)
+! write (iout,*) "Gather PRECOMP22"
+! call flush(iout)
+ call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
+ MPI_PRECOMP23(lensend),inext,9900+isend,&
+ Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
+ MPI_PRECOMP23(lenrecv),&
+ iprev,9900+irecv,FG_COMM,status,IERR)
+! write (iout,*) "Gather PRECOMP23"
+! call flush(iout)
+ endif
+ isend=irecv
+ irecv=irecv-1
+ if (irecv.lt.0) irecv=nfgtasks1-1
+ enddo
+#endif
+ time_gather=time_gather+MPI_Wtime()-time00
+ endif
+#ifdef DEBUG
+! if (fg_rank.eq.0) then
+ write (iout,*) "Arrays UG and UGDER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
+ ((ug(l,k,i),l=1,2),k=1,2),&
+ ((ugder(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays UG2 and UG2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
+ ((ug2(l,k,i),l=1,2),k=1,2),&
+ ((ug2der(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
+ (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
+ (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
+ enddo
+ write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
+ costab(i),sintab(i),costab2(i),sintab2(i)
+ enddo
+ write (iout,*) "Array MUDER"
+ do i=1,nres-1
+ write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
+ enddo
+! endif
+#endif
+#endif
+!d do i=1,nres
+!d iti = itortyp(itype(i))
+!d write (iout,*) i
+!d do j=1,2
+!d write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
+!d & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
+!d enddo
+!d enddo
+ return
+ end subroutine set_matrices
+!-----------------------------------------------------------------------------
+ subroutine eelec(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.
+!
+ use comm_locel
+! implicit real*8 (a-h,o-z)
+#ifdef MPI
+ include 'mpif.h'
+#endif
+! include 'DIMENSIONS'
+! include 'COMMON.CONTROL'
+! include 'COMMON.SETUP'
+! include 'COMMON.IOUNITS'
+! include 'COMMON.GEO'
+! include 'COMMON.VAR'
+! include 'COMMON.LOCAL'
+! include 'COMMON.CHAIN'
+! include 'COMMON.DERIV'
+! include 'COMMON.INTERACT'
+! include 'COMMON.CONTACTS'
+! include 'COMMON.TORSION'
+! include 'COMMON.VECTORS'
+! include 'COMMON.FFIELD'
+! include 'COMMON.TIME1'
+ 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,k,j
+ real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
+ real(kind=8) :: fac,t_eelecij
+
+
+!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
+! ees=0.0d0 !AS
+! evdw1=0.0d0
+! eel_loc=0.0d0
+! eello_turn3=0.0d0
+! eello_turn4=0.0d0
+ t_eelecij=0.0d0
+ ees=0.0D0
+ evdw1=0.0D0
+ eel_loc=0.0d0
+ eello_turn3=0.0d0
+ eello_turn4=0.0d0
+!
+
+ if (icheckgrad.eq.1) then
+!el
+! do i=0,2*nres+2
+! dc_norm(1,i)=0.0d0
+! dc_norm(2,i)=0.0d0
+! dc_norm(3,i)=0.0d0
+! enddo
+ 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(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(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)
+! write (iout,*) i,j,itype(i),itype(j)
+ if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
+ call eelecij(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
+!-----------------------------------------------------------------------------
+ subroutine eelecij(i,j,ees,evdw1,eel_loc)
+
+ use comm_locel
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+! include 'COMMON.CONTROL'
+! include 'COMMON.IOUNITS'
+! include 'COMMON.GEO'
+! include 'COMMON.VAR'
+! include 'COMMON.LOCAL'
+! include 'COMMON.CHAIN'
+! include 'COMMON.DERIV'
+! include 'COMMON.INTERACT'
+! include 'COMMON.CONTACTS'
+! include 'COMMON.TORSION'
+! include 'COMMON.VECTORS'
+! include 'COMMON.FFIELD'
+! include 'COMMON.TIME1'
+ 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))
+! integer :: maxconts=nres/4
+!el local variables
+ integer :: k,i,j,iteli,itelj,kkk,l,kkll,m
+ real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
+ real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
+ real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
+ rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
+ evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
+ ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
+ a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
+ ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
+ ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
+ ecosgp,ecosam,ecosbm,ecosgm,ghalf
+! maxconts=nres/4
+! 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)
+
+! time00=MPI_Wtime()
+!d write (iout,*) "eelecij",i,j
+! ind=ind+1
+ iteli=itel(i)
+ itelj=itel(j)
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2
+ aaa=app(iteli,itelj)
+ bbb=bpp(iteli,itelj)
+ ael6i=ael6(iteli,itelj)
+ ael3i=ael3(iteli,itelj)
+ dxj=dc(1,j)
+ dyj=dc(2,j)
+ dzj=dc(3,j)
+ dx_normj=dc_norm(1,j)
+ dy_normj=dc_norm(2,j)
+ dz_normj=dc_norm(3,j)
+ xj=c(1,j)+0.5D0*dxj-xmedi
+ yj=c(2,j)+0.5D0*dyj-ymedi
+ zj=c(3,j)+0.5D0*dzj-zmedi
+ rij=xj*xj+yj*yj+zj*zj
+ rrmij=1.0D0/rij
+ rij=dsqrt(rij)
+ rmij=1.0D0/rij
+ r3ij=rrmij*rmij
+ r6ij=r3ij*r3ij
+ cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
+ cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
+ cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
+ fac=cosa-3.0D0*cosb*cosg
+ ev1=aaa*r6ij*r6ij
+! 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
+!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,2i5,2e11.3)') &
+! 'evdw1',i,j,evdwij,&
+! iteli,itelj,aaa,evdw1
+ write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
+ write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
+ endif
+!
+! Calculate contributions to the Cartesian gradient.
+!
+#ifdef SPLITELE
+ facvdw=-6*rrmij*(ev1+evdwij)
+ facel=-3*rrmij*(el1+eesij)
+ fac1=fac
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+!
+! Radial derivatives. First process both termini of the fragment (i,j)
+!
+ ggg(1)=facel*xj
+ ggg(2)=facel*yj
+ ggg(3)=facel*zj
+! 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
+ 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
+! if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
+! if (energy_dec) write (iout,*) "muij",muij
+! write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
+
+ 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
+!el write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
+!el write (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
+! Diagnostics. Comment out or remove after debugging!
+!diag do k=1,3
+!diag gacontp_hb1(k,num_conti,i)=0.0D0
+!diag gacontp_hb2(k,num_conti,i)=0.0D0
+!diag gacontp_hb3(k,num_conti,i)=0.0D0
+!diag gacontm_hb1(k,num_conti,i)=0.0D0
+!diag gacontm_hb2(k,num_conti,i)=0.0D0
+!diag gacontm_hb3(k,num_conti,i)=0.0D0
+!diag 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
+!-----------------------------------------------------------------------------
+ subroutine eturn3(i,eello_turn3)
+! Third- and fourth-order contributions from turns
+
+ use comm_locel
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+! include 'COMMON.IOUNITS'
+! include 'COMMON.GEO'
+! include 'COMMON.VAR'
+! include 'COMMON.LOCAL'
+! include 'COMMON.CHAIN'
+! include 'COMMON.DERIV'
+! include 'COMMON.INTERACT'
+! include 'COMMON.CONTACTS'
+! include 'COMMON.TORSION'
+! include 'COMMON.VECTORS'
+! include 'COMMON.FFIELD'
+! include 'COMMON.CONTROL'
+ real(kind=8),dimension(3) :: ggg
+ real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
+ e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
+ real(kind=8),dimension(2) :: auxvec,auxvec1
+!el real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
+ real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
+!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
+!el local variables
+ integer :: i,j,l
+ real(kind=8) :: eello_turn3
+
+ j=i+2
+! write (iout,*) "eturn3",i,j,j1,j2
+ a_temp(1,1)=a22
+ a_temp(1,2)=a23
+ a_temp(2,1)=a32
+ a_temp(2,2)=a33
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!
+! Third-order contributions
+!
+! (i+2)o----(i+3)
+! | |
+! | |
+! (i+1)o----i
+!
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!d call checkint_turn3(i,a_temp,eello_turn3_num)
+ call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
+ call transpose2(auxmat(1,1),auxmat1(1,1))
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
+ 'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
+!d write (2,*) 'i,',i,' j',j,'eello_turn3',
+!d & 0.5d0*(pizda(1,1)+pizda(2,2)),
+!d & ' eello_turn3_num',4*eello_turn3_num
+! Derivatives in gamma(i)
+ call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
+ call transpose2(auxmat2(1,1),auxmat3(1,1))
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
+ gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
+! Derivatives in gamma(i+1)
+ call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
+ call transpose2(auxmat2(1,1),auxmat3(1,1))
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
+ gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
+ +0.5d0*(pizda(1,1)+pizda(2,2))
+! Cartesian derivatives
+ do l=1,3
+! ghalf1=0.5d0*agg(l,1)
+! ghalf2=0.5d0*agg(l,2)
+! ghalf3=0.5d0*agg(l,3)
+! ghalf4=0.5d0*agg(l,4)
+ a_temp(1,1)=aggi(l,1)!+ghalf1
+ a_temp(1,2)=aggi(l,2)!+ghalf2
+ a_temp(2,1)=aggi(l,3)!+ghalf3
+ a_temp(2,2)=aggi(l,4)!+ghalf4
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,i)=gcorr3_turn(l,i) &
+ +0.5d0*(pizda(1,1)+pizda(2,2))
+ a_temp(1,1)=aggi1(l,1)!+agg(l,1)
+ a_temp(1,2)=aggi1(l,2)!+agg(l,2)
+ a_temp(2,1)=aggi1(l,3)!+agg(l,3)
+ a_temp(2,2)=aggi1(l,4)!+agg(l,4)
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
+ +0.5d0*(pizda(1,1)+pizda(2,2))
+ a_temp(1,1)=aggj(l,1)!+ghalf1
+ a_temp(1,2)=aggj(l,2)!+ghalf2
+ a_temp(2,1)=aggj(l,3)!+ghalf3
+ a_temp(2,2)=aggj(l,4)!+ghalf4
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,j)=gcorr3_turn(l,j) &
+ +0.5d0*(pizda(1,1)+pizda(2,2))
+ a_temp(1,1)=aggj1(l,1)
+ a_temp(1,2)=aggj1(l,2)
+ a_temp(2,1)=aggj1(l,3)
+ a_temp(2,2)=aggj1(l,4)
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
+ +0.5d0*(pizda(1,1)+pizda(2,2))
+ enddo
+ return
+ end subroutine eturn3
+!-----------------------------------------------------------------------------
+ subroutine eturn4(i,eello_turn4)
+! Third- and fourth-order contributions from turns
+
+ use comm_locel
+! implicit real*8 (a-h,o-z)
+! include 'DIMENSIONS'
+! include 'COMMON.IOUNITS'
+! include 'COMMON.GEO'
+! include 'COMMON.VAR'
+! include 'COMMON.LOCAL'
+! include 'COMMON.CHAIN'
+! include 'COMMON.DERIV'
+! include 'COMMON.INTERACT'
+! include 'COMMON.CONTACTS'
+! include 'COMMON.TORSION'
+! include 'COMMON.VECTORS'
+! include 'COMMON.FFIELD'
+! include 'COMMON.CONTROL'
+ real(kind=8),dimension(3) :: ggg
+ real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
+ e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
+ real(kind=8),dimension(2) :: auxvec,auxvec1
+!el real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
+ real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
+!el real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
+!el dz_normi,xmedi,ymedi,zmedi
+!el integer :: num_conti,j1,j2
+!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
+!el local variables
+ integer :: i,j,iti1,iti2,iti3,l
+ real(kind=8) :: eello_turn4,s1,s2,s3
+
+ j=i+3
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!
+! Fourth-order contributions
+!
+! (i+3)o----(i+4)
+! / |
+! (i+2)o |
+! \ |
+! (i+1)o----i
+!
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!d call checkint_turn4(i,a_temp,eello_turn4_num)
+! write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
+ a_temp(1,1)=a22
+ a_temp(1,2)=a23
+ a_temp(2,1)=a32
+ a_temp(2,2)=a33
+ iti1=itortyp(itype(i+1))
+ iti2=itortyp(itype(i+2))
+ iti3=itortyp(itype(i+3))
+! write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
+ call transpose2(EUg(1,1,i+1),e1t(1,1))
+ call transpose2(Eug(1,1,i+2),e2t(1,1))
+ call transpose2(Eug(1,1,i+3),e3t(1,1))
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ eello_turn4=eello_turn4-(s1+s2+s3)
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
+ 'eturn4',i,j,-(s1+s2+s3)
+!d write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
+!d & ' eello_turn4_num',8*eello_turn4_num
+! Derivatives in gamma(i)
+ call transpose2(EUgder(1,1,i+1),e1tder(1,1))
+ call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
+! Derivatives in gamma(i+1)
+ call transpose2(EUgder(1,1,i+2),e2tder(1,1))
+ call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
+ call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
+! Derivatives in gamma(i+2)
+ call transpose2(EUgder(1,1,i+3),e3tder(1,1))
+ call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
+ call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
+! Cartesian derivatives
+! Derivatives of this turn contributions in DC(i+2)
+ if (j.lt.nres-1) then
+ do l=1,3
+ a_temp(1,1)=agg(l,1)
+ a_temp(1,2)=agg(l,2)
+ a_temp(2,1)=agg(l,3)
+ a_temp(2,2)=agg(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ ggg(l)=-(s1+s2+s3)
+ gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
+ enddo
+ endif
+! Remaining derivatives of this turn contribution
+ do l=1,3
+ a_temp(1,1)=aggi(l,1)
+ a_temp(1,2)=aggi(l,2)
+ a_temp(2,1)=aggi(l,3)
+ a_temp(2,2)=aggi(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
+ a_temp(1,1)=aggi1(l,1)
+ a_temp(1,2)=aggi1(l,2)
+ a_temp(2,1)=aggi1(l,3)
+ a_temp(2,2)=aggi1(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
+ a_temp(1,1)=aggj(l,1)
+ a_temp(1,2)=aggj(l,2)
+ a_temp(2,1)=aggj(l,3)
+ a_temp(2,2)=aggj(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
+ a_temp(1,1)=aggj1(l,1)
+ a_temp(1,2)=aggj1(l,2)
+ a_temp(2,1)=aggj1(l,3)
+ a_temp(2,2)=aggj1(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,iti2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,iti1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+! write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
+ gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
+ enddo
+ return
+ end subroutine eturn4
+!-----------------------------------------------------------------------------
+ subroutine unormderiv(u,ugrad,unorm,ungrad)
+! This subroutine computes the derivatives of a normalized vector u, given
+! the derivatives computed without normalization conditions, ugrad. Returns
+! ungrad.
+! implicit none
+ real(kind=8),dimension(3) :: u,vec
+ real(kind=8),dimension(3,3) ::ugrad,ungrad
+ real(kind=8) :: unorm !,scalar
+ integer :: i,j
+! write (2,*) 'ugrad',ugrad
+! write (2,*) 'u',u
+ do i=1,3
+ vec(i)=scalar(ugrad(1,i),u(1))
+ enddo
+! write (2,*) 'vec',vec
+ do i=1,3
+ do j=1,3
+ ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
+ enddo
+ enddo
+! write (2,*) 'ungrad',ungrad
+ return
+ end subroutine unormderiv
+!-----------------------------------------------------------------------------
+ subroutine escp_soft_sphere(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,r0_scp,xi,yi,zi,xj,yj,zj,&
+ fac,rij,r0ij,r0ijsq,evdwij,e1,e2
+
+ evdw2=0.0D0
+ evdw2_14=0.0d0
+ r0_scp=4.5d0
+!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)
+ if (itype(j).eq.ntyp1) cycle
+ itypj=iabs(itype(j))
+! 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
+ rij=xj*xj+yj*yj+zj*zj
+ r0ij=r0_scp
+ r0ijsq=r0ij*r0ij
+ if (rij.lt.r0ijsq) then
+ evdwij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdwij=0.0d0
+ fac=0.0d0
+ endif
+ evdw2=evdw2+evdwij
+!
+! Calculate contributions to the gradient in the virtual-bond and SC vectors.
+!
+ ggg(1)=xj*fac
+ ggg(2)=yj*fac
+ ggg(3)=zj*fac
+!grad if (j.lt.i) then
+!d write (iout,*) 'j<i'
+! Uncomment following three lines for SC-p interactions
+! do k=1,3
+! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+! enddo
+!grad else
+!d write (iout,*) 'j>i'
+!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),&
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
+ 'evdw2',i,j,evdwij
+!
+! 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,*) 'j<i'
+! Uncomment following three lines for SC-p interactions
+! do k=1,3
+! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+! enddo
+!grad else
+!d write (iout,*) 'j>i'
+!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,'(a7,i5,4f7.3)') &
+ "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 (itype(i-2).eq.ntyp1.or.itype(i).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(max0(i-3,1)).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=ithetyp(itype(i-2))
+ do k=1,nsingle
+ cosph1(k)=0.0d0
+ sinph1(k)=0.0d0
+ enddo
+ endif
+ if (i.lt.nres .and. itype(i+1).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=ithetyp(itype(i))
+ 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 (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
+ 'ebend',i,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-3).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,etors_d_ii
+ 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
+ etors_d_ii=0.0D0
+ if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 &
+ .or. itype(i-3).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
+ if (energy_dec) etors_d_ii=etors_d_ii+ &
+ 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
+ if (energy_dec) etors_d_ii=etors_d_ii+ &
+ 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
+ if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
+ 'etor_d',i,etors_d_ii
+ 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
+ esccor_ii=0.0D0
+!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))
+ if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
+ esccor=esccor+v1ij*cosphi+v2ij*sinphi
+ gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
+ enddo
+ if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
+ 'esccor',i,intertyp,esccor_ii
+! 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-4
+ 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))
+ Ub2(1,:)=0.0d0
+ Ub2(2,:)=0.0d0
+ 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)
+ mset(:)=0
+! 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(:,:)=1.0d300
+! enddo
+! enddo
+
+ if (nss.gt.0) then
+ allocate(idssb(nss),jdssb(nss))
+!(maxdim)
+ endif
+ allocate(dyn_ss_mask(nres))
+!(maxres)
+ dyn_ss_mask(:)=.false.
+!----------------------
+! 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
projects / unres4.git / blobdiff