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 ! Maximum number of local shielding effectors ! integer,parameter :: maxcontsshi=50 !----------------------------------------------------------------------------- ! 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,ees0plist !(maxconts,maxres) real(kind=8),dimension(:,:,:),allocatable :: gacont !(3,maxconts,maxres) integer,dimension(:),allocatable :: ishield_list integer,dimension(:,:),allocatable :: shield_list real(kind=8),dimension(:),allocatable :: enetube,enecavtube ! ! 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,gUb2 !(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(4) :: gmuij,gmuij1,gmuij2,gmuji1,gmuji2 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,gliptran,gliptranc,& gliptranx, & gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,& gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, & gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, & gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,& grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres) !-----------------------------NUCLEIC GRADIENT real(kind=8),dimension(:,:),allocatable ::gradb_nucl,gradbx_nucl, & gvdwpsb1,gelpp,gvdwpsb,gelsbc,gelsbx,gvdwsbx,gvdwsbc,gsbloc,& gsblocx,gradcorr_nucl,gradxorr_nucl,gradcorr3_nucl,gradxorr3_nucl,& gvdwpp_nucl !-----------------------------NUCLEIC-PROTEIN GRADIENT real(kind=8),dimension(:,:),allocatable :: gvdwx_scbase,gvdwc_scbase,& gvdwx_pepbase,gvdwc_pepbase,gvdwx_scpho,gvdwc_scpho,& gvdwc_peppho !------------------------------IONS GRADIENT real(kind=8),dimension(:,:),allocatable :: gradcatcat, & gradpepcat,gradpepcatx,gradnuclcat,gradnuclcatx ! 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) real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, & grad_shield_loc ! (3,maxcontsshileding,maxnres) ! integer :: nfl,icg ! common /deriv_loc/ real(kind=8), dimension(:),allocatable :: fac_shield 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 real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(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 #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,imatupdate 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,eliptran,etube, & Eafmforce,ethetacnstr real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6 ! now energies for nulceic alone parameters real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,& ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,& ecorr3_nucl ! energies for ions real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,& ecation_nucl ! energies for protein nucleic acid interaction real(kind=8) :: escbase,epepbase,escpho,epeppho #ifdef MPI real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw ! shielding effect varibles for MPI real(kind=8) :: fac_shieldbuf(nres), & grad_shield_locbuf1(3*maxcontsshi*nres), & grad_shield_sidebuf1(3*maxcontsshi*nres), & grad_shield_locbuf2(3*maxcontsshi*nres), & grad_shield_sidebuf2(3*maxcontsshi*nres), & grad_shieldbuf1(3*nres), & grad_shieldbuf2(3*nres) integer ishield_listbuf(-1:nres), & shield_listbuf(maxcontsshi,-1:nres),k,j,i,iii,impishi,mojint,jjj ! print *,"I START ENERGY" imatupdate=100 ! if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list ! real(kind=8), dimension(:),allocatable:: fac_shieldbuf ! real(kind=8), dimension(:,:,:),allocatable:: & ! grad_shield_locbuf,grad_shield_sidebuf ! real(kind=8), dimension(:,:),allocatable:: & ! grad_shieldbuf ! integer, dimension(:),allocatable:: & ! ishield_listbuf ! integer, dimension(:,:),allocatable:: shield_listbuf ! integer :: k,j,i ! if (.not.allocated(fac_shieldbuf)) then ! allocate(fac_shieldbuf(nres)) ! allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres)) ! allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres)) ! allocate(grad_shieldbuf(3,-1:nres)) ! allocate(ishield_listbuf(nres)) ! allocate(shield_listbuf(maxcontsshi,nres)) ! endif ! 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 weights_(26)=wvdwpp_nucl weights_(27)=welpp weights_(28)=wvdwpsb weights_(29)=welpsb weights_(30)=wvdwsb weights_(31)=welsb weights_(32)=wbond_nucl weights_(33)=wang_nucl weights_(34)=wsbloc weights_(35)=wtor_nucl weights_(36)=wtor_d_nucl weights_(37)=wcorr_nucl weights_(38)=wcorr3_nucl weights_(41)=wcatcat weights_(42)=wcatprot weights_(46)=wscbase weights_(47)=wpepbase weights_(48)=wscpho weights_(49)=wpeppho weights_(50)=wcatnucl ! wcatcat= weights(41) ! wcatprot=weights(42) ! 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) wvdwpp_nucl =weights(26) welpp =weights(27) wvdwpsb=weights(28) welpsb =weights(29) wvdwsb =weights(30) welsb =weights(31) wbond_nucl =weights(32) wang_nucl =weights(33) wsbloc =weights(34) wtor_nucl =weights(35) wtor_d_nucl =weights(36) wcorr_nucl =weights(37) wcorr3_nucl =weights(38) wcatcat= weights(41) wcatprot=weights(42) wscbase=weights(46) wpepbase=weights(47) wscpho=weights(48) wpeppho=weights(49) wcatnucl=weights(50) ! welpsb=weights(28)*fact(1) ! ! wcorr_nucl= weights(37)*fact(1) ! wcorr3_nucl=weights(38)*fact(2) ! wtor_nucl= weights(35)*fact(1) ! wtor_d_nucl=weights(36)*fact(2) endif time_Bcast=time_Bcast+MPI_Wtime()-time00 time_Bcastw=time_Bcastw+MPI_Wtime()-time00 ! call chainbuild_cart endif ! print *,"itime_mat",itime_mat,imatupdate if (nfgtasks.gt.1) then call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR) endif if (mod(itime_mat,imatupdate).eq.0) call make_SCp_inter_list ! write (iout,*) "after make_SCp_inter_list" if (mod(itime_mat,imatupdate).eq.0) call make_SCSC_inter_list ! write (iout,*) "after make_SCSC_inter_list" if (mod(itime_mat,imatupdate).eq.0) call make_pp_inter_list ! write (iout,*) "after make_pp_inter_list" ! 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 ! print *, "Before EVDW" ! 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) ! print *,"MOMO",scelemode if (scelemode.eq.0) then call egb(evdw) else call emomo(evdw) endif ! 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 ! print *,"after EGB" ! shielding effect if (shield_mode.eq.2) then call set_shield_fac2 if (nfgtasks.gt.1) then grad_shield_sidebuf1(:)=0.0d0 grad_shield_locbuf1(:)=0.0d0 grad_shield_sidebuf2(:)=0.0d0 grad_shield_locbuf2(:)=0.0d0 grad_shieldbuf1(:)=0.0d0 grad_shieldbuf2(:)=0.0d0 !#define DEBUG #ifdef DEBUG write(iout,*) "befor reduce fac_shield reduce" do i=1,nres write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i) write(2,*) "list", shield_list(1,i),ishield_list(i), & grad_shield_side(1,1,i),grad_shield_loc(1,1,i) enddo #endif iii=0 jjj=0 do i=1,nres ishield_listbuf(i)=0 do k=1,3 iii=iii+1 grad_shieldbuf1(iii)=grad_shield(k,i) enddo enddo do i=1,nres do j=1,maxcontsshi do k=1,3 jjj=jjj+1 grad_shield_sidebuf1(jjj)=grad_shield_side(k,j,i) grad_shield_locbuf1(jjj)=grad_shield_loc(k,j,i) enddo enddo enddo call MPI_Allgatherv(fac_shield(ivec_start), & ivec_count(fg_rank1), & MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), & ivec_displ(0), & MPI_DOUBLE_PRECISION,FG_COMM,IERROR) call MPI_Allgatherv(shield_list(1,ivec_start), & ivec_count(fg_rank1), & MPI_I50,shield_listbuf(1,1),ivec_count(0), & ivec_displ(0), & MPI_I50,FG_COMM,IERROR) ! write(2,*) "After I50" ! call flush(iout) call MPI_Allgatherv(ishield_list(ivec_start), & ivec_count(fg_rank1), & MPI_INTEGER,ishield_listbuf(1),ivec_count(0), & ivec_displ(0), & MPI_INTEGER,FG_COMM,IERROR) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! write(2,*) ivec_count(fg_rank1)*3,ivec_count(0)*3,ivec_displ(0)*3,3*ivec_start-2 ! write (2,*) "before" ! write(2,*) grad_shieldbuf1 ! call MPI_Allgatherv(grad_shieldbuf1(3*ivec_start-2), & ! ivec_count(fg_rank1)*3, & ! MPI_DOUBLE_PRECISION,grad_shieldbuf2(1),ivec_count(0), & ! ivec_count(0), & ! MPI_DOUBLE_PRECISION,FG_COMM,IERROR) call MPI_Allreduce(grad_shieldbuf1(1),grad_shieldbuf2(1), & nres*3, & MPI_DOUBLE_PRECISION, & MPI_SUM, & FG_COMM,IERROR) call MPI_Allreduce(grad_shield_sidebuf1(1),grad_shield_sidebuf2(1), & nres*3*maxcontsshi, & MPI_DOUBLE_PRECISION, & MPI_SUM, & FG_COMM,IERROR) call MPI_Allreduce(grad_shield_locbuf1(1),grad_shield_locbuf2(1), & nres*3*maxcontsshi, & MPI_DOUBLE_PRECISION, & MPI_SUM, & FG_COMM,IERROR) ! write(2,*) "after" ! write(2,*) grad_shieldbuf2 ! call MPI_Allgatherv(grad_shield_sidebuf1(3*maxcontsshi*ivec_start-2), & ! ivec_count(fg_rank1)*3*maxcontsshi, & ! MPI_DOUBLE_PRECISION,grad_shield_sidebuf2(1),ivec_count(0)*3*maxcontsshi,& ! ivec_displ(0)*3*maxcontsshi, & ! MPI_DOUBLE_PRECISION,FG_COMM,IERROR) ! write(2,*) "After grad_shield_side" ! call flush(iout) ! call MPI_Allgatherv(grad_shield_locbuf1(3*maxcontsshi*ivec_start-2), & ! ivec_count(fg_rank1)*3*maxcontsshi, & ! MPI_DOUBLE_PRECISION,grad_shield_locbuf2(1),ivec_count(0)*3*maxcontsshi, & ! ivec_displ(0)*3*maxcontsshi, & ! MPI_DOUBLE_PRECISION,FG_COMM,IERROR) ! write(2,*) "After MPI_SHI" ! call flush(iout) iii=0 jjj=0 do i=1,nres fac_shield(i)=fac_shieldbuf(i) ishield_list(i)=ishield_listbuf(i) ! write(iout,*) i,fac_shield(i) do j=1,3 iii=iii+1 grad_shield(j,i)=grad_shieldbuf2(iii) enddo !j do j=1,ishield_list(i) ! write (iout,*) "ishild", ishield_list(i),i shield_list(j,i)=shield_listbuf(j,i) enddo do j=1,maxcontsshi do k=1,3 jjj=jjj+1 grad_shield_loc(k,j,i)=grad_shield_locbuf2(jjj) grad_shield_side(k,j,i)=grad_shield_sidebuf2(jjj) enddo !k enddo !j enddo !i endif #ifdef DEBUG write(iout,*) "after reduce fac_shield reduce" do i=1,nres write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i) write(2,*) "list", shield_list(1,i),ishield_list(i), & grad_shield_side(1,1,i),grad_shield_loc(1,1,i) enddo #endif #undef DEBUG endif ! print *,"AFTER EGB",ipot,evdw !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 ! print *,"after ipot if", ipot 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 ! print *,"just befor eelec call" call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) ! print *, "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. ! ! write(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 ! write(iout,*) "in etotal before ebond",ipot ! ! Calculate the bond-stretching energy ! call ebond(estr) ! print *,"EBOND",estr ! write(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. ! write(iout,*) "in etotal afer edis",ipot ! if (wang.gt.0.0d0) then ! call ebend(ebe,ethetacnstr) ! else ! ebe=0 ! ethetacnstr=0 ! endif if (wang.gt.0d0) then if (tor_mode.eq.0) then call ebend(ebe) else !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the !C energy function call ebend_kcc(ebe) endif else ebe=0.0d0 endif ethetacnstr=0.0d0 if (with_theta_constr) call etheta_constr(ethetacnstr) ! write(iout,*) "in etotal afer ebe",ipot ! 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 if (wtor.gt.0.0d0) then if (tor_mode.eq.0) then call etor(etors) else !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the !C energy function call etor_kcc(etors) endif else etors=0.0d0 endif edihcnstr=0.0d0 if (ndih_constr.gt.0) call etor_constr(edihcnstr) !c print *,"Processor",myrank," computed Utor" ! 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 ! write(iout,*) "before multibody" call flush(iout) ! print *,"Processor",myrank," computed Usccorr" ! ! 12/1/95 Multi-body terms ! n_corr=0 n_corr1=0 call flush(iout) 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 ! write(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 call flush(iout) ! write(iout,*) "after Econstr" if (wliptran.gt.0) then ! print *,"PRZED WYWOLANIEM" call Eliptransfer(eliptran) else eliptran=0.0d0 endif if (fg_rank.eq.0) then if (AFMlog.gt.0) then call AFMforce(Eafmforce) else if (selfguide.gt.0) then call AFMvel(Eafmforce) else Eafmforce=0.0d0 endif endif if (tubemode.eq.1) then call calctube(etube) else if (tubemode.eq.2) then call calctube2(etube) elseif (tubemode.eq.3) then call calcnano(etube) else etube=0.0d0 endif !-------------------------------------------------------- ! write (iout,*) "NRES_MOLEC(2),",nres_molec(2) ! print *,"before",ees,evdw1,ecorr ! write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2) if (nres_molec(2).gt.0) then call ebond_nucl(estr_nucl) call ebend_nucl(ebe_nucl) call etor_nucl(etors_nucl) call esb_gb(evdwsb,eelsb) call epp_nucl_sub(evdwpp,eespp) call epsb(evdwpsb,eelpsb) call esb(esbloc) call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1) call ecat_nucl(ecation_nucl) else etors_nucl=0.0d0 estr_nucl=0.0d0 ecorr3_nucl=0.0d0 ecorr_nucl=0.0d0 ebe_nucl=0.0d0 evdwsb=0.0d0 eelsb=0.0d0 esbloc=0.0d0 evdwpsb=0.0d0 eelpsb=0.0d0 evdwpp=0.0d0 eespp=0.0d0 etors_d_nucl=0.0d0 ecation_nucl=0.0d0 endif ! write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2) ! print *,"before ecatcat",wcatcat if (nres_molec(5).gt.0) then if (nfgtasks.gt.1) then if (fg_rank.eq.0) then call ecatcat(ecationcation) endif else call ecatcat(ecationcation) endif if (oldion.gt.0) then call ecat_prot(ecation_prot) else call ecats_prot_amber(ecation_prot) endif else ecationcation=0.0d0 ecation_prot=0.0d0 endif if ((nres_molec(2).gt.0).and.(nres_molec(1).gt.0)) then call eprot_sc_base(escbase) call epep_sc_base(epepbase) call eprot_sc_phosphate(escpho) call eprot_pep_phosphate(epeppho) else epepbase=0.0 escbase=0.0 escpho=0.0 epeppho=0.0 endif ! call ecatcat(ecationcation) ! print *,"after ebend", wtor_nucl #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 energia(22)=eliptran energia(23)=Eafmforce energia(24)=ethetacnstr energia(25)=etube !--------------------------------------------------------------- energia(26)=evdwpp energia(27)=eespp energia(28)=evdwpsb energia(29)=eelpsb energia(30)=evdwsb energia(31)=eelsb energia(32)=estr_nucl energia(33)=ebe_nucl energia(34)=esbloc energia(35)=etors_nucl energia(36)=etors_d_nucl energia(37)=ecorr_nucl energia(38)=ecorr3_nucl !---------------------------------------------------------------------- ! 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" energia(42)=ecation_prot energia(41)=ecationcation energia(46)=escbase energia(47)=epepbase energia(48)=escpho energia(49)=epeppho ! energia(50)=ecations_prot_amber energia(50)=ecation_nucl 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 ! 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, & eliptran,etube, Eafmforce,ethetacnstr real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,& ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,& ecorr3_nucl real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,& ecation_nucl real(kind=8) :: escbase,epepbase,escpho,epeppho 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) eliptran=energia(22) Eafmforce=energia(23) ethetacnstr=energia(24) etube=energia(25) evdwpp=energia(26) eespp=energia(27) evdwpsb=energia(28) eelpsb=energia(29) evdwsb=energia(30) eelsb=energia(31) estr_nucl=energia(32) ebe_nucl=energia(33) esbloc=energia(34) etors_nucl=energia(35) etors_d_nucl=energia(36) ecorr_nucl=energia(37) ecorr3_nucl=energia(38) ecation_prot=energia(42) ecationcation=energia(41) escbase=energia(46) epepbase=energia(47) escpho=energia(48) epeppho=energia(49) ecation_nucl=energia(50) ! ecations_prot_amber=energia(50) ! energia(41)=ecation_prot ! energia(42)=ecationcation #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+wliptran*eliptran+wtube*etube& +Eafmforce+ethetacnstr & +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl& +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb& +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl& +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl& +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase& +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl #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+wliptran*eliptran+wtube*etube& +Eafmforce+ethetacnstr & +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl& +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb& +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl& +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl& +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase& +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl #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) welpsb=weights(28)*fact(1) wcorr_nucl= weights(37)*fact(1) wcorr3_nucl=weights(38)*fact(2) wtor_nucl= weights(35)*fact(1) wtor_d_nucl=weights(36)*fact(2) wpepbase=weights(47)*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,eliptran,& etube,ethetacnstr,Eafmforce real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,& ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,& ecorr3_nucl real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,& ecation_nucl real(kind=8) :: escbase,epepbase,escpho,epeppho 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) eliptran=energia(22) Eafmforce=energia(23) ethetacnstr=energia(24) etube=energia(25) evdwpp=energia(26) eespp=energia(27) evdwpsb=energia(28) eelpsb=energia(29) evdwsb=energia(30) eelsb=energia(31) estr_nucl=energia(32) ebe_nucl=energia(33) esbloc=energia(34) etors_nucl=energia(35) etors_d_nucl=energia(36) ecorr_nucl=energia(37) ecorr3_nucl=energia(38) ecation_prot=energia(42) ecationcation=energia(41) escbase=energia(46) epepbase=energia(47) escpho=energia(48) epeppho=energia(49) ecation_nucl=energia(50) ! ecations_prot_amber=energia(50) #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,ethetacnstr,ebr*nss,& Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, & evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,& evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,& etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,& ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, & escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,& ecation_nucl,wcatnucl,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)'/ & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & 'UCONST= ',1pE16.6,' (Constraint energy)'/ & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/& 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ & 'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ & 'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ & 'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ & 'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ & 'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ & 'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ & 'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ & 'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ & 'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ & 'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ & 'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ & 'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ & 'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ & 'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ & 'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ & 'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ & 'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ & 'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/& 'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/& 'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/& '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,& ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce, & etube,wtube, & estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,& evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,& evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,& etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,& ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, & escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,& ecation_nucl,wcatnucl,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)'/ & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & 'UCONST=',1pE16.6,' (Constraint energy)'/ & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ & 'ESTR_nucl= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ & 'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ & 'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ & 'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ & 'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ & 'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ & 'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ & 'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ & 'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ & 'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ & 'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ & 'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ & 'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ & 'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ & 'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ & 'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ & 'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ & 'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/& 'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/& 'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/& '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,gg_lipi,gg_lipj integer :: num_conti !el local variables integer :: i,itypi,iint,j,itypi1,itypj,k real(kind=8) :: rij,rcut,fcont,fprimcont,rrij,sslipi,ssgradlipi,& aa,bb,sslipj,ssgradlipj 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,1)) if (itypi.eq.ntyp1) cycle itypi1=iabs(itype(i+1,1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) ! 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,1)) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) ! 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_aq(itypi,itypj) e2=fac*bb_aq(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,1),i,restyp(itypj,1),j,aa(itypi,itypj), !d & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, !d & (c(k,i),k=1,3),(c(k,j),k=1,3) evdw=evdw+evdwij ! ! Calculate the components of the gradient in DC and X ! fac=-rrij*(e1+evdwij) gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) gvdwx(k,j)=gvdwx(k,j)+gg(k) gvdwc(k,i)=gvdwc(k,i)-gg(k) gvdwc(k,j)=gvdwc(k,j)+gg(k) enddo !grad do k=i,j-1 !grad do l=1,3 !grad gvdwc(l,k)=gvdwc(l,k)+gg(l) !grad enddo !grad enddo ! ! 12/1/95, revised on 5/20/97 ! ! Calculate the contact function. The ith column of the array JCONT will ! contain the numbers of atoms that make contacts with the atom I (of numbers ! greater than I). The arrays FACONT and GACONT will contain the values of ! the contact function and its derivative. ! ! Uncomment next line, if the correlation interactions include EVDW explicitly. ! if (j.gt.i+1 .and. evdwij.le.0.0D0) then ! Uncomment next line, if the correlation interactions are contact function only if (j.gt.i+1.and. eps0ij.gt.0.0D0) then rij=dsqrt(rij) sigij=sigma(itypi,itypj) r0ij=rs0(itypi,itypj) ! ! Check whether the SC's are not too far to make a contact. ! rcut=1.5d0*r0ij call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) ! Add a new contact, if the SC's are close enough, but not too close (ri' !grad do k=1,3 !grad ggg(k)=-ggg(k) ! Uncomment following line for SC-p interactions ! gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) !grad enddo !grad endif !grad do k=1,3 !grad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) !grad enddo !grad kstart=min0(i+1,j) !grad kend=max0(i-1,j-1) !d write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend !d write (iout,*) ggg(1),ggg(2),ggg(3) !grad do k=kstart,kend !grad do l=1,3 !grad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) !grad enddo !grad enddo do k=1,3 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) enddo enddo enddo ! iint enddo ! i return end subroutine escp_soft_sphere !----------------------------------------------------------------------------- subroutine escp(evdw2,evdw2_14) ! ! This subroutine calculates the excluded-volume interaction energy between ! peptide-group centers and side chains and its gradient in virtual-bond and ! side-chain vectors. ! ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.VAR' ! include 'COMMON.LOCAL' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.INTERACT' ! include 'COMMON.FFIELD' ! include 'COMMON.IOUNITS' ! include 'COMMON.CONTROL' real(kind=8),dimension(3) :: ggg !el local variables integer :: i,iint,j,k,iteli,itypj,subchap,icont real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,& e1,e2,evdwij,rij real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init integer xshift,yshift,zshift 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 do icont=g_listscp_start,g_listscp_end i=newcontlistscpi(icont) j=newcontlistscpj(icont) if (itype(i,1).eq.ntyp1 .or. itype(i+1,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)) call to_box(xi,yi,zi) ! do iint=1,nscp_gr(i) ! do j=iscpstart(i,iint),iscpend(i,iint) itypj=iabs(itype(j,1)) 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 xj=c(1,j) yj=c(2,j) zj=c(3,j) call to_box(xj,yj,zj) xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(1.0d0/rrij) sss_ele_cut=sscale_ele(rij) sss_ele_grad=sscagrad_ele(rij) ! print *,sss_ele_cut,sss_ele_grad,& ! (rij),r_cut_ele,rlamb_ele if (sss_ele_cut.le.0.0) cycle 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_ele_cut endif evdwij=e1+e2 evdw2=evdw2+evdwij*sss_ele_cut ! 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*sss_ele_cut fac=fac+evdwij*sss_ele_grad/rij/expon ggg(1)=xj*fac ggg(2)=yj*fac ggg(3)=zj*fac !grad if (j.lt.i) then !d write (iout,*) 'ji' !grad do k=1,3 !grad ggg(k)=-ggg(k) ! Uncomment following line for SC-p interactions !cgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) ! gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) !grad enddo !grad endif !grad do k=1,3 !grad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) !grad enddo !grad kstart=min0(i+1,j) !grad kend=max0(i-1,j-1) !d write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend !d write (iout,*) ggg(1),ggg(2),ggg(3) !grad do k=kstart,kend !grad do l=1,3 !grad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) !grad enddo !grad enddo do k=1,3 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) enddo ! enddo ! enddo ! iint enddo ! i do i=1,nct do j=1,3 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) gradx_scp(j,i)=expon*gradx_scp(j,i) enddo enddo !****************************************************************************** ! ! N O T E !!! ! ! To save time the factor EXPON has been extracted from ALL components ! of GVDWC and GRADX. Remember to multiply them by this factor before further ! use! ! !****************************************************************************** return end subroutine escp !----------------------------------------------------------------------------- subroutine edis(ehpb) ! ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. ! ! implicit real*8 (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.SBRIDGE' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.VAR' ! include 'COMMON.INTERACT' ! include 'COMMON.IOUNITS' real(kind=8),dimension(3) :: ggg !el local variables integer :: i,j,ii,jj,iii,jjj,k real(kind=8) :: fac,eij,rdis,ehpb,dd,waga ehpb=0.0D0 !d write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr !d write(iout,*)'link_start=',link_start,' link_end=',link_end if (link_end.eq.0) return do i=link_start,link_end ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a ! CA-CA distance used in regularization of structure. ii=ihpb(i) jj=jhpb(i) ! iii and jjj point to the residues for which the distance is assigned. if (ii.gt.nres) then iii=ii-nres jjj=jj-nres else iii=ii jjj=jj endif ! write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, ! & dhpb(i),dhpb1(i),forcon(i) ! 24/11/03 AL: SS bridges handled separately because of introducing a specific ! distance and angle dependent SS bond potential. !mc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds if (.not.dyn_ss .and. i.le.nss) then ! 15/02/13 CC dynamic SSbond - additional check if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. & iabs(itype(jjj,1)).eq.1) then call ssbond_ene(iii,jjj,eij) ehpb=ehpb+2*eij !d write (iout,*) "eij",eij endif else if (ii.gt.nres .and. jj.gt.nres) then !c Restraints from contact prediction dd=dist(ii,jj) if (constr_dist.eq.11) then ehpb=ehpb+fordepth(i)**4.0d0 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) fac=fordepth(i)**4.0d0 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, & ehpb,fordepth(i),dd else if (dhpb1(i).gt.0.0d0) then ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd !c write (iout,*) "beta nmr", !c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) else dd=dist(ii,jj) rdis=dd-dhpb(i) !C Get the force constant corresponding to this distance. waga=forcon(i) !C Calculate the contribution to energy. ehpb=ehpb+waga*rdis*rdis !c write (iout,*) "beta reg",dd,waga*rdis*rdis !C !C Evaluate gradient. !C fac=waga*rdis/dd endif endif do j=1,3 ggg(j)=fac*(c(j,jj)-c(j,ii)) enddo do j=1,3 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) enddo do k=1,3 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) enddo else dd=dist(ii,jj) if (constr_dist.eq.11) then ehpb=ehpb+fordepth(i)**4.0d0 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) fac=fordepth(i)**4.0d0 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, & ehpb,fordepth(i),dd else if (dhpb1(i).gt.0.0d0) then ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd !c write (iout,*) "alph nmr", !c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) else rdis=dd-dhpb(i) !C Get the force constant corresponding to this distance. waga=forcon(i) !C Calculate the contribution to energy. ehpb=ehpb+waga*rdis*rdis !c write (iout,*) "alpha reg",dd,waga*rdis*rdis !C !C Evaluate gradient. !C fac=waga*rdis/dd endif endif do j=1,3 ggg(j)=fac*(c(j,jj)-c(j,ii)) enddo !cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) !C If this is a SC-SC distance, we need to calculate the contributions to the !C Cartesian gradient in the SC vectors (ghpbx). if (iii.lt.ii) then do j=1,3 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) enddo endif !cgrad do j=iii,jjj-1 !cgrad do k=1,3 !cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k) !cgrad enddo !cgrad enddo do k=1,3 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) enddo endif enddo if (constr_dist.ne.11) 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,1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) 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,1)) ! 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 call to_box(xj,yj,zj) xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) 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,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then !C estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) !C do j=1,3 !C gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) & !C *dc(j,i-1)/vbld(i) !C enddo !C if (energy_dec) write(iout,*) & !C "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax) diff = vbld(i)-vbldpDUM else diff = vbld(i)-vbldp0 endif 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 ! print *,"estr_bb",estr,AKP ! ! 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,1)) if (iti.eq.0) print *,"WARNING WRONG SETTTING",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 ! print *,"estr_sc",estr 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 ! print *,"estr_sc",estr,i if (energy_dec) write (iout,*) & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,& AKSC(1,iti),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,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,1) ichir1=isign(1,itype(i-2,1)) ichir2=isign(1,itype(i,1)) if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1)) if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1)) if (itype(i-1,1).eq.10) then itype1=isign(10,itype(i-2,1)) ichir11=isign(1,itype(i-2,1)) ichir12=isign(1,itype(i-2,1)) itype2=isign(10,itype(i,1)) ichir21=isign(1,itype(i,1)) ichir22=isign(1,itype(i,1)) endif if (i.gt.3 .and. itype(i-2,1).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,1).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 ! print *,ithetaconstr_start,ithetaconstr_end,"TU" ! 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,ethetacnstr ! local variables for constrains real(kind=8) :: difi,thetiii integer itheta ! write(iout,*) "in ebend",ithet_start,ithet_end call flush(iout) etheta=0.0D0 do i=ithet_start,ithet_end if (itype(i-1,1).eq.ntyp1) cycle if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle if (iabs(itype(i+1,1)).eq.20) iblock=2 if (iabs(itype(i+1,1)).ne.20) iblock=1 dethetai=0.0d0 dephii=0.0d0 dephii1=0.0d0 theti2=0.5d0*theta(i) ityp2=ithetyp((itype(i-1,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),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,1))) ! 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,1)) do k=1,nsingle cosph1(k)=0.0d0 sinph1(k)=0.0d0 enddo endif if (i.lt.nres .and. itype(i+1,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,1))) do k=1,nsingle cosph2(k)=dcos(k*phii1) sinph2(k)=dsin(k*phii1) enddo else phii1=0.0d0 ityp3=ithetyp(itype(i,1)) do k=1,nsingle cosph2(k)=0.0d0 sinph2(k)=0.0d0 enddo endif ethetai=aa0thet(ityp1,ityp2,ityp3,iblock) do k=1,ndouble do l=1,k-1 ccl=cosph1(l)*cosph2(k-l) ssl=sinph1(l)*sinph2(k-l) scl=sinph1(l)*cosph2(k-l) csl=cosph1(l)*sinph2(k-l) cosph1ph2(l,k)=ccl-ssl cosph1ph2(k,l)=ccl+ssl sinph1ph2(l,k)=scl+csl sinph1ph2(k,l)=scl-csl enddo enddo if (lprn) then write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,& " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 write (iout,*) "coskt and sinkt" do k=1,nntheterm write (iout,*) k,coskt(k),sinkt(k) enddo endif do k=1,ntheterm ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k) dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) & *coskt(k) if (lprn) & write (iout,*) "k",k,& "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),& " ethetai",ethetai enddo if (lprn) then write (iout,*) "cosph and sinph" do k=1,nsingle write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) enddo write (iout,*) "cosph1ph2 and sinph2ph2" do k=2,ndouble do l=1,k-1 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),& sinph1ph2(l,k),sinph1ph2(k,l) enddo enddo write(iout,*) "ethetai",ethetai endif do m=1,ntheterm2 do k=1,nsingle aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k) ethetai=ethetai+sinkt(m)*aux dethetai=dethetai+0.5d0*m*aux*coskt(m) dephii=dephii+k*sinkt(m)* & (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)) dephii1=dephii1+k*sinkt(m)* & (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)) if (lprn) & write (iout,*) "m",m," k",k," bbthet", & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai enddo enddo if (lprn) & write(iout,*) "ethetai",ethetai do m=1,ntheterm3 do k=2,ndouble do l=1,k-1 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l) ethetai=ethetai+sinkt(m)*aux dethetai=dethetai+0.5d0*m*coskt(m)*aux dephii=dephii+l*sinkt(m)* & (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) dephii1=dephii1+(k-l)*sinkt(m)* & (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) if (lprn) then write (iout,*) "m",m," k",k," l",l," ffthet",& ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),& ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",& ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),& ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),& " ethetai",ethetai write (iout,*) cosph1ph2(l,k)*sinkt(m),& cosph1ph2(k,l)*sinkt(m),& sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) endif enddo enddo enddo 10 continue ! lprn1=.true. if (lprn1) & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') & i,theta(i)*rad2deg,phii*rad2deg,& phii1*rad2deg,ethetai ! lprn1=.false. etheta=etheta+ethetai if (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 !-----------thete constrains ! if (tor_mode.ne.2) then 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,1) 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,1).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,1)) 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,1))) 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,1)) 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,1)))*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 if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, & " escloc",sumene,escloc,it,itype(i,1) ! write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1) ! & ,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,1))) 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,1) #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,1) #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,1) #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,1) #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,1)))*dC_norm(j,i+nres) dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) & *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres) enddo dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) dZZ_XYZ(k)=vbld_inv(i+nres)* & (z_prime(k)-zz*dC_norm(k,i+nres)) ! 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,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 & .or. itype(i,1).eq.ntyp1) cycle itori=itortyp(itype(i-2,1)) itori1=itortyp(itype(i-1,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,1),1),i-2,restyp(itype(i-1,1),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(i)*difi**4 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 else if (difi.lt.-drange(i)) then difi=difi+drange(i) edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*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) ! 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,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 & .or. itype(i-3,1).eq.ntyp1 & .or. itype(i,1).eq.ntyp1) cycle etors_ii=0.0D0 if (iabs(itype(i,1)).eq.20) then iblock=2 else iblock=1 endif itori=itortyp(itype(i-2,1)) itori1=itortyp(itype(i-1,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,1),1),i-2,restyp(itype(i-1,1),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 return end subroutine etor !C The rigorous attempt to derive energy function !------------------------------------------------------------------------------------------- subroutine etor_kcc(etors) double precision c1(0:maxval_kcc),c2(0:maxval_kcc) real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,& sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,& sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,& gradvalst2,etori logical lprn integer :: i,j,itori,itori1,nval,k,l if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode etors=0.0D0 do i=iphi_start,iphi_end !C ANY TWO ARE DUMMY ATOMS in row CYCLE !c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or. !c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or. !c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 & .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle itori=itortyp(itype(i-2,1)) itori1=itortyp(itype(i-1,1)) phii=phi(i) glocig=0.0D0 glocit1=0.0d0 glocit2=0.0d0 !C to avoid multiple devision by 2 !c theti22=0.5d0*theta(i) !C theta 12 is the theta_1 /2 !C theta 22 is theta_2 /2 !c theti12=0.5d0*theta(i-1) !C and appropriate sinus function sinthet1=dsin(theta(i-1)) sinthet2=dsin(theta(i)) costhet1=dcos(theta(i-1)) costhet2=dcos(theta(i)) !C to speed up lets store its mutliplication sint1t2=sinthet2*sinthet1 sint1t2n=1.0d0 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma) !C +d_n*sin(n*gamma)) * !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2))) !C we have two sum 1) Non-Chebyshev which is with n and gamma nval=nterm_kcc_Tb(itori,itori1) c1(0)=0.0d0 c2(0)=0.0d0 c1(1)=1.0d0 c2(1)=1.0d0 do j=2,nval c1(j)=c1(j-1)*costhet1 c2(j)=c2(j-1)*costhet2 enddo etori=0.0d0 do j=1,nterm_kcc(itori,itori1) cosphi=dcos(j*phii) sinphi=dsin(j*phii) sint1t2n1=sint1t2n sint1t2n=sint1t2n*sint1t2 sumvalc=0.0d0 gradvalct1=0.0d0 gradvalct2=0.0d0 do k=1,nval do l=1,nval sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l) gradvalct1=gradvalct1+ & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l) gradvalct2=gradvalct2+ & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1) enddo enddo gradvalct1=-gradvalct1*sinthet1 gradvalct2=-gradvalct2*sinthet2 sumvals=0.0d0 gradvalst1=0.0d0 gradvalst2=0.0d0 do k=1,nval do l=1,nval sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l) gradvalst1=gradvalst1+ & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l) gradvalst2=gradvalst2+ & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1) enddo enddo gradvalst1=-gradvalst1*sinthet1 gradvalst2=-gradvalst2*sinthet2 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi) !C glocig is the gradient local i site in gamma glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi) !C now gradient over theta_1 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)& +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi) glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)& +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi) enddo ! j etors=etors+etori gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig !C derivative over theta1 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1 !C now derivative over theta2 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2 if (lprn) then write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,& theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori write (iout,*) "c1",(c1(k),k=0,nval), & " c2",(c2(k),k=0,nval) endif enddo return end subroutine etor_kcc !------------------------------------------------------------------------------ subroutine etor_constr(edihcnstr) 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,& gaudih_i,gauder_i,s,cos_i,dexpcos_i if (raw_psipred) then do i=idihconstr_start,idihconstr_end itori=idih_constr(i) phii=phi(itori) gaudih_i=vpsipred(1,i) gauder_i=0.0d0 do j=1,2 s = sdihed(j,i) cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2 dexpcos_i=dexp(-cos_i*cos_i) gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) & *cos_i*dexpcos_i/s**2 enddo edihcnstr=edihcnstr-wdihc*dlog(gaudih_i) gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i if (energy_dec) & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),& phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),& phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,& -wdihc*dlog(gaudih_i) enddo else 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(i)*difi**4 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 else if (difi.lt.-drange(i)) then difi=difi+drange(i) edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 else difi=0.0 endif enddo endif return end subroutine etor_constr !----------------------------------------------------------------------------- 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,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 & .or. itype(i-3,1).eq.ntyp1 & .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle itori=itortyp(itype(i-2,1)) itori1=itortyp(itype(i-1,1)) itori2=itortyp(itype(i,1)) phii=phi(i) phii1=phi(i+1) gloci1=0.0D0 gloci2=0.0D0 iblock=1 if (iabs(itype(i+1,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 ebend_kcc(etheta) logical lprn double precision thybt1(maxang_kcc),etheta integer :: i,iti,j,ihelp real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1 !C Set lprn=.true. for debugging lprn=energy_dec !c lprn=.true. !C print *,"wchodze kcc" if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode etheta=0.0D0 do i=ithet_start,ithet_end !c print *,i,itype(i-1),itype(i),itype(i-2) if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 & .or.itype(i,1).eq.ntyp1) cycle iti=iabs(itortyp(itype(i-1,1))) sinthet=dsin(theta(i)) costhet=dcos(theta(i)) do j=1,nbend_kcc_Tb(iti) thybt1(j)=v1bend_chyb(j,iti) enddo sumth1thyb=v1bend_chyb(0,iti)+ & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet) if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,& sumth1thyb ihelp=nbend_kcc_Tb(iti)-1 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet) etheta=etheta+sumth1thyb !C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0) gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet enddo return end subroutine ebend_kcc !c------------ !c------------------------------------------------------------------------------------- subroutine etheta_constr(ethetacnstr) real (kind=8) :: ethetacnstr,thetiii,difi integer :: i,itheta ethetacnstr=0.0d0 !C print *,ithetaconstr_start,ithetaconstr_end,"TU" do i=ithetaconstr_start,ithetaconstr_end itheta=itheta_constr(i) thetiii=theta(itheta) difi=pinorm(thetiii-theta_constr0(i)) if (difi.gt.theta_drange(i)) then difi=difi-theta_drange(i) ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) & +for_thet_constr(i)*difi**3 else if (difi.lt.-drange(i)) then difi=difi+drange(i) ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) & +for_thet_constr(i)*difi**3 else difi=0.0 endif if (energy_dec) then write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",& i,itheta,rad2deg*thetiii,& rad2deg*theta_constr0(i), rad2deg*theta_drange(i),& rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,& gloc(itheta+nphi-2,icg) endif enddo return end subroutine etheta_constr !----------------------------------------------------------------------------- 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,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle esccor_ii=0.0D0 isccori=isccortyp(itype(i-2,1)) isccori1=isccortyp(itype(i-1,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,1).eq.10).or. & (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. & (itype(i-1,1).eq.ntyp1))) & .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) & .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) & .or.(itype(i,1).eq.ntyp1))) & .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. & (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. & (itype(i-3,1).eq.ntyp1)))) cycle if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).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,1),1),i-2,restyp(itype(i-1,1),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,ilist,m, iresshield real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,& ees0mkl,ees,coeffpees0pij,coeffmees0mij,& coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, & rlocshield 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 if (shield_mode.gt.0) then j=ees0plist(jj,i) l=ees0plist(kk,k) !C print *,i,j,fac_shield(i),fac_shield(j), !C &fac_shield(k),fac_shield(l) if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then do ilist=1,ishield_list(i) iresshield=shield_list(ilist,i) do m=1,3 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i) gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ & rlocshield & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i) gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) & +rlocshield enddo enddo do ilist=1,ishield_list(j) iresshield=shield_list(ilist,j) do m=1,3 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j) gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ & rlocshield & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j) gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) & +rlocshield enddo enddo do ilist=1,ishield_list(k) iresshield=shield_list(ilist,k) do m=1,3 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k) gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ & rlocshield & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k) gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) & +rlocshield enddo enddo do ilist=1,ishield_list(l) iresshield=shield_list(ilist,l) do m=1,3 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l) gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ & rlocshield & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l) gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) & +rlocshield enddo enddo do m=1,3 gshieldc_ec(m,i)=gshieldc_ec(m,i)+ & grad_shield(m,i)*ehbcorr/fac_shield(i) gshieldc_ec(m,j)=gshieldc_ec(m,j)+ & grad_shield(m,j)*ehbcorr/fac_shield(j) gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+ & grad_shield(m,i)*ehbcorr/fac_shield(i) gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+ & grad_shield(m,j)*ehbcorr/fac_shield(j) gshieldc_ec(m,k)=gshieldc_ec(m,k)+ & grad_shield(m,k)*ehbcorr/fac_shield(k) gshieldc_ec(m,l)=gshieldc_ec(m,l)+ & grad_shield(m,l)*ehbcorr/fac_shield(l) gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+ & grad_shield(m,k)*ehbcorr/fac_shield(k) gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+ & grad_shield(m,l)*ehbcorr/fac_shield(l) enddo endif endif 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,1)) if (j.lt.nres-1) then itj1 = itype2loc(itype(j+1,1)) else itj1=nloctyp 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,1)) else iti=ntortyp+1 endif itk1=itortyp(itype(k+1,1)) itj=itortyp(itype(j,1)) if (l.lt.nres-1) then itl1=itortyp(itype(l+1,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,1)) else iti=ntortyp+1 endif itk1=itortyp(itype(k+1,1)) itl=itortyp(itype(l,1)) itj=itortyp(itype(j,1)) if (j.lt.nres-1) then itj1=itortyp(itype(j+1,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,1)) itl=itortyp(itype(l,1)) itj=itortyp(itype(j,1)) 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,1)) 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,1)) if (j.lt.nres-1) then itj1=itortyp(itype(j+1,1)) else itj1=ntortyp+1 endif itk=itortyp(itype(k,1)) itk1=itortyp(itype(k+1,1)) if (l.lt.nres-1) then itl1=itortyp(itype(l+1,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,1)) itj=itortyp(itype(j,1)) if (j.lt.nres-1) then itj1=itortyp(itype(j+1,1)) else itj1=ntortyp+1 endif itk=itortyp(itype(k,1)) if (k.lt.nres-1) then itk1=itortyp(itype(k+1,1)) else itk1=ntortyp+1 endif itl=itortyp(itype(l,1)) if (l.lt.nres-1) then itl1=itortyp(itype(l+1,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,1)) itk=itortyp(itype(k,1)) itk1=itortyp(itype(k+1,1)) itl=itortyp(itype(l,1)) itj=itortyp(itype(j,1)) !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,-1: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 !#define DEBUG #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=0,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) & +wliptran*gliptranc(j,i) & +gradafm(j,i) & +welec*gshieldc(j,i) & +wcorr*gshieldc_ec(j,i) & +wturn3*gshieldc_t3(j,i)& +wturn4*gshieldc_t4(j,i)& +wel_loc*gshieldc_ll(j,i)& +wtube*gg_tube(j,i) & +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ & wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ & wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ & wcorr_nucl*gradcorr_nucl(j,i)& +wcorr3_nucl*gradcorr3_nucl(j,i)+& wcatprot* gradpepcat(j,i)+ & wcatcat*gradcatcat(j,i)+ & wscbase*gvdwc_scbase(j,i)+ & wpepbase*gvdwc_pepbase(j,i)+& wscpho*gvdwc_scpho(j,i)+ & wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i) enddo enddo #else do i=0,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) & +wliptran*gliptranc(j,i) & +gradafm(j,i) & +welec*gshieldc(j,i)& +wcorr*gshieldc_ec(j,i) & +wturn4*gshieldc_t4(j,i) & +wel_loc*gshieldc_ll(j,i)& +wtube*gg_tube(j,i) & +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ & wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ & wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ & wcorr_nucl*gradcorr_nucl(j,i) & +wcorr3_nucl*gradcorr3_nucl(j,i) +& wcatprot* gradpepcat(j,i)+ & wcatcat*gradcatcat(j,i)+ & wscbase*gvdwc_scbase(j,i)+ & wpepbase*gvdwc_pepbase(j,i)+& wscpho*gvdwc_scpho(j,i)+& wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(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=0,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=0,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,-1,-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,-1,-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) & +wliptran*gliptranc(j,i) & +gradafm(j,i) & +welec*gshieldc(j,i) & +welec*gshieldc_loc(j,i) & +wcorr*gshieldc_ec(j,i) & +wcorr*gshieldc_loc_ec(j,i) & +wturn3*gshieldc_t3(j,i) & +wturn3*gshieldc_loc_t3(j,i) & +wturn4*gshieldc_t4(j,i) & +wturn4*gshieldc_loc_t4(j,i) & +wel_loc*gshieldc_ll(j,i) & +wel_loc*gshieldc_loc_ll(j,i) & +wtube*gg_tube(j,i) & +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)& +wvdwpsb*gvdwpsb1(j,i))& +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i) ! if (i.eq.21) then ! print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),& ! wturn4*gshieldc_t4(j,i), & ! wturn4*gshieldc_loc_t4(j,i) ! endif ! if ((i.le.2).and.(i.ge.1)) ! print *,gradc(j,i,icg),& ! gradbufc(j,i),welec*gelc(j,i), & ! wel_loc*gel_loc(j,i), & ! 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) & ! ,wliptran*gliptranc(j,i) & ! ,gradafm(j,i) & ! ,welec*gshieldc(j,i) & ! ,welec*gshieldc_loc(j,i) & ! ,wcorr*gshieldc_ec(j,i) & ! ,wcorr*gshieldc_loc_ec(j,i) & ! ,wturn3*gshieldc_t3(j,i) & ! ,wturn3*gshieldc_loc_t3(j,i) & ! ,wturn4*gshieldc_t4(j,i) & ! ,wturn4*gshieldc_loc_t4(j,i) & ! ,wel_loc*gshieldc_ll(j,i) & ! ,wel_loc*gshieldc_loc_ll(j,i) & ! ,wtube*gg_tube(j,i) & ! ,wbond_nucl*gradb_nucl(j,i) & ! ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),& ! wvdwpsb*gvdwpsb1(j,i)& ! ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(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) & +gradafm(j,i) & +wliptran*gliptranc(j,i) & +welec*gshieldc(j,i) & +welec*gshieldc_loc(j,i) & +wcorr*gshieldc_ec(j,i) & +wcorr*gshieldc_loc_ec(j,i) & +wturn3*gshieldc_t3(j,i) & +wturn3*gshieldc_loc_t3(j,i) & +wturn4*gshieldc_t4(j,i) & +wturn4*gshieldc_loc_t4(j,i) & +wel_loc*gshieldc_ll(j,i) & +wel_loc*gshieldc_loc_ll(j,i) & +wtube*gg_tube(j,i) & +wbond_nucl*gradb_nucl(j,i) & +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)& +wvdwpsb*gvdwpsb1(j,i))& +wsbloc*gsbloc(j,i)+wcatnucl*gradnuclcat(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) & +wliptran*gliptranx(j,i) & +welec*gshieldx(j,i) & +wcorr*gshieldx_ec(j,i) & +wturn3*gshieldx_t3(j,i) & +wturn4*gshieldx_t4(j,i) & +wel_loc*gshieldx_ll(j,i)& +wtube*gg_tube_sc(j,i) & +wbond_nucl*gradbx_nucl(j,i) & +wvdwsb*gvdwsbx(j,i) & +welsb*gelsbx(j,i) & +wcorr_nucl*gradxorr_nucl(j,i)& +wcorr3_nucl*gradxorr3_nucl(j,i) & +wsbloc*gsblocx(j,i) & +wcatprot* gradpepcatx(j,i)& +wscbase*gvdwx_scbase(j,i) & +wpepbase*gvdwx_pepbase(j,i)& +wscpho*gvdwx_scpho(j,i)+wcatnucl*gradnuclcatx(j,i) ! if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i) enddo enddo !#define DEBUG #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 !#undef DEBUG #ifdef MPI if (nfgtasks.gt.1) then do j=1,3 do i=0,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=0,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,0),gradc(1,0,icg),3*nres+3,& MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,& 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,0),gloc_sc(1,0,icg),3*nres+3,& MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) time_reduce=time_reduce+MPI_Wtime()-time00 !#define DEBUG ! print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg) #ifdef DEBUG write (iout,*) "gloc_sc after reduce" do i=0,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 !#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 !#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 ! print *,"wchodze" eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 & +dCAVdOM1+ dGCLdOM1+ dPOLdOM1 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 & +dCAVdOM2+ dGCLdOM2+ dPOLdOM2 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 & -2.0D0*alf12*eps3der+sigder*sigsq_om12& +dCAVdOM12+ dGCLdOM12 ! 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 !C print *,sss_ele_cut,'in sc_grad' 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))*sss_ele_cut !C print *,'gg',k,gg(k) enddo ! print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut ! write (iout,*) "gg",(gg(k),k=1,3) do k=1,3 gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)& +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv & *sss_ele_cut gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)& +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv & *sss_ele_cut ! 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)+gg_lipi(l) gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l) enddo return end subroutine sc_grad subroutine sc_grad_cat use calc_data real(kind=8), dimension(3) :: dcosom1,dcosom2 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 & +dCAVdOM1+ dGCLdOM1+ dPOLdOM1 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 & +dCAVdOM2+ dGCLdOM2+ dPOLdOM2 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 & -2.0D0*alf12*eps3der+sigder*sigsq_om12& +dCAVdOM12+ dGCLdOM12 ! diagnostics only ! eom1=0.0d0 ! eom2=0.0d0 ! eom12=evdwij*eps1_om12 ! end diagnostics do k=1,3 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k)) enddo do k=1,3 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)) !C print *,'gg',k,gg(k) enddo ! print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut ! write (iout,*) "gg",(gg(k),k=1,3) do k=1,3 gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) & +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv ! gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) & ! +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) & ! +eom2*(erij(k)-om2*dc_norm(k,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 ! do l=1,3 gradpepcat(l,i)=gradpepcat(l,i)-gg(l) gradpepcat(l,j)=gradpepcat(l,j)+gg(l) enddo end subroutine sc_grad_cat subroutine sc_grad_cat_pep use calc_data real(kind=8), dimension(3) :: dcosom1,dcosom2 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 & +dCAVdOM1+ dGCLdOM1+ dPOLdOM1 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 & +dCAVdOM2+ dGCLdOM2+ dPOLdOM2 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 & -2.0D0*alf12*eps3der+sigder*sigsq_om12& +dCAVdOM12+ dGCLdOM12 ! diagnostics only ! eom1=0.0d0 ! eom2=0.0d0 ! eom12=evdwij*eps1_om12 ! end diagnostics do k=1,3 dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k)) dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k) gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k)) & + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))& *dsci_inv*2.0 & - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0 gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k)) & - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) & *dsci_inv*2.0 & + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0 gradpepcat(k,j)=gradpepcat(k,j)+gg(k) enddo end subroutine sc_grad_cat_pep #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,1)) 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-6 aincr2=5.0d-7 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-5 print '(a)','CG processor',me,' calling CHECK_CART.',aincr 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 zerograd 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 zerograd 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 #ifdef CARGRAD !----------------------------------------------------------------------------- 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,ddc1,ddcn real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres) real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres) real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres) real(kind=8),dimension(0:n_ene) :: energia,energia1 integer :: uiparm(1) real(kind=8) :: urparm(1) !EL external fdum integer :: i,j,k,nf real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,& etot21,etot22 r_cut=2.0d0 rlambd=0.3d0 icg=1 nf=0 nfl=0 call intout ! call intcartderiv ! call checkintcartgrad call zerograd aincr=1.0D-5 write(iout,*) 'Calling CHECK_ECARTINT.' nf=0 icall=0 call geom_to_var(nvar,x) write (iout,*) "split_ene ",split_ene call flush(iout) if (.not.split_ene) then call zerograd call etotal(energia) etot=energia(0) call cartgrad 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 cartgrad icall =1 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) call enerprint(energia) call cartgrad icall =1 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=1,nres do i=nnt,nct do j=1,3 if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1) if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres) ddc(j)=c(j,i) ddx(j)=c(j,i+nres) dcnorm_safe1(j)=dc_norm(j,i-1) dcnorm_safe2(j)=dc_norm(j,i) dxnorm_safe(j)=dc_norm(j,i+nres) enddo do j=1,3 c(j,i)=ddc(j)+aincr if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1) dc(j,i)=c(j,i+1)-c(j,i) dc(j,i+nres)=c(j,i+nres)-c(j,i) call int_from_cart1(.false.) if (.not.split_ene) then call zerograd call etotal(energia1) etot1=energia1(0) write (iout,*) "ij",i,j," etot1",etot1 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 c(j,i)=ddc(j)-aincr if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1) dc(j,i)=c(j,i+1)-c(j,i) dc(j,i+nres)=c(j,i+nres)-c(j,i) call int_from_cart1(.false.) if (.not.split_ene) then call zerograd call etotal(energia1) etot2=energia1(0) write (iout,*) "ij",i,j," etot2",etot2 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 c(j,i)=ddc(j) if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j) if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j) if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1) dc(j,i)=c(j,i+1)-c(j,i) dc(j,i+nres)=c(j,i+nres)-c(j,i) dc_norm(j,i-1)=dcnorm_safe1(j) dc_norm(j,i)=dcnorm_safe2(j) dc_norm(j,i+nres)=dxnorm_safe(j) enddo do j=1,3 c(j,i+nres)=ddx(j)+aincr dc(j,i+nres)=c(j,i+nres)-c(j,i) call int_from_cart1(.false.) if (.not.split_ene) then call zerograd 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 c(j,i+nres)=ddx(j)-aincr dc(j,i+nres)=c(j,i+nres)-c(j,i) call int_from_cart1(.false.) if (.not.split_ene) then call zerograd 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 c(j,i+nres)=ddx(j) dc(j,i+nres)=c(j,i+nres)-c(j,i) dc_norm(j,i+nres)=dxnorm_safe(j) call int_from_cart1(.false.) 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 #else !----------------------------------------------------------------------------- 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-6 write(iout,*) 'Calling CHECK_ECARTINT.',aincr 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 cartgrad 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) ! if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i) ! if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(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 cartgrad icall =1 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) ! if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i) grad_s(j+3,i)=gxcart(j,i) enddo enddo call zerograd call etotal_short(energia) !el call enerprint(energia) call cartgrad icall =1 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 zerograd call etotal(energia1) etot1=energia1(0) ! call enerprint(energia1) 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 zerograd 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 zerograd 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 zerograd 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 #endif !----------------------------------------------------------------------------- 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 real(kind=8) function sscale_grad(r) ! include "COMMON.SPLITELE" real(kind=8) :: r,gamm if(r.lt.r_cut-rlamb) then sscale_grad=0.0d0 else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then gamm=(r-(r_cut-rlamb))/rlamb sscale_grad=gamm*(6*gamm-6.0d0)/rlamb else sscale_grad=0d0 endif return end function sscale_grad !!!!!!!!!! PBCSCALE real(kind=8) function sscale_ele(r) ! include "COMMON.SPLITELE" real(kind=8) :: r,gamm if(r.lt.r_cut_ele-rlamb_ele) then sscale_ele=1.0d0 else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0) else sscale_ele=0d0 endif return end function sscale_ele real(kind=8) function sscagrad_ele(r) real(kind=8) :: r,gamm ! include "COMMON.SPLITELE" if(r.lt.r_cut_ele-rlamb_ele) then sscagrad_ele=0.0d0 else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele else sscagrad_ele=0.0d0 endif return end function sscagrad_ele real(kind=8) function sscalelip(r) real(kind=8) r,gamm sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0) return end function sscalelip !C----------------------------------------------------------------------- real(kind=8) function sscagradlip(r) real(kind=8) r,gamm sscagradlip=r*(6.0d0*r-6.0d0) return end function sscagradlip !!!!!!!!!!!!!!! !----------------------------------------------------------------------------- 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,gg_lipi,gg_lipj !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,sslipi,ssgradlipi,& sslipj,ssgradlipj,aa,bb ! write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e itypi=itype(i,1) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1,1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) ! ! 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,1) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) 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_aq(itypi,itypj) e2=fac*bb_aq(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,gg_lipi,gg_lipj !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,sslipi,ssgradlipi,& sslipj,ssgradlipj ! write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e itypi=itype(i,1) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1,1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) ! 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,1) 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_aq(itypi,itypj) e2=fac*bb_aq(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,gg_lipi,gg_lipj 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,1) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1,1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) itypj=itype(j,1) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi call to_box(xj,yj,zj) xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) 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_aq(itypi,itypj) e2=fac*bb_aq(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,1),i,restyp(itypj,1),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,gg_lipi,gg_lipj 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,& sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb ! print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e itypi=itype(i,1) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1,1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) ! ! Calculate SC interaction energy. ! do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) itypj=itype(j,1) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) 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_aq(itypi,itypj) e2=fac*bb_aq(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,1),i,restyp(itypj,1),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,sslipi,ssgradlipi,& sslipj,ssgradlipj,aa,bb 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,1) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1,1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) 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,1) 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) 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 call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) 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_aq(itypi,itypj) e2=fac*bb_aq(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_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0) epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj) !d write (iout,'(2(a3,i3,2x),15(0pf7.3))') !d & restyp(itypi,1),i,restyp(itypj,1),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,aa,bb, & sslipi,ssgradlipi,sslipj,ssgradlipj 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,1) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1,1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) 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,1) 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 call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) 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_aq(itypi,itypj) e2=fac*bb_aq(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_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0) epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj) !d write (iout,'(2(a3,i3,2x),15(0pf7.3))') !d & restyp(itypi,1),i,restyp(itypj,1),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,subchap real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift real(kind=8) :: sss,e1,e2,evdw,sss_grad real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,& ssgradlipi,ssgradlipj 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,1) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1,1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) 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' ! do k=j+1,iend(i,iint) !C search over all next residues ! if (dyn_ss_mask(k)) then !C check if they are cysteins !C write(iout,*) 'k=',k !c write(iout,*) "PRZED TRI", evdwij ! evdwij_przed_tri=evdwij ! call triple_ssbond_ene(i,j,k,evdwij) !c if(evdwij_przed_tri.ne.evdwij) then !c write (iout,*) "TRI:", evdwij, evdwij_przed_tri !c endif !c write(iout,*) "PO TRI", evdwij !C call the energy function that removes the artifical triple disulfide !C bond the soubroutine is located in ssMD.F ! evdw=evdw+evdwij if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') & 'evdw',i,j,evdwij,'tss' ! endif!dyn_ss_mask(k) ! enddo! k ELSE !el ind=ind+1 itypj=itype(j,1) 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,1),itype(j,1) 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) yj=c(2,nres+j) zj=c(3,nres+j) ! Searching for nearest neighbour call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) 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))) sss_ele_cut=sscale_ele(1.0d0/(rij)) sss_ele_grad=sscagrad_ele(1.0d0/(rij)) sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj))) if (sss_ele_cut.le.0.0) cycle 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,1),i,restyp(itypj,1),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 e2=fac*bb 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)*sss_ele_cut if (lprn) then sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0) epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj) write (iout,'(2(a3,i3,2x),17(0pf7.3))') & restyp(itypi,1),i,restyp(itypj,1),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=fac+evdwij*(sss_ele_grad/sss_ele_cut& *rij-sss_grad/(1.0-sss)*rij & /sigmaii(itypi,itypj)) ! 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 !mask_dyn_ss 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,subchap real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,& ssgradlipi,ssgradlipj 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,1) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1,1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) 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) 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) 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' do k=j+1,iend(i,iint) !C search over all next residues if (dyn_ss_mask(k)) then !C check if they are cysteins !C write(iout,*) 'k=',k !c write(iout,*) "PRZED TRI", evdwij ! evdwij_przed_tri=evdwij call triple_ssbond_ene(i,j,k,evdwij) !c if(evdwij_przed_tri.ne.evdwij) then !c write (iout,*) "TRI:", evdwij, evdwij_przed_tri !c endif !c write(iout,*) "PO TRI", evdwij !C call the energy function that removes the artifical triple disulfide !C bond the soubroutine is located in ssMD.F evdw=evdw+evdwij if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') & 'evdw',i,j,evdwij,'tss' endif!dyn_ss_mask(k) enddo! k ELSE ! typj=itype(j,1) if (itypj.eq.ntyp1) cycle ! dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) dscj_inv=dsc_inv(itypj) ! write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, ! & 1.0d0/vbld(j+nres) ! write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1) 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 xj=c(1,nres+j) yj=c(2,nres+j) zj=c(3,nres+j) ! Searching for nearest neighbour call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) 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))) sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj))) sss_ele_cut=sscale_ele(1.0d0/(rij)) sss_ele_grad=sscagrad_ele(1.0d0/(rij)) if (sss_ele_cut.le.0.0) cycle 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,1),i,restyp(itypj,1),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 e2=fac*bb 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*sss_ele_cut if (lprn) then sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0) epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj) write (iout,'(2(a3,i3,2x),17(0pf7.3))') & restyp(itypi,1),i,restyp(itypj,1),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=fac+evdwij*(sss_ele_grad/sss_ele_cut& *rij+sss_grad/sss*rij & /sigmaii(itypi,itypj)) ! 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 ENDIF !mask_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_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,& sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb 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,1) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1,1) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) 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,1) 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 call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) 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_aq(itypi,itypj) e2=fac*bb_aq(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_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0) epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj) write (iout,'(2(a3,i3,2x),17(0pf7.3))') & restyp(itypi,1),i,restyp(itypj,1),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,& sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb 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,1) if (itypi.eq.ntyp1) cycle itypi1=itype(i+1,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) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) ! 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,1) 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 call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) 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_aq(itypi,itypj) e2=fac*bb_aq(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_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0) epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj) write (iout,'(2(a3,i3,2x),17(0pf7.3))') & restyp(itypi,1),i,restyp(itypj,1),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 ! print *, "before set matrices" call set_matrices ! print *,"after set martices" #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,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 & .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,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 call to_box(xmedi,ymedi,zmedi) call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi) 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,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 & .or. itype(i+3,1).eq.ntyp1 & .or. itype(i+4,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 call to_box(xmedi,ymedi,zmedi) call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi) 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,1).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,1).eq.ntyp1 .or. itype(i+1,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 call to_box(xmedi,ymedi,zmedi) call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi) ! 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,1).eq.ntyp1 .or. itype(j+1,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,xtemp 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 real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,sss_grad integer xshift,yshift,zshift !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,isubchap 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,faclipij,faclipij2 ! 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 xj=c(1,j)+0.5D0*dxj yj=c(2,j)+0.5D0*dyj zj=c(3,j)+0.5D0*dzj call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0 faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0 xj=boxshift(xj-xmedi,boxxsize) yj=boxshift(yj-ymedi,boxysize) zj=boxshift(zj-zmedi,boxzsize) 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)) sss_ele_cut=sscale_ele(rij) sss_ele_grad=sscagrad_ele(rij) sss_grad=sscale_grad((rij/rpp(iteli,itelj))) ! sss_ele_cut=1.0d0 ! sss_ele_grad=0.0d0 if (sss_ele_cut.le.0.0) go to 128 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*sss_ele_cut evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut !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)*sss_ele_cut facel=-3*rrmij*(el1+eesij)*sss_ele_cut 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+sss_ele_grad*rmij*eesij*xj ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*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+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss) & -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss) & -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss) & -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*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)*sss_ele_cut facel=(el1+eesij)*sss_ele_cut 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) )*sss_ele_cut 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)& *sss_ele_cut 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)& *sss_ele_cut 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,1)),j,itortyp(itype(j,1)),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 ! print *,"EELLOC",i,gel_loc_loc(i-1) 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*sss_ele_cut ! 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)) & *sss_ele_cut 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)) & *sss_ele_cut xtemp(1)=xj xtemp(2)=yj xtemp(3)=zj ! 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))& *sss_ele_cut & +eel_loc_ij*sss_ele_grad*rmij*xtemp(l) 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))& *sss_ele_cut 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))& *sss_ele_cut 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))& *sss_ele_cut 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))& *sss_ele_cut 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) & *sss_ele_cut ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) & *sss_ele_cut ! 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 gggp(1)=gggp(1)+ees0pijp*xj & +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad gggp(2)=gggp(2)+ees0pijp*yj & +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad gggp(3)=gggp(3)+ees0pijp*zj & +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad gggm(1)=gggm(1)+ees0mijp*xj & +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad gggm(2)=gggm(2)+ees0mijp*yj & +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad gggm(3)=gggm(3)+ees0mijp*zj & +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad ! 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) 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) & *sss_ele_cut 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)& *sss_ele_cut gacontp_hb3(k,num_conti,i)=gggp(k) & *sss_ele_cut 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) & *sss_ele_cut 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) & *sss_ele_cut gacontm_hb3(k,num_conti,i)=gggm(k) & *sss_ele_cut 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 128 continue ! 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,isubchap 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 real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,& sslipj,ssgradlipj,faclipij2 integer xshift,yshift,zshift 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,1).eq.ntyp1.or. itype(i+1,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 call to_box(xmedi,ymedi,zmedi) call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi) 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,1).eq.ntyp1 .or. itype(j+1,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 xj=c(1,j)+0.5D0*dxj yj=c(2,j)+0.5D0*dyj zj=c(3,j)+0.5D0*dzj call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0 xj=boxshift(xj-xmedi,boxxsize) yj=boxshift(yj-ymedi,boxysize) zj=boxshift(zj-zmedi,boxzsize) rij=xj*xj+yj*yj+zj*zj rrmij=1.0D0/rij rij=dsqrt(rij) sss=sscale(rij/rpp(iteli,itelj)) sss_ele_cut=sscale_ele(rij) sss_ele_grad=sscagrad_ele(rij) sss_grad=sscale_grad((rij/rpp(iteli,itelj))) if (sss_ele_cut.le.0.0) cycle 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*sss_ele_cut ! ! Calculate contributions to the Cartesian gradient. ! facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut ! ggg(1)=facvdw*xj ! ggg(2)=facvdw*yj ! ggg(3)=facvdw*zj ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss & +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss & +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss & +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*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,subchap real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij real(kind=8) :: evdw2,evdw2_14,evdwij real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init 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,1).eq.ntyp1 .or. itype(i+1,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)) call to_box(xi,yi,zi) do iint=1,nscp_gr(i) do j=iscpstart(i,iint),iscpend(i,iint) itypj=itype(j,1) 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) yj=c(2,j) zj=c(3,j) call to_box(xj,yj,zj) xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(1.0d0/rrij) sss_ele_cut=sscale_ele(rij) sss_ele_grad=sscagrad_ele(rij) ! print *,sss_ele_cut,sss_ele_grad,& ! (rij),r_cut_ele,rlamb_ele if (sss_ele_cut.le.0.0) cycle sss=sscale((rij/rscp(itypj,iteli))) sss_grad=sscale_grad(rij/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)*sss_ele_cut endif evdwij=e1+e2 evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut 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)*sss_ele_cut fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)& -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli) 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,subchap real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij real(kind=8) :: evdw2,evdw2_14,evdwij real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init 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,1).eq.ntyp1 .or. itype(i+1,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)) call to_box(xi,yi,zi) if (zi.lt.0) zi=zi+boxzsize do iint=1,nscp_gr(i) do j=iscpstart(i,iint),iscpend(i,iint) itypj=itype(j,1) 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 xj=c(1,j) yj=c(2,j) zj=c(3,j) call to_box(xj,yj,zj) xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(1.0d0/rrij) sss_ele_cut=sscale_ele(rij) sss_ele_grad=sscagrad_ele(rij) ! print *,sss_ele_cut,sss_ele_grad,& ! (rij),r_cut_ele,rlamb_ele if (sss_ele_cut.le.0.0) cycle sss=sscale(rij/rscp(itypj,iteli)) sss_grad=sscale_grad(rij/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*sss_ele_cut endif evdwij=e1+e2 evdw2=evdw2+evdwij*sss*sss_ele_cut 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*sss_ele_cut fac=fac+evdwij*sss_ele_grad/rij/expon*sss & +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli) 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& *sss_ele_cut 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& *sss_ele_cut 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& *sss_ele_cut ! 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,usampl,eq_time #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,ethetacnstr 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. ! ! Calculate the SC local energy. ! call vec_and_deriv call esc(escloc) ! if (wang.gt.0d0) then if (tor_mode.eq.0) then call ebend(ebe) else !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the !C energy function call ebend_kcc(ebe) endif else ebe=0.0d0 endif ethetacnstr=0.0d0 if (with_theta_constr) call etheta_constr(ethetacnstr) ! write(iout,*) "in etotal afer ebe",ipot ! 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 if (wtor.gt.0.0d0) then if (tor_mode.eq.0) then call etor(etors) else !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the !C energy function call etor_kcc(etors) endif else etors=0.0d0 endif edihcnstr=0.0d0 if (ndih_constr.gt.0) call etor_constr(edihcnstr) ! Calculate the virtual-bond torsional energy. ! ! ! 6/23/01 Calculate double-torsional energy ! if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then call etor_d(etors_d) endif ! ! 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 rlornmr1(y,ymin,ymax,sigma) real(kind=8) y,ymin,ymax,sigma real(kind=8) wykl /4.0d0/ if (y.lt.ymin) then rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl) else if (y.gt.ymax) then rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl) else rlornmr1=0.0d0 endif return end function rlornmr1 !------------------------------------------------------------------------------ real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma) real(kind=8) y,ymin,ymax,sigma real(kind=8) wykl /4.0d0/ if (y.lt.ymin) then rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ & ((ymin-y)**wykl+sigma**wykl)**2 else if (y.gt.ymax) then rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ & ((y-ymax)**wykl+sigma**wykl)**2 else rlornmr1prim=0.0d0 endif return end function rlornmr1prim 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,1).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,usampl,eq_time #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 real(kind=8) :: time00,time01 ! This subrouting calculates total Cartesian coordinate gradient. ! The subroutine chainbuild_cart and energy MUST be called beforehand. ! !#define DEBUG #ifdef TIMINGtime01 time00=MPI_Wtime() #endif icg=1 call sum_gradient #ifdef TIMING #endif !#define DEBUG !el write (iout,*) "After sum_gradient" #ifdef DEBUG 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 !#undef DEBUG ! 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' !#define DEBUG #ifdef DEBUG write (iout,*) "gcart, gxcart, gloc before int_to_cart" #endif do i=0,nct do j=1,3 gcart(j,i)=gradc(j,i,icg) gxcart(j,i)=gradx(j,i,icg) ! if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(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 ! print *,"gcart_two",gxcart(2,2),gradx(2,2,icg) call int_to_cart ! print *,"gcart_two",gxcart(2,2),gradx(2,2,icg) #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 !#undef DEBUG #ifdef CARGRAD #ifdef DEBUG write (iout,*) "CARGRAD" #endif do i=nres,0,-1 do j=1,3 gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i) ! gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i) enddo ! write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), & ! (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3) enddo ! Correction: dummy residues if (nnt.gt.1) then do j=1,3 ! gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1) gcart(j,nnt)=gcart(j,nnt)+gcart(j,1) enddo endif if (nct.lt.nres) then do j=1,3 ! gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres) gcart(j,nct)=gcart(j,nct)+gcart(j,nres) enddo endif #endif #ifdef TIMING time_cartgrad=time_cartgrad+MPI_Wtime()-time00 #endif !#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,k ! 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 gliptran(j,i)=0.0d0 gliptranx(j,i)=0.0d0 gliptranc(j,i)=0.0d0 gshieldx(j,i)=0.0d0 gshieldc(j,i)=0.0d0 gshieldc_loc(j,i)=0.0d0 gshieldx_ec(j,i)=0.0d0 gshieldc_ec(j,i)=0.0d0 gshieldc_loc_ec(j,i)=0.0d0 gshieldx_t3(j,i)=0.0d0 gshieldc_t3(j,i)=0.0d0 gshieldc_loc_t3(j,i)=0.0d0 gshieldx_t4(j,i)=0.0d0 gshieldc_t4(j,i)=0.0d0 gshieldc_loc_t4(j,i)=0.0d0 gshieldx_ll(j,i)=0.0d0 gshieldc_ll(j,i)=0.0d0 gshieldc_loc_ll(j,i)=0.0d0 gg_tube(j,i)=0.0d0 gg_tube_sc(j,i)=0.0d0 gradafm(j,i)=0.0d0 gradb_nucl(j,i)=0.0d0 gradbx_nucl(j,i)=0.0d0 gvdwpp_nucl(j,i)=0.0d0 gvdwpp(j,i)=0.0d0 gelpp(j,i)=0.0d0 gvdwpsb(j,i)=0.0d0 gvdwpsb1(j,i)=0.0d0 gvdwsbc(j,i)=0.0d0 gvdwsbx(j,i)=0.0d0 gelsbc(j,i)=0.0d0 gradcorr_nucl(j,i)=0.0d0 gradcorr3_nucl(j,i)=0.0d0 gradxorr_nucl(j,i)=0.0d0 gradxorr3_nucl(j,i)=0.0d0 gelsbx(j,i)=0.0d0 gsbloc(j,i)=0.0d0 gsblocx(j,i)=0.0d0 gradpepcat(j,i)=0.0d0 gradpepcatx(j,i)=0.0d0 gradcatcat(j,i)=0.0d0 gvdwx_scbase(j,i)=0.0d0 gvdwc_scbase(j,i)=0.0d0 gvdwx_pepbase(j,i)=0.0d0 gvdwc_pepbase(j,i)=0.0d0 gvdwx_scpho(j,i)=0.0d0 gvdwc_scpho(j,i)=0.0d0 gvdwc_peppho(j,i)=0.0d0 gradnuclcatx(j,i)=0.0d0 gradnuclcat(j,i)=0.0d0 enddo enddo do i=0,nres do j=1,3 do intertyp=1,3 gloc_sc(intertyp,i,icg)=0.0d0 enddo enddo enddo do i=1,nres do j=1,maxcontsshi shield_list(j,i)=0 do k=1,3 !C print *,i,j,k grad_shield_side(k,j,i)=0.0d0 grad_shield_loc(k,j,i)=0.0d0 enddo enddo ishield_list(i)=0 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,IERROR 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 dcosomicron(j,1,1,i)=0.0d0 dcosomicron(j,1,2,i)=0.0d0 dcosomicron(j,2,1,i)=0.0d0 dcosomicron(j,2,2,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,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,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,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ne.5) 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.0/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.0/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.0/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,1),vbld(i-1+nres) domicron(j,2,2,i)=-1.0/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,1).eq.21 .or. itype(i-2,1).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).ge.-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,1).ne.ntyp1 .and. itype(i-2,1).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,1).ne.ntyp1 .and. itype(i-2,1).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.0/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.0/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.0/sing*dcosphi(j,3,i) !#define DEBUG #ifdef DEBUG write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i) #endif !#undef DEBUG 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,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle ! if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or. ! & (itype(i-1,1).eq.ntyp1).or.(itype(i,1).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,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. & (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).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,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. & (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).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,1).ne.10 .and. itype(i,1).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) !#define DEBUG #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 !#undef DEBUG 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 !#define DEBUG #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 !#undef DEBUG 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,1).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,1).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,1).ne.10 .or. itype(jl,1).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,1).ne.10 .or. itype(jl,1).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,1).ne.10 .or. itype(jl,1).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,1).ne.10 .or. itype(jl,1).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,1) 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,1) 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_aq(itypi,itypj) ljA=ljA*aa_aq(itypi,itypj) ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(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_aq(itypi,itypj)/aa_aq(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_aq(itypi,itypj) e2=fac*bb_aq(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_aq(itypi,itypj)/aa_aq(itypi,itypj) d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(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 !-------------------------------------------------------------------------- subroutine triple_ssbond_ene(resi,resj,resk,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 double precision h_base external h_base !c Input arguments integer resi,resj,resk,m,itypi,itypj,itypk !c Output arguments double precision eij,eij1,eij2,eij3 !c Local variables logical havebond !c integer itypi,itypj,k,l double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk double precision sig0ij,ljd,sig,fac,e1,e2 double precision dcosom1(3),dcosom2(3),ed double precision pom1,pom2 double precision ljA,ljB,ljXs double precision d_ljB(1:3) double precision ssA,ssB,ssC,ssXs double precision ssxm,ljxm,ssm,ljm double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3) eij=0.0 if (dtriss.eq.0) return i=resi j=resj k=resk !C write(iout,*) resi,resj,resk itypi=itype(i,1) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) dsci_inv=vbld_inv(i+nres) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) itypj=itype(j,1) xj=c(1,nres+j) yj=c(2,nres+j) zj=c(3,nres+j) call to_box(xj,yj,zj) dxj=dc_norm(1,nres+j) dyj=dc_norm(2,nres+j) dzj=dc_norm(3,nres+j) dscj_inv=vbld_inv(j+nres) itypk=itype(k,1) xk=c(1,nres+k) yk=c(2,nres+k) zk=c(3,nres+k) call to_box(xk,yk,zk) dxk=dc_norm(1,nres+k) dyk=dc_norm(2,nres+k) dzk=dc_norm(3,nres+k) dscj_inv=vbld_inv(k+nres) xij=xj-xi xik=xk-xi xjk=xk-xj yij=yj-yi yik=yk-yi yjk=yk-yj zij=zj-zi zik=zk-zi zjk=zk-zj rrij=(xij*xij+yij*yij+zij*zij) rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse rrik=(xik*xik+yik*yik+zik*zik) rik=dsqrt(rrik) rrjk=(xjk*xjk+yjk*yjk+zjk*zjk) rjk=dsqrt(rrjk) !C there are three combination of distances for each trisulfide bonds !C The first case the ith atom is the center !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first !C distance y is second distance the a,b,c,d are parameters derived for !C this problem d parameter was set as a penalty currenlty set to 1. if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then eij1=0.0d0 else eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss) endif !C second case jth atom is center if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then eij2=0.0d0 else eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss) endif !C the third case kth atom is the center if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then eij3=0.0d0 else eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss) endif !C eij2=0.0 !C eij3=0.0 !C eij1=0.0 eij=eij1+eij2+eij3 !C write(iout,*)i,j,k,eij !C The energy penalty calculated now time for the gradient part !C derivative over rij fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) & -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5) gg(1)=xij*fac/rij gg(2)=yij*fac/rij gg(3)=zij*fac/rij do m=1,3 gvdwx(m,i)=gvdwx(m,i)-gg(m) gvdwx(m,j)=gvdwx(m,j)+gg(m) enddo do l=1,3 gvdwc(l,i)=gvdwc(l,i)-gg(l) gvdwc(l,j)=gvdwc(l,j)+gg(l) enddo !C now derivative over rik fac=-eij1**2/dtriss* & (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) & -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5) gg(1)=xik*fac/rik gg(2)=yik*fac/rik gg(3)=zik*fac/rik do m=1,3 gvdwx(m,i)=gvdwx(m,i)-gg(m) gvdwx(m,k)=gvdwx(m,k)+gg(m) enddo do l=1,3 gvdwc(l,i)=gvdwc(l,i)-gg(l) gvdwc(l,k)=gvdwc(l,k)+gg(l) enddo !C now derivative over rjk fac=-eij2**2/dtriss* & (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- & eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5) gg(1)=xjk*fac/rjk gg(2)=yjk*fac/rjk gg(3)=zjk*fac/rjk do m=1,3 gvdwx(m,j)=gvdwx(m,j)-gg(m) gvdwx(m,k)=gvdwx(m,k)+gg(m) enddo do l=1,3 gvdwc(l,j)=gvdwc(l,j)-gg(l) gvdwc(l,k)=gvdwc(l,k)+gg(l) enddo return end subroutine triple_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) ! print *,newnss,nss,maxdim do i=1,nss found=.false. ! print *,newnss do j=1,newnss !! print *,j if (idssb(i).eq.newihpb(j) .and. & jdssb(i).eq.newjhpb(j)) found=.true. enddo #ifndef CLUST #ifndef WHAM ! write(iout,*) "found",found,i,j 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 ! print *,i,j if (newihpb(i).eq.idssb(j) .and. & newjhpb(i).eq.jdssb(j)) found=.true. enddo #ifndef CLUST #ifndef WHAM ! write(iout,*) "found",found,i,j 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 ! Lipid transfer energy function subroutine Eliptransfer(eliptran) !C this is done by Adasko !C print *,"wchodze" !C structure of box: !C water !C--bordliptop-- buffore starts !C--bufliptop--- here true lipid starts !C lipid !C--buflipbot--- lipid ends buffore starts !C--bordlipbot--buffore ends real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip integer :: i eliptran=0.0 ! print *, "I am in eliptran" do i=ilip_start,ilip_end !C do i=1,1 if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))& cycle positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize)) if (positi.le.0.0) positi=positi+boxzsize !C print *,i !C first for peptide groups !c for each residue check if it is in lipid or lipid water border area if ((positi.gt.bordlipbot) & .and.(positi.lt.bordliptop)) then !C the energy transfer exist if (positi.lt.buflipbot) then !C what fraction I am in fracinbuf=1.0d0- & ((positi-bordlipbot)/lipbufthick) !C lipbufthick is thickenes of lipid buffore sslip=sscalelip(fracinbuf) ssgradlip=-sscagradlip(fracinbuf)/lipbufthick eliptran=eliptran+sslip*pepliptran gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 !C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran !C print *,"doing sccale for lower part" !C print *,i,sslip,fracinbuf,ssgradlip elseif (positi.gt.bufliptop) then fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) sslip=sscalelip(fracinbuf) ssgradlip=sscagradlip(fracinbuf)/lipbufthick eliptran=eliptran+sslip*pepliptran gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 !C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran !C print *, "doing sscalefor top part" !C print *,i,sslip,fracinbuf,ssgradlip else eliptran=eliptran+pepliptran !C print *,"I am in true lipid" endif !C else !C eliptran=elpitran+0.0 ! I am in water endif if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip enddo ! here starts the side chain transfer do i=ilip_start,ilip_end if (itype(i,1).eq.ntyp1) cycle positi=(mod(c(3,i+nres),boxzsize)) if (positi.le.0) positi=positi+boxzsize !C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop !c for each residue check if it is in lipid or lipid water border area !C respos=mod(c(3,i+nres),boxzsize) !C print *,positi,bordlipbot,buflipbot if ((positi.gt.bordlipbot) & .and.(positi.lt.bordliptop)) then !C the energy transfer exist if (positi.lt.buflipbot) then fracinbuf=1.0d0- & ((positi-bordlipbot)/lipbufthick) !C lipbufthick is thickenes of lipid buffore sslip=sscalelip(fracinbuf) ssgradlip=-sscagradlip(fracinbuf)/lipbufthick eliptran=eliptran+sslip*liptranene(itype(i,1)) gliptranx(3,i)=gliptranx(3,i) & +ssgradlip*liptranene(itype(i,1)) gliptranc(3,i-1)= gliptranc(3,i-1) & +ssgradlip*liptranene(itype(i,1)) !C print *,"doing sccale for lower part" elseif (positi.gt.bufliptop) then fracinbuf=1.0d0- & ((bordliptop-positi)/lipbufthick) sslip=sscalelip(fracinbuf) ssgradlip=sscagradlip(fracinbuf)/lipbufthick eliptran=eliptran+sslip*liptranene(itype(i,1)) gliptranx(3,i)=gliptranx(3,i) & +ssgradlip*liptranene(itype(i,1)) gliptranc(3,i-1)= gliptranc(3,i-1) & +ssgradlip*liptranene(itype(i,1)) !C print *, "doing sscalefor top part",sslip,fracinbuf else eliptran=eliptran+liptranene(itype(i,1)) !C print *,"I am in true lipid" endif endif ! if in lipid or buffor !C else !C eliptran=elpitran+0.0 ! I am in water if (energy_dec) write(iout,*) i,"eliptran=",eliptran enddo return end subroutine Eliptransfer !----------------------------------NANO FUNCTIONS !C----------------------------------------------------------------------- !C----------------------------------------------------------- !C This subroutine is to mimic the histone like structure but as well can be !C utilizet to nanostructures (infinit) small modification has to be used to !C make it finite (z gradient at the ends has to be changes as well as the x,y !C gradient has to be modified at the ends !C The energy function is Kihara potential !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6) !C 4eps is depth of well sigma is r_minimum r is distance from center of tube !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a !C simple Kihara potential subroutine calctube(Etube) real(kind=8),dimension(3) :: vectube real(kind=8) :: Etube,xtemp,xminact,yminact,& ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, & sc_aa_tube,sc_bb_tube integer :: i,j,iti Etube=0.0d0 do i=itube_start,itube_end enetube(i)=0.0d0 enetube(i+nres)=0.0d0 enddo !C first we calculate the distance from tube center !C for UNRES do i=itube_start,itube_end !C lets ommit dummy atoms for now if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle !C now calculate distance from center of tube and direction vectors xmin=boxxsize ymin=boxysize ! Find minimum distance in periodic box do j=-1,1 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize) vectube(1)=vectube(1)+boxxsize*j vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize) vectube(2)=vectube(2)+boxysize*j xminact=abs(vectube(1)-tubecenter(1)) yminact=abs(vectube(2)-tubecenter(2)) if (xmin.gt.xminact) then xmin=xminact xtemp=vectube(1) endif if (ymin.gt.yminact) then ymin=yminact ytemp=vectube(2) endif enddo vectube(1)=xtemp vectube(2)=ytemp vectube(1)=vectube(1)-tubecenter(1) vectube(2)=vectube(2)-tubecenter(2) !C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1) !C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2) !C as the tube is infinity we do not calculate the Z-vector use of Z !C as chosen axis vectube(3)=0.0d0 !C now calculte the distance tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2) !C now normalize vector vectube(1)=vectube(1)/tub_r vectube(2)=vectube(2)/tub_r !C calculte rdiffrence between r and r0 rdiff=tub_r-tubeR0 !C and its 6 power rdiff6=rdiff**6.0d0 !C for vectorization reasons we will sumup at the end to avoid depenence of previous enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6 !C write(iout,*) "TU13",i,rdiff6,enetube(i) !C print *,rdiff,rdiff6,pep_aa_tube !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6 !C now we calculate gradient fac=(-12.0d0*pep_aa_tube/rdiff6- & 6.0d0*pep_bb_tube)/rdiff6/rdiff !C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i), !C &rdiff,fac !C now direction of gg_tube vector do j=1,3 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0 enddo enddo !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END) !C print *,gg_tube(1,0),"TU" do i=itube_start,itube_end !C Lets not jump over memory as we use many times iti iti=itype(i,1) !C lets ommit dummy atoms for now if ((iti.eq.ntyp1) & !C in UNRES uncomment the line below as GLY has no side-chain... !C .or.(iti.eq.10) ) cycle xmin=boxxsize ymin=boxysize do j=-1,1 vectube(1)=mod((c(1,i+nres)),boxxsize) vectube(1)=vectube(1)+boxxsize*j vectube(2)=mod((c(2,i+nres)),boxysize) vectube(2)=vectube(2)+boxysize*j xminact=abs(vectube(1)-tubecenter(1)) yminact=abs(vectube(2)-tubecenter(2)) if (xmin.gt.xminact) then xmin=xminact xtemp=vectube(1) endif if (ymin.gt.yminact) then ymin=yminact ytemp=vectube(2) endif enddo vectube(1)=xtemp vectube(2)=ytemp !C write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2), !C & tubecenter(2) vectube(1)=vectube(1)-tubecenter(1) vectube(2)=vectube(2)-tubecenter(2) !C as the tube is infinity we do not calculate the Z-vector use of Z !C as chosen axis vectube(3)=0.0d0 !C now calculte the distance tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2) !C now normalize vector vectube(1)=vectube(1)/tub_r vectube(2)=vectube(2)/tub_r !C calculte rdiffrence between r and r0 rdiff=tub_r-tubeR0 !C and its 6 power rdiff6=rdiff**6.0d0 !C for vectorization reasons we will sumup at the end to avoid depenence of previous sc_aa_tube=sc_aa_tube_par(iti) sc_bb_tube=sc_bb_tube_par(iti) enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- & 6.0d0*sc_bb_tube/rdiff6/rdiff !C now direction of gg_tube vector do j=1,3 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac enddo enddo do i=itube_start,itube_end Etube=Etube+enetube(i)+enetube(i+nres) enddo !C print *,"ETUBE", etube return end subroutine calctube !C TO DO 1) add to total energy !C 2) add to gradient summation !C 3) add reading parameters (AND of course oppening of PARAM file) !C 4) add reading the center of tube !C 5) add COMMONs !C 6) add to zerograd !C 7) allocate matrices !C----------------------------------------------------------------------- !C----------------------------------------------------------- !C This subroutine is to mimic the histone like structure but as well can be !C utilizet to nanostructures (infinit) small modification has to be used to !C make it finite (z gradient at the ends has to be changes as well as the x,y !C gradient has to be modified at the ends !C The energy function is Kihara potential !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6) !C 4eps is depth of well sigma is r_minimum r is distance from center of tube !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a !C simple Kihara potential subroutine calctube2(Etube) real(kind=8),dimension(3) :: vectube real(kind=8) :: Etube,xtemp,xminact,yminact,& ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,& sstube,ssgradtube,sc_aa_tube,sc_bb_tube integer:: i,j,iti Etube=0.0d0 do i=itube_start,itube_end enetube(i)=0.0d0 enetube(i+nres)=0.0d0 enddo !C first we calculate the distance from tube center !C first sugare-phosphate group for NARES this would be peptide group !C for UNRES do i=itube_start,itube_end !C lets ommit dummy atoms for now if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle !C now calculate distance from center of tube and direction vectors !C vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize) !C if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize !C vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize) !C if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize xmin=boxxsize ymin=boxysize do j=-1,1 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize) vectube(1)=vectube(1)+boxxsize*j vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize) vectube(2)=vectube(2)+boxysize*j xminact=abs(vectube(1)-tubecenter(1)) yminact=abs(vectube(2)-tubecenter(2)) if (xmin.gt.xminact) then xmin=xminact xtemp=vectube(1) endif if (ymin.gt.yminact) then ymin=yminact ytemp=vectube(2) endif enddo vectube(1)=xtemp vectube(2)=ytemp vectube(1)=vectube(1)-tubecenter(1) vectube(2)=vectube(2)-tubecenter(2) !C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1) !C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2) !C as the tube is infinity we do not calculate the Z-vector use of Z !C as chosen axis vectube(3)=0.0d0 !C now calculte the distance tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2) !C now normalize vector vectube(1)=vectube(1)/tub_r vectube(2)=vectube(2)/tub_r !C calculte rdiffrence between r and r0 rdiff=tub_r-tubeR0 !C and its 6 power rdiff6=rdiff**6.0d0 !C THIS FRAGMENT MAKES TUBE FINITE positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize) if (positi.le.0) positi=positi+boxzsize !C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop !c for each residue check if it is in lipid or lipid water border area !C respos=mod(c(3,i+nres),boxzsize) !C print *,positi,bordtubebot,buftubebot,bordtubetop if ((positi.gt.bordtubebot) & .and.(positi.lt.bordtubetop)) then !C the energy transfer exist if (positi.lt.buftubebot) then fracinbuf=1.0d0- & ((positi-bordtubebot)/tubebufthick) !C lipbufthick is thickenes of lipid buffore sstube=sscalelip(fracinbuf) ssgradtube=-sscagradlip(fracinbuf)/tubebufthick !C print *,ssgradtube, sstube,tubetranene(itype(i,1)) enetube(i)=enetube(i)+sstube*tubetranenepep !C gg_tube_SC(3,i)=gg_tube_SC(3,i) !C &+ssgradtube*tubetranene(itype(i,1)) !C gg_tube(3,i-1)= gg_tube(3,i-1) !C &+ssgradtube*tubetranene(itype(i,1)) !C print *,"doing sccale for lower part" elseif (positi.gt.buftubetop) then fracinbuf=1.0d0- & ((bordtubetop-positi)/tubebufthick) sstube=sscalelip(fracinbuf) ssgradtube=sscagradlip(fracinbuf)/tubebufthick enetube(i)=enetube(i)+sstube*tubetranenepep !C gg_tube_SC(3,i)=gg_tube_SC(3,i) !C &+ssgradtube*tubetranene(itype(i,1)) !C gg_tube(3,i-1)= gg_tube(3,i-1) !C &+ssgradtube*tubetranene(itype(i,1)) !C print *, "doing sscalefor top part",sslip,fracinbuf else sstube=1.0d0 ssgradtube=0.0d0 enetube(i)=enetube(i)+sstube*tubetranenepep !C print *,"I am in true lipid" endif else !C sstube=0.0d0 !C ssgradtube=0.0d0 cycle endif ! if in lipid or buffor !C for vectorization reasons we will sumup at the end to avoid depenence of previous enetube(i)=enetube(i)+sstube* & (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6) !C write(iout,*) "TU13",i,rdiff6,enetube(i) !C print *,rdiff,rdiff6,pep_aa_tube !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6 !C now we calculate gradient fac=(-12.0d0*pep_aa_tube/rdiff6- & 6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube !C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i), !C &rdiff,fac !C now direction of gg_tube vector do j=1,3 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0 enddo gg_tube(3,i)=gg_tube(3,i) & +ssgradtube*enetube(i)/sstube/2.0d0 gg_tube(3,i-1)= gg_tube(3,i-1) & +ssgradtube*enetube(i)/sstube/2.0d0 enddo !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END) !C print *,gg_tube(1,0),"TU" do i=itube_start,itube_end !C Lets not jump over memory as we use many times iti iti=itype(i,1) !C lets ommit dummy atoms for now if ((iti.eq.ntyp1) & !!C in UNRES uncomment the line below as GLY has no side-chain... .or.(iti.eq.10) & ) cycle vectube(1)=c(1,i+nres) vectube(1)=mod(vectube(1),boxxsize) if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize vectube(2)=c(2,i+nres) vectube(2)=mod(vectube(2),boxysize) if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize vectube(1)=vectube(1)-tubecenter(1) vectube(2)=vectube(2)-tubecenter(2) !C THIS FRAGMENT MAKES TUBE FINITE positi=(mod(c(3,i+nres),boxzsize)) if (positi.le.0) positi=positi+boxzsize !C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop !c for each residue check if it is in lipid or lipid water border area !C respos=mod(c(3,i+nres),boxzsize) !C print *,positi,bordtubebot,buftubebot,bordtubetop if ((positi.gt.bordtubebot) & .and.(positi.lt.bordtubetop)) then !C the energy transfer exist if (positi.lt.buftubebot) then fracinbuf=1.0d0- & ((positi-bordtubebot)/tubebufthick) !C lipbufthick is thickenes of lipid buffore sstube=sscalelip(fracinbuf) ssgradtube=-sscagradlip(fracinbuf)/tubebufthick !C print *,ssgradtube, sstube,tubetranene(itype(i,1)) enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1)) !C gg_tube_SC(3,i)=gg_tube_SC(3,i) !C &+ssgradtube*tubetranene(itype(i,1)) !C gg_tube(3,i-1)= gg_tube(3,i-1) !C &+ssgradtube*tubetranene(itype(i,1)) !C print *,"doing sccale for lower part" elseif (positi.gt.buftubetop) then fracinbuf=1.0d0- & ((bordtubetop-positi)/tubebufthick) sstube=sscalelip(fracinbuf) ssgradtube=sscagradlip(fracinbuf)/tubebufthick enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1)) !C gg_tube_SC(3,i)=gg_tube_SC(3,i) !C &+ssgradtube*tubetranene(itype(i,1)) !C gg_tube(3,i-1)= gg_tube(3,i-1) !C &+ssgradtube*tubetranene(itype(i,1)) !C print *, "doing sscalefor top part",sslip,fracinbuf else sstube=1.0d0 ssgradtube=0.0d0 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1)) !C print *,"I am in true lipid" endif else !C sstube=0.0d0 !C ssgradtube=0.0d0 cycle endif ! if in lipid or buffor !CEND OF FINITE FRAGMENT !C as the tube is infinity we do not calculate the Z-vector use of Z !C as chosen axis vectube(3)=0.0d0 !C now calculte the distance tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2) !C now normalize vector vectube(1)=vectube(1)/tub_r vectube(2)=vectube(2)/tub_r !C calculte rdiffrence between r and r0 rdiff=tub_r-tubeR0 !C and its 6 power rdiff6=rdiff**6.0d0 !C for vectorization reasons we will sumup at the end to avoid depenence of previous sc_aa_tube=sc_aa_tube_par(iti) sc_bb_tube=sc_bb_tube_par(iti) enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)& *sstube+enetube(i+nres) !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6 !C now we calculate gradient fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-& 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube !C now direction of gg_tube vector do j=1,3 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac enddo gg_tube_SC(3,i)=gg_tube_SC(3,i) & +ssgradtube*enetube(i+nres)/sstube gg_tube(3,i-1)= gg_tube(3,i-1) & +ssgradtube*enetube(i+nres)/sstube enddo do i=itube_start,itube_end Etube=Etube+enetube(i)+enetube(i+nres) enddo !C print *,"ETUBE", etube return end subroutine calctube2 !===================================================================================================================================== subroutine calcnano(Etube) real(kind=8),dimension(3) :: vectube real(kind=8) :: Etube,xtemp,xminact,yminact,& ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,& sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact integer:: i,j,iti,r Etube=0.0d0 ! print *,itube_start,itube_end,"poczatek" do i=itube_start,itube_end enetube(i)=0.0d0 enetube(i+nres)=0.0d0 enddo !C first we calculate the distance from tube center !C first sugare-phosphate group for NARES this would be peptide group !C for UNRES do i=itube_start,itube_end !C lets ommit dummy atoms for now if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle !C now calculate distance from center of tube and direction vectors xmin=boxxsize ymin=boxysize zmin=boxzsize do j=-1,1 vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize) vectube(1)=vectube(1)+boxxsize*j vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize) vectube(2)=vectube(2)+boxysize*j vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize) vectube(3)=vectube(3)+boxzsize*j xminact=dabs(vectube(1)-tubecenter(1)) yminact=dabs(vectube(2)-tubecenter(2)) zminact=dabs(vectube(3)-tubecenter(3)) if (xmin.gt.xminact) then xmin=xminact xtemp=vectube(1) endif if (ymin.gt.yminact) then ymin=yminact ytemp=vectube(2) endif if (zmin.gt.zminact) then zmin=zminact ztemp=vectube(3) endif enddo vectube(1)=xtemp vectube(2)=ytemp vectube(3)=ztemp vectube(1)=vectube(1)-tubecenter(1) vectube(2)=vectube(2)-tubecenter(2) vectube(3)=vectube(3)-tubecenter(3) !C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1) !C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2) !C as the tube is infinity we do not calculate the Z-vector use of Z !C as chosen axis !C vectube(3)=0.0d0 !C now calculte the distance tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2) !C now normalize vector vectube(1)=vectube(1)/tub_r vectube(2)=vectube(2)/tub_r vectube(3)=vectube(3)/tub_r !C calculte rdiffrence between r and r0 rdiff=tub_r-tubeR0 !C and its 6 power rdiff6=rdiff**6.0d0 !C for vectorization reasons we will sumup at the end to avoid depenence of previous enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6 !C write(iout,*) "TU13",i,rdiff6,enetube(i) !C print *,rdiff,rdiff6,pep_aa_tube !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6 !C now we calculate gradient fac=(-12.0d0*pep_aa_tube/rdiff6- & 6.0d0*pep_bb_tube)/rdiff6/rdiff !C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i), !C &rdiff,fac if (acavtubpep.eq.0.0d0) then !C go to 667 enecavtube(i)=0.0 faccav=0.0 else denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6) enecavtube(i)= & (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) & /denominator enecavtube(i)=0.0 faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) & *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff) & +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0) & /denominator**2.0d0 !C faccav=0.0 !C fac=fac+faccav !C 667 continue endif if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i) do j=1,3 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0 enddo enddo do i=itube_start,itube_end enecavtube(i)=0.0d0 !C Lets not jump over memory as we use many times iti iti=itype(i,1) !C lets ommit dummy atoms for now if ((iti.eq.ntyp1) & !C in UNRES uncomment the line below as GLY has no side-chain... !C .or.(iti.eq.10) ) cycle xmin=boxxsize ymin=boxysize zmin=boxzsize do j=-1,1 vectube(1)=dmod((c(1,i+nres)),boxxsize) vectube(1)=vectube(1)+boxxsize*j vectube(2)=dmod((c(2,i+nres)),boxysize) vectube(2)=vectube(2)+boxysize*j vectube(3)=dmod((c(3,i+nres)),boxzsize) vectube(3)=vectube(3)+boxzsize*j xminact=dabs(vectube(1)-tubecenter(1)) yminact=dabs(vectube(2)-tubecenter(2)) zminact=dabs(vectube(3)-tubecenter(3)) if (xmin.gt.xminact) then xmin=xminact xtemp=vectube(1) endif if (ymin.gt.yminact) then ymin=yminact ytemp=vectube(2) endif if (zmin.gt.zminact) then zmin=zminact ztemp=vectube(3) endif enddo vectube(1)=xtemp vectube(2)=ytemp vectube(3)=ztemp !C write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2), !C & tubecenter(2) vectube(1)=vectube(1)-tubecenter(1) vectube(2)=vectube(2)-tubecenter(2) vectube(3)=vectube(3)-tubecenter(3) !C now calculte the distance tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2) !C now normalize vector vectube(1)=vectube(1)/tub_r vectube(2)=vectube(2)/tub_r vectube(3)=vectube(3)/tub_r !C calculte rdiffrence between r and r0 rdiff=tub_r-tubeR0 !C and its 6 power rdiff6=rdiff**6.0d0 sc_aa_tube=sc_aa_tube_par(iti) sc_bb_tube=sc_bb_tube_par(iti) enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6 !C enetube(i+nres)=0.0d0 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6 !C now we calculate gradient fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- & 6.0d0*sc_bb_tube/rdiff6/rdiff !C fac=0.0 !C now direction of gg_tube vector !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12) if (acavtub(iti).eq.0.0d0) then !C go to 667 enecavtube(i+nres)=0.0d0 faccav=0.0d0 else denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6) enecavtube(i+nres)= & (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) & /denominator !C enecavtube(i)=0.0 faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) & *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff) & +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0) & /denominator**2.0d0 !C faccav=0.0 fac=fac+faccav !C 667 continue endif !C print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator, !C & enecavtube(i),faccav !C print *,"licz=", !C & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti)) !C print *,"finene=",enetube(i+nres)+enecavtube(i) do j=1,3 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac enddo if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres) enddo do i=itube_start,itube_end Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) & +enecavtube(i+nres) enddo ! do i=1,20 ! print *,"begin", i,"a" ! do r=1,10000 ! rdiff=r/100.0d0 ! rdiff6=rdiff**6.0d0 ! sc_aa_tube=sc_aa_tube_par(i) ! sc_bb_tube=sc_bb_tube_par(i) ! enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6 ! denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6) ! enecavtube(i)= & ! (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) & ! /denominator ! print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i) ! enddo ! print *,"end",i,"a" ! enddo !C print *,"ETUBE", etube return end subroutine calcnano !=============================================== !-------------------------------------------------------------------------------- !C first for shielding is setting of function of side-chains subroutine set_shield_fac2 real(kind=8) :: div77_81=0.974996043d0, & div4_81=0.2222222222d0 real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, & scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,& short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi, & sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin !C the vector between center of side_chain and peptide group real(kind=8),dimension(3) :: pep_side_long,side_calf, & pept_group,costhet_grad,cosphi_grad_long, & cosphi_grad_loc,pep_side_norm,side_calf_norm, & sh_frac_dist_grad,pep_side integer i,j,k !C write(2,*) "ivec",ivec_start,ivec_end do i=1,nres fac_shield(i)=0.0d0 ishield_list(i)=0 do j=1,3 grad_shield(j,i)=0.0d0 enddo enddo do i=ivec_start,ivec_end !C do i=1,nres-1 !C if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle ! ishield_list(i)=0 if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle !Cif there two consequtive dummy atoms there is no peptide group between them !C the line below has to be changed for FGPROC>1 VolumeTotal=0.0 do k=1,nres if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle dist_pep_side=0.0 dist_side_calf=0.0 do j=1,3 !C first lets set vector conecting the ithe side-chain with kth side-chain pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 !C pep_side(j)=2.0d0 !C and vector conecting the side-chain with its proper calfa side_calf(j)=c(j,k+nres)-c(j,k) !C side_calf(j)=2.0d0 pept_group(j)=c(j,i)-c(j,i+1) !C lets have their lenght dist_pep_side=pep_side(j)**2+dist_pep_side dist_side_calf=dist_side_calf+side_calf(j)**2 dist_pept_group=dist_pept_group+pept_group(j)**2 enddo dist_pep_side=sqrt(dist_pep_side) dist_pept_group=sqrt(dist_pept_group) dist_side_calf=sqrt(dist_side_calf) do j=1,3 pep_side_norm(j)=pep_side(j)/dist_pep_side side_calf_norm(j)=dist_side_calf enddo !C now sscale fraction sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield ! print *,buff_shield,"buff",sh_frac_dist !C now sscale if (sh_frac_dist.le.0.0) cycle !C print *,ishield_list(i),i !C If we reach here it means that this side chain reaches the shielding sphere !C Lets add him to the list for gradient ishield_list(i)=ishield_list(i)+1 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient !C this list is essential otherwise problem would be O3 shield_list(ishield_list(i),i)=k !C Lets have the sscale value if (sh_frac_dist.gt.1.0) then scale_fac_dist=1.0d0 do j=1,3 sh_frac_dist_grad(j)=0.0d0 enddo else scale_fac_dist=-sh_frac_dist*sh_frac_dist & *(2.0d0*sh_frac_dist-3.0d0) fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) & /dist_pep_side/buff_shield*0.5d0 do j=1,3 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) !C sh_frac_dist_grad(j)=0.0d0 !C scale_fac_dist=1.0d0 !C print *,"jestem",scale_fac_dist,fac_help_scale, !C & sh_frac_dist_grad(j) enddo endif !C this is what is now we have the distance scaling now volume... short=short_r_sidechain(itype(k,1)) long=long_r_sidechain(itype(k,1)) costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2) sinthet=short/dist_pep_side*costhet ! print *,"SORT",short,long,sinthet,costhet !C now costhet_grad !C costhet=0.6d0 !C sinthet=0.8 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4 !C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet !C & -short/dist_pep_side**2/costhet) !C costhet_fac=0.0d0 do j=1,3 costhet_grad(j)=costhet_fac*pep_side(j) enddo !C remember for the final gradient multiply costhet_grad(j) !C for side_chain by factor -2 ! !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 !C pep_side0pept_group is vector multiplication pep_side0pept_group=0.0d0 do j=1,3 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) enddo cosalfa=(pep_side0pept_group/ & (dist_pep_side*dist_side_calf)) fac_alfa_sin=1.0d0-cosalfa**2 fac_alfa_sin=dsqrt(fac_alfa_sin) rkprim=fac_alfa_sin*(long-short)+short !C rkprim=short !C now costhet_grad cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2) !C cosphi=0.6 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ & dist_pep_side**2) !C sinphi=0.8 do j=1,3 cosphi_grad_long(j)=cosphi_fac*pep_side(j) & +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) & *(long-short)/fac_alfa_sin*cosalfa/ & ((dist_pep_side*dist_side_calf))* & ((side_calf(j))-cosalfa* & ((pep_side(j)/dist_pep_side)*dist_side_calf)) !C cosphi_grad_long(j)=0.0d0 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) & *(long-short)/fac_alfa_sin*cosalfa & /((dist_pep_side*dist_side_calf))* & (pep_side(j)- & cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) !C cosphi_grad_loc(j)=0.0d0 enddo !C print *,sinphi,sinthet VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) & /VSolvSphere_div !C & *wshield !C now the gradient... do j=1,3 grad_shield(j,i)=grad_shield(j,i) & !C gradient po skalowaniu +(sh_frac_dist_grad(j)*VofOverlap & !C gradient po costhet +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* & (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( & sinphi/sinthet*costhet*costhet_grad(j) & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) & )*wshield !C grad_shield_side is Cbeta sidechain gradient grad_shield_side(j,ishield_list(i),i)=& (sh_frac_dist_grad(j)*-2.0d0& *VofOverlap& -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*& (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(& sinphi/sinthet*costhet*costhet_grad(j)& +sinthet/sinphi*cosphi*cosphi_grad_long(j))) & )*wshield ! print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),& ! sinphi/sinthet,& ! +sinthet/sinphi,"HERE" grad_shield_loc(j,ishield_list(i),i)= & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*& (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(& sinthet/sinphi*cosphi*cosphi_grad_loc(j)& ))& *wshield ! print *,grad_shield_loc(j,ishield_list(i),i) enddo VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist enddo fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield) ! write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i) enddo return end subroutine set_shield_fac2 !---------------------------------------------------------------------------- ! SOUBROUTINE FOR AFM subroutine AFMvel(Eafmforce) use MD_data, only:totTafm real(kind=8),dimension(3) :: diffafm real(kind=8) :: afmdist,Eafmforce integer :: i !C Only for check grad COMMENT if not used for checkgrad !C totT=3.0d0 !C-------------------------------------------------------- !C print *,"wchodze" afmdist=0.0d0 Eafmforce=0.0d0 do i=1,3 diffafm(i)=c(i,afmend)-c(i,afmbeg) afmdist=afmdist+diffafm(i)**2 enddo afmdist=dsqrt(afmdist) ! totTafm=3.0 Eafmforce=0.5d0*forceAFMconst & *(distafminit+totTafm*velAFMconst-afmdist)**2 !C Eafmforce=-forceAFMconst*(dist-distafminit) do i=1,3 gradafm(i,afmend-1)=-forceAFMconst* & (distafminit+totTafm*velAFMconst-afmdist) & *diffafm(i)/afmdist gradafm(i,afmbeg-1)=forceAFMconst* & (distafminit+totTafm*velAFMconst-afmdist) & *diffafm(i)/afmdist enddo ! print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist return end subroutine AFMvel !--------------------------------------------------------- subroutine AFMforce(Eafmforce) real(kind=8),dimension(3) :: diffafm ! real(kind=8) ::afmdist real(kind=8) :: afmdist,Eafmforce integer :: i afmdist=0.0d0 Eafmforce=0.0d0 do i=1,3 diffafm(i)=c(i,afmend)-c(i,afmbeg) afmdist=afmdist+diffafm(i)**2 enddo afmdist=dsqrt(afmdist) ! print *,afmdist,distafminit Eafmforce=-forceAFMconst*(afmdist-distafminit) do i=1,3 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist enddo !C print *,'AFM',Eafmforce return end subroutine AFMforce !----------------------------------------------------------------------------- #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 use MD_data, only: mset !el local variables integer :: i,j if(nres.lt.100) then maxconts=10*nres elseif(nres.lt.200) then maxconts=10*nres ! Max. number of contacts per residue else maxconts=10*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(nint_gr_nucl(nres)) allocate(nscp_gr_nucl(nres)) allocate(ielstart_nucl(nres)) allocate(ielend_nucl(nres)) !(maxres) allocate(istart_nucl(nres,maxint_gr)) allocate(iend_nucl(nres,maxint_gr)) !(maxres,maxint_gr) allocate(iscpstart_nucl(nres,maxint_gr)) allocate(iscpend_nucl(nres,maxint_gr)) !(maxres,maxint_gr) allocate(ielstart_vdw_nucl(nres)) allocate(ielend_vdw_nucl(nres)) 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)) allocate(ees0plist(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) allocate(b1(2,nres)) !(2,-maxtor:maxtor) allocate(b2(2,nres)) !(2,-maxtor:maxtor) allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor) allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor) allocate(ctilde(2,2,nres)) allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor) allocate(gtb1(2,nres)) allocate(gtb2(2,nres)) allocate(cc(2,2,nres)) allocate(dd(2,2,nres)) allocate(ee(2,2,nres)) allocate(gtcc(2,2,nres)) allocate(gtdd(2,2,nres)) allocate(gtee(2,2,nres)) allocate(gUb2(2,nres)) allocate(gteUg(2,2,nres)) ! 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,-1:nres,0:2)) allocate(gradc(3,-1:nres,0:2)) !(3,maxres,2) allocate(gvdwx(3,-1:nres)) allocate(gvdwc(3,-1:nres)) allocate(gelc(3,-1:nres)) allocate(gelc_long(3,-1:nres)) allocate(gvdwpp(3,-1:nres)) allocate(gvdwc_scpp(3,-1:nres)) allocate(gradx_scp(3,-1:nres)) allocate(gvdwc_scp(3,-1:nres)) allocate(ghpbx(3,-1:nres)) allocate(ghpbc(3,-1:nres)) allocate(gradcorr(3,-1:nres)) allocate(gradcorr_long(3,-1:nres)) allocate(gradcorr5_long(3,-1:nres)) allocate(gradcorr6_long(3,-1:nres)) allocate(gcorr6_turn_long(3,-1:nres)) allocate(gradxorr(3,-1:nres)) allocate(gradcorr5(3,-1:nres)) allocate(gradcorr6(3,-1:nres)) allocate(gliptran(3,-1:nres)) allocate(gliptranc(3,-1:nres)) allocate(gliptranx(3,-1:nres)) allocate(gshieldx(3,-1:nres)) allocate(gshieldc(3,-1:nres)) allocate(gshieldc_loc(3,-1:nres)) allocate(gshieldx_ec(3,-1:nres)) allocate(gshieldc_ec(3,-1:nres)) allocate(gshieldc_loc_ec(3,-1:nres)) allocate(gshieldx_t3(3,-1:nres)) allocate(gshieldc_t3(3,-1:nres)) allocate(gshieldc_loc_t3(3,-1:nres)) allocate(gshieldx_t4(3,-1:nres)) allocate(gshieldc_t4(3,-1:nres)) allocate(gshieldc_loc_t4(3,-1:nres)) allocate(gshieldx_ll(3,-1:nres)) allocate(gshieldc_ll(3,-1:nres)) allocate(gshieldc_loc_ll(3,-1:nres)) allocate(grad_shield(3,-1:nres)) allocate(gg_tube_sc(3,-1:nres)) allocate(gg_tube(3,-1:nres)) allocate(gradafm(3,-1:nres)) allocate(gradb_nucl(3,-1:nres)) allocate(gradbx_nucl(3,-1:nres)) allocate(gvdwpsb1(3,-1:nres)) allocate(gelpp(3,-1:nres)) allocate(gvdwpsb(3,-1:nres)) allocate(gelsbc(3,-1:nres)) allocate(gelsbx(3,-1:nres)) allocate(gvdwsbx(3,-1:nres)) allocate(gvdwsbc(3,-1:nres)) allocate(gsbloc(3,-1:nres)) allocate(gsblocx(3,-1:nres)) allocate(gradcorr_nucl(3,-1:nres)) allocate(gradxorr_nucl(3,-1:nres)) allocate(gradcorr3_nucl(3,-1:nres)) allocate(gradxorr3_nucl(3,-1:nres)) allocate(gvdwpp_nucl(3,-1:nres)) allocate(gradpepcat(3,-1:nres)) allocate(gradpepcatx(3,-1:nres)) allocate(gradcatcat(3,-1:nres)) allocate(gradnuclcat(3,-1:nres)) allocate(gradnuclcatx(3,-1:nres)) !(3,maxres) allocate(grad_shield_side(3,maxcontsshi,-1:nres)) allocate(grad_shield_loc(3,maxcontsshi,-1:nres)) ! grad for shielding surroing allocate(gloc(0:maxvar,0:2)) allocate(gloc_x(0:maxvar,2)) !(maxvar,2) allocate(gel_loc(3,-1:nres)) allocate(gel_loc_long(3,-1:nres)) allocate(gcorr3_turn(3,-1:nres)) allocate(gcorr4_turn(3,-1:nres)) allocate(gcorr6_turn(3,-1:nres)) allocate(gradb(3,-1:nres)) allocate(gradbx(3,-1: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,-1:nres)) allocate(gsccorx(3,-1:nres)) !(3,maxres) allocate(gsccor_loc(-1:nres)) !(maxres) allocate(gvdwx_scbase(3,-1:nres)) allocate(gvdwc_scbase(3,-1:nres)) allocate(gvdwx_pepbase(3,-1:nres)) allocate(gvdwc_pepbase(3,-1:nres)) allocate(gvdwx_scpho(3,-1:nres)) allocate(gvdwc_scpho(3,-1:nres)) allocate(gvdwc_peppho(3,-1:nres)) allocate(dtheta(3,2,-1:nres)) !(3,2,maxres) allocate(gscloc(3,-1:nres)) allocate(gsclocx(3,-1:nres)) !(3,maxres) allocate(dphi(3,3,-1:nres)) allocate(dalpha(3,3,-1:nres)) allocate(domega(3,3,-1: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,-1:nres)) allocate(gxcart(3,-1:nres)) !(3,0:MAXRES) allocate(gradcag(3,-1:nres)) allocate(gradxag(3,-1: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(maxdim),jdssb(maxdim)) ! allocate(newihpb(nss),newjhpb(nss)) !(maxdim) ! endif allocate(ishield_list(-1:nres)) allocate(shield_list(maxcontsshi,-1:nres)) allocate(dyn_ss_mask(nres)) allocate(fac_shield(-1:nres)) allocate(enetube(nres*2)) allocate(enecavtube(nres*2)) !(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) ! allocateion of lists JPRDLA allocate(newcontlistppi(300*nres)) allocate(newcontlistscpi(300*nres)) allocate(newcontlisti(300*nres)) allocate(newcontlistppj(300*nres)) allocate(newcontlistscpj(300*nres)) allocate(newcontlistj(300*nres)) return end subroutine alloc_ener_arrays !----------------------------------------------------------------- subroutine ebond_nucl(estr_nucl) !c !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds !c real(kind=8),dimension(3) :: u,ud real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder real(kind=8) :: estr_nucl,diff integer :: iti,i,j,k,nbi estr_nucl=0.0d0 !C print *,"I enter ebond" if (energy_dec) & write (iout,*) "ibondp_start,ibondp_end",& ibondp_nucl_start,ibondp_nucl_end do i=ibondp_nucl_start,ibondp_nucl_end if (itype(i-1,2).eq.ntyp1_molec(2) .or. & itype(i,2).eq.ntyp1_molec(2)) cycle ! 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,vbld(i),distchainmax, ! & gnmr1(vbld(i),-1.0d0,distchainmax) diff = vbld(i)-vbldp0_nucl if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),& vbldp0_nucl,diff,AKP_nucl*diff*diff estr_nucl=estr_nucl+diff*diff ! print *,estr_nucl do j=1,3 gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i) enddo !c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) enddo estr_nucl=0.5d0*AKP_nucl*estr_nucl ! print *,"partial sum", estr_nucl,AKP_nucl if (energy_dec) & write (iout,*) "ibondp_start,ibondp_end",& ibond_nucl_start,ibond_nucl_end do i=ibond_nucl_start,ibond_nucl_end !C print *, "I am stuck",i iti=itype(i,2) if (iti.eq.ntyp1_molec(2)) cycle nbi=nbondterm_nucl(iti) !C print *,iti,nbi if (nbi.eq.1) then diff=vbld(i+nres)-vbldsc0_nucl(1,iti) if (energy_dec) & write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, & AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff ! print *,estr_nucl do j=1,3 gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) enddo else do j=1,nbi diff=vbld(i+nres)-vbldsc0_nucl(j,iti) ud(j)=aksc_nucl(j,iti)*diff u(j)=abond0_nucl(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_nucl=estr_nucl+uprod/usum do j=1,3 gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) enddo endif enddo !C print *,"I am about to leave ebond" return end subroutine ebond_nucl !----------------------------------------------------------------------------- subroutine ebend_nucl(etheta_nucl) real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: 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_nucl,ccl,ssl,scl,csl,ethetacnstr ! local variables for constrains real(kind=8) :: difi,thetiii integer itheta etheta_nucl=0.0D0 ! print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres do i=ithet_nucl_start,ithet_nucl_end if ((itype(i-1,2).eq.ntyp1_molec(2)).or.& (itype(i-2,2).eq.ntyp1_molec(2)).or. & (itype(i,2).eq.ntyp1_molec(2))) cycle dethetai=0.0d0 dephii=0.0d0 dephii1=0.0d0 theti2=0.5d0*theta(i) ityp2=ithetyp_nucl(itype(i-1,2)) do k=1,nntheterm_nucl coskt(k)=dcos(k*theti2) sinkt(k)=dsin(k*theti2) enddo if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then #ifdef OSF phii=phi(i) if (phii.ne.phii) phii=150.0 #else phii=phi(i) #endif ityp1=ithetyp_nucl(itype(i-2,2)) do k=1,nsingle_nucl cosph1(k)=dcos(k*phii) sinph1(k)=dsin(k*phii) enddo else phii=0.0d0 ityp1=nthetyp_nucl+1 do k=1,nsingle_nucl cosph1(k)=0.0d0 sinph1(k)=0.0d0 enddo endif if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) 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_nucl(itype(i,2)) do k=1,nsingle_nucl cosph2(k)=dcos(k*phii1) sinph2(k)=dsin(k*phii1) enddo else phii1=0.0d0 ityp3=nthetyp_nucl+1 do k=1,nsingle_nucl cosph2(k)=0.0d0 sinph2(k)=0.0d0 enddo endif ethetai=aa0thet_nucl(ityp1,ityp2,ityp3) do k=1,ndouble_nucl 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",nntheterm_nucl do k=1,nntheterm_nucl write (iout,*) k,coskt(k),sinkt(k) enddo endif do k=1,ntheterm_nucl ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k) dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)& *coskt(k) if (lprn)& write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),& " ethetai",ethetai enddo if (lprn) then write (iout,*) "cosph and sinph" do k=1,nsingle_nucl write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) enddo write (iout,*) "cosph1ph2 and sinph2ph2" do k=2,ndouble_nucl 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_nucl do k=1,nsingle_nucl aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)& +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)& +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)& +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k) ethetai=ethetai+sinkt(m)*aux dethetai=dethetai+0.5d0*m*aux*coskt(m) dephii=dephii+k*sinkt(m)*(& ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-& bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)) dephii1=dephii1+k*sinkt(m)*(& eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-& ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)) if (lprn) & write (iout,*) "m",m," k",k," bbthet",& bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",& ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",& ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",& eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai enddo enddo if (lprn) & write(iout,*) "ethetai",ethetai do m=1,ntheterm3_nucl do k=2,ndouble_nucl do l=1,k-1 aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+& ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+& ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+& ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l) ethetai=ethetai+sinkt(m)*aux dethetai=dethetai+0.5d0*m*coskt(m)*aux dephii=dephii+l*sinkt(m)*(& -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-& ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+& ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+& ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) dephii1=dephii1+(k-l)*sinkt(m)*( & -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+& ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+& ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-& ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) if (lprn) then write (iout,*) "m",m," k",k," l",l," ffthet", & ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), & ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",& ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),& ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai write (iout,*) cosph1ph2(l,k)*sinkt(m), & cosph1ph2(k,l)*sinkt(m),& sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) endif enddo enddo enddo 10 continue if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') & i,theta(i)*rad2deg,phii*rad2deg, & phii1*rad2deg,ethetai etheta_nucl=etheta_nucl+ethetai ! print *,i,"partial sum",etheta_nucl if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1 gloc(nphi+i-2,icg)=wang_nucl*dethetai enddo return end subroutine ebend_nucl !---------------------------------------------------- subroutine etor_nucl(etors_nucl) ! 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_nucl,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_nucl=0.0D0 ! print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end do i=iphi_nucl_start,iphi_nucl_end if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) & .or. itype(i-3,2).eq.ntyp1_molec(2) & .or. itype(i,2).eq.ntyp1_molec(2)) cycle etors_ii=0.0D0 itori=itortyp_nucl(itype(i-2,2)) itori1=itortyp_nucl(itype(i-1,2)) phii=phi(i) ! print *,i,itori,itori1 gloci=0.0D0 !C Regular cosine and sine terms do j=1,nterm_nucl(itori,itori1) v1ij=v1_nucl(j,itori,itori1) v2ij=v2_nucl(j,itori,itori1) cosphi=dcos(j*phii) sinphi=dsin(j*phii) etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi if (energy_dec) etors_ii=etors_ii+& v1ij*cosphi+v2ij*sinphi gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) enddo !C Lorentz terms !C v1 !C E = SUM ----------------------------------- - v1 !C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 !C cosphi=dcos(0.5d0*phii) sinphi=dsin(0.5d0*phii) do j=1,nlor_nucl(itori,itori1) vl1ij=vlor1_nucl(j,itori,itori1) vl2ij=vlor2_nucl(j,itori,itori1) vl3ij=vlor3_nucl(j,itori,itori1) pom=vl2ij*cosphi+vl3ij*sinphi pom1=1.0d0/(pom*pom+1.0d0) etors_nucl=etors_nucl+vl1ij*pom1 if (energy_dec) etors_ii=etors_ii+ & vl1ij*pom1 pom=-pom*pom1*pom1 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom enddo !C Subtract the constant term etors_nucl=etors_nucl-v0_nucl(itori,itori1) if (energy_dec) write (iout,'(a6,i5,0pf7.3)') & 'etor',i,etors_ii-v0_nucl(itori,itori1) if (lprn) & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') & restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, & (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6) gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci !c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) enddo return end subroutine etor_nucl !------------------------------------------------------------ subroutine epp_nucl_sub(evdw1,ees) !C !C This subroutine calculates the average interaction energy and its gradient !C in the virtual-bond vectors between non-adjacent peptide groups, based on !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. !C The potential depends both on the distance of peptide-group centers and on !C the orientation of the CA-CA virtual bonds. !C integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, & sslipj,ssgradlipj,faclipij2 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 real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,sss_grad,fac,evdw1ij integer xshift,yshift,zshift real(kind=8),dimension(3):: ggg,gggp,gggm,erij real(kind=8) :: ees,eesij !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions real(kind=8) scal_el /0.5d0/ t_eelecij=0.0d0 ees=0.0D0 evdw1=0.0D0 ind=0 !c !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 !c ! print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl do i=iatel_s_nucl,iatel_e_nucl if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) 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 call to_box(xmedi,ymedi,zmedi) call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi) do j=ielstart_nucl(i),ielend_nucl(i) if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle ind=ind+1 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 xj=c(1,j)+0.5D0*dxj yj=c(2,j)+0.5D0*dyj zj=c(3,j)+0.5D0*dzj call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0 xj=boxshift(xj-xmedi,boxxsize) yj=boxshift(yj-ymedi,boxysize) zj=boxshift(zj-zmedi,boxzsize) rij=xj*xj+yj*yj+zj*zj !c write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp fac=(r0pp**2/rij)**3 ev1=epspp*fac*fac ev2=epspp*fac evdw1ij=ev1-2*ev2 fac=(-ev1-evdw1ij)/rij ! write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij evdw1=evdw1+evdw1ij !C !C Calculate contributions to the Cartesian gradient. !C ggg(1)=fac*xj ggg(2)=fac*yj ggg(3)=fac*zj do k=1,3 gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k) gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k) enddo !c phoshate-phosphate electrostatic interactions rij=dsqrt(rij) fac=1.0d0/rij eesij=dexp(-BEES*rij)*fac ! write (2,*)"fac",fac," eesijpp",eesij if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij ees=ees+eesij !c fac=-eesij*fac fac=-(fac+BEES)*eesij*fac ggg(1)=fac*xj ggg(2)=fac*yj ggg(3)=fac*zj !c write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3) !c write(2,*) "gelpp",i,(gelpp(k,i),k=1,3) !c write(2,*) "gelpp",j,(gelpp(k,j),k=1,3) do k=1,3 gelpp(k,i)=gelpp(k,i)-ggg(k) gelpp(k,j)=gelpp(k,j)+ggg(k) enddo enddo ! j enddo ! i !c ees=332.0d0*ees ees=AEES*ees do i=nnt,nct !c write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3) do k=1,3 gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i) !c gelpp(k,i)=332.0d0*gelpp(k,i) gelpp(k,i)=AEES*gelpp(k,i) enddo !c write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3) enddo !c write (2,*) "total EES",ees return end subroutine epp_nucl_sub !--------------------------------------------------------------------- subroutine epsb(evdwpsb,eelpsb) ! use comm_locel !C !C This subroutine calculates the excluded-volume interaction energy between !C peptide-group centers and side chains and its gradient in virtual-bond and !C side-chain vectors. !C real(kind=8),dimension(3):: ggg integer :: i,iint,j,k,iteli,itypj,subchap real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,& e1,e2,evdwij,rij,evdwpsb,eelpsb real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init integer xshift,yshift,zshift !cd print '(a)','Enter ESCP' !cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e eelpsb=0.0d0 evdwpsb=0.0d0 ! print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl do i=iatscp_s_nucl,iatscp_e_nucl if (itype(i,2).eq.ntyp1_molec(2) & .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle 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)) call to_box(xi,yi,zi) do iint=1,nscp_gr_nucl(i) do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint) itypj=itype(j,2) if (itypj.eq.ntyp1_molec(2)) cycle !C Uncomment following three lines for SC-p interactions !c xj=c(1,nres+j)-xi !c yj=c(2,nres+j)-yi !c zj=c(3,nres+j)-zi !C Uncomment following three lines for Ca-p interactions ! xj=c(1,j)-xi ! yj=c(2,j)-yi ! zj=c(3,j)-zi xj=c(1,j) yj=c(2,j) zj=c(3,j) call to_box(xj,yj,zj) xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) dist_init=xj**2+yj**2+zj**2 rrij=1.0D0/(xj*xj+yj*yj+zj*zj) fac=rrij**expon2 e1=fac*fac*aad_nucl(itypj) e2=fac*bad_nucl(itypj) if (iabs(j-i) .le. 2) then e1=scal14*e1 e2=scal14*e2 endif evdwij=e1+e2 evdwpsb=evdwpsb+evdwij if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') & 'evdw2',i,j,evdwij,"tu4" !C !C Calculate contributions to the gradient in the virtual-bond and SC vectors. !C fac=-(evdwij+e1)*rrij ggg(1)=xj*fac ggg(2)=yj*fac ggg(3)=zj*fac do k=1,3 gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k) gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k) enddo enddo enddo ! iint enddo ! i do i=1,nct do j=1,3 gvdwpsb(j,i)=expon*gvdwpsb(j,i) gvdwpsb1(j,i)=expon*gvdwpsb1(j,i) enddo enddo return end subroutine epsb !------------------------------------------------------ subroutine esb_gb(evdwsb,eelsb) use comm_locel use calc_data_nucl integer :: iint,itypi,itypi1,itypj,subchap,num_conti2 real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,aa,bb,faclip,sig0ij integer :: ii logical lprn evdw=0.0D0 eelsb=0.0d0 ecorr=0.0d0 evdwsb=0.0D0 lprn=.false. ind=0 ! print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl do i=iatsc_s_nucl,iatsc_e_nucl num_conti=0 num_conti2=0 itypi=itype(i,2) ! PRINT *,"I=",i,itypi if (itypi.eq.ntyp1_molec(2)) cycle itypi1=itype(i+1,2) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) dsci_inv=vbld_inv(i+nres) !C !C Calculate SC interaction energy. !C do iint=1,nint_gr_nucl(i) ! print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint) do j=istart_nucl(i,iint),iend_nucl(i,iint) ind=ind+1 ! print *,"JESTEM" itypj=itype(j,2) if (itypj.eq.ntyp1_molec(2)) cycle dscj_inv=vbld_inv(j+nres) sig0ij=sigma_nucl(itypi,itypj) chi1=chi_nucl(itypi,itypj) chi2=chi_nucl(itypj,itypi) chi12=chi1*chi2 chip1=chip_nucl(itypi,itypj) chip2=chip_nucl(itypj,itypi) chip12=chip1*chip2 ! xj=c(1,nres+j)-xi ! yj=c(2,nres+j)-yi ! zj=c(3,nres+j)-zi xj=c(1,nres+j) yj=c(2,nres+j) zj=c(3,nres+j) call to_box(xj,yj,zj) ! call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) ! aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 ! bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) 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) !C Calculate angle-dependent terms of energy and contributions to their !C derivatives. 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_nucl sigsq=1.0D0/sigsq sig=sig0ij*dsqrt(sigsq) rij_shift=1.0D0/rij-sig+sig0ij ! print *,rij_shift,"rij_shift" !c write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij, !c & " rij_shift",rij_shift if (rij_shift.le.0.0D0) then evdw=1.0D20 return endif sigder=-sig*sigsq !c--------------------------------------------------------------- rij_shift=1.0D0/rij_shift fac=rij_shift**expon e1=fac*fac*aa_nucl(itypi,itypj) e2=fac*bb_nucl(itypi,itypj) evdwij=eps1*eps2rt*(e1+e2) !c write (2,*) "eps1",eps1," eps2rt",eps2rt, !c & " e1",e1," e2",e2," evdwij",evdwij eps2der=evdwij evdwij=evdwij*eps2rt evdwsb=evdwsb+evdwij if (lprn) then sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0) epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj) write (iout,'(2(a3,i3,2x),17(0pf7.3))') & restyp(itypi,2),i,restyp(itypj,2),j, & epsi,sigm,chi1,chi2,chip1,chip2, & eps1,eps2rt**2,sig,sig0ij, & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,& evdwij write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj) endif if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') & 'evdw',i,j,evdwij,"tu3" !C Calculate gradient components. e1=e1*eps1*eps2rt**2 fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac !c fac=0.0d0 !C Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac !C Calculate angular part of the gradient. call sc_grad_nucl call eelsbij(eelij,num_conti2) if (energy_dec .and. & (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) & write (istat,'(e14.5)') evdwij eelsb=eelsb+eelij enddo ! j enddo ! iint num_cont_hb(i)=num_conti2 enddo ! i !c write (iout,*) "Number of loop steps in EGB:",ind !cccc energy_dec=.false. return end subroutine esb_gb !------------------------------------------------------------------------------- subroutine eelsbij(eesij,num_conti2) use comm_locel use calc_data_nucl real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,rlocshield,fracinbuf integer xshift,yshift,zshift,ilist,iresshield,num_conti2 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions real(kind=8) scal_el /0.5d0/ integer :: iteli,itelj,kkk,kkll,m,isubchap real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i real(kind=8) :: dx_normj,dy_normj,dz_normj,& r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,& el1,el2,el3,el4,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,itypi,itypj ind=ind+1 itypi=itype(i,2) itypj=itype(j,2) ! print *,i,j,itypi,itypj,istype(i),istype(j),"????" ael6i=ael6_nucl(itypi,itypj) ael3i=ael3_nucl(itypi,itypj) ael63i=ael63_nucl(itypi,itypj) ael32i=ael32_nucl(itypi,itypj) !c write (iout,*) "eelecij",i,j,itype(i),itype(j), !c & ael6i,ael3i,ael63i,al32i,rij,rrij dxj=dc(1,j+nres) dyj=dc(2,j+nres) dzj=dc(3,j+nres) dx_normi=dc_norm(1,i+nres) dy_normi=dc_norm(2,i+nres) dz_normi=dc_norm(3,i+nres) dx_normj=dc_norm(1,j+nres) dy_normj=dc_norm(2,j+nres) dz_normj=dc_norm(3,j+nres) !c xj=c(1,j)+0.5D0*dxj-xmedi !c yj=c(2,j)+0.5D0*dyj-ymedi !c zj=c(3,j)+0.5D0*dzj-zmedi if (ipot_nucl.ne.2) then 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 else cosa=om12 cosb=om1 cosg=om2 endif r3ij=rij*rrij r6ij=r3ij*r3ij fac=cosa-3.0D0*cosb*cosg facfac=fac*fac fac1=3.0d0*(cosb*cosb+cosg*cosg) fac3=ael6i*r6ij fac4=ael3i*r3ij fac5=ael63i*r6ij fac6=ael32i*r6ij !c write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1, !c & " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6 el1=fac3*(4.0D0+facfac-fac1) el2=fac4*fac el3=fac5*(2.0d0-2.0d0*facfac+fac1) el4=fac6*facfac eesij=el1+el2+el3+el4 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions ees0ij=4.0D0+facfac-fac1 if (energy_dec) then if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) & write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') & sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),& restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, & (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij endif !C !C Calculate contributions to the Cartesian gradient. !C facel=-3.0d0*rrij*(eesij+el1+el3+el4) fac1=fac !c erij(1)=xj*rmij !c erij(2)=yj*rmij !c 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 gelsbc(k,j)=gelsbc(k,j)+ggg(k) gelsbc(k,i)=gelsbc(k,i)-ggg(k) gelsbx(k,j)=gelsbx(k,j)+ggg(k) gelsbx(k,i)=gelsbx(k,i)-ggg(k) enddo !* !* Angular part !* ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1 fac4=-3.0D0*fac4 fac3=-6.0D0*fac3 fac5= 6.0d0*fac5 fac6=-6.0d0*fac6 ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+& fac6*fac1*cosg ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+& fac6*fac1*cosb do k=1,3 dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb) dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg) enddo do k=1,3 ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) enddo do k=1,3 gelsbx(k,i)=gelsbx(k,i)-ggg(k) & +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))& + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres) gelsbx(k,j)=gelsbx(k,j)+ggg(k) & +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))& + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres) gelsbc(k,j)=gelsbc(k,j)+ggg(k) gelsbc(k,i)=gelsbc(k,i)-ggg(k) enddo ! IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and. IF ( j.gt.i+1 .and.& num_conti.le.maxcont) THEN !C !C Calculate the contact function. The ith column of the array JCONT will !C contain the numbers of atoms that make contacts with the atom I (of numbers !C greater than I). The arrays FACONT and GACONT will contain the values of !C the contact function and its derivative. r0ij=2.20D0*sigma_nucl(itypi,itypj) !c write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont) !c write (2,*) "fcont",fcont if (fcont.gt.0.0D0) then num_conti=num_conti+1 num_conti2=num_conti2+1 if (num_conti.gt.maxconts) then write (iout,*) 'WARNING - max. # of contacts exceeded;',& ' will skip next contacts for this conf.',maxconts else jcont_hb(num_conti,i)=j !c write (iout,*) "num_conti",num_conti, !c & " jcont_hb",jcont_hb(num_conti,i) !C Calculate contact energies cosa4=4.0D0*cosa wij=cosa-3.0D0*cosb*cosg cosbg1=cosb+cosg cosbg2=cosb-cosg fac3=dsqrt(-ael6i)*r3ij !c write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 if (ees0tmp.gt.0) then ees0pij=dsqrt(ees0tmp) else ees0pij=0 endif ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 if (ees0tmp.gt.0) then ees0mij=dsqrt(ees0tmp) else ees0mij=0 endif ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) !c write (iout,*) "i",i," j",j, !c & " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i) ees0pij1=fac3/ees0pij ees0mij1=fac3/ees0mij fac3p=-3.0D0*fac3*rrij ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) ecosap=ecosa1+ecosa2 ecosbp=ecosb1+ecosb2 ecosgp=ecosg1+ecosg2 ecosam=ecosa1-ecosa2 ecosbm=ecosb1-ecosb2 ecosgm=ecosg1-ecosg2 !C End diagnostics facont_hb(num_conti,i)=fcont fprimcont=fprimcont/rij do k=1,3 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) enddo gggp(1)=gggp(1)+ees0pijp*xj gggp(2)=gggp(2)+ees0pijp*yj gggp(3)=gggp(3)+ees0pijp*zj gggm(1)=gggm(1)+ees0mijp*xj gggm(2)=gggm(2)+ees0mijp*yj gggm(3)=gggm(3)+ees0mijp*zj !C Derivatives due to the contact function gacont_hbr(1,num_conti,i)=fprimcont*xj gacont_hbr(2,num_conti,i)=fprimcont*yj gacont_hbr(3,num_conti,i)=fprimcont*zj do k=1,3 !c !c Gradient of the correlation terms !c gacontp_hb1(k,num_conti,i)= & (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) & + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres) gacontp_hb2(k,num_conti,i)= & (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) & + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres) gacontp_hb3(k,num_conti,i)=gggp(k) gacontm_hb1(k,num_conti,i)= & (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) & + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres) gacontm_hb2(k,num_conti,i)= & (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))& + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres) gacontm_hb3(k,num_conti,i)=gggm(k) enddo endif endif ENDIF return end subroutine eelsbij !------------------------------------------------------------------ subroutine sc_grad_nucl use comm_locel use calc_data_nucl real(kind=8),dimension(3) :: dcosom1,dcosom2 eom1=eps2der*eps2rt_om1+sigder*sigsq_om1 eom2=eps2der*eps2rt_om2+sigder*sigsq_om2 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12 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 do k=1,3 gvdwsbx(k,i)=gvdwsbx(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 gvdwsbx(k,j)=gvdwsbx(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 !C !C Calculate the components of the gradient in DC and X !C do l=1,3 gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l) gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l) enddo return end subroutine sc_grad_nucl !----------------------------------------------------------------------- subroutine esb(esbloc) !C Calculate the local energy of a side chain and its derivatives in the !C corresponding virtual-bond valence angles THETA and the spherical angles !C ALPHA and OMEGA derived from AM1 all-atom calculations. !C added by Urszula Kozlowska. 07/11/2007 !C real(kind=8),dimension(3):: x_prime,y_prime,z_prime real(kind=8),dimension(9):: 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,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 real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,& cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom integer::it,nlobit,i,j,k ! common /sccalc/ time11,time12,time112,theti,it,nlobit delta=0.02d0*pi esbloc=0.0D0 do i=loc_start_nucl,loc_end_nucl if (itype(i,2).eq.ntyp1_molec(2)) 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=itype(i,2) if (it.eq.10) goto 1 !c !C Compute the axes of tghe local cartesian coordinates system; store in !c x_prime, y_prime and z_prime !c do j=1,3 x_prime(j) = 0.00 y_prime(j) = 0.00 z_prime(j) = 0.00 enddo !C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), !C & dc_norm(3,i+nres) do j = 1,3 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac enddo do j = 1,3 z_prime(j) = -uz(j,i-1) ! z_prime(j)=0.0 enddo 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 it=itype(i,2) do j = 1,9 x(j) = sc_parmin_nucl(j,it) enddo #ifdef CHECK_COORD !Cc diagnostics - remove later xx1 = dcos(alph(2)) yy1 = dsin(alph(2))*dcos(omeg(2)) zz1 = -dsin(alph(2))*dsin(omeg(2)) write(2,'(3f8.1,3f9.3,1x,3f9.3)') & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,& xx1,yy1,zz1 !C," --- ", xx_w,yy_w,zz_w !c end diagnostics #endif sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) esbloc = esbloc + sumene sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1)) ! print *,"enecomp",sumene,sumene2 ! if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz ! if (energy_dec) write(iout,*) "x",(x(k),k=1,9) #ifdef DEBUG write (2,*) "x",(x(k),k=1,9) !C !C This section to check the numerical derivatives of the energy of ith side !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert !C #define DEBUG in the code to turn it on. !C write (2,*) "sumene =",sumene aincr=1.0d-7 xxsave=xx xx=xx+aincr write (2,*) xx,yy,zz sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) de_dxx_num=(sumenep-sumene)/aincr xx=xxsave write (2,*) "xx+ sumene from enesc=",sumenep,sumene 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,sumene 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,sumene 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,sumene cost2tab(i+1)=costsave sint2tab(i+1)=sintsave !C End of diagnostics section. #endif !C !C Compute the gradient of esc !C de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy de_dtt=0.0d0 #ifdef DEBUG write (2,*) "x",(x(k),k=1,9) write (2,*) "xx",xx," yy",yy," zz",zz write (2,*) "de_xx ",de_xx," de_yy ",de_yy,& " de_zz ",de_zz," de_tt ",de_tt write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,& " de_zz_num",de_dzz_num," de_dt_num",de_dt_num #endif !C cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) cosfac2xx=cosfac2*xx sinfac2yy=sinfac2*yy do k = 1,3 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*& vbld_inv(i+1) dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*& vbld_inv(i) pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) !c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, !c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) !c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), !c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy dZZ_Ci1(k)=0.0d0 dZZ_Ci(k)=0.0d0 do j=1,3 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres) dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) enddo dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) !c dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) enddo do k=1,3 dXX_Ctab(k,i)=dXX_Ci(k) dXX_C1tab(k,i)=dXX_Ci1(k) dYY_Ctab(k,i)=dYY_Ci(k) dYY_C1tab(k,i)=dYY_Ci1(k) dZZ_Ctab(k,i)=dZZ_Ci(k) dZZ_C1tab(k,i)=dZZ_Ci1(k) dXX_XYZtab(k,i)=dXX_XYZ(k) dYY_XYZtab(k,i)=dYY_XYZ(k) dZZ_XYZtab(k,i)=dZZ_XYZ(k) enddo do k = 1,3 !c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", !c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) !c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", !c & dyy_ci(k)," dzz_ci",dzz_ci(k) !c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", !c & dt_dci(k) !c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", !c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)) gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)) gsblocx(k,i)= de_dxx*dxx_XYZ(k)& +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) ! print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2 enddo !c write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3), !c & (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3) !C to check gradient call subroutine check_grad 1 continue enddo return end subroutine esb !=------------------------------------------------------- real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2) ! implicit none real(kind=8),dimension(9):: x(9) 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 integer i !c write (2,*) "enesc" !c write (2,*) "x",(x(i),i=1,9) !c write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2 sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 & + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy & + x(9)*yy*zz enesc_nucl=sumene return end function enesc_nucl !----------------------------------------------------------------------------- subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1) #ifdef MPI include 'mpif.h' integer,parameter :: max_cont=2000 integer,parameter:: max_dim=2*(8*3+6) integer, parameter :: msglen1=max_cont*max_dim integer,parameter :: msglen2=2*msglen1 integer source,CorrelType,CorrelID,Error real(kind=8) :: buffer(max_cont,max_dim) integer status(MPI_STATUS_SIZE) integer :: ierror,nbytes #endif real(kind=8),dimension(3):: gx(3),gx1(3) real(kind=8) :: time00 logical lprn,ldone integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn real(kind=8) ecorr,ecorr3 integer :: n_corr,n_corr1,mm,msglen !C Set lprn=.true. for debugging lprn=.false. n_corr=0 n_corr1=0 #ifdef MPI if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8)) if (nfgtasks.le.1) goto 30 if (lprn) then write (iout,'(a)') 'Contact function values:' do i=nnt,nct-1 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 !C Caution! Following code assumes that electrostatic interactions concerning !C a given atom are split among at most two processors! CorrelType=477 CorrelID=fg_rank+1 ldone=.false. do i=1,max_cont do j=1,max_dim buffer(i,j)=0.0D0 enddo enddo mm=mod(fg_rank,2) !c write (*,*) 'MyRank',MyRank,' mm',mm if (mm) 20,20,10 10 continue !c write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone if (fg_rank.gt.0) then !C Send correlation contributions to the preceding processor msglen=msglen1 nn=num_cont_hb(iatel_s_nucl) call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) !c write (*,*) 'The BUFFER array:' !c do i=1,nn !c write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30) !c enddo if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then msglen=msglen2 call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer) !C Clear the contacts of the atom passed to the neighboring processor nn=num_cont_hb(iatel_s_nucl+1) !c do i=1,nn !c write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30) !c enddo num_cont_hb(iatel_s_nucl)=0 endif !cd write (iout,*) 'Processor ',fg_rank,MyRank, !cd & ' is sending correlation contribution to processor',fg_rank-1, !cd & ' msglen=',msglen !c write (*,*) 'Processor ',fg_rank,MyRank, !c & ' is sending correlation contribution to processor',fg_rank-1, !c & ' msglen=',msglen,' CorrelType=',CorrelType time00=MPI_Wtime() call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, & CorrelType,FG_COMM,IERROR) time_sendrecv=time_sendrecv+MPI_Wtime()-time00 !cd write (iout,*) 'Processor ',fg_rank, !cd & ' has sent correlation contribution to processor',fg_rank-1, !cd & ' msglen=',msglen,' CorrelID=',CorrelID !c write (*,*) 'Processor ',fg_rank, !c & ' has sent correlation contribution to processor',fg_rank-1, !c & ' msglen=',msglen,' CorrelID=',CorrelID !c msglen=msglen1 endif ! (fg_rank.gt.0) if (ldone) goto 30 ldone=.true. 20 continue !c write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone if (fg_rank.lt.nfgtasks-1) then !C Receive correlation contributions from the next processor msglen=msglen1 if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2 !cd write (iout,*) 'Processor',fg_rank, !cd & ' is receiving correlation contribution from processor',fg_rank+1, !cd & ' msglen=',msglen,' CorrelType=',CorrelType !c write (*,*) 'Processor',fg_rank, !c &' is receiving correlation contribution from processor',fg_rank+1, !c & ' msglen=',msglen,' CorrelType=',CorrelType time00=MPI_Wtime() nbytes=-1 do while (nbytes.le.0) call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR) call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR) enddo !c print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, & fg_rank+1,CorrelType,FG_COMM,status,IERROR) time_sendrecv=time_sendrecv+MPI_Wtime()-time00 !c write (*,*) 'Processor',fg_rank, !c &' has received correlation contribution from processor',fg_rank+1, !c & ' msglen=',msglen,' nbytes=',nbytes !c write (*,*) 'The received BUFFER array:' !c do i=1,max_cont !c write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60) !c enddo if (msglen.eq.msglen1) then call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer) else if (msglen.eq.msglen2) then call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer) call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer) else write (iout,*) & 'ERROR!!!! message length changed while processing correlations.' write (*,*) & 'ERROR!!!! message length changed while processing correlations.' call MPI_Abort(MPI_COMM_WORLD,Error,IERROR) endif ! msglen.eq.msglen1 endif ! fg_rank.lt.nfgtasks-1 if (ldone) goto 30 ldone=.true. goto 10 30 continue #endif if (lprn) then write (iout,'(a)') 'Contact function values:' do i=nnt_molec(2),nct_molec(2)-1 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 ecorr=0.0D0 ecorr3=0.0d0 !C Remove the loop below after debugging !!! ! do i=nnt_molec(2),nct_molec(2) ! do j=1,3 ! gradcorr_nucl(j,i)=0.0D0 ! gradxorr_nucl(j,i)=0.0D0 ! gradcorr3_nucl(j,i)=0.0D0 ! gradxorr3_nucl(j,i)=0.0D0 ! enddo ! enddo ! print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl !C Calculate the local-electrostatic correlation terms do i=iatsc_s_nucl,iatsc_e_nucl i1=i+1 num_conti=num_cont_hb(i) num_conti1=num_cont_hb(i+1) ! print *,i,num_conti,num_conti1 do jj=1,num_conti j=jcont_hb(jj,i) do kk=1,num_conti1 j1=jcont_hb(kk,i1) !c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, !c & ' jj=',jj,' kk=',kk if (j1.eq.j+1 .or. j1.eq.j-1) then !C !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. !C The system gains extra energy. !C Tentative expression & coefficients; assumed d(stacking)=4.5 A, !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998. !C ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0) if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & 'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0) n_corr=n_corr+1 else if (j1.eq.j) then !C !C Contacts I-J and I-(J+1) occur simultaneously. !C The system loses extra energy. !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A, !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7 !C Need to implement full formulas 32 from Liwo et al., 1998. !C !c write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1, !c & ' jj=',jj,' kk=',kk ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0) endif enddo ! kk do kk=1,num_conti j1=jcont_hb(kk,i) !c write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1, !c & ' jj=',jj,' kk=',kk if (j1.eq.j+1) then !C Contacts I-J and (I+1)-J occur simultaneously. !C The system loses extra energy. ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0) endif ! j1==j+1 enddo ! kk enddo ! jj enddo ! i return end subroutine multibody_hb_nucl !----------------------------------------------------------- real(kind=8) function ehbcorr_nucl(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,ilist,m, iresshield real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,& ees0mkl,ees,coeffpees0pij,coeffmees0mij,& coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, & rlocshield 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) ! print *,"ehbcorr_nucl",ekont,ees !cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) !C Following 4 lines for diagnostics. !cd ees0pkl=0.0D0 !cd ees0pij=1.0D0 !cd ees0mkl=0.0D0 !cd ees0mij=1.0D0 !cd write (iout,*)'Contacts have occurred for nucleic bases', !cd & i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l !cd & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees !C Calculate the multi-body contribution to energy. ! ecorr_nucl=ecorr_nucl+ekont*ees !C Calculate multi-body contributions to the gradient. coeffpees0pij=coeffp*ees0pij coeffmees0mij=coeffm*ees0mij coeffpees0pkl=coeffp*ees0pkl coeffmees0mkl=coeffm*ees0mkl do ll=1,3 gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+& coeffmees0mkl*gacontm_hb1(ll,jj,i)) gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+& coeffmees0mkl*gacontm_hb2(ll,jj,i)) gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+& coeffmees0mij*gacontm_hb1(ll,kk,k)) gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) & -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_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij gradcorr_nucl(ll,i)=gradcorr_nucl(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_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl enddo ehbcorr_nucl=ekont*ees return end function ehbcorr_nucl !------------------------------------------------------------------------- real(kind=8) function ehbcorr3_nucl(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,ilist,m, iresshield real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,& ees0mkl,ees,coeffpees0pij,coeffmees0mij,& coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, & rlocshield lprn=.false. eij=facont_hb(jj,i) ekl=facont_hb(kk,k) ees0pij=ees0p(jj,i) ees0pkl=ees0p(kk,k) ees0mij=ees0m(jj,i) ees0mkl=ees0m(kk,k) ekont=eij*ekl ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) !cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) !C Following 4 lines for diagnostics. !cd ees0pkl=0.0D0 !cd ees0pij=1.0D0 !cd ees0mkl=0.0D0 !cd ees0mij=1.0D0 !cd write (iout,*)'Contacts have occurred for nucleic bases', !cd & i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l !cd & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees !C Calculate the multi-body contribution to energy. ! ecorr=ecorr+ekont*ees !C Calculate multi-body contributions to the gradient. coeffpees0pij=coeffp*ees0pij coeffmees0mij=coeffm*ees0mij coeffpees0pkl=coeffp*ees0pkl coeffmees0mkl=coeffm*ees0mkl do ll=1,3 gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+& coeffmees0mkl*gacontm_hb1(ll,jj,i)) gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ & coeffmees0mkl*gacontm_hb2(ll,jj,i)) gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ & coeffmees0mij*gacontm_hb1(ll,kk,k)) gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) & -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)) gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ & coeffmees0mij*gacontm_hb3(ll,kk,k)) gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl enddo ehbcorr3_nucl=ekont*ees return end function ehbcorr3_nucl #ifdef MPI subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer) integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old real(kind=8):: buffer(dimen1,dimen2) num_kont=num_cont_hb(atom) do i=1,num_kont do k=1,8 do j=1,3 buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k) enddo ! j enddo ! k buffer(i,indx+25)=facont_hb(i,atom) buffer(i,indx+26)=ees0p(i,atom) buffer(i,indx+27)=ees0m(i,atom) buffer(i,indx+28)=d_cont(i,atom) buffer(i,indx+29)=dfloat(jcont_hb(i,atom)) enddo ! i buffer(1,indx+30)=dfloat(num_kont) return end subroutine pack_buffer !c------------------------------------------------------------------------------ subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer) integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old real(kind=8):: buffer(dimen1,dimen2) ! double precision zapas ! common /contacts_hb/ zapas(3,maxconts,maxres,8), ! & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), ! & ees0m(maxconts,maxres),d_cont(maxconts,maxres), ! & num_cont_hb(maxres),jcont_hb(maxconts,maxres) num_kont=buffer(1,indx+30) num_kont_old=num_cont_hb(atom) num_cont_hb(atom)=num_kont+num_kont_old do i=1,num_kont ii=i+num_kont_old do k=1,8 do j=1,3 zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j) enddo ! j enddo ! k facont_hb(ii,atom)=buffer(i,indx+25) ees0p(ii,atom)=buffer(i,indx+26) ees0m(ii,atom)=buffer(i,indx+27) d_cont(i,atom)=buffer(i,indx+28) jcont_hb(ii,atom)=buffer(i,indx+29) enddo ! i return end subroutine unpack_buffer !c------------------------------------------------------------------------------ #endif subroutine ecatcat(ecationcation) integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,& r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, & dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,& gg,r ecationcation=0.0d0 if (nres_molec(5).eq.0) return rcat0=3.472 epscalc=0.05 r06 = rcat0**6 r012 = r06**2 ! k0 = 332.0*(2.0*2.0)/80.0 itmp=0 do i=1,4 itmp=itmp+nres_molec(i) enddo ! write(iout,*) "itmp",itmp do i=itmp+1,itmp+nres_molec(5)-1 xi=c(1,i) yi=c(2,i) zi=c(3,i) ! write (iout,*) i,"TUTUT",c(1,i) itypi=itype(i,5) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) do j=i+1,itmp+nres_molec(5) itypj=itype(j,5) ! print *,i,j,itypi,itypj k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0 ! print *,i,j,'catcat' xj=c(1,j) yj=c(2,j) zj=c(3,j) call to_box(xj,yj,zj) ! call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) ! aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 ! bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) rcal =xj**2+yj**2+zj**2 ract=sqrt(rcal) ! rcat0=3.472 ! epscalc=0.05 ! r06 = rcat0**6 ! r012 = r06**2 ! k0 = 332*(2*2)/80 Evan1cat=epscalc*(r012/(rcal**6)) Evan2cat=epscalc*2*(r06/(rcal**3)) Eeleccat=k0/ract r7 = rcal**7 r4 = rcal**4 r(1)=xj r(2)=yj r(3)=zj do k=1,3 dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7 dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4 dEeleccat(k)=-k0*r(k)/ract**3 enddo do k=1,3 gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k) gradcatcat(k,i)=gradcatcat(k,i)-gg(k) gradcatcat(k,j)=gradcatcat(k,j)+gg(k) enddo if (energy_dec) write (iout,*) i,j,Evan1cat,Evan2cat,Eeleccat,& r012,rcal**6,ichargecat(itypi)*ichargecat(itypj) ! write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat enddo enddo return end subroutine ecatcat !--------------------------------------------------------------------------- ! new for K+ subroutine ecats_prot_amber(evdw) ! subroutine ecat_prot2(ecation_prot) use calc_data use comm_momo logical :: lprn !el local variables integer :: iint,itypi1,subchap,isel,itmp real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi real(kind=8) :: evdw,aa,bb real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,ssgradlipi,ssgradlipj, & sslipi,sslipj,faclip,alpha_sco integer :: ii real(kind=8) :: fracinbuf real (kind=8) :: escpho real (kind=8),dimension(4):: ener real(kind=8) :: b1,b2,egb real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,& Lambf,& Chif,ChiLambf,Fcav,dFdR,dFdOM1,& ecations_prot_amber,dFdOM2,dFdL,dFdOM12,& federmaus,& d1i,d1j ! real(kind=8),dimension(3,2)::erhead_tail ! real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance real(kind=8) :: facd4, adler, Fgb, facd3 integer troll,jj,istate real (kind=8) :: dcosom1(3),dcosom2(3) evdw=0.0D0 if (nres_molec(5).eq.0) return eps_out=80.0d0 ! sss_ele_cut=1.0d0 itmp=0 do i=1,4 itmp=itmp+nres_molec(i) enddo ! go to 17 ! do i=1,nres_molec(1)-1 ! loop over all peptide groups needs parralelization do i=ibond_start,ibond_end ! print *,"I am in EVDW",i itypi=iabs(itype(i,1)) ! if (i.ne.47) cycle if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle itypi1=iabs(itype(i+1,1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) dsci_inv=vbld_inv(i+nres) do j=itmp+1,itmp+nres_molec(5) ! Calculate SC interaction energy. itypj=iabs(itype(j,5)) if ((itypj.eq.ntyp1)) cycle CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol) dscj_inv=0.0 xj=c(1,j) yj=c(2,j) zj=c(3,j) call to_box(xj,yj,zj) ! call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) ! aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 ! bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) ! dxj = dc_norm( 1, nres+j ) ! dyj = dc_norm( 2, nres+j ) ! dzj = dc_norm( 3, nres+j ) itypi = itype(i,1) itypj = itype(j,5) ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella ! sampling performed with amber package ! alf1 = 0.0d0 ! alf2 = 0.0d0 ! alf12 = 0.0d0 ! a12sq = rborn(itypi,itypj) * rborn(itypj,itypi) chi1 = chi1cat(itypi,itypj) chis1 = chis1cat(itypi,itypj) chip1 = chipp1cat(itypi,itypj) ! chi1=0.0d0 ! chis1=0.0d0 ! chip1=0.0d0 chi2=0.0 chip2=0.0 chis2=0.0 ! chis2 = chis(itypj,itypi) chis12 = chis1 * chis2 sig1 = sigmap1cat(itypi,itypj) ! sig2 = sigmap2(itypi,itypj) ! alpha factors from Fcav/Gcav b1cav = alphasurcat(1,itypi,itypj) b2cav = alphasurcat(2,itypi,itypj) b3cav = alphasurcat(3,itypi,itypj) b4cav = alphasurcat(4,itypi,itypj) ! used to determine whether we want to do quadrupole calculations eps_in = epsintabcat(itypi,itypj) if (eps_in.eq.0.0) eps_in=1.0 eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) ! Rtail = 0.0d0 DO k = 1, 3 ctail(k,1)=c(k,i+nres) ctail(k,2)=c(k,j) END DO !c! tail distances will be themselves usefull elswhere !c1 (in Gcav, for example) Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 ) Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 ) Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 ) Rtail = dsqrt( & (Rtail_distance(1)*Rtail_distance(1)) & + (Rtail_distance(2)*Rtail_distance(2)) & + (Rtail_distance(3)*Rtail_distance(3))) ! tail location and distance calculations ! dhead1 d1 = dheadcat(1, 1, itypi, itypj) ! d2 = dhead(2, 1, itypi, itypj) DO k = 1,3 ! location of polar head is computed by taking hydrophobic centre ! and moving by a d1 * dc_norm vector ! see unres publications for very informative images chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) chead(k,2) = c(k, j) ! distance ! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) ! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) Rhead_distance(k) = chead(k,2) - chead(k,1) END DO ! pitagoras (root of sum of squares) Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) !------------------------------------------------------------------- ! zero everything that should be zero'ed evdwij = 0.0d0 ECL = 0.0d0 Elj = 0.0d0 Equad = 0.0d0 Epol = 0.0d0 Fcav=0.0d0 eheadtail = 0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 Fcav = 0.0d0 dFdR = 0.0d0 dCAVdOM1 = 0.0d0 dCAVdOM2 = 0.0d0 dCAVdOM12 = 0.0d0 dscj_inv = vbld_inv(j+nres) ! print *,i,j,dscj_inv,dsci_inv ! rij holds 1/(distance of Calpha atoms) rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj) rij = dsqrt(rrij) CALL sc_angular ! this should be in elgrad_init but om's are calculated by sc_angular ! which in turn is used by older potentials ! om = omega, sqom = om^2 sqom1 = om1 * om1 sqom2 = om2 * om2 sqom12 = om12 * om12 ! now we calculate EGB - Gey-Berne ! It will be summed up in evdwij and saved in evdw sigsq = 1.0D0 / sigsq sig = sig0ij * dsqrt(sigsq) ! rij_shift = 1.0D0 / rij - sig + sig0ij rij_shift = Rtail - sig + sig0ij IF (rij_shift.le.0.0D0) THEN evdw = 1.0D20 RETURN END IF sigder = -sig * sigsq rij_shift = 1.0D0 / rij_shift fac = rij_shift**expon c1 = fac * fac * aa_aq_cat(itypi,itypj) ! print *,"ADAM",aa_aq(itypi,itypj) ! c1 = 0.0d0 c2 = fac * bb_aq_cat(itypi,itypj) ! c2 = 0.0d0 evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) eps2der = eps3rt * evdwij eps3der = eps2rt * evdwij ! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij evdwij = eps2rt * eps3rt * evdwij !#ifdef TSCSC ! IF (bb_aq(itypi,itypj).gt.0) THEN ! evdw_p = evdw_p + evdwij ! ELSE ! evdw_m = evdw_m + evdwij ! END IF !#else evdw = evdw & + evdwij !#endif c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 fac = -expon * (c1 + evdwij) * rij_shift sigder = fac * sigder ! Calculate distance derivative gg(1) = fac gg(2) = fac gg(3) = fac fac = chis1 * sqom1 + chis2 * sqom2 & - 2.0d0 * chis12 * om1 * om2 * om12 pom = 1.0d0 - chis1 * chis2 * sqom12 Lambf = (1.0d0 - (fac / pom)) Lambf = dsqrt(Lambf) sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0) Chif = Rtail * sparrow ChiLambf = Chif * Lambf eagle = dsqrt(ChiLambf) bat = ChiLambf ** 11.0d0 top = b1cav * ( eagle + b2cav * ChiLambf - b3cav ) bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0) botsq = bot * bot Fcav = top / bot dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf)) dbot = 12.0d0 * b4cav * bat * Lambf dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif)) dbot = 12.0d0 * b4cav * bat * Chif eagle = Lambf * pom dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle) dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle) dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) & * (chis2 * om2 * om12 - om1) / (eagle * pom) dFdL = ((dtop * bot - top * dbot) / botsq) dCAVdOM1 = dFdL * ( dFdOM1 ) dCAVdOM2 = dFdL * ( dFdOM2 ) dCAVdOM12 = dFdL * ( dFdOM12 ) DO k= 1, 3 ertail(k) = Rtail_distance(k)/Rtail END DO erdxi = scalar( ertail(1), dC_norm(1,i+nres) ) erdxj = scalar( ertail(1), dC_norm(1,j) ) facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres) facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) gradpepcatx(k,i) = gradpepcatx(k,i) & - (( dFdR + gg(k) ) * pom) pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres)) ! gvdwx(k,j) = gvdwx(k,j) & ! + (( dFdR + gg(k) ) * pom) gradpepcat(k,i) = gradpepcat(k,i) & - (( dFdR + gg(k) ) * ertail(k)) gradpepcat(k,j) = gradpepcat(k,j) & + (( dFdR + gg(k) ) * ertail(k)) gg(k) = 0.0d0 ENDDO !c! Compute head-head and head-tail energies for each state isel = iabs(Qi) + 1 ! ion is always charged so iabs(Qj) IF (isel.eq.0) THEN !c! No charges - do nothing eheadtail = 0.0d0 ELSE IF (isel.eq.1) THEN !c! Nonpolar-charge interactions if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then Qi=Qi*2 Qij=Qij*2 endif if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then Qj=Qj*2 Qij=Qij*2 endif CALL enq_cat(epol) eheadtail = epol ! eheadtail = 0.0d0 ELSE IF (isel.eq.3) THEN !c! Dipole-charge interactions if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then Qi=Qi*2 Qij=Qij*2 endif if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then Qj=Qj*2 Qij=Qij*2 endif ! write(iout,*) "KURWA0",d1 CALL edq_cat(ecl, elj, epol) eheadtail = ECL + elj + epol ! eheadtail = 0.0d0 ELSE IF ((isel.eq.2)) THEN !c! Same charge-charge interaction ( +/+ or -/- ) if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then Qi=Qi*2 Qij=Qij*2 endif if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then Qj=Qj*2 Qij=Qij*2 endif CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj) eheadtail = ECL + Egb + Epol + Fisocav + Elj ! eheadtail = 0.0d0 ! ELSE IF ((isel.eq.2.and. & ! iabs(Qi).eq.1).and. & ! nstate(itypi,itypj).ne.1) THEN !c! Different charge-charge interaction ( +/- or -/+ ) ! if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then ! Qi=Qi*2 ! Qij=Qij*2 ! endif ! if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then ! Qj=Qj*2 ! Qij=Qij*2 ! endif ! ! CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) END IF ! this endif ends the "catch the gly-gly" at the beggining of Fcav evdw = evdw + Fcav + eheadtail IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') & restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,& 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,& Equad,evdwij+Fcav+eheadtail,evdw ! evdw = evdw + Fcav + eheadtail ! iF (nstate(itypi,itypj).eq.1) THEN CALL sc_grad_cat ! END IF !c!------------------------------------------------------------------- !c! NAPISY KONCOWE END DO ! j END DO ! i !c write (iout,*) "Number of loop steps in EGB:",ind !c energy_dec=.false. ! print *,"EVDW KURW",evdw,nres !!! return 17 continue do i=ibond_start,ibond_end ! print *,"I am in EVDW",i itypi=10 ! the peptide group parameters are for glicine ! if (i.ne.47) cycle if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle itypi1=iabs(itype(i+1,1)) xi=(c(1,i)+c(1,i+1))/2.0 yi=(c(2,i)+c(2,i+1))/2.0 zi=(c(3,i)+c(3,i+1))/2.0 call to_box(xi,yi,zi) dxi=dc_norm(1,i) dyi=dc_norm(2,i) dzi=dc_norm(3,i) dsci_inv=vbld_inv(i+1)/2.0 do j=itmp+1,itmp+nres_molec(5) ! Calculate SC interaction energy. itypj=iabs(itype(j,5)) if ((itypj.eq.ntyp1)) cycle CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol) dscj_inv=0.0 xj=c(1,j) yj=c(2,j) zj=c(3,j) call to_box(xj,yj,zj) dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 dxj = 0.0d0! dc_norm( 1, nres+j ) dyj = 0.0d0!dc_norm( 2, nres+j ) dzj = 0.0d0! dc_norm( 3, nres+j ) itypi = 10 itypj = itype(j,5) ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella ! sampling performed with amber package ! alf1 = 0.0d0 ! alf2 = 0.0d0 ! alf12 = 0.0d0 ! a12sq = rborn(itypi,itypj) * rborn(itypj,itypi) chi1 = chi1cat(itypi,itypj) chis1 = chis1cat(itypi,itypj) chip1 = chipp1cat(itypi,itypj) ! chi1=0.0d0 ! chis1=0.0d0 ! chip1=0.0d0 chi2=0.0 chip2=0.0 chis2=0.0 ! chis2 = chis(itypj,itypi) chis12 = chis1 * chis2 sig1 = sigmap1cat(itypi,itypj) ! sig2 = sigmap2(itypi,itypj) ! alpha factors from Fcav/Gcav b1cav = alphasurcat(1,itypi,itypj) b2cav = alphasurcat(2,itypi,itypj) b3cav = alphasurcat(3,itypi,itypj) b4cav = alphasurcat(4,itypi,itypj) ! used to determine whether we want to do quadrupole calculations eps_in = epsintabcat(itypi,itypj) if (eps_in.eq.0.0) eps_in=1.0 eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) ! Rtail = 0.0d0 DO k = 1, 3 ctail(k,1)=(c(k,i)+c(k,i+1))/2.0 ctail(k,2)=c(k,j) END DO !c! tail distances will be themselves usefull elswhere !c1 (in Gcav, for example) Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 ) Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 ) Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 ) Rtail = dsqrt( & (Rtail_distance(1)*Rtail_distance(1)) & + (Rtail_distance(2)*Rtail_distance(2)) & + (Rtail_distance(3)*Rtail_distance(3))) ! tail location and distance calculations ! dhead1 d1 = dheadcat(1, 1, itypi, itypj) ! print *,"d1",d1 ! d1=0.0d0 ! d2 = dhead(2, 1, itypi, itypj) DO k = 1,3 ! location of polar head is computed by taking hydrophobic centre ! and moving by a d1 * dc_norm vector ! see unres publications for very informative images chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i) chead(k,2) = c(k, j) ! distance ! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) ! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) Rhead_distance(k) = chead(k,2) - chead(k,1) END DO ! pitagoras (root of sum of squares) Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) !------------------------------------------------------------------- ! zero everything that should be zero'ed evdwij = 0.0d0 ECL = 0.0d0 Elj = 0.0d0 Equad = 0.0d0 Epol = 0.0d0 Fcav=0.0d0 eheadtail = 0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 Fcav = 0.0d0 dFdR = 0.0d0 dCAVdOM1 = 0.0d0 dCAVdOM2 = 0.0d0 dCAVdOM12 = 0.0d0 dscj_inv = vbld_inv(j+nres) ! print *,i,j,dscj_inv,dsci_inv ! rij holds 1/(distance of Calpha atoms) rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj) rij = dsqrt(rrij) CALL sc_angular ! this should be in elgrad_init but om's are calculated by sc_angular ! which in turn is used by older potentials ! om = omega, sqom = om^2 sqom1 = om1 * om1 sqom2 = om2 * om2 sqom12 = om12 * om12 ! now we calculate EGB - Gey-Berne ! It will be summed up in evdwij and saved in evdw sigsq = 1.0D0 / sigsq sig = sig0ij * dsqrt(sigsq) ! rij_shift = 1.0D0 / rij - sig + sig0ij rij_shift = Rtail - sig + sig0ij IF (rij_shift.le.0.0D0) THEN evdw = 1.0D20 RETURN END IF sigder = -sig * sigsq rij_shift = 1.0D0 / rij_shift fac = rij_shift**expon c1 = fac * fac * aa_aq_cat(itypi,itypj) ! print *,"ADAM",aa_aq(itypi,itypj) ! c1 = 0.0d0 c2 = fac * bb_aq_cat(itypi,itypj) ! c2 = 0.0d0 evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) eps2der = eps3rt * evdwij eps3der = eps2rt * evdwij ! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij evdwij = eps2rt * eps3rt * evdwij !#ifdef TSCSC ! IF (bb_aq(itypi,itypj).gt.0) THEN ! evdw_p = evdw_p + evdwij ! ELSE ! evdw_m = evdw_m + evdwij ! END IF !#else evdw = evdw & + evdwij !#endif c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 fac = -expon * (c1 + evdwij) * rij_shift sigder = fac * sigder ! Calculate distance derivative gg(1) = fac gg(2) = fac gg(3) = fac fac = chis1 * sqom1 + chis2 * sqom2 & - 2.0d0 * chis12 * om1 * om2 * om12 pom = 1.0d0 - chis1 * chis2 * sqom12 ! print *,"TUT2",fac,chis1,sqom1,pom Lambf = (1.0d0 - (fac / pom)) Lambf = dsqrt(Lambf) sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0) Chif = Rtail * sparrow ChiLambf = Chif * Lambf eagle = dsqrt(ChiLambf) bat = ChiLambf ** 11.0d0 top = b1cav * ( eagle + b2cav * ChiLambf - b3cav ) bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0) botsq = bot * bot Fcav = top / bot dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf)) dbot = 12.0d0 * b4cav * bat * Lambf dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif)) dbot = 12.0d0 * b4cav * bat * Chif eagle = Lambf * pom dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle) dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle) dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) & * (chis2 * om2 * om12 - om1) / (eagle * pom) dFdL = ((dtop * bot - top * dbot) / botsq) dCAVdOM1 = dFdL * ( dFdOM1 ) dCAVdOM2 = dFdL * ( dFdOM2 ) dCAVdOM12 = dFdL * ( dFdOM12 ) DO k= 1, 3 ertail(k) = Rtail_distance(k)/Rtail END DO erdxi = scalar( ertail(1), dC_norm(1,i) ) erdxj = scalar( ertail(1), dC_norm(1,j) ) facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i) facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i)) ! gradpepcatx(k,i) = gradpepcatx(k,i) & ! - (( dFdR + gg(k) ) * pom) pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres)) ! gvdwx(k,j) = gvdwx(k,j) & ! + (( dFdR + gg(k) ) * pom) gradpepcat(k,i) = gradpepcat(k,i) & - (( dFdR + gg(k) ) * ertail(k))/2.0d0 gradpepcat(k,i+1) = gradpepcat(k,i+1) & - (( dFdR + gg(k) ) * ertail(k))/2.0d0 gradpepcat(k,j) = gradpepcat(k,j) & + (( dFdR + gg(k) ) * ertail(k)) gg(k) = 0.0d0 ENDDO !c! Compute head-head and head-tail energies for each state isel = 3 !c! Dipole-charge interactions if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then Qi=Qi*2 Qij=Qij*2 endif if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then Qj=Qj*2 Qij=Qij*2 endif CALL edq_cat_pep(ecl, elj, epol) eheadtail = ECL + elj + epol ! print *,"i,",i,eheadtail ! eheadtail = 0.0d0 evdw = evdw + Fcav + eheadtail IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') & restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,& 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,& Equad,evdwij+Fcav+eheadtail,evdw ! evdw = evdw + Fcav + eheadtail ! iF (nstate(itypi,itypj).eq.1) THEN CALL sc_grad_cat_pep ! END IF !c!------------------------------------------------------------------- !c! NAPISY KONCOWE END DO ! j END DO ! i !c write (iout,*) "Number of loop steps in EGB:",ind !c energy_dec=.false. ! print *,"EVDW KURW",evdw,nres return end subroutine ecats_prot_amber !--------------------------------------------------------------------------- ! old for Ca2+ subroutine ecat_prot(ecation_prot) ! use calc_data ! use comm_momo integer i,j,k,subchap,itmp,inum real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,& r7,r4,ecationcation real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, & dist_init,dist_temp,ecation_prot,rcal,rocal, & Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, & catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, & wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet, & costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,& Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, & rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt, & opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,& opt13,opt14,opt15,opt16,opt17,opt18,opt19, & Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,& ndiv,ndivi real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,& gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, & dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, & tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat, & v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,& dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp, & dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,& dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,& dEvan1Cat real(kind=8),dimension(6) :: vcatprm ecation_prot=0.0d0 ! first lets calculate interaction with peptide groups if (nres_molec(5).eq.0) return itmp=0 do i=1,4 itmp=itmp+nres_molec(i) enddo ! do i=1,nres_molec(1)-1 ! loop over all peptide groups needs parralelization do i=ibond_start,ibond_end ! cycle if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms 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)) call to_box(xi,yi,zi) do j=itmp+1,itmp+nres_molec(5) ! print *,"WTF",itmp,j,i ! all parameters were for Ca2+ to approximate single charge divide by two ndiv=1.0 if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0 wconst=78*ndiv wdip =1.092777950857032D2 wdip=wdip/wconst wmodquad=-2.174122713004870D4 wmodquad=wmodquad/wconst wquad1 = 3.901232068562804D1 wquad1=wquad1/wconst wquad2 = 3 wquad2=wquad2/wconst wvan1 = 0.1 wvan2 = 6 ! itmp=0 xj=c(1,j) yj=c(2,j) zj=c(3,j) call to_box(xj,yj,zj) dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 ! enddo ! enddo rcpm = sqrt(xj**2+yj**2+zj**2) drcp_norm(1)=xj/rcpm drcp_norm(2)=yj/rcpm drcp_norm(3)=zj/rcpm dcmag=0.0 do k=1,3 dcmag=dcmag+dc(k,i)**2 enddo dcmag=dsqrt(dcmag) do k=1,3 myd_norm(k)=dc(k,i)/dcmag enddo costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+& drcp_norm(3)*myd_norm(3) rsecp = rcpm**2 Ir = 1.0d0/rcpm Irsecp = 1.0d0/rsecp Irthrp = Irsecp/rcpm Irfourp = Irthrp/rcpm Irfiftp = Irfourp/rcpm Irsistp=Irfiftp/rcpm Irseven=Irsistp/rcpm Irtwelv=Irsistp*Irsistp Irthir=Irtwelv/rcpm sin2thet = (1-costhet*costhet) sinthet=sqrt(sin2thet) E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)& *sin2thet E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-& 2*wvan2**6*Irsistp) ecation_prot = ecation_prot+E1+E2 ! print *,"ecatprot",i,j,ecation_prot,rcpm dE1dr = -2*costhet*wdip*Irthrp-& (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet dE2dr = 3*wquad1*wquad2*Irfourp- & 12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven) dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet do k=1,3 drdpep(k) = -drcp_norm(k) dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k)) dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k) dEddci(k) = dEdcos*dcosddci(k) enddo do k=1,3 gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k) gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k) gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k) enddo enddo ! j enddo ! i !------------------------------------------sidechains ! do i=1,nres_molec(1) do i=ibond_start,ibond_end if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms ! cycle ! print *,i,ecation_prot xi=(c(1,i+nres)) yi=(c(2,i+nres)) zi=(c(3,i+nres)) call to_box(xi,yi,zi) do k=1,3 cm1(k)=dc(k,i+nres) enddo cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2) do j=itmp+1,itmp+nres_molec(5) ndiv=1.0 if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0 xj=c(1,j) yj=c(2,j) zj=c(3,j) call to_box(xj,yj,zj) dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 ! enddo ! enddo ! 15- Glu 16-Asp if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.& ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.& (itype(i,1).eq.25))) then if(itype(i,1).eq.16) then inum=1 else inum=2 endif do k=1,6 vcatprm(k)=catprm(k,inum) enddo dASGL=catprm(7,inum) ! do k=1,3 ! vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres) vcm(1)=(cm1(1)/cm1mag)*dASGL+xi vcm(2)=(cm1(2)/cm1mag)*dASGL+yi vcm(3)=(cm1(3)/cm1mag)*dASGL+zi ! valpha(k)=c(k,i) ! vcat(k)=c(k,j) if (subchap.eq.1) then vcat(1)=xj_temp vcat(2)=yj_temp vcat(3)=zj_temp else vcat(1)=xj_safe vcat(2)=yj_safe vcat(3)=zj_safe endif valpha(1)=xi-c(1,i+nres)+c(1,i) valpha(2)=yi-c(2,i+nres)+c(2,i) valpha(3)=zi-c(3,i+nres)+c(3,i) ! enddo do k=1,3 dx(k) = vcat(k)-vcm(k) enddo do k=1,3 v1(k)=(vcm(k)-valpha(k)) v2(k)=(vcat(k)-valpha(k)) enddo v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2) v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2) v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3) ! The weights of the energy function calculated from !The quantum mechanical GAMESS simulations of calcium with ASP/GLU if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then ndivi=0.5 else ndivi=1.0 endif ndiv=1.0 if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0 wh2o=78*ndivi*ndiv wc = vcatprm(1) wc=wc/wh2o wdip =vcatprm(2) wdip=wdip/wh2o wquad1 =vcatprm(3) wquad1=wquad1/wh2o wquad2 = vcatprm(4) wquad2=wquad2/wh2o wquad2p = 1.0d0-wquad2 wvan1 = vcatprm(5) wvan2 =vcatprm(6) opt = dx(1)**2+dx(2)**2 rsecp = opt+dx(3)**2 rs = sqrt(rsecp) rthrp = rsecp*rs rfourp = rthrp*rs rsixp = rfourp*rsecp reight=rsixp*rsecp Ir = 1.0d0/rs Irsecp = 1.0d0/rsecp Irthrp = Irsecp/rs Irfourp = Irthrp/rs Irsixp = 1.0d0/rsixp Ireight=1.0d0/reight Irtw=Irsixp*Irsixp Irthir=Irtw/rs Irfourt=Irthir/rs opt1 = (4*rs*dx(3)*wdip) opt2 = 6*rsecp*wquad1*opt opt3 = wquad1*wquad2p*Irsixp opt4 = (wvan1*wvan2**12) opt5 = opt4*12*Irfourt opt6 = 2*wvan1*wvan2**6 opt7 = 6*opt6*Ireight opt8 = wdip/v1m opt10 = wdip/v2m opt11 = (rsecp*v2m)**2 opt12 = (rsecp*v1m)**2 opt14 = (v1m*v2m*rsecp)**2 opt15 = -wquad1/v2m**2 opt16 = (rthrp*(v1m*v2m)**2)**2 opt17 = (v1m**2*rthrp)**2 opt18 = -wquad1/rthrp opt19 = (v1m**2*v2m**2)**2 Ec = wc*Ir do k=1,3 dEcCat(k) = -(dx(k)*wc)*Irthrp dEcCm(k)=(dx(k)*wc)*Irthrp dEcCalp(k)=0.0d0 enddo Edip=opt8*(v1dpv2)/(rsecp*v2m) do k=1,3 dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m & *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11 dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m & *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12 dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m & *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) & *v1dpv2)/opt14 enddo Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2) do k=1,3 dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* & (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* & v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16 dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* & (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* & v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16 dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* & v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* & v1dpv2**2)/opt19 enddo Equad2=wquad1*wquad2p*Irthrp do k=1,3 dEquad2Cat(k)=-3*dx(k)*rs*opt3 dEquad2Cm(k)=3*dx(k)*rs*opt3 dEquad2Calp(k)=0.0d0 enddo Evan1=opt4*Irtw do k=1,3 dEvan1Cat(k)=-dx(k)*opt5 dEvan1Cm(k)=dx(k)*opt5 dEvan1Calp(k)=0.0d0 enddo Evan2=-opt6*Irsixp do k=1,3 dEvan2Cat(k)=dx(k)*opt7 dEvan2Cm(k)=-dx(k)*opt7 dEvan2Calp(k)=0.0d0 enddo ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2 ! print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2 do k=1,3 dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ & dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k) !c write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3) dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ & dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k) dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) & +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k) enddo dscmag = 0.0d0 do k=1,3 dscvec(k) = dc(k,i+nres) dscmag = dscmag+dscvec(k)*dscvec(k) enddo dscmag3 = dscmag dscmag = sqrt(dscmag) dscmag3 = dscmag3*dscmag constA = 1.0d0+dASGL/dscmag constB = 0.0d0 do k=1,3 constB = constB+dscvec(k)*dEtotalCm(k) enddo constB = constB*dASGL/dscmag3 do k=1,3 gg(k) = dEtotalCm(k)+dEtotalCalp(k) gradpepcatx(k,i)=gradpepcatx(k,i)+ & constA*dEtotalCm(k)-constB*dscvec(k) ! print *,j,constA,dEtotalCm(k),constB,dscvec(k) gradpepcat(k,i)=gradpepcat(k,i)+gg(k) gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k) enddo else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then if(itype(i,1).eq.14) then inum=3 else inum=4 endif do k=1,6 vcatprm(k)=catprm(k,inum) enddo dASGL=catprm(7,inum) ! do k=1,3 ! vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres) ! valpha(k)=c(k,i) ! vcat(k)=c(k,j) ! enddo vcm(1)=(cm1(1)/cm1mag)*dASGL+xi vcm(2)=(cm1(2)/cm1mag)*dASGL+yi vcm(3)=(cm1(3)/cm1mag)*dASGL+zi if (subchap.eq.1) then vcat(1)=xj_temp vcat(2)=yj_temp vcat(3)=zj_temp else vcat(1)=xj_safe vcat(2)=yj_safe vcat(3)=zj_safe endif valpha(1)=xi-c(1,i+nres)+c(1,i) valpha(2)=yi-c(2,i+nres)+c(2,i) valpha(3)=zi-c(3,i+nres)+c(3,i) do k=1,3 dx(k) = vcat(k)-vcm(k) enddo do k=1,3 v1(k)=(vcm(k)-valpha(k)) v2(k)=(vcat(k)-valpha(k)) enddo v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2) v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2) v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3) ! The weights of the energy function calculated from !The quantum mechanical GAMESS simulations of ASN/GLN with calcium ndiv=1.0 if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0 wh2o=78*ndiv wdip =vcatprm(2) wdip=wdip/wh2o wquad1 =vcatprm(3) wquad1=wquad1/wh2o wquad2 = vcatprm(4) wquad2=wquad2/wh2o wquad2p = 1-wquad2 wvan1 = vcatprm(5) wvan2 =vcatprm(6) opt = dx(1)**2+dx(2)**2 rsecp = opt+dx(3)**2 rs = sqrt(rsecp) rthrp = rsecp*rs rfourp = rthrp*rs rsixp = rfourp*rsecp reight=rsixp*rsecp Ir = 1.0d0/rs Irsecp = 1/rsecp Irthrp = Irsecp/rs Irfourp = Irthrp/rs Irsixp = 1/rsixp Ireight=1/reight Irtw=Irsixp*Irsixp Irthir=Irtw/rs Irfourt=Irthir/rs opt1 = (4*rs*dx(3)*wdip) opt2 = 6*rsecp*wquad1*opt opt3 = wquad1*wquad2p*Irsixp opt4 = (wvan1*wvan2**12) opt5 = opt4*12*Irfourt opt6 = 2*wvan1*wvan2**6 opt7 = 6*opt6*Ireight opt8 = wdip/v1m opt10 = wdip/v2m opt11 = (rsecp*v2m)**2 opt12 = (rsecp*v1m)**2 opt14 = (v1m*v2m*rsecp)**2 opt15 = -wquad1/v2m**2 opt16 = (rthrp*(v1m*v2m)**2)**2 opt17 = (v1m**2*rthrp)**2 opt18 = -wquad1/rthrp opt19 = (v1m**2*v2m**2)**2 Edip=opt8*(v1dpv2)/(rsecp*v2m) do k=1,3 dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m& *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11 dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m& *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12 dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m& *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)& *v1dpv2)/opt14 enddo Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2) do k=1,3 dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*& (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*& v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16 dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*& (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*& v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16 dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* & v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*& v1dpv2**2)/opt19 enddo Equad2=wquad1*wquad2p*Irthrp do k=1,3 dEquad2Cat(k)=-3*dx(k)*rs*opt3 dEquad2Cm(k)=3*dx(k)*rs*opt3 dEquad2Calp(k)=0.0d0 enddo Evan1=opt4*Irtw do k=1,3 dEvan1Cat(k)=-dx(k)*opt5 dEvan1Cm(k)=dx(k)*opt5 dEvan1Calp(k)=0.0d0 enddo Evan2=-opt6*Irsixp do k=1,3 dEvan2Cat(k)=dx(k)*opt7 dEvan2Cm(k)=-dx(k)*opt7 dEvan2Calp(k)=0.0d0 enddo ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2 do k=1,3 dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ & dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k) dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ & dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k) dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) & +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k) enddo dscmag = 0.0d0 do k=1,3 dscvec(k) = c(k,i+nres)-c(k,i) ! TU SPRAWDZ??? ! dscvec(1) = xj ! dscvec(2) = yj ! dscvec(3) = zj dscmag = dscmag+dscvec(k)*dscvec(k) enddo dscmag3 = dscmag dscmag = sqrt(dscmag) dscmag3 = dscmag3*dscmag constA = 1+dASGL/dscmag constB = 0.0d0 do k=1,3 constB = constB+dscvec(k)*dEtotalCm(k) enddo constB = constB*dASGL/dscmag3 do k=1,3 gg(k) = dEtotalCm(k)+dEtotalCalp(k) gradpepcatx(k,i)=gradpepcatx(k,i)+ & constA*dEtotalCm(k)-constB*dscvec(k) gradpepcat(k,i)=gradpepcat(k,i)+gg(k) gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k) enddo else rcal = 0.0d0 do k=1,3 ! r(k) = c(k,j)-c(k,i+nres) r(1) = xj r(2) = yj r(3) = zj rcal = rcal+r(k)*r(k) enddo ract=sqrt(rcal) rocal=1.5 epscalc=0.2 r0p=0.5*(rocal+sig0(itype(i,1))) r06 = r0p**6 r012 = r06*r06 Evan1=epscalc*(r012/rcal**6) Evan2=epscalc*2*(r06/rcal**3) r4 = rcal**4 r7 = rcal**7 do k=1,3 dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7 dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4 enddo do k=1,3 dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k) enddo ecation_prot = ecation_prot+ Evan1+Evan2 do k=1,3 gradpepcatx(k,i)=gradpepcatx(k,i)+ & dEtotalCm(k) gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k) gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k) enddo endif ! 13-16 residues enddo !j enddo !i return end subroutine ecat_prot !---------------------------------------------------------------------------- !--------------------------------------------------------------------------- subroutine ecat_nucl(ecation_nucl) integer i,j,k,subchap,itmp,inum,itypi,itypj real(kind=8) :: xi,yi,zi,xj,yj,zj real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, & dist_init,dist_temp,ecation_nucl,Evan1,Evan2,Ecav,Egb,wdip1,wdip2, & wvan1,wvan2,wgbsig,wgbeps,wgbchi,wgbchip,wcav1,wcav2,wcav3,wcav4, & wcavsig,wcavchi,v1m,v1dpdx,wh2o,wc,Edip,rcs2,invrcs6,invrcs8,invrcs12, & invrcs14,rcb,rcb2,invrcb,invrcb2,invrcb4,invrcb6,cosinus,cos2,dcosdcatconst, & dcosdcalpconst,dcosdcmconst,rcav,rcav11,rcav12,constcav1,constcav2, & constgb1,constgb2,constdvan1,constdvan2,sgb,sgb6,sgb7,sgb12,sgb13, & cavnum,cavdenom,invcavdenom2,dcavnumdcos,dcavnumdr,dcavdenomdcos, & dcavdenomdr,sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb real(kind=8),dimension(3) ::gg,r,dEtotalCm,dEtotalCalp,dEvan1Cm,& dEvan2Cm,cm1,cm,vcat,vsug,v1,v2,dx,vcm,dEdipCm,dEdipCalp, & dEvan1Calp,dEvan2Cat,dEvan2Calp,dEtotalCat,dEdipCat,dEvan1Cat,dcosdcat, & dcosdcalp,dcosdcm,dEgbdCat,dEgbdCalp,dEgbdCm,dEcavdCat,dEcavdCalp, & dEcavdCm real(kind=8),dimension(14) :: vcatnuclprm ecation_nucl=0.0d0 if (nres_molec(5).eq.0) return itmp=0 do i=1,4 itmp=itmp+nres_molec(i) enddo do i=iatsc_s_nucl,iatsc_e_nucl if ((itype(i,2).eq.ntyp1_molec(2))) cycle ! leave dummy atoms xi=(c(1,i+nres)) yi=(c(2,i+nres)) zi=(c(3,i+nres)) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) do k=1,3 cm1(k)=dc(k,i+nres) enddo do j=itmp+1,itmp+nres_molec(5) xj=c(1,j) yj=c(2,j) zj=c(3,j) call to_box(xj,yj,zj) ! call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) ! aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 ! bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) dist_init=xj**2+yj**2+zj**2 itypi=itype(i,2) itypj=itype(j,5) do k=1,13 vcatnuclprm(k)=catnuclprm(k,itypi,itypj) enddo do k=1,3 vcm(k)=c(k,i+nres) vsug(k)=c(k,i) vcat(k)=c(k,j) enddo do k=1,3 dx(k) = vcat(k)-vcm(k) enddo do k=1,3 v1(k)=dc(k,i+nres) v2(k)=(vcat(k)-vsug(k)) enddo v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2) v1dpdx = v1(1)*dx(1)+v1(2)*dx(2)+v1(3)*dx(3) ! The weights of the energy function calculated from !The quantum mechanical Gaussian simulations of potassium and sodium with deoxynucleosides wh2o=78 wdip1 = vcatnuclprm(1) wdip1 = wdip1/wh2o !w1 wdip2 = vcatnuclprm(2) wdip2 = wdip2/wh2o !w2 wvan1 = vcatnuclprm(3) wvan2 = vcatnuclprm(4) !pis1 wgbsig = vcatnuclprm(5) !sigma0 wgbeps = vcatnuclprm(6) !epsi0 wgbchi = vcatnuclprm(7) !chi1 wgbchip = vcatnuclprm(8) !chip1 wcavsig = vcatnuclprm(9) !sig wcav1 = vcatnuclprm(10) !b1 wcav2 = vcatnuclprm(11) !b2 wcav3 = vcatnuclprm(12) !b3 wcav4 = vcatnuclprm(13) !b4 wcavchi = vcatnuclprm(14) !chis1 rcs2 = v2(1)**2+v2(2)**2+v2(3)**2 invrcs6 = 1/rcs2**3 invrcs8 = invrcs6/rcs2 invrcs12 = invrcs6**2 invrcs14 = invrcs12/rcs2 rcb2 = dx(1)**2+dx(2)**2+dx(3)**2 rcb = sqrt(rcb2) invrcb = 1/rcb invrcb2 = invrcb**2 invrcb4 = invrcb2**2 invrcb6 = invrcb4*invrcb2 cosinus = v1dpdx/(v1m*rcb) cos2 = cosinus**2 dcosdcatconst = invrcb2/v1m dcosdcalpconst = invrcb/v1m**2 dcosdcmconst = invrcb2/v1m**2 do k=1,3 dcosdcat(k) = (v1(k)*rcb-dx(k)*v1m*cosinus)*dcosdcatconst dcosdcalp(k) = (v1(k)*rcb*cosinus-dx(k)*v1m)*dcosdcalpconst dcosdcm(k) = ((dx(k)-v1(k))*v1m*rcb+ & cosinus*(dx(k)*v1m**2-v1(k)*rcb2))*dcosdcmconst enddo rcav = rcb/wcavsig rcav11 = rcav**11 rcav12 = rcav11*rcav constcav1 = 1-wcavchi*cos2 constcav2 = sqrt(constcav1) constgb1 = 1/sqrt(1-wgbchi*cos2) constgb2 = wgbeps*(1-wgbchip*cos2)**2 constdvan1 = 12*wvan1*wvan2**12*invrcs14 constdvan2 = 6*wvan1*wvan2**6*invrcs8 !---------------------------------------------------------------------------- !Gay-Berne term !--------------------------------------------------------------------------- sgb = 1/(1-constgb1+(rcb/wgbsig)) sgb6 = sgb**6 sgb7 = sgb6*sgb sgb12 = sgb6**2 sgb13 = sgb12*sgb Egb = constgb2*(sgb12-sgb6) do k=1,3 dEgbdCat(k) = -constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) & +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) & -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcat(k) dEgbdCm(k) = constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) & +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) & -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcm(k) dEgbdCalp(k) = (constgb1**3*constgb2*wgbchi*cosinus & *(12*sgb13-6*sgb7) & -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcalp(k) enddo !---------------------------------------------------------------------------- !cavity term !--------------------------------------------------------------------------- cavnum = sqrt(rcav*constcav2)+wcav2*rcav*constcav2-wcav3 cavdenom = 1+wcav4*rcav12*constcav1**6 Ecav = wcav1*cavnum/cavdenom invcavdenom2 = 1/cavdenom**2 dcavnumdcos = -wcavchi*cosinus/constcav2 & *(sqrt(rcav/constcav2)/2+wcav2*rcav) dcavnumdr = (0.5*sqrt(constcav2/rcav)+wcav2*constcav2)/wcavsig dcavdenomdcos = -12*wcav4*wcavchi*rcav12*constcav1**5*cosinus dcavdenomdr = 12*wcav4/wcavsig*rcav11*constcav1**6 do k=1,3 dEcavdCat(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) & *dcosdcat(k)+(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2 dEcavdCm(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) & *dcosdcm(k)-(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2 dEcavdCalp(k) = (dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) & *dcosdcalp(k)*wcav1*invcavdenom2 enddo !---------------------------------------------------------------------------- !van der Waals and dipole-charge interaction energy !--------------------------------------------------------------------------- Evan1 = wvan1*wvan2**12*invrcs12 do k=1,3 dEvan1Cat(k) = -v2(k)*constdvan1 dEvan1Cm(k) = 0.0d0 dEvan1Calp(k) = v2(k)*constdvan1 enddo Evan2 = -wvan1*wvan2**6*invrcs6 do k=1,3 dEvan2Cat(k) = v2(k)*constdvan2 dEvan2Cm(k) = 0.0d0 dEvan2Calp(k) = -v2(k)*constdvan2 enddo Edip = wdip1*cosinus*invrcb2-wdip2*(1-cos2)*invrcb4 do k=1,3 dEdipCat(k) = (-2*wdip1*cosinus*invrcb4 & +4*wdip2*(1-cos2)*invrcb6)*dx(k) & +dcosdcat(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4) dEdipCm(k) = (2*wdip1*cosinus*invrcb4 & -4*wdip2*(1-cos2)*invrcb6)*dx(k) & +dcosdcm(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4) dEdipCalp(k) = dcosdcalp(k)*(wdip1*invrcb2 & +2*wdip2*cosinus*invrcb4) enddo if (energy_dec) write (iout,'(2i5,4(a6,f7.3))') i,j, & ' E GB ',Egb,' ECav ',Ecav,' Evdw ',Evan1+Evan2,' Edip ',Edip ecation_nucl=ecation_nucl+Ecav+Egb+Edip+Evan1+Evan2 do k=1,3 dEtotalCat(k) = dEcavdCat(k)+dEvan1Cat(k)+dEvan2Cat(k) & +dEgbdCat(k)+dEdipCat(k) dEtotalCm(k) = dEcavdCm(k)+dEvan1Cm(k)+dEvan2Cm(k) & +dEgbdCm(k)+dEdipCm(k) dEtotalCalp(k) = dEcavdCalp(k)+dEgbdCalp(k)+dEvan1Calp(k) & +dEdipCalp(k)+dEvan2Calp(k) enddo do k=1,3 gg(k) = dEtotalCm(k)+dEtotalCalp(k) gradnuclcatx(k,i)=gradnuclcatx(k,i)+dEtotalCm(k) gradnuclcat(k,i)=gradnuclcat(k,i)+gg(k) gradnuclcat(k,j)=gradnuclcat(k,j)+dEtotalCat(k) enddo enddo !j enddo !i return end subroutine ecat_nucl !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- subroutine eprot_sc_base(escbase) 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,subchap real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi real(kind=8) :: evdw,sig0ij real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, & sslipi,sslipj,faclip integer :: ii real(kind=8) :: fracinbuf real (kind=8) :: escbase real (kind=8),dimension(4):: ener real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,& sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,& Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,& dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,& r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,& dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,& sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1 real(kind=8),dimension(3,2)::chead,erhead_tail real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead integer troll eps_out=80.0d0 escbase=0.0d0 ! do i=1,nres_molec(1) do i=ibond_start,ibond_end if (itype(i,1).eq.ntyp1_molec(1)) cycle itypi = itype(i,1) dxi = dc_norm(1,nres+i) dyi = dc_norm(2,nres+i) dzi = dc_norm(3,nres+i) dsci_inv = vbld_inv(i+nres) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1) itypj= itype(j,2) if (itype(j,2).eq.ntyp1_molec(2))cycle xj=c(1,j+nres) yj=c(2,j+nres) zj=c(3,j+nres) call to_box(xj,yj,zj) ! call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) ! aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 ! bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) dxj = dc_norm( 1, nres+j ) dyj = dc_norm( 2, nres+j ) dzj = dc_norm( 3, nres+j ) ! print *,i,j,itypi,itypj d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge ! d1i=0.0d0 ! d1j=0.0d0 ! BetaT = 1.0d0 / (298.0d0 * Rb) ! Gay-berne var's sig0ij = sigma_scbase( itypi,itypj ) chi1 = chi_scbase( itypi, itypj,1 ) chi2 = chi_scbase( itypi, itypj,2 ) ! chi1=0.0d0 ! chi2=0.0d0 chi12 = chi1 * chi2 chip1 = chipp_scbase( itypi, itypj,1 ) chip2 = chipp_scbase( itypi, itypj,2 ) ! chip1=0.0d0 ! chip2=0.0d0 chip12 = chip1 * chip2 ! not used by momo potential, but needed by sc_angular which is shared ! by all energy_potential subroutines alf1 = 0.0d0 alf2 = 0.0d0 alf12 = 0.0d0 a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj) ! a12sq = a12sq * a12sq ! charge of amino acid itypi is... chis1 = chis_scbase(itypi,itypj,1) chis2 = chis_scbase(itypi,itypj,2) chis12 = chis1 * chis2 sig1 = sigmap1_scbase(itypi,itypj) sig2 = sigmap2_scbase(itypi,itypj) ! write (*,*) "sig1 = ", sig1 ! write (*,*) "sig2 = ", sig2 ! alpha factors from Fcav/Gcav b1 = alphasur_scbase(1,itypi,itypj) ! b1=0.0d0 b2 = alphasur_scbase(2,itypi,itypj) b3 = alphasur_scbase(3,itypi,itypj) b4 = alphasur_scbase(4,itypi,itypj) ! used to determine whether we want to do quadrupole calculations ! used by Fgb eps_in = epsintab_scbase(itypi,itypj) if (eps_in.eq.0.0) eps_in=1.0 eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) ! write (*,*) "eps_inout_fac = ", eps_inout_fac !------------------------------------------------------------------- ! tail location and distance calculations DO k = 1,3 ! location of polar head is computed by taking hydrophobic centre ! and moving by a d1 * dc_norm vector ! see unres publications for very informative images chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres) chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres) ! distance ! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) ! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) Rhead_distance(k) = chead(k,2) - chead(k,1) END DO ! pitagoras (root of sum of squares) Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) !------------------------------------------------------------------- ! zero everything that should be zero'ed evdwij = 0.0d0 ECL = 0.0d0 Elj = 0.0d0 Equad = 0.0d0 Epol = 0.0d0 Fcav=0.0d0 eheadtail = 0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 Fcav = 0.0d0 dFdR = 0.0d0 dCAVdOM1 = 0.0d0 dCAVdOM2 = 0.0d0 dCAVdOM12 = 0.0d0 dscj_inv = vbld_inv(j+nres) ! print *,i,j,dscj_inv,dsci_inv ! rij holds 1/(distance of Calpha atoms) rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj) rij = dsqrt(rrij) !---------------------------- CALL sc_angular ! this should be in elgrad_init but om's are calculated by sc_angular ! which in turn is used by older potentials ! om = omega, sqom = om^2 sqom1 = om1 * om1 sqom2 = om2 * om2 sqom12 = om12 * om12 ! now we calculate EGB - Gey-Berne ! It will be summed up in evdwij and saved in evdw sigsq = 1.0D0 / sigsq sig = sig0ij * dsqrt(sigsq) ! rij_shift = 1.0D0 / rij - sig + sig0ij rij_shift = 1.0/rij - sig + sig0ij IF (rij_shift.le.0.0D0) THEN evdw = 1.0D20 RETURN END IF sigder = -sig * sigsq rij_shift = 1.0D0 / rij_shift fac = rij_shift**expon c1 = fac * fac * aa_scbase(itypi,itypj) ! c1 = 0.0d0 c2 = fac * bb_scbase(itypi,itypj) ! c2 = 0.0d0 evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) eps2der = eps3rt * evdwij eps3der = eps2rt * evdwij ! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij evdwij = eps2rt * eps3rt * evdwij c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 fac = -expon * (c1 + evdwij) * rij_shift sigder = fac * sigder ! fac = rij * fac ! Calculate distance derivative gg(1) = fac gg(2) = fac gg(3) = fac ! if (b2.gt.0.0) then fac = chis1 * sqom1 + chis2 * sqom2 & - 2.0d0 * chis12 * om1 * om2 * om12 ! we will use pom later in Gcav, so dont mess with it! pom = 1.0d0 - chis1 * chis2 * sqom12 Lambf = (1.0d0 - (fac / pom)) Lambf = dsqrt(Lambf) sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0) ! write (*,*) "sparrow = ", sparrow Chif = 1.0d0/rij * sparrow ChiLambf = Chif * Lambf eagle = dsqrt(ChiLambf) bat = ChiLambf ** 11.0d0 top = b1 * ( eagle + b2 * ChiLambf - b3 ) bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0) botsq = bot * bot Fcav = top / bot ! print *,i,j,Fcav dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf)) dbot = 12.0d0 * b4 * bat * Lambf dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow ! dFdR = 0.0d0 ! write (*,*) "dFcav/dR = ", dFdR dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif)) dbot = 12.0d0 * b4 * bat * Chif eagle = Lambf * pom dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle) dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle) dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) & * (chis2 * om2 * om12 - om1) / (eagle * pom) dFdL = ((dtop * bot - top * dbot) / botsq) ! dFdL = 0.0d0 dCAVdOM1 = dFdL * ( dFdOM1 ) dCAVdOM2 = dFdL * ( dFdOM2 ) dCAVdOM12 = dFdL * ( dFdOM12 ) ertail(1) = xj*rij ertail(2) = yj*rij ertail(3) = zj*rij ! 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 ! print *,"EOMY",eom1,eom2,eom12 ! erdxi = scalar( ertail(1), dC_norm(1,i+nres) ) ! erdxj = scalar( ertail(1), dC_norm(1,j+nres) ) ! here dtail=0.0 ! facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres) ! facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 ! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) ! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) pom = ertail(k) !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) gvdwx_scbase(k,i) = gvdwx_scbase(k,i) & - (( dFdR + gg(k) ) * pom) ! +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & ! +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv ! & - ( dFdR * pom ) pom = ertail(k) !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres)) gvdwx_scbase(k,j) = gvdwx_scbase(k,j) & + (( dFdR + gg(k) ) * pom) ! +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & ! +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv !c! & + ( dFdR * pom ) gvdwc_scbase(k,i) = gvdwc_scbase(k,i) & - (( dFdR + gg(k) ) * ertail(k)) !c! & - ( dFdR * ertail(k)) gvdwc_scbase(k,j) = gvdwc_scbase(k,j) & + (( dFdR + gg(k) ) * ertail(k)) !c! & + ( dFdR * ertail(k)) gg(k) = 0.0d0 !c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) !c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) END DO ! else ! endif !Now dipole-dipole if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then w1 = wdipdip_scbase(1,itypi,itypj) w2 = -wdipdip_scbase(3,itypi,itypj)/2.0 w3 = wdipdip_scbase(2,itypi,itypj) !c!------------------------------------------------------------------- !c! ECL fac = (om12 - 3.0d0 * om1 * om2) c1 = (w1 / (Rhead**3.0d0)) * fac c2 = (w2 / Rhead ** 6.0d0) & * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) c3= (w3/ Rhead ** 6.0d0) & * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2)) ECL = c1 - c2 + c3 !c! write (*,*) "w1 = ", w1 !c! write (*,*) "w2 = ", w2 !c! write (*,*) "om1 = ", om1 !c! write (*,*) "om2 = ", om2 !c! write (*,*) "om12 = ", om12 !c! write (*,*) "fac = ", fac !c! write (*,*) "c1 = ", c1 !c! write (*,*) "c2 = ", c2 !c! write (*,*) "Ecl = ", Ecl !c! write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0) !c! write (*,*) "c2_2 = ", !c! & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) !c!------------------------------------------------------------------- !c! dervative of ECL is GCL... !c! dECL/dr c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0) c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) & * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2)) c3= (-6.0d0 * w3) / (Rhead ** 7.0d0) & * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2)) dGCLdR = c1 - c2 + c3 !c! dECL/dom1 c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0) c2 = (-6.0d0 * w2) / (Rhead**6.0d0) & * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 ) c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2)) dGCLdOM1 = c1 - c2 + c3 !c! dECL/dom2 c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0) c2 = (-6.0d0 * w2) / (Rhead**6.0d0) & * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 ) c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1)) dGCLdOM2 = c1 - c2 + c3 !c! dECL/dom12 c1 = w1 / (Rhead ** 3.0d0) c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac) dGCLdOM12 = c1 - c2 + c3 DO k= 1, 3 erhead(k) = Rhead_distance(k)/Rhead END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) facd1 = d1i * vbld_inv(i+nres) facd2 = d1j * vbld_inv(j+nres) DO k = 1, 3 pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gvdwx_scbase(k,i) = gvdwx_scbase(k,i) & - dGCLdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) gvdwx_scbase(k,j) = gvdwx_scbase(k,j) & + dGCLdR * pom gvdwc_scbase(k,i) = gvdwc_scbase(k,i) & - dGCLdR * erhead(k) gvdwc_scbase(k,j) = gvdwc_scbase(k,j) & + dGCLdR * erhead(k) END DO endif !now charge with dipole eg. ARG-dG if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then alphapol1 = alphapol_scbase(itypi,itypj) w1 = wqdip_scbase(1,itypi,itypj) w2 = wqdip_scbase(2,itypi,itypj) ! w1=0.0d0 ! w2=0.0d0 ! pis = sig0head_scbase(itypi,itypj) ! eps_head = epshead_scbase(itypi,itypj) !c!------------------------------------------------------------------- !c! R1 - distance between head of ith side chain and tail of jth sidechain R1 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances tail is center of side-chain R1=R1+(c(k,j+nres)-chead(k,1))**2 END DO !c! Pitagoras R1 = dsqrt(R1) !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c!------------------------------------------------------------------- !c! ecl sparrow = w1 * om1 hawk = w2 * (1.0d0 - sqom2) Ecl = sparrow / Rhead**2.0d0 & - hawk / Rhead**4.0d0 !c!------------------------------------------------------------------- !c! derivative of ecl is Gcl !c! dF/dr part dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 & + 4.0d0 * hawk / Rhead**5.0d0 !c! dF/dom1 dGCLdOM1 = (w1) / (Rhead**2.0d0) !c! dF/dom2 dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0) !c-------------------------------------------------------------------- !c Polarization energy !c Epol MomoFac1 = (1.0d0 - chi1 * sqom2) RR1 = R1 * R1 / MomoFac1 ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) fgb1 = sqrt( RR1 + a12sq * ee1) ! eps_inout_fac=0.0d0 epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) ! derivative of Epol is Gpol... dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) & / (fgb1 ** 5.0d0) dFGBdR1 = ( (R1 / MomoFac1) & * ( 2.0d0 - (0.5d0 * ee1) ) ) & / ( 2.0d0 * fgb1 ) dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) & * (2.0d0 - 0.5d0 * ee1) ) & / (2.0d0 * fgb1) dPOLdR1 = dPOLdFGB1 * dFGBdR1 ! dPOLdR1 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) ! bat=0.0d0 federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) facd1 = d1i * vbld_inv(i+nres) facd2 = d1j * vbld_inv(j+nres) ! facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 hawk = (erhead_tail(k,1) + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) ! facd1=0.0d0 ! facd2=0.0d0 pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gvdwx_scbase(k,i) = gvdwx_scbase(k,i) & - dGCLdR * pom & - dPOLdR1 * (erhead_tail(k,1)) ! & - dGLJdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) gvdwx_scbase(k,j) = gvdwx_scbase(k,j) & + dGCLdR * pom & + dPOLdR1 * (erhead_tail(k,1)) ! & + dGLJdR * pom gvdwc_scbase(k,i) = gvdwc_scbase(k,i) & - dGCLdR * erhead(k) & - dPOLdR1 * erhead_tail(k,1) ! & - dGLJdR * erhead(k) gvdwc_scbase(k,j) = gvdwc_scbase(k,j) & + dGCLdR * erhead(k) & + dPOLdR1 * erhead_tail(k,1) ! & + dGLJdR * erhead(k) END DO endif ! print *,i,j,evdwij,epol,Fcav,ECL escbase=escbase+evdwij+epol+Fcav+ECL call sc_grad_scbase enddo enddo return end subroutine eprot_sc_base SUBROUTINE sc_grad_scbase use calc_data real (kind=8) :: dcosom1(3),dcosom2(3) eom1 = & eps2der * eps2rt_om1 & - 2.0D0 * alf1 * eps3der & + sigder * sigsq_om1 & + dCAVdOM1 & + dGCLdOM1 & + dPOLdOM1 eom2 = & eps2der * eps2rt_om2 & + 2.0D0 * alf2 * eps3der & + sigder * sigsq_om2 & + dCAVdOM2 & + dGCLdOM2 & + dPOLdOM2 eom12 = & evdwij * eps1_om12 & + eps2der * eps2rt_om12 & - 2.0D0 * alf12 * eps3der & + sigder *sigsq_om12 & + dCAVdOM12 & + dGCLdOM12 ! print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3) ! print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),& ! gg(1),gg(2),"rozne" DO k = 1, 3 dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k)) dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k) gvdwx_scbase(k,i)= gvdwx_scbase(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_scbase(k,j)= gvdwx_scbase(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 gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k) gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k) END DO RETURN END SUBROUTINE sc_grad_scbase subroutine epep_sc_base(epepbase) use calc_data logical :: lprn !el local variables integer :: iint,itypi,itypi1,itypj,subchap real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi real(kind=8) :: evdw,sig0ij real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, & sslipi,sslipj,faclip integer :: ii real(kind=8) :: fracinbuf real (kind=8) :: epepbase real (kind=8),dimension(4):: ener real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,& sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,& Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,& dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,& r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,& dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,& sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1 real(kind=8),dimension(3,2)::chead,erhead_tail real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead integer troll eps_out=80.0d0 epepbase=0.0d0 ! do i=1,nres_molec(1)-1 do i=ibond_start,ibond_end if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle !C itypi = itype(i,1) dxi = dc_norm(1,i) dyi = dc_norm(2,i) dzi = dc_norm(3,i) ! print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1) dsci_inv = vbld_inv(i+1)/2.0 xi=(c(1,i)+c(1,i+1))/2.0 yi=(c(2,i)+c(2,i+1))/2.0 zi=(c(3,i)+c(3,i+1))/2.0 call to_box(xi,yi,zi) do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1) itypj= itype(j,2) if (itype(j,2).eq.ntyp1_molec(2))cycle xj=c(1,j+nres) yj=c(2,j+nres) zj=c(3,j+nres) call to_box(xj,yj,zj) xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) dist_init=xj**2+yj**2+zj**2 dxj = dc_norm( 1, nres+j ) dyj = dc_norm( 2, nres+j ) dzj = dc_norm( 3, nres+j ) ! d1i = dhead_scbasei(itypi) !this is shift of dipole/charge ! d1j = dhead_scbasej(itypi) !this is shift of dipole/charge ! Gay-berne var's sig0ij = sigma_pepbase(itypj ) chi1 = chi_pepbase(itypj,1 ) chi2 = chi_pepbase(itypj,2 ) ! chi1=0.0d0 ! chi2=0.0d0 chi12 = chi1 * chi2 chip1 = chipp_pepbase(itypj,1 ) chip2 = chipp_pepbase(itypj,2 ) ! chip1=0.0d0 ! chip2=0.0d0 chip12 = chip1 * chip2 chis1 = chis_pepbase(itypj,1) chis2 = chis_pepbase(itypj,2) chis12 = chis1 * chis2 sig1 = sigmap1_pepbase(itypj) sig2 = sigmap2_pepbase(itypj) ! write (*,*) "sig1 = ", sig1 ! write (*,*) "sig2 = ", sig2 DO k = 1,3 ! location of polar head is computed by taking hydrophobic centre ! and moving by a d1 * dc_norm vector ! see unres publications for very informative images chead(k,1) = (c(k,i)+c(k,i+1))/2.0 ! + d1i * dc_norm(k, i+nres) chead(k,2) = c(k, j+nres) ! + d1j * dc_norm(k, j+nres) ! distance ! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) ! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) Rhead_distance(k) = chead(k,2) - chead(k,1) ! print *,gvdwc_pepbase(k,i) END DO Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) ! alpha factors from Fcav/Gcav b1 = alphasur_pepbase(1,itypj) ! b1=0.0d0 b2 = alphasur_pepbase(2,itypj) b3 = alphasur_pepbase(3,itypj) b4 = alphasur_pepbase(4,itypj) alf1 = 0.0d0 alf2 = 0.0d0 alf12 = 0.0d0 rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj) ! print *,i,j,rrij rij = dsqrt(rrij) !---------------------------- evdwij = 0.0d0 ECL = 0.0d0 Elj = 0.0d0 Equad = 0.0d0 Epol = 0.0d0 Fcav=0.0d0 eheadtail = 0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 Fcav = 0.0d0 dFdR = 0.0d0 dCAVdOM1 = 0.0d0 dCAVdOM2 = 0.0d0 dCAVdOM12 = 0.0d0 dscj_inv = vbld_inv(j+nres) CALL sc_angular ! this should be in elgrad_init but om's are calculated by sc_angular ! which in turn is used by older potentials ! om = omega, sqom = om^2 sqom1 = om1 * om1 sqom2 = om2 * om2 sqom12 = om12 * om12 ! now we calculate EGB - Gey-Berne ! It will be summed up in evdwij and saved in evdw sigsq = 1.0D0 / sigsq sig = sig0ij * dsqrt(sigsq) rij_shift = 1.0/rij - sig + sig0ij IF (rij_shift.le.0.0D0) THEN evdw = 1.0D20 RETURN END IF sigder = -sig * sigsq rij_shift = 1.0D0 / rij_shift fac = rij_shift**expon c1 = fac * fac * aa_pepbase(itypj) ! c1 = 0.0d0 c2 = fac * bb_pepbase(itypj) ! c2 = 0.0d0 evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) eps2der = eps3rt * evdwij eps3der = eps2rt * evdwij ! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij evdwij = eps2rt * eps3rt * evdwij c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 fac = -expon * (c1 + evdwij) * rij_shift sigder = fac * sigder ! fac = rij * fac ! Calculate distance derivative gg(1) = fac gg(2) = fac gg(3) = fac fac = chis1 * sqom1 + chis2 * sqom2 & - 2.0d0 * chis12 * om1 * om2 * om12 ! we will use pom later in Gcav, so dont mess with it! pom = 1.0d0 - chis1 * chis2 * sqom12 Lambf = (1.0d0 - (fac / pom)) Lambf = dsqrt(Lambf) sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0) ! write (*,*) "sparrow = ", sparrow Chif = 1.0d0/rij * sparrow ChiLambf = Chif * Lambf eagle = dsqrt(ChiLambf) bat = ChiLambf ** 11.0d0 top = b1 * ( eagle + b2 * ChiLambf - b3 ) bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0) botsq = bot * bot Fcav = top / bot ! print *,i,j,Fcav dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf)) dbot = 12.0d0 * b4 * bat * Lambf dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow ! dFdR = 0.0d0 ! write (*,*) "dFcav/dR = ", dFdR dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif)) dbot = 12.0d0 * b4 * bat * Chif eagle = Lambf * pom dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle) dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle) dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) & * (chis2 * om2 * om12 - om1) / (eagle * pom) dFdL = ((dtop * bot - top * dbot) / botsq) ! dFdL = 0.0d0 dCAVdOM1 = dFdL * ( dFdOM1 ) dCAVdOM2 = dFdL * ( dFdOM2 ) dCAVdOM12 = dFdL * ( dFdOM12 ) ertail(1) = xj*rij ertail(2) = yj*rij ertail(3) = zj*rij DO k = 1, 3 ! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) ! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) pom = ertail(k) !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) & - (( dFdR + gg(k) ) * pom)/2.0 ! print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0 ! +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & ! +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv ! & - ( dFdR * pom ) pom = ertail(k) !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres)) gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) & + (( dFdR + gg(k) ) * pom) ! +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & ! +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv !c! & + ( dFdR * pom ) gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) & - (( dFdR + gg(k) ) * ertail(k))/2.0 ! print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0 !c! & - ( dFdR * ertail(k)) gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) & + (( dFdR + gg(k) ) * ertail(k)) !c! & + ( dFdR * ertail(k)) gg(k) = 0.0d0 !c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) !c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) END DO w1 = wdipdip_pepbase(1,itypj) w2 = -wdipdip_pepbase(3,itypj)/2.0 w3 = wdipdip_pepbase(2,itypj) ! w1=0.0d0 ! w2=0.0d0 !c!------------------------------------------------------------------- !c! ECL ! w3=0.0d0 fac = (om12 - 3.0d0 * om1 * om2) c1 = (w1 / (Rhead**3.0d0)) * fac c2 = (w2 / Rhead ** 6.0d0) & * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) c3= (w3/ Rhead ** 6.0d0) & * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2)) ECL = c1 - c2 + c3 c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0) c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) & * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2)) c3= (-6.0d0 * w3) / (Rhead ** 7.0d0) & * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2)) dGCLdR = c1 - c2 + c3 !c! dECL/dom1 c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0) c2 = (-6.0d0 * w2) / (Rhead**6.0d0) & * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 ) c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2)) dGCLdOM1 = c1 - c2 + c3 !c! dECL/dom2 c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0) c2 = (-6.0d0 * w2) / (Rhead**6.0d0) & * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 ) c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1)) dGCLdOM2 = c1 - c2 + c3 !c! dECL/dom12 c1 = w1 / (Rhead ** 3.0d0) c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac) dGCLdOM12 = c1 - c2 + c3 DO k= 1, 3 erhead(k) = Rhead_distance(k)/Rhead END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) ! facd1 = d1 * vbld_inv(i+nres) ! facd2 = d2 * vbld_inv(j+nres) DO k = 1, 3 ! pom = erhead(k) !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) ! gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) & ! - dGCLdR * pom pom = erhead(k) !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) & + dGCLdR * pom gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) & - dGCLdR * erhead(k)/2.0d0 ! print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0 gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) & - dGCLdR * erhead(k)/2.0d0 ! print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0 gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) & + dGCLdR * erhead(k) END DO ! print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl" epepbase=epepbase+evdwij+Fcav+ECL call sc_grad_pepbase enddo enddo END SUBROUTINE epep_sc_base SUBROUTINE sc_grad_pepbase use calc_data real (kind=8) :: dcosom1(3),dcosom2(3) eom1 = & eps2der * eps2rt_om1 & - 2.0D0 * alf1 * eps3der & + sigder * sigsq_om1 & + dCAVdOM1 & + dGCLdOM1 & + dPOLdOM1 eom2 = & eps2der * eps2rt_om2 & + 2.0D0 * alf2 * eps3der & + sigder * sigsq_om2 & + dCAVdOM2 & + dGCLdOM2 & + dPOLdOM2 eom12 = & evdwij * eps1_om12 & + eps2der * eps2rt_om12 & - 2.0D0 * alf12 * eps3der & + sigder *sigsq_om12 & + dCAVdOM12 & + dGCLdOM12 ! om12=0.0 ! eom12=0.0 ! print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3) ! if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),& ! (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))& ! *dsci_inv*2.0 ! print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),& ! gg(1),gg(2),"rozne" DO k = 1, 3 dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k)) dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k) gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k)) & + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))& *dsci_inv*2.0 & - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0 gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k)) & - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) & *dsci_inv*2.0 & + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0 ! print *,eom12,eom2,om12,om2 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),& ! (eom2*(erij(k)-om2*dc_norm(k,nres+j))) gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k) & + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))& + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k) END DO RETURN END SUBROUTINE sc_grad_pepbase subroutine eprot_sc_phosphate(escpho) 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,subchap real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi real(kind=8) :: evdw,sig0ij,aa,bb real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,ssgradlipi,ssgradlipj, & sslipi,sslipj,faclip,alpha_sco integer :: ii real(kind=8) :: fracinbuf real (kind=8) :: escpho real (kind=8),dimension(4):: ener real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,& sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,& Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,& dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,& r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,& dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,& sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1 real(kind=8),dimension(3,2)::chead,erhead_tail real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead integer troll eps_out=80.0d0 escpho=0.0d0 ! do i=1,nres_molec(1) do i=ibond_start,ibond_end if (itype(i,1).eq.ntyp1_molec(1)) cycle itypi = itype(i,1) dxi = dc_norm(1,nres+i) dyi = dc_norm(2,nres+i) dzi = dc_norm(3,nres+i) dsci_inv = vbld_inv(i+nres) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1 itypj= itype(j,2) if ((itype(j,2).eq.ntyp1_molec(2)).or.& (itype(j+1,2).eq.ntyp1_molec(2))) cycle xj=(c(1,j)+c(1,j+1))/2.0 yj=(c(2,j)+c(2,j+1))/2.0 zj=(c(3,j)+c(3,j+1))/2.0 call to_box(xj,yj,zj) ! call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) ! aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 ! bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & ! +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) dxj = dc_norm( 1,j ) dyj = dc_norm( 2,j ) dzj = dc_norm( 3,j ) dscj_inv = vbld_inv(j+1) ! Gay-berne var's sig0ij = sigma_scpho(itypi ) chi1 = chi_scpho(itypi,1 ) chi2 = chi_scpho(itypi,2 ) ! chi1=0.0d0 ! chi2=0.0d0 chi12 = chi1 * chi2 chip1 = chipp_scpho(itypi,1 ) chip2 = chipp_scpho(itypi,2 ) ! chip1=0.0d0 ! chip2=0.0d0 chip12 = chip1 * chip2 chis1 = chis_scpho(itypi,1) chis2 = chis_scpho(itypi,2) chis12 = chis1 * chis2 sig1 = sigmap1_scpho(itypi) sig2 = sigmap2_scpho(itypi) ! write (*,*) "sig1 = ", sig1 ! write (*,*) "sig1 = ", sig1 ! write (*,*) "sig2 = ", sig2 ! alpha factors from Fcav/Gcav alf1 = 0.0d0 alf2 = 0.0d0 alf12 = 0.0d0 a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi) b1 = alphasur_scpho(1,itypi) ! b1=0.0d0 b2 = alphasur_scpho(2,itypi) b3 = alphasur_scpho(3,itypi) b4 = alphasur_scpho(4,itypi) ! used to determine whether we want to do quadrupole calculations ! used by Fgb eps_in = epsintab_scpho(itypi) if (eps_in.eq.0.0) eps_in=1.0 eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) ! write (*,*) "eps_inout_fac = ", eps_inout_fac !------------------------------------------------------------------- ! tail location and distance calculations d1i = dhead_scphoi(itypi) !this is shift of dipole/charge d1j = 0.0 DO k = 1,3 ! location of polar head is computed by taking hydrophobic centre ! and moving by a d1 * dc_norm vector ! see unres publications for very informative images chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres) chead(k,2) = (c(k, j) + c(k, j+1))/2.0 ! distance ! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) ! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) Rhead_distance(k) = chead(k,2) - chead(k,1) END DO ! pitagoras (root of sum of squares) Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) Rhead_sq=Rhead**2.0 !------------------------------------------------------------------- ! zero everything that should be zero'ed evdwij = 0.0d0 ECL = 0.0d0 Elj = 0.0d0 Equad = 0.0d0 Epol = 0.0d0 Fcav=0.0d0 eheadtail = 0.0d0 dGCLdR=0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 Fcav = 0.0d0 dFdR = 0.0d0 dCAVdOM1 = 0.0d0 dCAVdOM2 = 0.0d0 dCAVdOM12 = 0.0d0 dscj_inv = vbld_inv(j+1)/2.0 !dhead_scbasej(itypi,itypj) ! print *,i,j,dscj_inv,dsci_inv ! rij holds 1/(distance of Calpha atoms) rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj) rij = dsqrt(rrij) !---------------------------- CALL sc_angular ! this should be in elgrad_init but om's are calculated by sc_angular ! which in turn is used by older potentials ! om = omega, sqom = om^2 sqom1 = om1 * om1 sqom2 = om2 * om2 sqom12 = om12 * om12 ! now we calculate EGB - Gey-Berne ! It will be summed up in evdwij and saved in evdw sigsq = 1.0D0 / sigsq sig = sig0ij * dsqrt(sigsq) ! rij_shift = 1.0D0 / rij - sig + sig0ij rij_shift = 1.0/rij - sig + sig0ij IF (rij_shift.le.0.0D0) THEN evdw = 1.0D20 RETURN END IF sigder = -sig * sigsq rij_shift = 1.0D0 / rij_shift fac = rij_shift**expon c1 = fac * fac * aa_scpho(itypi) ! c1 = 0.0d0 c2 = fac * bb_scpho(itypi) ! c2 = 0.0d0 evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) eps2der = eps3rt * evdwij eps3der = eps2rt * evdwij ! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij evdwij = eps2rt * eps3rt * evdwij c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 fac = -expon * (c1 + evdwij) * rij_shift sigder = fac * sigder ! fac = rij * fac ! Calculate distance derivative gg(1) = fac gg(2) = fac gg(3) = fac fac = chis1 * sqom1 + chis2 * sqom2 & - 2.0d0 * chis12 * om1 * om2 * om12 ! we will use pom later in Gcav, so dont mess with it! pom = 1.0d0 - chis1 * chis2 * sqom12 Lambf = (1.0d0 - (fac / pom)) Lambf = dsqrt(Lambf) sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0) ! write (*,*) "sparrow = ", sparrow Chif = 1.0d0/rij * sparrow ChiLambf = Chif * Lambf eagle = dsqrt(ChiLambf) bat = ChiLambf ** 11.0d0 top = b1 * ( eagle + b2 * ChiLambf - b3 ) bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0) botsq = bot * bot Fcav = top / bot dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf)) dbot = 12.0d0 * b4 * bat * Lambf dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow ! dFdR = 0.0d0 ! write (*,*) "dFcav/dR = ", dFdR dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif)) dbot = 12.0d0 * b4 * bat * Chif eagle = Lambf * pom dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle) dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle) dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) & * (chis2 * om2 * om12 - om1) / (eagle * pom) dFdL = ((dtop * bot - top * dbot) / botsq) ! dFdL = 0.0d0 dCAVdOM1 = dFdL * ( dFdOM1 ) dCAVdOM2 = dFdL * ( dFdOM2 ) dCAVdOM12 = dFdL * ( dFdOM12 ) ertail(1) = xj*rij ertail(2) = yj*rij ertail(3) = zj*rij DO k = 1, 3 ! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) ! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) ! if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i pom = ertail(k) ! print *,pom,gg(k),dFdR !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) gvdwx_scpho(k,i) = gvdwx_scpho(k,i) & - (( dFdR + gg(k) ) * pom) ! +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & ! +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv ! & - ( dFdR * pom ) ! pom = ertail(k) !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres)) ! gvdwx_scpho(k,j) = gvdwx_scpho(k,j) & ! + (( dFdR + gg(k) ) * pom) ! +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & ! +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv !c! & + ( dFdR * pom ) gvdwc_scpho(k,i) = gvdwc_scpho(k,i) & - (( dFdR + gg(k) ) * ertail(k)) !c! & - ( dFdR * ertail(k)) gvdwc_scpho(k,j) = gvdwc_scpho(k,j) & + (( dFdR + gg(k) ) * ertail(k))/2.0 gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) & + (( dFdR + gg(k) ) * ertail(k))/2.0 !c! & + ( dFdR * ertail(k)) gg(k) = 0.0d0 ENDDO !c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) !c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) ! alphapol1 = alphapol_scpho(itypi) if (wqq_scpho(itypi).ne.0.0) then Qij=wqq_scpho(itypi)/eps_in alpha_sco=1.d0/alphi_scpho(itypi) ! Qij=0.0 Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead !c! derivative of Ecl is Gcl... dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)* & (Rhead*alpha_sco+1) ) / Rhead_sq if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij else if (wqdip_scpho(2,itypi).gt.0.0d0) then w1 = wqdip_scpho(1,itypi) w2 = wqdip_scpho(2,itypi) ! w1=0.0d0 ! w2=0.0d0 ! pis = sig0head_scbase(itypi,itypj) ! eps_head = epshead_scbase(itypi,itypj) !c!------------------------------------------------------------------- !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c!------------------------------------------------------------------- !c! ecl sparrow = w1 * om1 hawk = w2 * (1.0d0 - sqom2) Ecl = sparrow / Rhead**2.0d0 & - hawk / Rhead**4.0d0 !c!------------------------------------------------------------------- if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,& 1.0/rij,sparrow !c! derivative of ecl is Gcl !c! dF/dr part dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 & + 4.0d0 * hawk / Rhead**5.0d0 !c! dF/dom1 dGCLdOM1 = (w1) / (Rhead**2.0d0) !c! dF/dom2 dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0) endif !c-------------------------------------------------------------------- !c Polarization energy !c Epol R1 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances tail is center of side-chain R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2 END DO !c! Pitagoras R1 = dsqrt(R1) alphapol1 = alphapol_scpho(itypi) ! alphapol1=0.0 MomoFac1 = (1.0d0 - chi2 * sqom1) RR1 = R1 * R1 / MomoFac1 ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) ! print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac fgb1 = sqrt( RR1 + a12sq * ee1) ! eps_inout_fac=0.0d0 epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) ! derivative of Epol is Gpol... dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) & / (fgb1 ** 5.0d0) dFGBdR1 = ( (R1 / MomoFac1) & * ( 2.0d0 - (0.5d0 * ee1) ) ) & / ( 2.0d0 * fgb1 ) dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) & * (2.0d0 - 0.5d0 * ee1) ) & / (2.0d0 * fgb1) dPOLdR1 = dPOLdFGB1 * dFGBdR1 ! dPOLdR1 = 0.0d0 ! dPOLdOM1 = 0.0d0 dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) & * (2.0d0 - 0.5d0 * ee1) ) & / (2.0d0 * fgb1) dPOLdOM1 = dPOLdFGB1 * dFGBdOM1 dPOLdOM2 = 0.0 DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j) ) bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) ! bat=0.0d0 federmaus = scalar(erhead_tail(1,1),dC_norm(1,j)) facd1 = d1i * vbld_inv(i+nres) facd2 = d1j * vbld_inv(j) ! facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 hawk = (erhead_tail(k,1) + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) ! facd1=0.0d0 ! facd2=0.0d0 ! if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,& ! pom,(erhead_tail(k,1)) ! print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gvdwx_scpho(k,i) = gvdwx_scpho(k,i) & - dGCLdR * pom & - dPOLdR1 * (erhead_tail(k,1)) ! & - dGLJdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j)) ! gvdwx_scpho(k,j) = gvdwx_scpho(k,j) & ! + dGCLdR * pom & ! + dPOLdR1 * (erhead_tail(k,1)) ! & + dGLJdR * pom gvdwc_scpho(k,i) = gvdwc_scpho(k,i) & - dGCLdR * erhead(k) & - dPOLdR1 * erhead_tail(k,1) ! & - dGLJdR * erhead(k) gvdwc_scpho(k,j) = gvdwc_scpho(k,j) & + (dGCLdR * erhead(k) & + dPOLdR1 * erhead_tail(k,1))/2.0 gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) & + (dGCLdR * erhead(k) & + dPOLdR1 * erhead_tail(k,1))/2.0 ! & + dGLJdR * erhead(k) ! if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i END DO ! if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), & "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho escpho=escpho+evdwij+epol+Fcav+ECL call sc_grad_scpho enddo enddo return end subroutine eprot_sc_phosphate SUBROUTINE sc_grad_scpho use calc_data real (kind=8) :: dcosom1(3),dcosom2(3) eom1 = & eps2der * eps2rt_om1 & - 2.0D0 * alf1 * eps3der & + sigder * sigsq_om1 & + dCAVdOM1 & + dGCLdOM1 & + dPOLdOM1 eom2 = & eps2der * eps2rt_om2 & + 2.0D0 * alf2 * eps3der & + sigder * sigsq_om2 & + dCAVdOM2 & + dGCLdOM2 & + dPOLdOM2 eom12 = & evdwij * eps1_om12 & + eps2der * eps2rt_om12 & - 2.0D0 * alf12 * eps3der & + sigder *sigsq_om12 & + dCAVdOM12 & + dGCLdOM12 ! om12=0.0 ! eom12=0.0 ! print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3) ! if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),& ! (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))& ! *dsci_inv*2.0 ! print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),& ! gg(1),gg(2),"rozne" DO k = 1, 3 dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k)) dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k)) gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k) gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k)) & + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))& *dscj_inv*2.0 & - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0 gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k)) & - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) & *dscj_inv*2.0 & + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0 gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k) & + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) & + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv ! print *,eom12,eom2,om12,om2 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),& ! (eom2*(erij(k)-om2*dc_norm(k,nres+j))) ! gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k) & ! + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))& ! + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k) END DO RETURN END SUBROUTINE sc_grad_scpho subroutine eprot_pep_phosphate(epeppho) 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,subchap real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi real(kind=8) :: evdw,sig0ij real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, & sslipi,sslipj,faclip integer :: ii real(kind=8) :: fracinbuf real (kind=8) :: epeppho real (kind=8),dimension(4):: ener real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,& sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,& Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,& dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,& r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,& dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,& sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1 real(kind=8),dimension(3,2)::chead,erhead_tail real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead integer troll real (kind=8) :: dcosom1(3),dcosom2(3) epeppho=0.0d0 ! do i=1,nres_molec(1) do i=ibond_start,ibond_end if (itype(i,1).eq.ntyp1_molec(1)) cycle itypi = itype(i,1) dsci_inv = vbld_inv(i+1)/2.0 dxi = dc_norm(1,i) dyi = dc_norm(2,i) dzi = dc_norm(3,i) xi=(c(1,i)+c(1,i+1))/2.0 yi=(c(2,i)+c(2,i+1))/2.0 zi=(c(3,i)+c(3,i+1))/2.0 call to_box(xi,yi,zi) do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1 itypj= itype(j,2) if ((itype(j,2).eq.ntyp1_molec(2)).or.& (itype(j+1,2).eq.ntyp1_molec(2))) cycle xj=(c(1,j)+c(1,j+1))/2.0 yj=(c(2,j)+c(2,j+1))/2.0 zj=(c(3,j)+c(3,j+1))/2.0 call to_box(xj,yj,zj) xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) dist_init=xj**2+yj**2+zj**2 rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj) rij = dsqrt(rrij) dxj = dc_norm( 1,j ) dyj = dc_norm( 2,j ) dzj = dc_norm( 3,j ) dscj_inv = vbld_inv(j+1)/2.0 ! Gay-berne var's sig0ij = sigma_peppho ! chi1=0.0d0 ! chi2=0.0d0 chi12 = chi1 * chi2 ! chip1=0.0d0 ! chip2=0.0d0 chip12 = chip1 * chip2 ! chis1 = 0.0d0 ! chis2 = 0.0d0 chis12 = chis1 * chis2 sig1 = sigmap1_peppho sig2 = sigmap2_peppho ! write (*,*) "sig1 = ", sig1 ! write (*,*) "sig1 = ", sig1 ! write (*,*) "sig2 = ", sig2 ! alpha factors from Fcav/Gcav alf1 = 0.0d0 alf2 = 0.0d0 alf12 = 0.0d0 b1 = alphasur_peppho(1) ! b1=0.0d0 b2 = alphasur_peppho(2) b3 = alphasur_peppho(3) b4 = alphasur_peppho(4) CALL sc_angular sqom1=om1*om1 evdwij = 0.0d0 ECL = 0.0d0 Elj = 0.0d0 Equad = 0.0d0 Epol = 0.0d0 Fcav=0.0d0 eheadtail = 0.0d0 dGCLdR=0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 Fcav = 0.0d0 dFdR = 0.0d0 dCAVdOM1 = 0.0d0 dCAVdOM2 = 0.0d0 dCAVdOM12 = 0.0d0 rij_shift = rij fac = rij_shift**expon c1 = fac * fac * aa_peppho ! c1 = 0.0d0 c2 = fac * bb_peppho ! c2 = 0.0d0 evdwij = c1 + c2 ! Now cavity.................... eagle = dsqrt(1.0/rij_shift) top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 ) bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0) botsq = bot * bot Fcav = top / bot dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2)) dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0 dFdR = ((dtop * bot - top * dbot) / botsq) w1 = wqdip_peppho(1) w2 = wqdip_peppho(2) ! w1=0.0d0 ! w2=0.0d0 ! pis = sig0head_scbase(itypi,itypj) ! eps_head = epshead_scbase(itypi,itypj) !c!------------------------------------------------------------------- !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c!------------------------------------------------------------------- !c! ecl sparrow = w1 * om1 hawk = w2 * (1.0d0 - sqom1) Ecl = sparrow * rij_shift**2.0d0 & - hawk * rij_shift**4.0d0 !c!------------------------------------------------------------------- !c! derivative of ecl is Gcl !c! dF/dr part ! rij_shift=5.0 dGCLdR = - 2.0d0 * sparrow * rij_shift**3.0d0 & + 4.0d0 * hawk * rij_shift**5.0d0 !c! dF/dom1 dGCLdOM1 = (w1) * (rij_shift**2.0d0) !c! dF/dom2 dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0) eom1 = dGCLdOM1+dGCLdOM2 eom2 = 0.0 fac = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR ! fac=0.0 gg(1) = fac*xj*rij gg(2) = fac*yj*rij gg(3) = fac*zj*rij do k=1,3 gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0 gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0 gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0 gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0 gg(k)=0.0 enddo DO k = 1, 3 dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k)) dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k)) gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k) gvdwc_peppho(k,j)= gvdwc_peppho(k,j) +0.5*( gg(k)) !& ! - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0 gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1) +0.5*( gg(k)) !& ! + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0 gvdwc_peppho(k,i)= gvdwc_peppho(k,i) -0.5*( gg(k)) & - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0 gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k)) & + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0 enddo epeppho=epeppho+evdwij+Fcav+ECL ! print *,i,j,evdwij,Fcav,ECL,rij_shift enddo enddo end subroutine eprot_pep_phosphate !!!!!!!!!!!!!!!!------------------------------------------------------------- subroutine emomo(evdw) use calc_data use comm_momo ! 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,itypi1,subchap,isel real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi real(kind=8) :: evdw,aa,bb real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,& dist_temp, dist_init,ssgradlipi,ssgradlipj, & sslipi,sslipj,faclip,alpha_sco integer :: ii real(kind=8) :: fracinbuf real (kind=8) :: escpho real (kind=8),dimension(4):: ener real(kind=8) :: b1,b2,egb real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,& Lambf,& Chif,ChiLambf,Fcav,dFdR,dFdOM1,& dFdOM2,dFdL,dFdOM12,& federmaus,& d1i,d1j ! real(kind=8),dimension(3,2)::erhead_tail ! real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance real(kind=8) :: facd4, adler, Fgb, facd3 integer troll,jj,istate real (kind=8) :: dcosom1(3),dcosom2(3) evdw=0.0d0 eps_out=80.0d0 sss_ele_cut=1.0d0 ! print *,"EVDW KURW",evdw,nres do i=iatsc_s,iatsc_e ! print *,"I am in EVDW",i itypi=iabs(itype(i,1)) ! if (i.ne.47) cycle if (itypi.eq.ntyp1) cycle itypi1=iabs(itype(i+1,1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) call lipid_layer(xi,yi,zi,sslipi,ssgradlipi) ! endif ! print *, sslipi,ssgradlipi 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) ! print *,"JA PIER",i,j,iint,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' do k=j+1,iend(i,iint) !C search over all next residues if (dyn_ss_mask(k)) then !C check if they are cysteins !C write(iout,*) 'k=',k !c write(iout,*) "PRZED TRI", evdwij ! evdwij_przed_tri=evdwij call triple_ssbond_ene(i,j,k,evdwij) !c if(evdwij_przed_tri.ne.evdwij) then !c write (iout,*) "TRI:", evdwij, evdwij_przed_tri !c endif !c write(iout,*) "PO TRI", evdwij !C call the energy function that removes the artifical triple disulfide !C bond the soubroutine is located in ssMD.F evdw=evdw+evdwij if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') & 'evdw',i,j,evdwij,'tss' endif!dyn_ss_mask(k) enddo! k ELSE !el ind=ind+1 itypj=iabs(itype(j,1)) if (itypj.eq.ntyp1) cycle CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol) ! if (j.ne.78) cycle ! dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) xj=c(1,j+nres) yj=c(2,j+nres) zj=c(3,j+nres) call to_box(xj,yj,zj) call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) write(iout,*) "KRUWA", i,j aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) dxj = dc_norm( 1, nres+j ) dyj = dc_norm( 2, nres+j ) dzj = dc_norm( 3, nres+j ) ! print *,i,j,itypi,itypj ! d1i=0.0d0 ! d1j=0.0d0 ! BetaT = 1.0d0 / (298.0d0 * Rb) ! Gay-berne var's !1! sig0ij = sigma_scsc( itypi,itypj ) ! chi1=0.0d0 ! chi2=0.0d0 ! chip1=0.0d0 ! chip2=0.0d0 ! not used by momo potential, but needed by sc_angular which is shared ! by all energy_potential subroutines alf1 = 0.0d0 alf2 = 0.0d0 alf12 = 0.0d0 a12sq = rborn(itypi,itypj) * rborn(itypj,itypi) ! a12sq = a12sq * a12sq ! charge of amino acid itypi is... chis1 = chis(itypi,itypj) chis2 = chis(itypj,itypi) chis12 = chis1 * chis2 sig1 = sigmap1(itypi,itypj) sig2 = sigmap2(itypi,itypj) ! write (*,*) "sig1 = ", sig1 ! chis1=0.0 ! chis2=0.0 ! chis12 = chis1 * chis2 ! sig1=0.0 ! sig2=0.0 ! write (*,*) "sig2 = ", sig2 ! alpha factors from Fcav/Gcav b1cav = alphasur(1,itypi,itypj) ! b1cav=0.0d0 b2cav = alphasur(2,itypi,itypj) b3cav = alphasur(3,itypi,itypj) b4cav = alphasur(4,itypi,itypj) ! used to determine whether we want to do quadrupole calculations eps_in = epsintab(itypi,itypj) if (eps_in.eq.0.0) eps_in=1.0 eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) Rtail = 0.0d0 ! dtail(1,itypi,itypj)=0.0 ! dtail(2,itypi,itypj)=0.0 DO k = 1, 3 ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i) ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j) END DO !c! tail distances will be themselves usefull elswhere !c1 (in Gcav, for example) Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 ) Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 ) Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 ) Rtail = dsqrt( & (Rtail_distance(1)*Rtail_distance(1)) & + (Rtail_distance(2)*Rtail_distance(2)) & + (Rtail_distance(3)*Rtail_distance(3))) ! write (*,*) "eps_inout_fac = ", eps_inout_fac !------------------------------------------------------------------- ! tail location and distance calculations d1 = dhead(1, 1, itypi, itypj) d2 = dhead(2, 1, itypi, itypj) DO k = 1,3 ! location of polar head is computed by taking hydrophobic centre ! and moving by a d1 * dc_norm vector ! see unres publications for very informative images chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) ! distance ! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) ! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) Rhead_distance(k) = chead(k,2) - chead(k,1) END DO ! pitagoras (root of sum of squares) Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) !------------------------------------------------------------------- ! zero everything that should be zero'ed evdwij = 0.0d0 ECL = 0.0d0 Elj = 0.0d0 Equad = 0.0d0 Epol = 0.0d0 Fcav=0.0d0 eheadtail = 0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 Fcav = 0.0d0 dFdR = 0.0d0 dCAVdOM1 = 0.0d0 dCAVdOM2 = 0.0d0 dCAVdOM12 = 0.0d0 dscj_inv = vbld_inv(j+nres) ! print *,i,j,dscj_inv,dsci_inv ! rij holds 1/(distance of Calpha atoms) rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj) rij = dsqrt(rrij) !---------------------------- CALL sc_angular ! this should be in elgrad_init but om's are calculated by sc_angular ! which in turn is used by older potentials ! om = omega, sqom = om^2 sqom1 = om1 * om1 sqom2 = om2 * om2 sqom12 = om12 * om12 ! now we calculate EGB - Gey-Berne ! It will be summed up in evdwij and saved in evdw sigsq = 1.0D0 / sigsq sig = sig0ij * dsqrt(sigsq) ! rij_shift = 1.0D0 / rij - sig + sig0ij rij_shift = Rtail - sig + sig0ij IF (rij_shift.le.0.0D0) THEN evdw = 1.0D20 RETURN END IF sigder = -sig * sigsq rij_shift = 1.0D0 / rij_shift fac = rij_shift**expon c1 = fac * fac * aa_aq(itypi,itypj) ! print *,"ADAM",aa_aq(itypi,itypj) ! c1 = 0.0d0 c2 = fac * bb_aq(itypi,itypj) ! c2 = 0.0d0 evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) eps2der = eps3rt * evdwij eps3der = eps2rt * evdwij ! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij evdwij = eps2rt * eps3rt * evdwij !#ifdef TSCSC ! IF (bb_aq(itypi,itypj).gt.0) THEN ! evdw_p = evdw_p + evdwij ! ELSE ! evdw_m = evdw_m + evdwij ! END IF !#else evdw = evdw & + evdwij !#endif c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 fac = -expon * (c1 + evdwij) * rij_shift sigder = fac * sigder ! fac = rij * fac ! Calculate distance derivative gg(1) = fac gg(2) = fac gg(3) = fac ! if (b2.gt.0.0) then fac = chis1 * sqom1 + chis2 * sqom2 & - 2.0d0 * chis12 * om1 * om2 * om12 ! we will use pom later in Gcav, so dont mess with it! pom = 1.0d0 - chis1 * chis2 * sqom12 Lambf = (1.0d0 - (fac / pom)) ! print *,"fac,pom",fac,pom,Lambf Lambf = dsqrt(Lambf) sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0) ! print *,"sig1,sig2",sig1,sig2,itypi,itypj ! write (*,*) "sparrow = ", sparrow Chif = Rtail * sparrow ! print *,"rij,sparrow",rij , sparrow ChiLambf = Chif * Lambf eagle = dsqrt(ChiLambf) bat = ChiLambf ** 11.0d0 top = b1cav * ( eagle + b2cav * ChiLambf - b3cav ) bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0) botsq = bot * bot ! print *,top,bot,"bot,top",ChiLambf,Chif Fcav = top / bot dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf)) dbot = 12.0d0 * b4cav * bat * Lambf dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif)) dbot = 12.0d0 * b4cav * bat * Chif eagle = Lambf * pom dFdOM1 = -(chis1 * om1 - chis12 * om2 * om12) / (eagle) dFdOM2 = -(chis2 * om2 - chis12 * om1 * om12) / (eagle) dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) & * (chis2 * om2 * om12 - om1) / (eagle * pom) dFdL = ((dtop * bot - top * dbot) / botsq) ! dFdL = 0.0d0 dCAVdOM1 = dFdL * ( dFdOM1 ) dCAVdOM2 = dFdL * ( dFdOM2 ) dCAVdOM12 = dFdL * ( dFdOM12 ) DO k= 1, 3 ertail(k) = Rtail_distance(k)/Rtail END DO erdxi = scalar( ertail(1), dC_norm(1,i+nres) ) erdxj = scalar( ertail(1), dC_norm(1,j+nres) ) facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres) facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 !c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) !c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) gvdwx(k,i) = gvdwx(k,i) & - (( dFdR + gg(k) ) * pom) !c! & - ( dFdR * pom ) pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres)) gvdwx(k,j) = gvdwx(k,j) & + (( dFdR + gg(k) ) * pom) !c! & + ( dFdR * pom ) gvdwc(k,i) = gvdwc(k,i) & - (( dFdR + gg(k) ) * ertail(k)) !c! & - ( dFdR * ertail(k)) gvdwc(k,j) = gvdwc(k,j) & + (( dFdR + gg(k) ) * ertail(k)) !c! & + ( dFdR * ertail(k)) gg(k) = 0.0d0 ! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) ! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) END DO !c! Compute head-head and head-tail energies for each state isel = iabs(Qi) + iabs(Qj) ! double charge for Phophorylated! itype - 25,27,27 ! if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then ! Qi=Qi*2 ! Qij=Qij*2 ! endif ! if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then ! Qj=Qj*2 ! Qij=Qij*2 ! endif ! isel=0 IF (isel.eq.0) THEN !c! No charges - do nothing eheadtail = 0.0d0 ELSE IF (isel.eq.4) THEN !c! Calculate dipole-dipole interactions CALL edd(ecl) eheadtail = ECL ! eheadtail = 0.0d0 ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN !c! Charge-nonpolar interactions if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then Qi=Qi*2 Qij=Qij*2 endif if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then Qj=Qj*2 Qij=Qij*2 endif CALL eqn(epol) eheadtail = epol ! eheadtail = 0.0d0 ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN !c! Nonpolar-charge interactions if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then Qi=Qi*2 Qij=Qij*2 endif if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then Qj=Qj*2 Qij=Qij*2 endif CALL enq(epol) eheadtail = epol ! eheadtail = 0.0d0 ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN !c! Charge-dipole interactions if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then Qi=Qi*2 Qij=Qij*2 endif if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then Qj=Qj*2 Qij=Qij*2 endif CALL eqd(ecl, elj, epol) eheadtail = ECL + elj + epol ! eheadtail = 0.0d0 ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN !c! Dipole-charge interactions if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then Qi=Qi*2 Qij=Qij*2 endif if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then Qj=Qj*2 Qij=Qij*2 endif CALL edq(ecl, elj, epol) eheadtail = ECL + elj + epol ! eheadtail = 0.0d0 ELSE IF ((isel.eq.2.and. & iabs(Qi).eq.1).and. & nstate(itypi,itypj).eq.1) THEN !c! Same charge-charge interaction ( +/+ or -/- ) if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then Qi=Qi*2 Qij=Qij*2 endif if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then Qj=Qj*2 Qij=Qij*2 endif CALL eqq(Ecl,Egb,Epol,Fisocav,Elj) eheadtail = ECL + Egb + Epol + Fisocav + Elj ! eheadtail = 0.0d0 ELSE IF ((isel.eq.2.and. & iabs(Qi).eq.1).and. & nstate(itypi,itypj).ne.1) THEN !c! Different charge-charge interaction ( +/- or -/+ ) if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then Qi=Qi*2 Qij=Qij*2 endif if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then Qj=Qj*2 Qij=Qij*2 endif CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) END IF END IF ! this endif ends the "catch the gly-gly" at the beggining of Fcav evdw = evdw + Fcav + eheadtail IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') & restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,& 1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,& Equad,evdwij+Fcav+eheadtail,evdw ! evdw = evdw + Fcav + eheadtail iF (nstate(itypi,itypj).eq.1) THEN CALL sc_grad END IF !c!------------------------------------------------------------------- !c! NAPISY KONCOWE END DO ! j END DO ! iint END DO ! i !c write (iout,*) "Number of loop steps in EGB:",ind !c energy_dec=.false. ! print *,"EVDW KURW",evdw,nres RETURN END SUBROUTINE emomo !C------------------------------------------------------------------------------------ SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj) use calc_data use comm_momo real (kind=8) :: facd3, facd4, federmaus, adler,& Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap ! integer :: k !c! Epol and Gpol analytical parameters alphapol1 = alphapol(itypi,itypj) alphapol2 = alphapol(itypj,itypi) !c! Fisocav and Gisocav analytical parameters al1 = alphiso(1,itypi,itypj) al2 = alphiso(2,itypi,itypj) al3 = alphiso(3,itypi,itypj) al4 = alphiso(4,itypi,itypj) csig = (1.0d0 & / dsqrt(sigiso1(itypi, itypj)**2.0d0 & + sigiso2(itypi,itypj)**2.0d0)) !c! pis = sig0head(itypi,itypj) eps_head = epshead(itypi,itypj) Rhead_sq = Rhead * Rhead !c! R1 - distance between head of ith side chain and tail of jth sidechain !c! R2 - distance between head of jth side chain and tail of ith sidechain R1 = 0.0d0 R2 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances needed by Epol R1=R1+(ctail(k,2)-chead(k,1))**2 R2=R2+(chead(k,2)-ctail(k,1))**2 END DO !c! Pitagoras R1 = dsqrt(R1) R2 = dsqrt(R2) !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c!------------------------------------------------------------------- !c! Coulomb electrostatic interaction Ecl = (332.0d0 * Qij) / Rhead !c! derivative of Ecl is Gcl... dGCLdR = (-332.0d0 * Qij ) / Rhead_sq dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0) debkap=debaykap(itypi,itypj) Egb = -(332.0d0 * Qij *& (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb ! print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out !c! Derivative of Egb is Ggb... dGGBdFGB = -(-332.0d0 * Qij * & (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)& -(332.0d0 * Qij *& (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb ) dGGBdR = dGGBdFGB * dFGBdR !c!------------------------------------------------------------------- !c! Fisocav - isotropic cavity creation term !c! or "how much energy it costs to put charged head in water" pom = Rhead * csig top = al1 * (dsqrt(pom) + al2 * pom - al3) bot = (1.0d0 + al4 * pom**12.0d0) botsq = bot * bot FisoCav = top / bot ! write (*,*) "Rhead = ",Rhead ! write (*,*) "csig = ",csig ! write (*,*) "pom = ",pom ! write (*,*) "al1 = ",al1 ! write (*,*) "al2 = ",al2 ! write (*,*) "al3 = ",al3 ! write (*,*) "al4 = ",al4 ! write (*,*) "top = ",top ! write (*,*) "bot = ",bot !c! Derivative of Fisocav is GCV... dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) dbot = 12.0d0 * al4 * pom ** 11.0d0 dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig !c!------------------------------------------------------------------- !c! Epol !c! Polarization energy - charged heads polarize hydrophobic "neck" MomoFac1 = (1.0d0 - chi1 * sqom2) MomoFac2 = (1.0d0 - chi2 * sqom1) RR1 = ( R1 * R1 ) / MomoFac1 RR2 = ( R2 * R2 ) / MomoFac2 ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) fgb1 = sqrt( RR1 + a12sq * ee1 ) fgb2 = sqrt( RR2 + a12sq * ee2 ) epol = 332.0d0 * eps_inout_fac * ( & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) !c! epol = 0.0d0 dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)& / (fgb1 ** 5.0d0) dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)& / (fgb2 ** 5.0d0) dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )& / ( 2.0d0 * fgb1 ) dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )& / ( 2.0d0 * fgb2 ) dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))& * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 ) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))& * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 ) dPOLdR1 = dPOLdFGB1 * dFGBdR1 !c! dPOLdR1 = 0.0d0 dPOLdR2 = dPOLdFGB2 * dFGBdR2 !c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 !c! dPOLdOM1 = 0.0d0 dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 !c! dPOLdOM2 = 0.0d0 !c!------------------------------------------------------------------- !c! Elj !c! Lennard-Jones 6-12 interaction between heads pom = (pis / Rhead)**6.0d0 Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) !c! derivative of Elj is Glj dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))& + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) !c!------------------------------------------------------------------- !c! Return the results !c! These things do the dRdX derivatives, that is !c! allow us to change what we see from function that changes with !c! distance to function that changes with LOCATION (of the interaction !c! site) DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j+nres) facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) !c! Now we add appropriate partial derivatives (one in each dimension) DO k = 1, 3 hawk = (erhead_tail(k,1) + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) condor = (erhead_tail(k,2) + & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gvdwx(k,i) = gvdwx(k,i) & - dGCLdR * pom& - dGGBdR * pom& - dGCVdR * pom& - dPOLdR1 * hawk& - dPOLdR2 * (erhead_tail(k,2)& -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))& - dGLJdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom& + dGGBdR * pom+ dGCVdR * pom& + dPOLdR1 * (erhead_tail(k,1)& -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))& + dPOLdR2 * condor + dGLJdR * pom gvdwc(k,i) = gvdwc(k,i) & - dGCLdR * erhead(k)& - dGGBdR * erhead(k)& - dGCVdR * erhead(k)& - dPOLdR1 * erhead_tail(k,1)& - dPOLdR2 * erhead_tail(k,2)& - dGLJdR * erhead(k) gvdwc(k,j) = gvdwc(k,j) & + dGCLdR * erhead(k) & + dGGBdR * erhead(k) & + dGCVdR * erhead(k) & + dPOLdR1 * erhead_tail(k,1) & + dPOLdR2 * erhead_tail(k,2)& + dGLJdR * erhead(k) END DO RETURN END SUBROUTINE eqq SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj) use calc_data use comm_momo real (kind=8) :: facd3, facd4, federmaus, adler,& Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap ! integer :: k !c! Epol and Gpol analytical parameters alphapol1 = alphapolcat(itypi,itypj) alphapol2 = alphapolcat(itypj,itypi) !c! Fisocav and Gisocav analytical parameters al1 = alphisocat(1,itypi,itypj) al2 = alphisocat(2,itypi,itypj) al3 = alphisocat(3,itypi,itypj) al4 = alphisocat(4,itypi,itypj) csig = (1.0d0 & / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 & + sigiso2cat(itypi,itypj)**2.0d0)) !c! pis = sig0headcat(itypi,itypj) eps_head = epsheadcat(itypi,itypj) Rhead_sq = Rhead * Rhead !c! R1 - distance between head of ith side chain and tail of jth sidechain !c! R2 - distance between head of jth side chain and tail of ith sidechain R1 = 0.0d0 R2 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances needed by Epol R1=R1+(ctail(k,2)-chead(k,1))**2 R2=R2+(chead(k,2)-ctail(k,1))**2 END DO !c! Pitagoras R1 = dsqrt(R1) R2 = dsqrt(R2) !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c!------------------------------------------------------------------- !c! Coulomb electrostatic interaction Ecl = (332.0d0 * Qij) / Rhead !c! derivative of Ecl is Gcl... dGCLdR = (-332.0d0 * Qij ) / Rhead_sq dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0) debkap=debaykapcat(itypi,itypj) Egb = -(332.0d0 * Qij *& (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb ! print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out !c! Derivative of Egb is Ggb... dGGBdFGB = -(-332.0d0 * Qij * & (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)& -(332.0d0 * Qij *& (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb ) dGGBdR = dGGBdFGB * dFGBdR !c!------------------------------------------------------------------- !c! Fisocav - isotropic cavity creation term !c! or "how much energy it costs to put charged head in water" pom = Rhead * csig top = al1 * (dsqrt(pom) + al2 * pom - al3) bot = (1.0d0 + al4 * pom**12.0d0) botsq = bot * bot FisoCav = top / bot ! write (*,*) "Rhead = ",Rhead ! write (*,*) "csig = ",csig ! write (*,*) "pom = ",pom ! write (*,*) "al1 = ",al1 ! write (*,*) "al2 = ",al2 ! write (*,*) "al3 = ",al3 ! write (*,*) "al4 = ",al4 ! write (*,*) "top = ",top ! write (*,*) "bot = ",bot !c! Derivative of Fisocav is GCV... dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) dbot = 12.0d0 * al4 * pom ** 11.0d0 dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig !c!------------------------------------------------------------------- !c! Epol !c! Polarization energy - charged heads polarize hydrophobic "neck" MomoFac1 = (1.0d0 - chi1 * sqom2) MomoFac2 = (1.0d0 - chi2 * sqom1) RR1 = ( R1 * R1 ) / MomoFac1 RR2 = ( R2 * R2 ) / MomoFac2 ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) fgb1 = sqrt( RR1 + a12sq * ee1 ) fgb2 = sqrt( RR2 + a12sq * ee2 ) epol = 332.0d0 * eps_inout_fac * ( & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) !c! epol = 0.0d0 dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)& / (fgb1 ** 5.0d0) dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)& / (fgb2 ** 5.0d0) dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )& / ( 2.0d0 * fgb1 ) dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )& / ( 2.0d0 * fgb2 ) dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))& * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 ) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))& * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 ) dPOLdR1 = dPOLdFGB1 * dFGBdR1 !c! dPOLdR1 = 0.0d0 dPOLdR2 = dPOLdFGB2 * dFGBdR2 !c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 !c! dPOLdOM1 = 0.0d0 dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 !c! dPOLdOM2 = 0.0d0 !c!------------------------------------------------------------------- !c! Elj !c! Lennard-Jones 6-12 interaction between heads pom = (pis / Rhead)**6.0d0 Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) !c! derivative of Elj is Glj dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))& + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) !c!------------------------------------------------------------------- !c! Return the results !c! These things do the dRdX derivatives, that is !c! allow us to change what we see from function that changes with !c! distance to function that changes with LOCATION (of the interaction !c! site) DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j) ) bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) federmaus = scalar(erhead_tail(1,1),dC_norm(1,j)) eagle = scalar( erhead_tail(1,2), dC_norm(1,j) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j) facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres) facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j) !c! Now we add appropriate partial derivatives (one in each dimension) DO k = 1, 3 hawk = (erhead_tail(k,1) + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) condor = (erhead_tail(k,2) + & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j))) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gradpepcatx(k,i) = gradpepcatx(k,i) & - dGCLdR * pom& - dGGBdR * pom& - dGCVdR * pom& - dPOLdR1 * hawk& - dPOLdR2 * (erhead_tail(k,2)& -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))& - dGLJdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j)) ! gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom& ! + dGGBdR * pom+ dGCVdR * pom& ! + dPOLdR1 * (erhead_tail(k,1)& ! -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))& ! + dPOLdR2 * condor + dGLJdR * pom gradpepcat(k,i) = gradpepcat(k,i) & - dGCLdR * erhead(k)& - dGGBdR * erhead(k)& - dGCVdR * erhead(k)& - dPOLdR1 * erhead_tail(k,1)& - dPOLdR2 * erhead_tail(k,2)& - dGLJdR * erhead(k) gradpepcat(k,j) = gradpepcat(k,j) & + dGCLdR * erhead(k) & + dGGBdR * erhead(k) & + dGCVdR * erhead(k) & + dPOLdR1 * erhead_tail(k,1) & + dPOLdR2 * erhead_tail(k,2)& + dGLJdR * erhead(k) END DO RETURN END SUBROUTINE eqq_cat !c!------------------------------------------------------------------- SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) use comm_momo use calc_data double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad double precision ener(4) double precision dcosom1(3),dcosom2(3) !c! used in Epol derivatives double precision facd3, facd4 double precision federmaus, adler integer istate,ii,jj real (kind=8) :: Fgb ! print *,"CALLING EQUAD" !c! Epol and Gpol analytical parameters alphapol1 = alphapol(itypi,itypj) alphapol2 = alphapol(itypj,itypi) !c! Fisocav and Gisocav analytical parameters al1 = alphiso(1,itypi,itypj) al2 = alphiso(2,itypi,itypj) al3 = alphiso(3,itypi,itypj) al4 = alphiso(4,itypi,itypj) csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0& + sigiso2(itypi,itypj)**2.0d0)) !c! w1 = wqdip(1,itypi,itypj) w2 = wqdip(2,itypi,itypj) pis = sig0head(itypi,itypj) eps_head = epshead(itypi,itypj) !c! First things first: !c! We need to do sc_grad's job with GB and Fcav eom1 = eps2der * eps2rt_om1 & - 2.0D0 * alf1 * eps3der& + sigder * sigsq_om1& + dCAVdOM1 eom2 = eps2der * eps2rt_om2 & + 2.0D0 * alf2 * eps3der& + sigder * sigsq_om2& + dCAVdOM2 eom12 = evdwij * eps1_om12 & + eps2der * eps2rt_om12 & - 2.0D0 * alf12 * eps3der& + sigder *sigsq_om12& + dCAVdOM12 !c! now some magical transformations to project gradient into !c! three cartesian vectors DO k = 1, 3 dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k)) dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k) !c! this acts on hydrophobic center of interaction gvdwx(k,i)= gvdwx(k,i) - gg(k) & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))& + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv gvdwx(k,j)= gvdwx(k,j) + gg(k) & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))& + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv !c! this acts on Calpha gvdwc(k,i)=gvdwc(k,i)-gg(k) gvdwc(k,j)=gvdwc(k,j)+gg(k) END DO !c! sc_grad is done, now we will compute eheadtail = 0.0d0 eom1 = 0.0d0 eom2 = 0.0d0 eom12 = 0.0d0 DO istate = 1, nstate(itypi,itypj) !c************************************************************* IF (istate.ne.1) THEN IF (istate.lt.3) THEN ii = 1 ELSE ii = 2 END IF jj = istate/ii d1 = dhead(1,ii,itypi,itypj) d2 = dhead(2,jj,itypi,itypj) DO k = 1,3 chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) Rhead_distance(k) = chead(k,2) - chead(k,1) END DO !c! pitagoras (root of sum of squares) Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) END IF Rhead_sq = Rhead * Rhead !c! R1 - distance between head of ith side chain and tail of jth sidechain !c! R2 - distance between head of jth side chain and tail of ith sidechain R1 = 0.0d0 R2 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances R1=R1+(ctail(k,2)-chead(k,1))**2 R2=R2+(chead(k,2)-ctail(k,1))**2 END DO !c! Pitagoras R1 = dsqrt(R1) R2 = dsqrt(R2) Ecl = (332.0d0 * Qij) / (Rhead * eps_in) !c! Ecl = 0.0d0 !c! write (*,*) "Ecl = ", Ecl !c! derivative of Ecl is Gcl... dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in) !c! dGCLdR = 0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 !c!------------------------------------------------------------------- !c! Generalised Born Solvent Polarization ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq)) Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0) Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb !c! Egb = 0.0d0 !c! write (*,*) "a1*a2 = ", a12sq !c! write (*,*) "Rhead = ", Rhead !c! write (*,*) "Rhead_sq = ", Rhead_sq !c! write (*,*) "ee = ", ee !c! write (*,*) "Fgb = ", Fgb !c! write (*,*) "fac = ", eps_inout_fac !c! write (*,*) "Qij = ", Qij !c! write (*,*) "Egb = ", Egb !c! Derivative of Egb is Ggb... !c! dFGBdR is used by Quad's later... dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb) dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )& / ( 2.0d0 * Fgb ) dGGBdR = dGGBdFGB * dFGBdR !c! dGGBdR = 0.0d0 !c!------------------------------------------------------------------- !c! Fisocav - isotropic cavity creation term pom = Rhead * csig top = al1 * (dsqrt(pom) + al2 * pom - al3) bot = (1.0d0 + al4 * pom**12.0d0) botsq = bot * bot FisoCav = top / bot dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2) dbot = 12.0d0 * al4 * pom ** 11.0d0 dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig !c! dGCVdR = 0.0d0 !c!------------------------------------------------------------------- !c! Polarization energy !c! Epol MomoFac1 = (1.0d0 - chi1 * sqom2) MomoFac2 = (1.0d0 - chi2 * sqom1) RR1 = ( R1 * R1 ) / MomoFac1 RR2 = ( R2 * R2 ) / MomoFac2 ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) ee2 = exp(-( RR2 / (4.0d0 * a12sq) )) fgb1 = sqrt( RR1 + a12sq * ee1 ) fgb2 = sqrt( RR2 + a12sq * ee2 ) epol = 332.0d0 * eps_inout_fac * (& (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 )) !c! epol = 0.0d0 !c! derivative of Epol is Gpol... dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)& / (fgb1 ** 5.0d0) dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)& / (fgb2 ** 5.0d0) dFGBdR1 = ( (R1 / MomoFac1) & * ( 2.0d0 - (0.5d0 * ee1) ) )& / ( 2.0d0 * fgb1 ) dFGBdR2 = ( (R2 / MomoFac2) & * ( 2.0d0 - (0.5d0 * ee2) ) ) & / ( 2.0d0 * fgb2 ) dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) & * ( 2.0d0 - 0.5d0 * ee1) ) & / ( 2.0d0 * fgb1 ) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) & * ( 2.0d0 - 0.5d0 * ee2) ) & / ( 2.0d0 * fgb2 ) dPOLdR1 = dPOLdFGB1 * dFGBdR1 !c! dPOLdR1 = 0.0d0 dPOLdR2 = dPOLdFGB2 * dFGBdR2 !c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 !c! dPOLdOM1 = 0.0d0 dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 pom = (pis / Rhead)**6.0d0 Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) !c! Elj = 0.0d0 !c! derivative of Elj is Glj dGLJdR = 4.0d0 * eps_head & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) !c! dGLJdR = 0.0d0 !c!------------------------------------------------------------------- !c! Equad IF (Wqd.ne.0.0d0) THEN Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) & - 37.5d0 * ( sqom1 + sqom2 ) & + 157.5d0 * ( sqom1 * sqom2 ) & - 45.0d0 * om1*om2*om12 fac = -( Wqd / (2.0d0 * Fgb**5.0d0) ) Equad = fac * Beta1 !c! Equad = 0.0d0 !c! derivative of Equad... dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR !c! dQUADdR = 0.0d0 dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12) !c! dQUADdOM1 = 0.0d0 dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12) !c! dQUADdOM2 = 0.0d0 dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 ) ELSE Beta1 = 0.0d0 Equad = 0.0d0 END IF !c!------------------------------------------------------------------- !c! Return the results !c! Angular stuff eom1 = dPOLdOM1 + dQUADdOM1 eom2 = dPOLdOM2 + dQUADdOM2 eom12 = dQUADdOM12 !c! now some magical transformations to project gradient into !c! three cartesian vectors DO k = 1, 3 dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k)) dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k)) tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k) END DO !c! Radial stuff DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j+nres) facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 hawk = erhead_tail(k,1) + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)) condor = erhead_tail(k,2) + & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) !c! this acts on hydrophobic center of interaction gheadtail(k,1,1) = gheadtail(k,1,1) & - dGCLdR * pom & - dGGBdR * pom & - dGCVdR * pom & - dPOLdR1 * hawk & - dPOLdR2 * (erhead_tail(k,2) & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))& - dGLJdR * pom & - dQUADdR * pom& - tuna(k) & + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))& + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) !c! this acts on hydrophobic center of interaction gheadtail(k,2,1) = gheadtail(k,2,1) & + dGCLdR * pom & + dGGBdR * pom & + dGCVdR * pom & + dPOLdR1 * (erhead_tail(k,1) & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) & + dPOLdR2 * condor & + dGLJdR * pom & + dQUADdR * pom & + tuna(k) & + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv !c! this acts on Calpha gheadtail(k,3,1) = gheadtail(k,3,1) & - dGCLdR * erhead(k)& - dGGBdR * erhead(k)& - dGCVdR * erhead(k)& - dPOLdR1 * erhead_tail(k,1)& - dPOLdR2 * erhead_tail(k,2)& - dGLJdR * erhead(k) & - dQUADdR * erhead(k)& - tuna(k) !c! this acts on Calpha gheadtail(k,4,1) = gheadtail(k,4,1) & + dGCLdR * erhead(k) & + dGGBdR * erhead(k) & + dGCVdR * erhead(k) & + dPOLdR1 * erhead_tail(k,1) & + dPOLdR2 * erhead_tail(k,2) & + dGLJdR * erhead(k) & + dQUADdR * erhead(k)& + tuna(k) END DO ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad eheadtail = eheadtail & + wstate(istate, itypi, itypj) & * dexp(-betaT * ener(istate)) !c! foreach cartesian dimension DO k = 1, 3 !c! foreach of two gvdwx and gvdwc DO l = 1, 4 gheadtail(k,l,2) = gheadtail(k,l,2) & + wstate( istate, itypi, itypj ) & * dexp(-betaT * ener(istate)) & * gheadtail(k,l,1) gheadtail(k,l,1) = 0.0d0 END DO END DO END DO !c! Here ended the gigantic DO istate = 1, 4, which starts !c! at the beggining of the subroutine DO k = 1, 3 DO l = 1, 4 gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail END DO gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2) gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2) gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2) gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2) DO l = 1, 4 gheadtail(k,l,1) = 0.0d0 gheadtail(k,l,2) = 0.0d0 END DO END DO eheadtail = (-dlog(eheadtail)) / betaT dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 dQUADdOM1 = 0.0d0 dQUADdOM2 = 0.0d0 dQUADdOM12 = 0.0d0 RETURN END SUBROUTINE energy_quad !!----------------------------------------------------------- SUBROUTINE eqn(Epol) use comm_momo use calc_data double precision facd4, federmaus,epol alphapol1 = alphapol(itypi,itypj) !c! R1 - distance between head of ith side chain and tail of jth sidechain R1 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances R1=R1+(ctail(k,2)-chead(k,1))**2 END DO !c! Pitagoras R1 = dsqrt(R1) !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c-------------------------------------------------------------------- !c Polarization energy !c Epol MomoFac1 = (1.0d0 - chi1 * sqom2) RR1 = R1 * R1 / MomoFac1 ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) fgb1 = sqrt( RR1 + a12sq * ee1) epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) & / (fgb1 ** 5.0d0) dFGBdR1 = ( (R1 / MomoFac1) & * ( 2.0d0 - (0.5d0 * ee1) ) ) & / ( 2.0d0 * fgb1 ) dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) & * (2.0d0 - 0.5d0 * ee1) ) & / (2.0d0 * fgb1) dPOLdR1 = dPOLdFGB1 * dFGBdR1 !c! dPOLdR1 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 DO k = 1, 3 erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) END DO bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) facd1 = d1 * vbld_inv(i+nres) facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 hawk = (erhead_tail(k,1) + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) gvdwx(k,i) = gvdwx(k,i) & - dPOLdR1 * hawk gvdwx(k,j) = gvdwx(k,j) & + dPOLdR1 * (erhead_tail(k,1) & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) gvdwc(k,i) = gvdwc(k,i) - dPOLdR1 * erhead_tail(k,1) gvdwc(k,j) = gvdwc(k,j) + dPOLdR1 * erhead_tail(k,1) END DO RETURN END SUBROUTINE eqn SUBROUTINE enq(Epol) use calc_data use comm_momo double precision facd3, adler,epol alphapol2 = alphapol(itypj,itypi) !c! R2 - distance between head of jth side chain and tail of ith sidechain R2 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances R2=R2+(chead(k,2)-ctail(k,1))**2 END DO !c! Pitagoras R2 = dsqrt(R2) !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c------------------------------------------------------------------------ !c Polarization energy MomoFac2 = (1.0d0 - chi2 * sqom1) RR2 = R2 * R2 / MomoFac2 ee2 = exp(-(RR2 / (4.0d0 * a12sq))) fgb2 = sqrt(RR2 + a12sq * ee2) epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) & / (fgb2 ** 5.0d0) dFGBdR2 = ( (R2 / MomoFac2) & * ( 2.0d0 - (0.5d0 * ee2) ) ) & / (2.0d0 * fgb2) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) & * (2.0d0 - 0.5d0 * ee2) ) & / (2.0d0 * fgb2) dPOLdR2 = dPOLdFGB2 * dFGBdR2 !c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 !c! dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 !c!------------------------------------------------------------------- !c! Return the results !c! (See comments in Eqq) DO k = 1, 3 erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) facd2 = d2 * vbld_inv(j+nres) facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) DO k = 1, 3 condor = (erhead_tail(k,2) & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) gvdwx(k,i) = gvdwx(k,i) & - dPOLdR2 * (erhead_tail(k,2) & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) gvdwx(k,j) = gvdwx(k,j) & + dPOLdR2 * condor gvdwc(k,i) = gvdwc(k,i) & - dPOLdR2 * erhead_tail(k,2) gvdwc(k,j) = gvdwc(k,j) & + dPOLdR2 * erhead_tail(k,2) END DO RETURN END SUBROUTINE enq SUBROUTINE enq_cat(Epol) use calc_data use comm_momo double precision facd3, adler,epol alphapol2 = alphapolcat(itypj,itypi) !c! R2 - distance between head of jth side chain and tail of ith sidechain R2 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances R2=R2+(chead(k,2)-ctail(k,1))**2 END DO !c! Pitagoras R2 = dsqrt(R2) !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c------------------------------------------------------------------------ !c Polarization energy MomoFac2 = (1.0d0 - chi2 * sqom1) RR2 = R2 * R2 / MomoFac2 ee2 = exp(-(RR2 / (4.0d0 * a12sq))) fgb2 = sqrt(RR2 + a12sq * ee2) epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) & / (fgb2 ** 5.0d0) dFGBdR2 = ( (R2 / MomoFac2) & * ( 2.0d0 - (0.5d0 * ee2) ) ) & / (2.0d0 * fgb2) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) & * (2.0d0 - 0.5d0 * ee2) ) & / (2.0d0 * fgb2) dPOLdR2 = dPOLdFGB2 * dFGBdR2 !c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 !c! dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 !c!------------------------------------------------------------------- !c! Return the results !c! (See comments in Eqq) DO k = 1, 3 erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO eagle = scalar( erhead_tail(1,2), dC_norm(1,j) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) facd2 = d2 * vbld_inv(j+nres) facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres) DO k = 1, 3 condor = (erhead_tail(k,2) & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j))) gradpepcatx(k,i) = gradpepcatx(k,i) & - dPOLdR2 * (erhead_tail(k,2) & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) ! gradpepcatx(k,j) = gradpepcatx(k,j) & ! + dPOLdR2 * condor gradpepcat(k,i) = gradpepcat(k,i) & - dPOLdR2 * erhead_tail(k,2) gradpepcat(k,j) = gradpepcat(k,j) & + dPOLdR2 * erhead_tail(k,2) END DO RETURN END SUBROUTINE enq_cat SUBROUTINE eqd(Ecl,Elj,Epol) use calc_data use comm_momo double precision facd4, federmaus,ecl,elj,epol alphapol1 = alphapol(itypi,itypj) w1 = wqdip(1,itypi,itypj) w2 = wqdip(2,itypi,itypj) pis = sig0head(itypi,itypj) eps_head = epshead(itypi,itypj) !c!------------------------------------------------------------------- !c! R1 - distance between head of ith side chain and tail of jth sidechain R1 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances R1=R1+(ctail(k,2)-chead(k,1))**2 END DO !c! Pitagoras R1 = dsqrt(R1) !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c!------------------------------------------------------------------- !c! ecl sparrow = w1 * Qi * om1 hawk = w2 * Qi * Qi * (1.0d0 - sqom2) Ecl = sparrow / Rhead**2.0d0 & - hawk / Rhead**4.0d0 dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 & + 4.0d0 * hawk / Rhead**5.0d0 !c! dF/dom1 dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) !c! dF/dom2 dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) !c-------------------------------------------------------------------- !c Polarization energy !c Epol MomoFac1 = (1.0d0 - chi1 * sqom2) RR1 = R1 * R1 / MomoFac1 ee1 = exp(-( RR1 / (4.0d0 * a12sq) )) fgb1 = sqrt( RR1 + a12sq * ee1) epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0) !c! epol = 0.0d0 !c!------------------------------------------------------------------ !c! derivative of Epol is Gpol... dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) & / (fgb1 ** 5.0d0) dFGBdR1 = ( (R1 / MomoFac1) & * ( 2.0d0 - (0.5d0 * ee1) ) ) & / ( 2.0d0 * fgb1 ) dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) & * (2.0d0 - 0.5d0 * ee1) ) & / (2.0d0 * fgb1) dPOLdR1 = dPOLdFGB1 * dFGBdR1 !c! dPOLdR1 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 !c! dPOLdOM2 = 0.0d0 !c!------------------------------------------------------------------- !c! Elj pom = (pis / Rhead)**6.0d0 Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) !c! derivative of Elj is Glj dGLJdR = 4.0d0 * eps_head & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres)) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j+nres) facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres) DO k = 1, 3 hawk = (erhead_tail(k,1) + & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gvdwx(k,i) = gvdwx(k,i) & - dGCLdR * pom& - dPOLdR1 * hawk & - dGLJdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) gvdwx(k,j) = gvdwx(k,j) & + dGCLdR * pom & + dPOLdR1 * (erhead_tail(k,1) & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) & + dGLJdR * pom gvdwc(k,i) = gvdwc(k,i) & - dGCLdR * erhead(k) & - dPOLdR1 * erhead_tail(k,1) & - dGLJdR * erhead(k) gvdwc(k,j) = gvdwc(k,j) & + dGCLdR * erhead(k) & + dPOLdR1 * erhead_tail(k,1) & + dGLJdR * erhead(k) END DO RETURN END SUBROUTINE eqd SUBROUTINE edq(Ecl,Elj,Epol) ! IMPLICIT NONE use comm_momo use calc_data double precision facd3, adler,ecl,elj,epol alphapol2 = alphapol(itypj,itypi) w1 = wqdip(1,itypi,itypj) w2 = wqdip(2,itypi,itypj) pis = sig0head(itypi,itypj) eps_head = epshead(itypi,itypj) !c!------------------------------------------------------------------- !c! R2 - distance between head of jth side chain and tail of ith sidechain R2 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances R2=R2+(chead(k,2)-ctail(k,1))**2 END DO !c! Pitagoras R2 = dsqrt(R2) !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c!------------------------------------------------------------------- !c! ecl sparrow = w1 * Qj * om1 hawk = w2 * Qj * Qj * (1.0d0 - sqom2) ECL = sparrow / Rhead**2.0d0 & - hawk / Rhead**4.0d0 !c!------------------------------------------------------------------- !c! derivative of ecl is Gcl !c! dF/dr part dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 & + 4.0d0 * hawk / Rhead**5.0d0 !c! dF/dom1 dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0) !c! dF/dom2 dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0) !c-------------------------------------------------------------------- !c Polarization energy !c Epol MomoFac2 = (1.0d0 - chi2 * sqom1) RR2 = R2 * R2 / MomoFac2 ee2 = exp(-(RR2 / (4.0d0 * a12sq))) fgb2 = sqrt(RR2 + a12sq * ee2) epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) & / (fgb2 ** 5.0d0) dFGBdR2 = ( (R2 / MomoFac2) & * ( 2.0d0 - (0.5d0 * ee2) ) ) & / (2.0d0 * fgb2) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) & * (2.0d0 - 0.5d0 * ee2) ) & / (2.0d0 * fgb2) dPOLdR2 = dPOLdFGB2 * dFGBdR2 !c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 !c! dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 !c!------------------------------------------------------------------- !c! Elj pom = (pis / Rhead)**6.0d0 Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) !c! derivative of Elj is Glj dGLJdR = 4.0d0 * eps_head & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) !c!------------------------------------------------------------------- !c! Return the results !c! (see comments in Eqq) DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j+nres) facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres) DO k = 1, 3 condor = (erhead_tail(k,2) & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gvdwx(k,i) = gvdwx(k,i) & - dGCLdR * pom & - dPOLdR2 * (erhead_tail(k,2) & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) & - dGLJdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) gvdwx(k,j) = gvdwx(k,j) & + dGCLdR * pom & + dPOLdR2 * condor & + dGLJdR * pom gvdwc(k,i) = gvdwc(k,i) & - dGCLdR * erhead(k) & - dPOLdR2 * erhead_tail(k,2) & - dGLJdR * erhead(k) gvdwc(k,j) = gvdwc(k,j) & + dGCLdR * erhead(k) & + dPOLdR2 * erhead_tail(k,2) & + dGLJdR * erhead(k) END DO RETURN END SUBROUTINE edq SUBROUTINE edq_cat(Ecl,Elj,Epol) use comm_momo use calc_data double precision facd3, adler,ecl,elj,epol alphapol2 = alphapolcat(itypj,itypi) w1 = wqdipcat(1,itypi,itypj) w2 = wqdipcat(2,itypi,itypj) pis = sig0headcat(itypi,itypj) eps_head = epsheadcat(itypi,itypj) !c!------------------------------------------------------------------- !c! R2 - distance between head of jth side chain and tail of ith sidechain R2 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances R2=R2+(chead(k,2)-ctail(k,1))**2 END DO !c! Pitagoras R2 = dsqrt(R2) !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c!------------------------------------------------------------------- !c! ecl ! write(iout,*) "KURWA2",Rhead sparrow = w1 * Qj * om1 hawk = w2 * Qj * Qj * (1.0d0 - sqom2) ECL = sparrow / Rhead**2.0d0 & - hawk / Rhead**4.0d0 !c!------------------------------------------------------------------- !c! derivative of ecl is Gcl !c! dF/dr part dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 & + 4.0d0 * hawk / Rhead**5.0d0 !c! dF/dom1 dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0) !c! dF/dom2 dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0) !c-------------------------------------------------------------------- !c-------------------------------------------------------------------- !c Polarization energy !c Epol MomoFac2 = (1.0d0 - chi2 * sqom1) RR2 = R2 * R2 / MomoFac2 ee2 = exp(-(RR2 / (4.0d0 * a12sq))) fgb2 = sqrt(RR2 + a12sq * ee2) epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) & / (fgb2 ** 5.0d0) dFGBdR2 = ( (R2 / MomoFac2) & * ( 2.0d0 - (0.5d0 * ee2) ) ) & / (2.0d0 * fgb2) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) & * (2.0d0 - 0.5d0 * ee2) ) & / (2.0d0 * fgb2) dPOLdR2 = dPOLdFGB2 * dFGBdR2 !c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 !c! dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 !c!------------------------------------------------------------------- !c! Elj pom = (pis / Rhead)**6.0d0 Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) !c! derivative of Elj is Glj dGLJdR = 4.0d0 * eps_head & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) !c!------------------------------------------------------------------- !c! Return the results !c! (see comments in Eqq) DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j) ) eagle = scalar( erhead_tail(1,2), dC_norm(1,j) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) ) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j) facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres) DO k = 1, 3 condor = (erhead_tail(k,2) & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j))) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gradpepcatx(k,i) = gradpepcatx(k,i) & - dGCLdR * pom & - dPOLdR2 * (erhead_tail(k,2) & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) & - dGLJdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j)) ! gradpepcatx(k,j) = gradpepcatx(k,j) & ! + dGCLdR * pom & ! + dPOLdR2 * condor & ! + dGLJdR * pom gradpepcat(k,i) = gradpepcat(k,i) & - dGCLdR * erhead(k) & - dPOLdR2 * erhead_tail(k,2) & - dGLJdR * erhead(k) gradpepcat(k,j) = gradpepcat(k,j) & + dGCLdR * erhead(k) & + dPOLdR2 * erhead_tail(k,2) & + dGLJdR * erhead(k) END DO RETURN END SUBROUTINE edq_cat SUBROUTINE edq_cat_pep(Ecl,Elj,Epol) use comm_momo use calc_data double precision facd3, adler,ecl,elj,epol alphapol2 = alphapolcat(itypj,itypi) w1 = wqdipcat(1,itypi,itypj) w2 = wqdipcat(2,itypi,itypj) pis = sig0headcat(itypi,itypj) eps_head = epsheadcat(itypi,itypj) !c!------------------------------------------------------------------- !c! R2 - distance between head of jth side chain and tail of ith sidechain R2 = 0.0d0 DO k = 1, 3 !c! Calculate head-to-tail distances R2=R2+(chead(k,2)-ctail(k,1))**2 END DO !c! Pitagoras R2 = dsqrt(R2) !c! R1 = dsqrt((Rtail**2)+((dtail(1,itypi,itypj) !c! & +dhead(1,1,itypi,itypj))**2)) !c! R2 = dsqrt((Rtail**2)+((dtail(2,itypi,itypj) !c! & +dhead(2,1,itypi,itypj))**2)) !c!------------------------------------------------------------------- !c! ecl sparrow = w1 * Qj * om1 hawk = w2 * Qj * Qj * (1.0d0 - sqom2) ! print *,"CO2", itypi,itypj ! print *,"CO?!.", w1,w2,Qj,om1 ECL = sparrow / Rhead**2.0d0 & - hawk / Rhead**4.0d0 !c!------------------------------------------------------------------- !c! derivative of ecl is Gcl !c! dF/dr part dGCLdR = - 2.0d0 * sparrow / Rhead**3.0d0 & + 4.0d0 * hawk / Rhead**5.0d0 !c! dF/dom1 dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0) !c! dF/dom2 dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0) !c-------------------------------------------------------------------- !c-------------------------------------------------------------------- !c Polarization energy !c Epol MomoFac2 = (1.0d0 - chi2 * sqom1) RR2 = R2 * R2 / MomoFac2 ee2 = exp(-(RR2 / (4.0d0 * a12sq))) fgb2 = sqrt(RR2 + a12sq * ee2) epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 ) dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) & / (fgb2 ** 5.0d0) dFGBdR2 = ( (R2 / MomoFac2) & * ( 2.0d0 - (0.5d0 * ee2) ) ) & / (2.0d0 * fgb2) dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) & * (2.0d0 - 0.5d0 * ee2) ) & / (2.0d0 * fgb2) dPOLdR2 = dPOLdFGB2 * dFGBdR2 !c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 !c! dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 !c!------------------------------------------------------------------- !c! Elj pom = (pis / Rhead)**6.0d0 Elj = 4.0d0 * eps_head * pom * (pom-1.0d0) !c! derivative of Elj is Glj dGLJdR = 4.0d0 * eps_head & * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) & + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0))) !c!------------------------------------------------------------------- !c! Return the results !c! (see comments in Eqq) DO k = 1, 3 erhead(k) = Rhead_distance(k)/Rhead erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) END DO erdxi = scalar( erhead(1), dC_norm(1,i) ) erdxj = scalar( erhead(1), dC_norm(1,j) ) eagle = scalar( erhead_tail(1,2), dC_norm(1,j) ) adler = scalar( erhead_tail(1,2), dC_norm(1,i) ) facd1 = d1 * vbld_inv(i+1)/2.0 facd2 = d2 * vbld_inv(j) facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0 DO k = 1, 3 condor = (erhead_tail(k,2) & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j))) pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i)) ! gradpepcatx(k,i) = gradpepcatx(k,i) & ! - dGCLdR * pom & ! - dPOLdR2 * (erhead_tail(k,2) & ! -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) & ! - dGLJdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j)) ! gradpepcatx(k,j) = gradpepcatx(k,j) & ! + dGCLdR * pom & ! + dPOLdR2 * condor & ! + dGLJdR * pom gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( & - dGCLdR * erhead(k) & - dPOLdR2 * erhead_tail(k,2) & - dGLJdR * erhead(k)) gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( & - dGCLdR * erhead(k) & - dPOLdR2 * erhead_tail(k,2) & - dGLJdR * erhead(k)) gradpepcat(k,j) = gradpepcat(k,j) & + dGCLdR * erhead(k) & + dPOLdR2 * erhead_tail(k,2) & + dGLJdR * erhead(k) END DO RETURN END SUBROUTINE edq_cat_pep SUBROUTINE edd(ECL) ! IMPLICIT NONE use comm_momo use calc_data double precision ecl !c! csig = sigiso(itypi,itypj) w1 = wqdip(1,itypi,itypj) w2 = wqdip(2,itypi,itypj) !c!------------------------------------------------------------------- !c! ECL fac = (om12 - 3.0d0 * om1 * om2) c1 = (w1 / (Rhead**3.0d0)) * fac c2 = (w2 / Rhead ** 6.0d0) & * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) ECL = c1 - c2 !c! write (*,*) "w1 = ", w1 !c! write (*,*) "w2 = ", w2 !c! write (*,*) "om1 = ", om1 !c! write (*,*) "om2 = ", om2 !c! write (*,*) "om12 = ", om12 !c! write (*,*) "fac = ", fac !c! write (*,*) "c1 = ", c1 !c! write (*,*) "c2 = ", c2 !c! write (*,*) "Ecl = ", Ecl !c! write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0) !c! write (*,*) "c2_2 = ", !c! & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2)) !c!------------------------------------------------------------------- !c! dervative of ECL is GCL... !c! dECL/dr c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0) c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) & * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2)) dGCLdR = c1 - c2 !c! dECL/dom1 c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0) c2 = (-6.0d0 * w2) / (Rhead**6.0d0) & * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 ) dGCLdOM1 = c1 - c2 !c! dECL/dom2 c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0) c2 = (-6.0d0 * w2) / (Rhead**6.0d0) & * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 ) dGCLdOM2 = c1 - c2 !c! dECL/dom12 c1 = w1 / (Rhead ** 3.0d0) c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 dGCLdOM12 = c1 - c2 !c!------------------------------------------------------------------- !c! Return the results !c! (see comments in Eqq) DO k= 1, 3 erhead(k) = Rhead_distance(k)/Rhead END DO erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) facd1 = d1 * vbld_inv(i+nres) facd2 = d2 * vbld_inv(j+nres) DO k = 1, 3 pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) gvdwx(k,i) = gvdwx(k,i) - dGCLdR * pom pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) gvdwx(k,j) = gvdwx(k,j) + dGCLdR * pom gvdwc(k,i) = gvdwc(k,i) - dGCLdR * erhead(k) gvdwc(k,j) = gvdwc(k,j) + dGCLdR * erhead(k) END DO RETURN END SUBROUTINE edd SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol) ! IMPLICIT NONE use comm_momo use calc_data real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb eps_out=80.0d0 itypi = itype(i,1) itypj = itype(j,1) !c! 1/(Gas Constant * Thermostate temperature) = BetaT !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!! !c! t_bath = 300 !c! BetaT = 1.0d0 / (t_bath * Rb)i Rb=0.001986d0 BetaT = 1.0d0 / (298.0d0 * Rb) !c! Gay-berne var's sig0ij = sigma( itypi,itypj ) chi1 = chi( itypi, itypj ) chi2 = chi( itypj, itypi ) chi12 = chi1 * chi2 chip1 = chipp( itypi, itypj ) chip2 = chipp( itypj, itypi ) chip12 = chip1 * chip2 ! chi1=0.0 ! chi2=0.0 ! chi12=0.0 ! chip1=0.0 ! chip2=0.0 ! chip12=0.0 !c! not used by momo potential, but needed by sc_angular which is shared !c! by all energy_potential subroutines alf1 = 0.0d0 alf2 = 0.0d0 alf12 = 0.0d0 !c! location, location, location ! xj = c( 1, nres+j ) - xi ! yj = c( 2, nres+j ) - yi ! zj = c( 3, nres+j ) - zi dxj = dc_norm( 1, nres+j ) dyj = dc_norm( 2, nres+j ) dzj = dc_norm( 3, nres+j ) !c! distance from center of chain(?) to polar/charged head !c! write (*,*) "istate = ", 1 !c! write (*,*) "ii = ", 1 !c! write (*,*) "jj = ", 1 d1 = dhead(1, 1, itypi, itypj) d2 = dhead(2, 1, itypi, itypj) !c! ai*aj from Fgb a12sq = rborn(itypi,itypj) * rborn(itypj,itypi) !c! a12sq = a12sq * a12sq !c! charge of amino acid itypi is... Qi = icharge(itypi) Qj = icharge(itypj) Qij = Qi * Qj !c! chis1,2,12 chis1 = chis(itypi,itypj) chis2 = chis(itypj,itypi) chis12 = chis1 * chis2 sig1 = sigmap1(itypi,itypj) sig2 = sigmap2(itypi,itypj) !c! write (*,*) "sig1 = ", sig1 !c! write (*,*) "sig2 = ", sig2 !c! alpha factors from Fcav/Gcav b1cav = alphasur(1,itypi,itypj) ! b1cav=0.0 b2cav = alphasur(2,itypi,itypj) b3cav = alphasur(3,itypi,itypj) b4cav = alphasur(4,itypi,itypj) wqd = wquad(itypi, itypj) !c! used by Fgb eps_in = epsintab(itypi,itypj) eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) !c! write (*,*) "eps_inout_fac = ", eps_inout_fac !c!------------------------------------------------------------------- !c! tail location and distance calculations Rtail = 0.0d0 DO k = 1, 3 ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i) ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j) END DO !c! tail distances will be themselves usefull elswhere !c1 (in Gcav, for example) Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 ) Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 ) Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 ) Rtail = dsqrt( & (Rtail_distance(1)*Rtail_distance(1)) & + (Rtail_distance(2)*Rtail_distance(2)) & + (Rtail_distance(3)*Rtail_distance(3))) !c!------------------------------------------------------------------- !c! Calculate location and distance between polar heads !c! distance between heads !c! for each one of our three dimensional space... d1 = dhead(1, 1, itypi, itypj) d2 = dhead(2, 1, itypi, itypj) DO k = 1,3 !c! location of polar head is computed by taking hydrophobic centre !c! and moving by a d1 * dc_norm vector !c! see unres publications for very informative images chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres) !c! distance !c! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) !c! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) Rhead_distance(k) = chead(k,2) - chead(k,1) END DO !c! pitagoras (root of sum of squares) Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) !c!------------------------------------------------------------------- !c! zero everything that should be zero'ed Egb = 0.0d0 ECL = 0.0d0 Elj = 0.0d0 Equad = 0.0d0 Epol = 0.0d0 eheadtail = 0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 RETURN END SUBROUTINE elgrad_init SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol) use comm_momo use calc_data real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb eps_out=80.0d0 itypi = itype(i,1) itypj = itype(j,5) !c! 1/(Gas Constant * Thermostate temperature) = BetaT !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!! !c! t_bath = 300 !c! BetaT = 1.0d0 / (t_bath * Rb)i Rb=0.001986d0 BetaT = 1.0d0 / (298.0d0 * Rb) !c! Gay-berne var's sig0ij = sigmacat( itypi,itypj ) chi1 = chi1cat( itypi, itypj ) chi2 = 0.0d0 chi12 = 0.0d0 chip1 = chipp1cat( itypi, itypj ) chip2 = 0.0d0 chip12 = 0.0d0 !c! not used by momo potential, but needed by sc_angular which is shared !c! by all energy_potential subroutines alf1 = 0.0d0 alf2 = 0.0d0 alf12 = 0.0d0 dxj = dc_norm( 1, nres+j ) dyj = dc_norm( 2, nres+j ) dzj = dc_norm( 3, nres+j ) !c! distance from center of chain(?) to polar/charged head d1 = dheadcat(1, 1, itypi, itypj) d2 = dheadcat(2, 1, itypi, itypj) !c! ai*aj from Fgb a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj) !c! a12sq = a12sq * a12sq !c! charge of amino acid itypi is... Qi = icharge(itypi) Qj = ichargecat(itypj) Qij = Qi * Qj !c! chis1,2,12 chis1 = chis1cat(itypi,itypj) chis2 = 0.0d0 chis12 = 0.0d0 sig1 = sigmap1cat(itypi,itypj) sig2 = sigmap2cat(itypi,itypj) !c! alpha factors from Fcav/Gcav b1cav = alphasurcat(1,itypi,itypj) b2cav = alphasurcat(2,itypi,itypj) b3cav = alphasurcat(3,itypi,itypj) b4cav = alphasurcat(4,itypi,itypj) wqd = wquadcat(itypi, itypj) !c! used by Fgb eps_in = epsintabcat(itypi,itypj) eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) !c!------------------------------------------------------------------- !c! tail location and distance calculations Rtail = 0.0d0 DO k = 1, 3 ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i) ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j) END DO !c! tail distances will be themselves usefull elswhere !c1 (in Gcav, for example) Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 ) Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 ) Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 ) Rtail = dsqrt( & (Rtail_distance(1)*Rtail_distance(1)) & + (Rtail_distance(2)*Rtail_distance(2)) & + (Rtail_distance(3)*Rtail_distance(3))) !c!------------------------------------------------------------------- !c! Calculate location and distance between polar heads !c! distance between heads !c! for each one of our three dimensional space... d1 = dheadcat(1, 1, itypi, itypj) d2 = dheadcat(2, 1, itypi, itypj) DO k = 1,3 !c! location of polar head is computed by taking hydrophobic centre !c! and moving by a d1 * dc_norm vector !c! see unres publications for very informative images chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) chead(k,2) = c(k, j) !c! distance !c! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) !c! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) Rhead_distance(k) = chead(k,2) - chead(k,1) END DO !c! pitagoras (root of sum of squares) Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) !c!------------------------------------------------------------------- !c! zero everything that should be zero'ed Egb = 0.0d0 ECL = 0.0d0 Elj = 0.0d0 Equad = 0.0d0 Epol = 0.0d0 eheadtail = 0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 RETURN END SUBROUTINE elgrad_init_cat SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol) use comm_momo use calc_data real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb eps_out=80.0d0 itypi = 10 itypj = itype(j,5) !c! 1/(Gas Constant * Thermostate temperature) = BetaT !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!! !c! t_bath = 300 !c! BetaT = 1.0d0 / (t_bath * Rb)i Rb=0.001986d0 BetaT = 1.0d0 / (298.0d0 * Rb) !c! Gay-berne var's sig0ij = sigmacat( itypi,itypj ) chi1 = chi1cat( itypi, itypj ) chi2 = 0.0d0 chi12 = 0.0d0 chip1 = chipp1cat( itypi, itypj ) chip2 = 0.0d0 chip12 = 0.0d0 !c! not used by momo potential, but needed by sc_angular which is shared !c! by all energy_potential subroutines alf1 = 0.0d0 alf2 = 0.0d0 alf12 = 0.0d0 dxj = 0.0d0 !dc_norm( 1, nres+j ) dyj = 0.0d0 !dc_norm( 2, nres+j ) dzj = 0.0d0 !dc_norm( 3, nres+j ) !c! distance from center of chain(?) to polar/charged head d1 = dheadcat(1, 1, itypi, itypj) d2 = dheadcat(2, 1, itypi, itypj) !c! ai*aj from Fgb a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj) !c! a12sq = a12sq * a12sq !c! charge of amino acid itypi is... Qi = 0 Qj = ichargecat(itypj) ! Qij = Qi * Qj !c! chis1,2,12 chis1 = chis1cat(itypi,itypj) chis2 = 0.0d0 chis12 = 0.0d0 sig1 = sigmap1cat(itypi,itypj) sig2 = sigmap2cat(itypi,itypj) !c! alpha factors from Fcav/Gcav b1cav = alphasurcat(1,itypi,itypj) b2cav = alphasurcat(2,itypi,itypj) b3cav = alphasurcat(3,itypi,itypj) b4cav = alphasurcat(4,itypi,itypj) wqd = wquadcat(itypi, itypj) !c! used by Fgb eps_in = epsintabcat(itypi,itypj) eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) !c!------------------------------------------------------------------- !c! tail location and distance calculations Rtail = 0.0d0 DO k = 1, 3 ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i) ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j) END DO !c! tail distances will be themselves usefull elswhere !c1 (in Gcav, for example) Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 ) Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 ) Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 ) Rtail = dsqrt( & (Rtail_distance(1)*Rtail_distance(1)) & + (Rtail_distance(2)*Rtail_distance(2)) & + (Rtail_distance(3)*Rtail_distance(3))) !c!------------------------------------------------------------------- !c! Calculate location and distance between polar heads !c! distance between heads !c! for each one of our three dimensional space... d1 = dheadcat(1, 1, itypi, itypj) d2 = dheadcat(2, 1, itypi, itypj) DO k = 1,3 !c! location of polar head is computed by taking hydrophobic centre !c! and moving by a d1 * dc_norm vector !c! see unres publications for very informative images chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i) chead(k,2) = c(k, j) !c! distance !c! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) !c! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) Rhead_distance(k) = chead(k,2) - chead(k,1) END DO !c! pitagoras (root of sum of squares) Rhead = dsqrt( & (Rhead_distance(1)*Rhead_distance(1)) & + (Rhead_distance(2)*Rhead_distance(2)) & + (Rhead_distance(3)*Rhead_distance(3))) !c!------------------------------------------------------------------- !c! zero everything that should be zero'ed Egb = 0.0d0 ECL = 0.0d0 Elj = 0.0d0 Equad = 0.0d0 Epol = 0.0d0 eheadtail = 0.0d0 dGCLdOM1 = 0.0d0 dGCLdOM2 = 0.0d0 dGCLdOM12 = 0.0d0 dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 RETURN END SUBROUTINE elgrad_init_cat_pep double precision function tschebyshev(m,n,x,y) implicit none integer i,m,n double precision x(n),y,yy(0:maxvar),aux !c Tschebyshev polynomial. Note that the first term is omitted !c m=0: the constant term is included !c m=1: the constant term is not included yy(0)=1.0d0 yy(1)=y do i=2,n yy(i)=2*yy(1)*yy(i-1)-yy(i-2) enddo aux=0.0d0 do i=m,n aux=aux+x(i)*yy(i) enddo tschebyshev=aux return end function tschebyshev !C-------------------------------------------------------------------------- double precision function gradtschebyshev(m,n,x,y) implicit none integer i,m,n double precision x(n+1),y,yy(0:maxvar),aux !c Tschebyshev polynomial. Note that the first term is omitted !c m=0: the constant term is included !c m=1: the constant term is not included yy(0)=1.0d0 yy(1)=2.0d0*y do i=2,n yy(i)=2*y*yy(i-1)-yy(i-2) enddo aux=0.0d0 do i=m,n aux=aux+x(i+1)*yy(i)*(i+1) !C print *, x(i+1),yy(i),i enddo gradtschebyshev=aux return end function gradtschebyshev subroutine make_SCSC_inter_list include 'mpif.h' real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp real*8 :: dist_init, dist_temp,r_buff_list integer:: contlisti(250*nres),contlistj(250*nres) ! integer :: newcontlisti(200*nres),newcontlistj(200*nres) integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr ! print *,"START make_SC" r_buff_list=5.0 ilist_sc=0 do i=iatsc_s,iatsc_e itypi=iabs(itype(i,1)) if (itypi.eq.ntyp1) cycle xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) call to_box(xi,yi,zi) do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) itypj=iabs(itype(j,1)) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j) yj=c(2,nres+j) zj=c(3,nres+j) call to_box(xj,yj,zj) ! call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) ! faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0 xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) dist_init=xj**2+yj**2+zj**2 ! dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 ! r_buff_list is a read value for a buffer if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then ! Here the list is created ilist_sc=ilist_sc+1 ! this can be substituted by cantor and anti-cantor contlisti(ilist_sc)=i contlistj(ilist_sc)=j endif enddo enddo enddo ! call MPI_Reduce(ilist_sc,g_ilist_sc,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) #ifdef DEBUG write (iout,*) "before MPIREDUCE",ilist_sc do i=1,ilist_sc write (iout,*) i,contlisti(i),contlistj(i) enddo #endif if (nfgtasks.gt.1)then call MPI_Reduce(ilist_sc,g_ilist_sc,1,& MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) ! write(iout,*) "before bcast",g_ilist_sc call MPI_Gather(ilist_sc,1,MPI_INTEGER,& i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR) displ(0)=0 do i=1,nfgtasks-1,1 displ(i)=i_ilist_sc(i-1)+displ(i-1) enddo ! write(iout,*) "before gather",displ(0),displ(1) call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,& newcontlisti,i_ilist_sc,displ,MPI_INTEGER,& king,FG_COMM,IERR) call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,& newcontlistj,i_ilist_sc,displ,MPI_INTEGER,& king,FG_COMM,IERR) call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR) ! write(iout,*) "before bcast",g_ilist_sc ! call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM) call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR) call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR) ! call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM) else g_ilist_sc=ilist_sc do i=1,ilist_sc newcontlisti(i)=contlisti(i) newcontlistj(i)=contlistj(i) enddo endif #ifdef DEBUG write (iout,*) "after MPIREDUCE",g_ilist_sc do i=1,g_ilist_sc write (iout,*) i,newcontlisti(i),newcontlistj(i) enddo #endif call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end) return end subroutine make_SCSC_inter_list !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine make_SCp_inter_list use MD_data, only: itime_mat include 'mpif.h' real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp real*8 :: dist_init, dist_temp,r_buff_list integer:: contlistscpi(250*nres),contlistscpj(250*nres) ! integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres) integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr ! print *,"START make_SC" r_buff_list=5.0 ilist_scp=0 do i=iatscp_s,iatscp_e if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle 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)) call to_box(xi,yi,zi) do iint=1,nscp_gr(i) do j=iscpstart(i,iint),iscpend(i,iint) itypj=iabs(itype(j,1)) 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 xj=c(1,j) yj=c(2,j) zj=c(3,j) call to_box(xj,yj,zj) xj=boxshift(xj-xi,boxxsize) yj=boxshift(yj-yi,boxysize) zj=boxshift(zj-zi,boxzsize) dist_init=xj**2+yj**2+zj**2 #ifdef DEBUG ! r_buff_list is a read value for a buffer if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then ! Here the list is created ilist_scp_first=ilist_scp_first+1 ! this can be substituted by cantor and anti-cantor contlistscpi_f(ilist_scp_first)=i contlistscpj_f(ilist_scp_first)=j endif #endif ! r_buff_list is a read value for a buffer if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then ! Here the list is created ilist_scp=ilist_scp+1 ! this can be substituted by cantor and anti-cantor contlistscpi(ilist_scp)=i contlistscpj(ilist_scp)=j endif enddo enddo enddo #ifdef DEBUG write (iout,*) "before MPIREDUCE",ilist_scp do i=1,ilist_scp write (iout,*) i,contlistscpi(i),contlistscpj(i) enddo #endif if (nfgtasks.gt.1)then call MPI_Reduce(ilist_scp,g_ilist_scp,1,& MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) ! write(iout,*) "before bcast",g_ilist_sc call MPI_Gather(ilist_scp,1,MPI_INTEGER,& i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR) displ(0)=0 do i=1,nfgtasks-1,1 displ(i)=i_ilist_scp(i-1)+displ(i-1) enddo ! write(iout,*) "before gather",displ(0),displ(1) call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,& newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,& king,FG_COMM,IERR) call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,& newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,& king,FG_COMM,IERR) call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR) ! write(iout,*) "before bcast",g_ilist_sc ! call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM) call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR) call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR) ! call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM) else g_ilist_scp=ilist_scp do i=1,ilist_scp newcontlistscpi(i)=contlistscpi(i) newcontlistscpj(i)=contlistscpj(i) enddo endif #ifdef DEBUG write (iout,*) "after MPIREDUCE",g_ilist_scp do i=1,g_ilist_scp write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i) enddo ! if (ifirstrun.eq.0) ifirstrun=1 ! do i=1,ilist_scp_first ! do j=1,g_ilist_scp ! if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.& ! (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126 ! enddo ! print *,itime_mat,"ERROR matrix needs updating" ! print *,contlistscpi_f(i),contlistscpj_f(i) ! 126 continue ! enddo #endif call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end) return end subroutine make_SCp_inter_list !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- subroutine make_pp_inter_list include 'mpif.h' real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp real*8 :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj real*8 :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi real*8 :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj integer:: contlistppi(250*nres),contlistppj(250*nres) ! integer :: newcontlistppi(200*nres),newcontlistppj(200*nres) integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr ! write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list ilist_pp=0 r_buff_list=5.0 do i=iatel_s,iatel_e if (itype(i,1).eq.ntyp1 .or. itype(i+1,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 call to_box(xmedi,ymedi,zmedi) call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi) ! write (iout,*) i,j,itype(i,1),itype(j,1) ! if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle ! 1,j) do j=ielstart(i),ielend(i) ! write (iout,*) i,j,itype(i,1),itype(j,1) if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle 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 xj=c(1,j)+0.5D0*dxj yj=c(2,j)+0.5D0*dyj zj=c(3,j)+0.5D0*dzj call to_box(xj,yj,zj) ! call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) ! faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0 xj=boxshift(xj-xmedi,boxxsize) yj=boxshift(yj-ymedi,boxysize) zj=boxshift(zj-zmedi,boxzsize) dist_init=xj**2+yj**2+zj**2 if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then ! Here the list is created ilist_pp=ilist_pp+1 ! this can be substituted by cantor and anti-cantor contlistppi(ilist_pp)=i contlistppj(ilist_pp)=j endif ! enddo enddo enddo #ifdef DEBUG write (iout,*) "before MPIREDUCE",ilist_pp do i=1,ilist_pp write (iout,*) i,contlistppi(i),contlistppj(i) enddo #endif if (nfgtasks.gt.1)then call MPI_Reduce(ilist_pp,g_ilist_pp,1,& MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) ! write(iout,*) "before bcast",g_ilist_sc call MPI_Gather(ilist_pp,1,MPI_INTEGER,& i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR) displ(0)=0 do i=1,nfgtasks-1,1 displ(i)=i_ilist_pp(i-1)+displ(i-1) enddo ! write(iout,*) "before gather",displ(0),displ(1) call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,& newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,& king,FG_COMM,IERR) call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,& newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,& king,FG_COMM,IERR) call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR) ! write(iout,*) "before bcast",g_ilist_sc ! call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM) call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR) call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR) ! call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM) else g_ilist_pp=ilist_pp do i=1,ilist_pp newcontlistppi(i)=contlistppi(i) newcontlistppj(i)=contlistppj(i) enddo endif call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end) #ifdef DEBUG write (iout,*) "after MPIREDUCE",g_ilist_pp do i=1,g_ilist_pp write (iout,*) i,newcontlistppi(i),newcontlistppj(i) enddo #endif return end subroutine make_pp_inter_list !----------------------------------------------------------------------------- double precision function boxshift(x,boxsize) implicit none double precision x,boxsize double precision xtemp xtemp=dmod(x,boxsize) if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then boxshift=xtemp-boxsize else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then boxshift=xtemp+boxsize else boxshift=xtemp endif return end function boxshift !----------------------------------------------------------------------------- subroutine to_box(xi,yi,zi) implicit none ! include 'DIMENSIONS' ! include 'COMMON.CHAIN' double precision xi,yi,zi xi=dmod(xi,boxxsize) if (xi.lt.0.0d0) xi=xi+boxxsize yi=dmod(yi,boxysize) if (yi.lt.0.0d0) yi=yi+boxysize zi=dmod(zi,boxzsize) if (zi.lt.0.0d0) zi=zi+boxzsize return end subroutine to_box !-------------------------------------------------------------------------- subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi) implicit none ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.CHAIN' double precision xi,yi,zi,sslipi,ssgradlipi double precision fracinbuf ! double precision sscalelip,sscagradlip #ifdef DEBUG write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick write (iout,*) "xi yi zi",xi,yi,zi #endif if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then ! the energy transfer exist if (zi.lt.buflipbot) then ! what fraction I am in fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick) ! lipbufthick is thickenes of lipid buffore sslipi=sscalelip(fracinbuf) ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick elseif (zi.gt.bufliptop) then fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick) sslipi=sscalelip(fracinbuf) ssgradlipi=sscagradlip(fracinbuf)/lipbufthick else sslipi=1.0d0 ssgradlipi=0.0 endif else sslipi=0.0d0 ssgradlipi=0.0 endif #ifdef DEBUG write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi #endif return end subroutine lipid_layer !-------------------------------------------------------------------------- !-------------------------------------------------------------------------- end module energy