X-Git-Url: http://mmka.chem.univ.gda.pl/gitweb/?a=blobdiff_plain;f=source%2Funres%2Fenergy.F90;h=bb7d08d5afe704eb0f2bd1c4bc4afffc7d5f22aa;hb=refs%2Fheads%2FUCGM;hp=4a763c20c4506c21ab6916269d8b2848e0eab645;hpb=e837223cef419e16dfd7fc71baee35cd807096e9;p=unres4.git diff --git a/source/unres/energy.F90 b/source/unres/energy.F90 index 4a763c2..bb7d08d 100644 --- a/source/unres/energy.F90 +++ b/source/unres/energy.F90 @@ -1,4 +1,4 @@ - module energy + module energy !----------------------------------------------------------------------------- use io_units use names @@ -74,7 +74,7 @@ ! amino-acid residue. ! common /precomp1/ real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,& - Ctobr,Ctobrder,Dtobr2,Dtobr2der !(2,maxres) + 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 @@ -87,6 +87,7 @@ 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 @@ -136,9 +137,12 @@ gvdwc_peppho !------------------------------IONS GRADIENT real(kind=8),dimension(:,:),allocatable :: gradcatcat, & - gradpepcat,gradpepcatx + gradpepcat,gradpepcatx,gradnuclcat,gradnuclcatx,gradcattranx,& + gradcattranc,gradcatangc,gradcatangx ! real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2) - +!---------------------------------------- + real(kind=8),dimension(:,:),allocatable ::gradlipelec,gradlipbond,& + gradlipang,gradliplj,gradpepmart, gradpepmartx real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,& gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres) @@ -181,7 +185,7 @@ !----------------------------------------------------------------------------- ! common.sbridge ! common /dyn_ssbond/ - real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres) + real(kind=8),dimension(:),allocatable :: dyn_ssbond_ij !(maxres,maxres) !----------------------------------------------------------------------------- ! common.sccor ! Parameters of the SCCOR term @@ -197,7 +201,11 @@ ! common /przechowalnia/ real(kind=8),dimension(:,:,:),allocatable :: zapas real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs) +#ifdef FIVEDIAG + real(kind=8),dimension(:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2) +#else real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2) +#endif !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ! @@ -208,7 +216,7 @@ ! energy_p_new_barrier.F !----------------------------------------------------------------------------- subroutine etotal(energia) -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' use MD_data #ifndef ISNAN @@ -235,36 +243,42 @@ ! include 'COMMON.TIME1' real(kind=8) :: time00 !el local variables - integer :: n_corr,n_corr1,ierror + 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 + real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6,ehomology_constr ! 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 + real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,& + ecation_nucl,ecat_prottran,ecation_protang ! energies for protein nucleic acid interaction real(kind=8) :: escbase,epepbase,escpho,epeppho +! energies for MARTINI + real(kind=8) :: elipbond,elipang,elipelec,eliplj,elipidprot #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 - - + real(kind=8) :: fac_shieldbuf(nres_molec(1)), & + grad_shield_locbuf1(3*maxcontsshi*nres_molec(1)), & + grad_shield_sidebuf1(3*maxcontsshi*nres_molec(1)), & + grad_shield_locbuf2(3*maxcontsshi*nres_molec(1)), & + grad_shield_sidebuf2(3*maxcontsshi*nres_molec(1)), & + grad_shieldbuf1(3*nres_molec(1)), & + grad_shieldbuf2(3*nres_molec(1)) + + integer ishield_listbuf(-1:nres_molec(1)), & + shield_listbuf(maxcontsshi,-1:nres_molec(1)),k,j,i,iii,impishi,mojint,jjj + integer :: imatupdate2 +! print *,"I START ENERGY" + imatupdate=100 + imatupdate2=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 @@ -282,7 +296,7 @@ ! allocate(ishield_listbuf(nres)) ! allocate(shield_listbuf(maxcontsshi,nres)) ! endif - +! print *,"wstrain check", wstrain ! print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, ! & " nfgtasks",nfgtasks if (nfgtasks.gt.1) then @@ -293,7 +307,7 @@ ! 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_(1)=wsc weights_(2)=wscp weights_(3)=welec weights_(4)=wcorr @@ -328,8 +342,13 @@ weights_(41)=wcatcat weights_(42)=wcatprot weights_(46)=wscbase - weights_(47)=wscpho - weights_(48)=wpeppho + weights_(47)=wpepbase + weights_(48)=wscpho + weights_(49)=wpeppho + weights_(50)=wcatnucl + weights_(56)=wcat_tran + weights_(58)=wlip_prot + weights_(52)=wmartini ! wcatcat= weights(41) ! wcatprot=weights(42) @@ -375,13 +394,56 @@ wcatcat= weights(41) wcatprot=weights(42) wscbase=weights(46) - wscpho=weights(47) - wpeppho=weights(48) + wpepbase=weights(47) + wscpho=weights(48) + wpeppho=weights(49) + wcatnucl=weights(50) + wmartini=weights(52) + wcat_tran=weights(56) + wlip_prot=weights(58) +! 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 (nres_molec(1).gt.0) then + 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 (nres_molec(4).gt.0) then + if (mod(itime_mat,imatupdate).eq.0) call make_lip_pep_list + endif + if (mod(itime_mat,imatupdate).eq.0) call make_pp_inter_list + if (nres_molec(5).gt.0) then + if (mod(itime_mat,imatupdate).eq.0) then +! print *,'Processor',myrank,' calling etotal ipot=',ipot + call make_cat_pep_list +! call make_cat_cat_list + endif + endif + endif + if (nres_molec(5).gt.0) then + if (mod(itime_mat,imatupdate2).eq.0) then +! print *, "before cat cat" +! print *,'Processor',myrank,' calling etotal ipot=',ipot +! call make_cat_pep_list + call make_cat_cat_list + endif + endif +! write (iout,*) "after make_pp_inter_list" + ! print *,'Processor',myrank,' calling etotal ipot=',ipot ! print *,'Processor',myrank,' nnt=',nnt,' nct=',nct #else @@ -396,6 +458,7 @@ ! Compute the side-chain and electrostatic interaction energy ! print *, "Before EVDW" ! goto (101,102,103,104,105,106) ipot + if (nres_molec(1).gt.0) then select case(ipot) ! Lennard-Jones potential. ! 101 call elj(evdw) @@ -609,9 +672,9 @@ .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then #endif - write(iout,*),"just befor eelec call" +! print *,"just befor eelec call" call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) -! write (iout,*) "ELEC calc" +! print *, "ELEC calc" else ees=0.0d0 evdw1=0.0d0 @@ -643,7 +706,7 @@ call escp_soft_sphere(evdw2,evdw2_14) endif ! write(iout,*) "in etotal before ebond",ipot - +! print *,"after escp" ! ! Calculate the bond-stretching energy ! @@ -655,19 +718,34 @@ ! Calculate the disulfide-bridge and other energy and the contributions ! from other distance constraints. ! print *,'Calling EHPB' - call edis(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) +! 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 - ethetacnstr=0 + ebe=0.0d0 endif + ethetacnstr=0.0d0 +! write(iout,*) with_theta_constr,"with_theta_constr" + if (with_theta_constr) call etheta_constr(ethetacnstr) + ! write(iout,*) "in etotal afer ebe",ipot ! print *,"Processor",myrank," computed UB" @@ -675,24 +753,50 @@ ! Calculate the SC local energy. ! call esc(escloc) -!elwrite(iout,*) "in etotal afer esc",ipot +! print *, "in etotal afer esc",wtor ! print *,"Processor",myrank," computed USC" ! ! Calculate the virtual-bond torsional energy. ! !d print *,'nterm=',nterm - if (wtor.gt.0) then - call etor(etors,edihcnstr) +! if (wtor.gt.0) then +! call etor(etors,edihcnstr) +! else +! etors=0 +! edihcnstr=0 +! endif + if (wtor.gt.0.0d0) then +! print *,"WTOR",wtor,tor_mode + 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 - edihcnstr=0 + etors=0.0d0 endif + edihcnstr=0.0d0 + if (ndih_constr.gt.0) call etor_constr(edihcnstr) +!c print *,"Processor",myrank," computed Utor" + +! print *, "constr_homol",constr_homology ! print *,"Processor",myrank," computed Utor" - + if (constr_homology.ge.1) then + call e_modeller(ehomology_constr) +! print *,'iset=',iset,'me=',me,ehomology_constr, +! & 'Processor',fg_rank,' CG group',kolor, +! & ' absolute rank',MyRank +! print *,"tu" + else + ehomology_constr=0.0d0 + endif + ! ! 6/23/01 Calculate double-torsional energy ! -!elwrite(iout,*) "in etotal",ipot +! print *, "before etor_d",wtor_d if (wtor_d.gt.0) then call etor_d(etors_d) else @@ -739,8 +843,8 @@ ! ! 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" + if((usampl).and.(totT.gt.eq_time)) then + write(iout,*) "usampl",usampl call EconstrQ !elwrite(iout,*) "afeter multibody hb" call Econstr_back @@ -758,13 +862,53 @@ else eliptran=0.0d0 endif + else + eliptran=0.0d0 + evdw=0.0d0 +#ifdef SCP14 + evdw2=0.0d0 + evdw2_14=0.0d0 +#else + evdw2=0.0d0 +#endif +#ifdef SPLITELE + ees=0.0d0 + evdw1=0.0d0 +#else + ees=0.0d0 + evdw1=0.0d0 +#endif + ecorr=0.0d0 + ecorr5=0.0d0 + ecorr6=0.0d0 + eel_loc=0.0d0 + eello_turn3=0.0d0 + eello_turn4=0.0d0 + eturn6=0.0d0 + ebe=0.0d0 + escloc=0.0d0 + etors=0.0d0 + etors_d=0.0d0 + ehpb=0.0d0 + edihcnstr=0.0d0 + estr=0.0d0 + Uconst=0.0d0 + esccor=0.0d0 + ehomology_constr=0.0d0 + ethetacnstr=0.0d0 + endif !nres_molec(1) +! write(iout,*) "TU JEST PRZED EHPB" +! call edis(ehpb) 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 +! print *,"before tubemode",tubemode if (tubemode.eq.1) then call calctube(etube) else if (tubemode.eq.2) then @@ -774,8 +918,11 @@ else etube=0.0d0 endif +! print *, "TU JEST PRZED EHPB" + call edis(ehpb) + !-------------------------------------------------------- -! write (iout,*) "NRES_MOLEC(2),",nres_molec(2) +! print *, "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 @@ -787,10 +934,12 @@ 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 @@ -799,17 +948,42 @@ 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) - if (nfgtasks.gt.1) then - if (fg_rank.eq.0) then - call ecatcat(ecationcation) - endif +! print *,"before ecatcat",wcatcat + if (nres_molec(5).gt.0) then + if (g_ilist_catsctran.gt.0) then + call ecat_prot_transition(ecat_prottran) + else + ecat_prottran=0.0d0 + endif + if (g_ilist_catscang.gt.0) then + call ecat_prot_ang(ecation_protang) + else + ecation_protang=0.0d0 + endif +! if (nfgtasks.gt.1) then +! if (fg_rank.eq.0) then + if (nres_molec(5).gt.1) call ecatcat(ecationcation) +! endif +! else +! if (nres_molec(5).gt.1) call ecatcat(ecationcation) +! endif + if (oldion.gt.0) then + if (g_ilist_catpnorm.gt.0) call ecat_prot(ecation_prot) + else + if (g_ilist_catpnorm.gt.0) call ecats_prot_amber(ecation_prot) + endif else - call ecatcat(ecationcation) + ecationcation=0.0d0 + ecation_prot=0.0d0 + ecation_protang=0.0d0 + ecat_prottran=0.0d0 endif - call ecat_prot(ecation_prot) - if (nres_molec(2).gt.0) then + if (g_ilist_catscnorm.eq.0) ecation_prot=0.0d0 + 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) @@ -820,8 +994,32 @@ escpho=0.0 epeppho=0.0 endif +! MARTINI FORCE FIELD ENERGY TERMS + if (nres_molec(4).gt.0) then + if (nfgtasks.gt.1) then + if (fg_rank.eq.0) then + call lipid_bond(elipbond) + call lipid_angle(elipang) + endif + else + call lipid_bond(elipbond) + call lipid_angle(elipang) + endif + call lipid_LJ(eliplj) + call lipid_elec(elipelec) + if (nres_molec(1).gt.0) then + call elip_prot(elipidprot) + else + elipidprot=0.0d0 + endif + else + elipbond=0.0d0 + elipang=0.0d0 + eliplj=0.0d0 + elipelec=0.0d0 + endif ! call ecatcat(ecationcation) -! print *,"after ebend", ebe_nucl +! print *,"after ebend", wtor_nucl #ifdef TIMING time_enecalc=time_enecalc+MPI_Wtime()-time00 #endif @@ -885,12 +1083,26 @@ ! 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(41)=ecation_prot - energia(42)=ecationcation + 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 + energia(51)=ehomology_constr +! energia(51)=homology + energia(52)=elipbond + energia(53)=elipang + energia(54)=eliplj + energia(55)=elipelec + energia(56)=ecat_prottran + energia(57)=ecation_protang + energia(58)=elipidprot +! write(iout,*) elipelec,"elipelec" +! write(iout,*) elipang,"elipang" +! write(iout,*) eliplj,"eliplj" call sum_energy(energia,.true.) if (dyn_ss) call dyn_set_nss ! print *," Processor",myrank," left SUM_ENERGY" @@ -903,7 +1115,7 @@ end subroutine etotal !----------------------------------------------------------------------------- subroutine sum_energy(energia,reduce) -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' #ifndef ISNAN external proc_proc @@ -932,10 +1144,12 @@ 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 + ecorr3_nucl,ehomology_constr + real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,& + ecation_nucl,ecat_prottran,ecation_protang real(kind=8) :: escbase,epepbase,escpho,epeppho integer :: i + real(kind=8) :: elipbond,elipang,eliplj,elipelec,elipidprot #ifdef MPI integer :: ierr real(kind=8) :: time00 @@ -1011,12 +1225,23 @@ etors_d_nucl=energia(36) ecorr_nucl=energia(37) ecorr3_nucl=energia(38) - ecation_prot=energia(41) - ecationcation=energia(42) + ecation_prot=energia(42) + ecationcation=energia(41) escbase=energia(46) epepbase=energia(47) escpho=energia(48) epeppho=energia(49) + ecation_nucl=energia(50) + ehomology_constr=energia(51) + elipbond=energia(52) + elipang=energia(53) + eliplj=energia(54) + elipelec=energia(55) + ecat_prottran=energia(56) + ecation_protang=energia(57) + elipidprot=energia(58) +! ecations_prot_amber=energia(50) + ! energia(41)=ecation_prot ! energia(42)=ecationcation @@ -1034,7 +1259,15 @@ +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 + +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl& + +(elipbond+elipang+eliplj+elipelec)*wmartini& + +wcat_tran*ecat_prottran+ecation_protang& + +wlip_prot*elipidprot& +#ifdef WHAM_RUN + +0.0d0 +#else + +ehomology_constr +#endif #else etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) & +wang*ebe+wtor*etors+wscloc*escloc & @@ -1048,7 +1281,15 @@ +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 + +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl& + +(elipbond+elipang+eliplj+elipelec)*wmartini& + +wcat_tran*ecat_prottran+ecation_protang& + +wlip_prot*elipidprot& +#ifdef WHAM_RUN + +0.0d0 +#else + +ehomology_constr +#endif #endif energia(0)=etot ! detecting NaNQ @@ -1076,7 +1317,7 @@ end subroutine sum_energy !----------------------------------------------------------------------------- subroutine rescale_weights(t_bath) -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) #ifdef MPI include 'mpif.h' #endif @@ -1156,12 +1397,17 @@ 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) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.FFIELD' @@ -1175,10 +1421,11 @@ 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 + ecorr3_nucl,ehomology_constr + real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,& + ecation_nucl,ecat_prottran,ecation_protang real(kind=8) :: escbase,epepbase,escpho,epeppho - + real(kind=8) :: elipbond,elipang,eliplj,elipelec,elipidprot etot=energia(0) evdw=energia(1) evdw2=energia(2) @@ -1224,12 +1471,22 @@ etors_d_nucl=energia(36) ecorr_nucl=energia(37) ecorr3_nucl=energia(38) - ecation_prot=energia(41) - ecationcation=energia(42) + ecation_prot=energia(42) + ecationcation=energia(41) escbase=energia(46) epepbase=energia(47) escpho=energia(48) epeppho=energia(49) + ecation_nucl=energia(50) + elipbond=energia(52) + elipang=energia(53) + eliplj=energia(54) + elipelec=energia(55) + ecat_prottran=energia(56) + ecation_protang=energia(57) + ehomology_constr=energia(51) + elipidprot=energia(58) +! ecations_prot_amber=energia(50) #ifdef SPLITELE write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,& estr,wbond,ebe,wang,& @@ -1243,9 +1500,12 @@ 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, & + ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,& + ecat_prottran,wcat_tran,ecation_protang,wcat_ang,& + ecationcation,wcatcat, & escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,& - etot + ecation_nucl,wcatnucl,ehomology_constr,& + elipbond,elipang,eliplj,elipelec,elipidprot,wlip_prot,etot 10 format (/'Virtual-chain energies:'// & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ & @@ -1287,11 +1547,20 @@ '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)'/ & + 'ECATPTRAN=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot tran)'/ & + 'ECATPANG=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot angle)'/ & '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)'/& + 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/& + 'ELIPBOND=',1pE16.6,'(matrini bond energy)'/& + 'ELIPANG=',1pE16.6,'(matrini angle energy)'/& + 'ELIPLJ=',1pE16.6,'(matrini Lennard-Jones energy)'/& + 'ELIPELEC=',1pE16.6,'(matrini electrostatic energy)'/& + 'ELIPPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(lipid prot)'/ & 'ETOT= ',1pE16.6,' (total)') #else write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,& @@ -1300,15 +1569,15 @@ 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,Eafmforc, & - etube,wtube, & + ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce, & + etube,wtube, ehomology_constr,& 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& + 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,& - etot + ecation_nucl,wcatnucl,ehomology_constr,elipidprot,wlip_prot,etot 10 format (/'Virtual-chain energies:'// & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ & @@ -1354,6 +1623,13 @@ '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)'/& + 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/& + 'ELIPBOND=',1pE16.6,'(matrini bond energy)'/& + 'ELIPANG=',1pE16.6,'(matrini angle energy)'/& + 'ELIPLJ=',1pE16.6,'(matrini Lennard-Jones energy)'/& + 'ELIPELEC=',1pE16.6,'(matrini electrostatic energy)'/& + 'ELIPPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(lipid prot)'/ & 'ETOT= ',1pE16.6,' (total)') #endif return @@ -1364,7 +1640,7 @@ ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the LJ potential of interaction. ! -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' real(kind=8),parameter :: accur=1.0d-10 ! include 'COMMON.GEO' @@ -1382,7 +1658,8 @@ integer :: num_conti !el local variables integer :: i,itypi,iint,j,itypi1,itypj,k - real(kind=8) :: rij,rcut,fcont,fprimcont,rrij + real(kind=8) :: 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 @@ -1400,6 +1677,9 @@ 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 ! @@ -1414,6 +1694,15 @@ 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 @@ -1532,7 +1821,7 @@ ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the LJK potential of interaction. ! -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.VAR' @@ -1546,7 +1835,8 @@ logical :: scheck !el local variables integer :: i,iint,j,itypi,itypi1,k,itypj - real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij + real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij, & + sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij ! print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon @@ -1558,6 +1848,9 @@ 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. ! @@ -1568,6 +1861,15 @@ 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 @@ -1623,7 +1925,7 @@ ! use comm_srutu use calc_data -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.VAR' @@ -1641,7 +1943,8 @@ logical :: lprn !el local variables integer :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi + real(kind=8) :: rrij,xi,yi,zi, sslipi,ssgradlipi, sslipj, & + ssgradlipj, aa, bb real(kind=8) :: evdw,fac,e1,e2,sigm,epsi ! print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon @@ -1659,6 +1962,8 @@ 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) @@ -1696,6 +2001,15 @@ 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) @@ -1753,7 +2067,7 @@ ! assuming the Gay-Berne potential of interaction. ! use calc_data -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.VAR' @@ -1768,7 +2082,7 @@ ! include 'COMMON.SBRIDGE' logical :: lprn !el local variables - integer :: iint,itypi,itypi1,itypj,subchap + integer :: iint,itypi,itypi1,itypj,subchap,icont,countss 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,& @@ -1781,6 +2095,7 @@ ! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 lprn=.false. + countss=0 ! if (icall.eq.0) lprn=.false. !el ind=0 dCAVdOM2=0.0d0 @@ -1789,9 +2104,13 @@ dCAVdOM1=0.0d0 dGCLdOM1=0.0d0 dPOLdOM1=0.0d0 - - - do i=iatsc_s,iatsc_e +! write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j + if (nres_molec(1).eq.0) return + do icont=g_listscsc_start,g_listscsc_end + i=newcontlisti(icont) + j=newcontlistj(icont) +! write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j +! do i=iatsc_s,iatsc_e !C print *,"I am in EVDW",i itypi=iabs(itype(i,1)) ! if (i.ne.47) cycle @@ -1800,36 +2119,9 @@ xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) - xi=dmod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=dmod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=dmod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - - if ((zi.gt.bordlipbot) & - .and.(zi.lt.bordliptop)) then -!C the energy transfer exist - if (zi.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zi-bordlipbot)/lipbufthick) -!C 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 -! print *, sslipi,ssgradlipi + 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) @@ -1840,16 +2132,17 @@ ! ! Calculate SC interaction energy. ! - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) +! 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) + countss=countss+1 + call dyn_ssbond_ene(i,j,evdwij,countss) 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) + do k=j+1,nres !C search over all next residues if (dyn_ss_mask(k)) then !C check if they are cysteins @@ -1903,73 +2196,16 @@ xj=c(1,nres+j) yj=c(2,nres+j) zj=c(3,nres+j) - xj=dmod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=dmod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=dmod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize -! print *,"tu",xi,yi,zi,xj,yj,zj -! print *,"tu2",j,j+nres,c(1,j),c(1,j+nres) -! this fragment set correct epsilon for lipid phase - if ((zj.gt.bordlipbot) & - .and.(zj.lt.bordliptop)) then -!C the energy transfer exist - if (zj.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zj-bordlipbot)/lipbufthick) -!C lipbufthick is thickenes of lipid buffore - sslipj=sscalelip(fracinbuf) - ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick - elseif (zj.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick) - sslipj=sscalelip(fracinbuf) - ssgradlipj=sscagradlip(fracinbuf)/lipbufthick - else - sslipj=1.0d0 - ssgradlipj=0.0 - endif - else - sslipj=0.0d0 - ssgradlipj=0.0 - endif - 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 -!------------------------------------------------ - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif + call to_box(xj,yj,zj) + call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) +! write (iout,*) "KWA2", itypi,itypj + 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) @@ -1982,8 +2218,8 @@ ! write(iout,*)"c ", c(1,:), c(2,:), c(3,:) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj))) - sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj))) + sss_ele_cut=sscale_ele(1.0d0/(rij)) + sss_ele_grad=sscagrad_ele(1.0d0/(rij)) ! print *,sss_ele_cut,sss_ele_grad,& ! 1.0d0/(rij),r_cut_ele,rlamb_ele if (sss_ele_cut.le.0.0) cycle @@ -2032,7 +2268,7 @@ endif if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')& - 'evdw',i,j,evdwij,xi,xj,rij !,"egb" + 'evdw',i,j,evdwij,1.0D0/rij,1.0D0/rij_shift,dabs(aa/bb)**(1.0D0/6.0D0)!,"egb" !C print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j) ! if (energy_dec) write (iout,*) & ! 'evdw',i,j,evdwij @@ -2045,7 +2281,7 @@ fac=rij*fac ! print *,'before fac',fac,rij,evdwij fac=fac+evdwij*sss_ele_grad/sss_ele_cut& - /sigma(itypi,itypj)*rij + *rij ! print *,'grad part scale',fac, & ! evdwij*sss_ele_grad/sss_ele_cut & ! /sigma(itypi,itypj)*rij @@ -2066,8 +2302,8 @@ ! Calculate angular part of the gradient. call sc_grad ENDIF ! dyn_ss - enddo ! j - enddo ! iint +! enddo ! j +! enddo ! iint enddo ! i ! print *,"ZALAMKA", evdw ! write (iout,*) "Number of loop steps in EGB:",ind @@ -2082,7 +2318,7 @@ ! use comm_srutu use calc_data -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.VAR' @@ -2099,7 +2335,8 @@ logical :: lprn !el local variables integer :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm + real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2, & + sigm,sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi ! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon @@ -2114,6 +2351,8 @@ 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) @@ -2153,6 +2392,15 @@ 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) @@ -2217,7 +2465,7 @@ ! This subroutine calculates the interaction energy of nonbonded side chains ! assuming the LJ potential of interaction. ! -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' real(kind=8),parameter :: accur=1.0d-10 ! include 'COMMON.GEO' @@ -2246,6 +2494,8 @@ 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. ! @@ -2255,9 +2505,9 @@ 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 + xj=boxshift(c(1,nres+j)-xi,boxxsize) + yj=boxshift(c(2,nres+j)-yi,boxysize) + zj=boxshift(c(3,nres+j)-zi,boxzsize) rij=xj*xj+yj*yj+zj*zj ! write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj r0ij=r0(itypi,itypj) @@ -2298,7 +2548,7 @@ ! ! Soft-sphere potential of p-p interaction ! -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.CONTROL' ! include 'COMMON.IOUNITS' @@ -2334,6 +2584,7 @@ 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) num_conti=0 ! write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) do j=ielstart(i),ielend(i) @@ -2350,6 +2601,10 @@ xj=c(1,j)+0.5D0*dxj-xmedi yj=c(2,j)+0.5D0*dyj-ymedi zj=c(3,j)+0.5D0*dzj-zmedi + call to_box(xj,yj,zj) + xj=boxshift(xj-xmedi,boxxsize) + yj=boxshift(yj-ymedi,boxysize) + zj=boxshift(zj-zmedi,boxzsize) rij=xj*xj+yj*yj+zj*zj if (rij.lt.r0ijsq) then evdw1ij=0.25d0*(rij-r0ijsq)**2 @@ -2393,7 +2648,7 @@ end subroutine eelec_soft_sphere !----------------------------------------------------------------------------- subroutine vec_and_deriv -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -2580,7 +2835,7 @@ end subroutine vec_and_deriv !----------------------------------------------------------------------------- subroutine check_vecgrad -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.GEO' @@ -2668,7 +2923,7 @@ end subroutine check_vecgrad !----------------------------------------------------------------------------- subroutine set_matrices -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -2688,21 +2943,212 @@ ! include 'COMMON.VECTORS' ! include 'COMMON.FFIELD' real(kind=8) :: auxvec(2),auxmat(2,2) - integer :: i,iti1,iti,k,l - real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2 + integer :: i,iti1,iti,k,l,ii,innt,inct + real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,& + sint1sq,sint1cub,sint1cost1,b1k,b2k,aux ! print *,"in set matrices" ! ! Compute the virtual-bond-torsional-angle dependent quantities needed ! to calculate the el-loc multibody terms of various order. ! !AL el mu=0.0d0 + +#ifdef PARMAT + do i=ivec_start+2,ivec_end+2 +#else + do i=3,nres+1 +#endif +#ifdef FIVEDIAG + ii=ireschain(i-2) +!c write (iout,*) "i",i,i-2," ii",ii + if (ii.eq.0) cycle + innt=chain_border(1,ii) + inct=chain_border(2,ii) +!c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct +!c if (i.gt. nnt+2 .and. i.lt.nct+2) then + if (i.gt. innt+2 .and. i.lt.inct+2) then + if (itype(i-2,1).eq.0) then + iti = nloctyp + else + iti = itype2loc(itype(i-2,1)) + endif + else + iti=nloctyp + endif +!c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then + if (i.gt. innt+1 .and. i.lt.inct+1) then +! iti1 = itype2loc(itype(i-1)) + if (itype(i-1,1).eq.0) then + iti1 = nloctyp + else + iti1 = itype2loc(itype(i-1,1)) + endif + else + iti1=nloctyp + endif +#else + if (i.gt. nnt+2 .and. i.lt.nct+2) then + if (itype(i-2,1).eq.0) then + iti = nloctyp + else + iti = itype2loc(itype(i-2,1)) + endif + else + iti=nloctyp + endif +!c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then + if (i.gt. nnt+1 .and. i.lt.nct+1) then + iti1 = itype2loc(itype(i-1,1)) + else + iti1=nloctyp + endif +#endif +! print *,i,itype(i-2,1),iti +#ifdef NEWCORR + cost1=dcos(theta(i-1)) + sint1=dsin(theta(i-1)) + sint1sq=sint1*sint1 + sint1cub=sint1sq*sint1 + sint1cost1=2*sint1*cost1 +! print *,"cost1",cost1,theta(i-1) +!c write (iout,*) "bnew1",i,iti +!c write (iout,*) (bnew1(k,1,iti),k=1,3) +!c write (iout,*) (bnew1(k,2,iti),k=1,3) +!c write (iout,*) "bnew2",i,iti +!c write (iout,*) (bnew2(k,1,iti),k=1,3) +!c write (iout,*) (bnew2(k,2,iti),k=1,3) + k=1 +! print *,bnew1(1,k,iti),"bnew1" + do k=1,2 + b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1 +! print *,b1k +! write(*,*) shape(b1) +! if(.not.allocated(b1)) print *, "WTF?" + b1(k,i-2)=sint1*b1k +! +! print *,b1(k,i-2) + + gtb1(k,i-2)=cost1*b1k-sint1sq*& + (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1) +! print *,gtb1(k,i-2) + + b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1 + b2(k,i-2)=sint1*b2k +! print *,b2(k,i-2) + + gtb2(k,i-2)=cost1*b2k-sint1sq*& + (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1) +! print *,gtb2(k,i-2) + + enddo +! print *,b1k,b2k + do k=1,2 + aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1 + cc(1,k,i-2)=sint1sq*aux + gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*& + (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1) + aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1 + dd(1,k,i-2)=sint1sq*aux + gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*& + (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1) + enddo +! print *,"after cc" + cc(2,1,i-2)=cc(1,2,i-2) + cc(2,2,i-2)=-cc(1,1,i-2) + gtcc(2,1,i-2)=gtcc(1,2,i-2) + gtcc(2,2,i-2)=-gtcc(1,1,i-2) + dd(2,1,i-2)=dd(1,2,i-2) + dd(2,2,i-2)=-dd(1,1,i-2) + gtdd(2,1,i-2)=gtdd(1,2,i-2) + gtdd(2,2,i-2)=-gtdd(1,1,i-2) +! print *,"after dd" + + do k=1,2 + do l=1,2 + aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1 + EE(l,k,i-2)=sint1sq*aux + gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti) + enddo + enddo + EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1 + EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1 + EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti) + EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti) + gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1 + gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1 + gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1 +! print *,"after ee" + +!c b1tilde(1,i-2)=b1(1,i-2) +!c b1tilde(2,i-2)=-b1(2,i-2) +!c b2tilde(1,i-2)=b2(1,i-2) +!c b2tilde(2,i-2)=-b2(2,i-2) +#ifdef DEBUG + write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2) + write(iout,*) 'b1=',(b1(k,i-2),k=1,2) + write(iout,*) 'b2=',(b2(k,i-2),k=1,2) + write (iout,*) 'theta=', theta(i-1) +#endif +#else + if (i.gt. innt+2 .and. i.lt.inct+2) then +! write(iout,*) "i,",molnum(i),nloctyp +! print *, "i,",molnum(i),i,itype(i-2,1) + if (molnum(i).eq.1) then + if (itype(i-2,1).eq.ntyp1) then + iti=nloctyp + else + iti = itype2loc(itype(i-2,1)) + endif + else + iti=nloctyp + endif + else + iti=nloctyp + endif +!c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti +!c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then + if (i.gt. nnt+1 .and. i.lt.nct+1) then + iti1 = itype2loc(itype(i-1,1)) + else + iti1=nloctyp + endif +! print *,i,iti + b1(1,i-2)=b(3,iti) + b1(2,i-2)=b(5,iti) + b2(1,i-2)=b(2,iti) + b2(2,i-2)=b(4,iti) + do k=1,2 + do l=1,2 + CC(k,l,i-2)=ccold(k,l,iti) + DD(k,l,i-2)=ddold(k,l,iti) + EE(k,l,i-2)=eeold(k,l,iti) + enddo + enddo +#endif + b1tilde(1,i-2)= b1(1,i-2) + b1tilde(2,i-2)=-b1(2,i-2) + b2tilde(1,i-2)= b2(1,i-2) + b2tilde(2,i-2)=-b2(2,i-2) +!c + Ctilde(1,1,i-2)= CC(1,1,i-2) + Ctilde(1,2,i-2)= CC(1,2,i-2) + Ctilde(2,1,i-2)=-CC(2,1,i-2) + Ctilde(2,2,i-2)=-CC(2,2,i-2) +!c + Dtilde(1,1,i-2)= DD(1,1,i-2) + Dtilde(1,2,i-2)= DD(1,2,i-2) + Dtilde(2,1,i-2)=-DD(2,1,i-2) + Dtilde(2,2,i-2)=-DD(2,2,i-2) + enddo #ifdef PARMAT do i=ivec_start+2,ivec_end+2 #else do i=3,nres+1 #endif + ! print *,i,"i" - if (i .lt. nres+1) then + if (i .lt. nres+1 .and. (itype(i-1,1).lt.ntyp1).and.(itype(i-1,1).ne.0)) then +! if (i .lt. nres+1) then sin1=dsin(phi(i)) cos1=dcos(phi(i)) sintab(i-2)=sin1 @@ -2739,7 +3185,7 @@ Ug2(2,1,i-2)=0.0d0 Ug2(2,2,i-2)=0.0d0 endif - if (i .gt. 3 .and. i .lt. nres+1) then + if (i .gt. 3) then ! .and. i .lt. nres+1) then obrot_der(1,i-2)=-sin1 obrot_der(2,i-2)= cos1 Ugder(1,1,i-2)= sin1 @@ -2773,37 +3219,43 @@ if (itype(i-2,1).eq.0) then iti=ntortyp+1 else - iti = itortyp(itype(i-2,1)) + iti = itype2loc(itype(i-2,1)) endif else - iti=ntortyp+1 + iti=nloctyp endif ! if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then if (i.gt. nnt+1 .and. i.lt.nct+1) then if (itype(i-1,1).eq.0) then - iti1=ntortyp+1 + iti1=nloctyp else - iti1 = itortyp(itype(i-1,1)) + iti1 = itype2loc(itype(i-1,1)) endif else - iti1=ntortyp+1 + iti1=nloctyp endif ! print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1) !d write (iout,*) '*******i',i,' iti1',iti -!d write (iout,*) 'b1',b1(:,iti) -!d write (iout,*) 'b2',b2(:,iti) +! write (iout,*) 'b1',b1(:,iti) +! write (iout,*) 'b2',b2(:,i-2) !d write (iout,*) 'Ug',Ug(:,:,i-2) ! if (i .gt. iatel_s+2) then if (i .gt. nnt+2) then - call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2)) - call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2)) + call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2)) +#ifdef NEWCORR + call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2)) +!c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj" +#endif + + call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2)) + call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2)) if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then - call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2)) - call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2)) - call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2)) - call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2)) - call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2)) + call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2)) + call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2)) + call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2)) + call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2)) + call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2)) endif else do k=1,2 @@ -2818,44 +3270,44 @@ enddo enddo endif - call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2)) - call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2)) + call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2)) + call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2)) do k=1,2 muder(k,i-2)=Ub2der(k,i-2) enddo ! if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then if (i.gt. nnt+1 .and. i.lt.nct+1) then if (itype(i-1,1).eq.0) then - iti1=ntortyp+1 + iti1=nloctyp elseif (itype(i-1,1).le.ntyp) then - iti1 = itortyp(itype(i-1,1)) + iti1 = itype2loc(itype(i-1,1)) else - iti1=ntortyp+1 + iti1=nloctyp endif else - iti1=ntortyp+1 + iti1=nloctyp endif do k=1,2 - mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1) + mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1) enddo -! if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2) -! if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1) -! if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2) + if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2) + if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1) + if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2) !d write (iout,*) 'mu1',mu1(:,i-2) !d write (iout,*) 'mu2',mu2(:,i-2) if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) & then - call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2)) - call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2)) - call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2)) - call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2)) - call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2)) + call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2)) + call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2)) + call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2)) + call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2)) + call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2)) ! Vectors and matrices dependent on a single virtual-bond dihedral. - call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1)) + call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1)) call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2)) call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2)) - call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2)) - call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2)) + call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2)) + call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2)) call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2)) call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2)) call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2)) @@ -3146,7 +3598,7 @@ ! the orientation of the CA-CA virtual bonds. ! use comm_locel -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) #ifdef MPI include 'mpif.h' #endif @@ -3190,7 +3642,7 @@ 0.0d0,1.0d0,0.0d0,& 0.0d0,0.0d0,1.0d0/),shape(unmat)) !el local variables - integer :: i,k,j + integer :: i,k,j,icont real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4 real(kind=8) :: fac,t_eelecij,fracinbuf @@ -3218,6 +3670,7 @@ eel_loc=0.0d0 eello_turn3=0.0d0 eello_turn4=0.0d0 + if (nres_molec(1).eq.0) return ! if (icheckgrad.eq.1) then @@ -3302,36 +3755,9 @@ xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi - xmedi=dmod(xmedi,boxxsize) - if (xmedi.lt.0) xmedi=xmedi+boxxsize - ymedi=dmod(ymedi,boxysize) - if (ymedi.lt.0) ymedi=ymedi+boxysize - zmedi=dmod(zmedi,boxzsize) - if (zmedi.lt.0) zmedi=zmedi+boxzsize + call to_box(xmedi,ymedi,zmedi) + call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi) num_conti=0 - if ((zmedi.gt.bordlipbot) & - .and.(zmedi.lt.bordliptop)) then -!C the energy transfer exist - if (zmedi.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zmedi-bordlipbot)/lipbufthick) -!C lipbufthick is thickenes of lipid buffore - sslipi=sscalelip(fracinbuf) - ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick - elseif (zmedi.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick) - sslipi=sscalelip(fracinbuf) - ssgradlipi=sscagradlip(fracinbuf)/lipbufthick - else - sslipi=1.0d0 - ssgradlipi=0.0 - endif - else - sslipi=0.0d0 - ssgradlipi=0.0 - endif -! print *,i,sslipi,ssgradlipi call eelecij(i,i+2,ees,evdw1,eel_loc) if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) num_cont_hb(i)=num_conti @@ -3350,39 +3776,12 @@ xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi - xmedi=dmod(xmedi,boxxsize) - if (xmedi.lt.0) xmedi=xmedi+boxxsize - ymedi=dmod(ymedi,boxysize) - if (ymedi.lt.0) ymedi=ymedi+boxysize - zmedi=dmod(zmedi,boxzsize) - if (zmedi.lt.0) zmedi=zmedi+boxzsize - if ((zmedi.gt.bordlipbot) & - .and.(zmedi.lt.bordliptop)) then -!C the energy transfer exist - if (zmedi.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zmedi-bordlipbot)/lipbufthick) -!C lipbufthick is thickenes of lipid buffore - sslipi=sscalelip(fracinbuf) - ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick - elseif (zmedi.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick) - sslipi=sscalelip(fracinbuf) - ssgradlipi=sscagradlip(fracinbuf)/lipbufthick - else - sslipi=1.0d0 - ssgradlipi=0.0 - endif - else - sslipi=0.0d0 - ssgradlipi=0.0 - endif - + call to_box(xmedi,ymedi,zmedi) + call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi) num_conti=num_cont_hb(i) call eelecij(i,i+3,ees,evdw1,eel_loc) if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) & - call eturn4(i,eello_turn4) + call eturn4(i,eello_turn4) ! print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i) num_cont_hb(i)=num_conti enddo ! i @@ -3390,7 +3789,11 @@ ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 ! ! print *,"iatel_s,iatel_e,",iatel_s,iatel_e - do i=iatel_s,iatel_e +! do i=iatel_s,iatel_e +! JPRDLC + do icont=g_listpp_start,g_listpp_end + i=newcontlistppi(icont) + j=newcontlistppj(icont) if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle dxi=dc(1,i) dyi=dc(2,i) @@ -3401,42 +3804,16 @@ xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi - xmedi=dmod(xmedi,boxxsize) - if (xmedi.lt.0) xmedi=xmedi+boxxsize - ymedi=dmod(ymedi,boxysize) - if (ymedi.lt.0) ymedi=ymedi+boxysize - zmedi=dmod(zmedi,boxzsize) - if (zmedi.lt.0) zmedi=zmedi+boxzsize - if ((zmedi.gt.bordlipbot) & - .and.(zmedi.lt.bordliptop)) then -!C the energy transfer exist - if (zmedi.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zmedi-bordlipbot)/lipbufthick) -!C lipbufthick is thickenes of lipid buffore - sslipi=sscalelip(fracinbuf) - ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick - elseif (zmedi.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick) - sslipi=sscalelip(fracinbuf) - ssgradlipi=sscagradlip(fracinbuf)/lipbufthick - else - sslipi=1.0d0 - ssgradlipi=0.0 - endif - else - sslipi=0.0d0 - ssgradlipi=0.0 - endif + 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) +! 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 call eelecij(i,j,ees,evdw1,eel_loc) - enddo ! j +! enddo ! j num_cont_hb(i)=num_conti enddo ! i ! write (iout,*) "Number of loop steps in EELEC:",ind @@ -3453,7 +3830,7 @@ subroutine eelecij(i,j,ees,evdw1,eel_loc) use comm_locel -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -3476,6 +3853,7 @@ 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) :: geel_loc_ij,geel_loc_ji 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 @@ -3502,6 +3880,7 @@ !el local variables integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp + real(kind=8) :: faclipij2, faclipij real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,& rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,& @@ -3537,67 +3916,14 @@ xj=c(1,j)+0.5D0*dxj yj=c(2,j)+0.5D0*dyj zj=c(3,j)+0.5D0*dzj - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - if ((zj.gt.bordlipbot) & - .and.(zj.lt.bordliptop)) then -!C the energy transfer exist - if (zj.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zj-bordlipbot)/lipbufthick) -!C lipbufthick is thickenes of lipid buffore - sslipj=sscalelip(fracinbuf) - ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick - elseif (zj.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick) - sslipj=sscalelip(fracinbuf) - ssgradlipj=sscagradlip(fracinbuf)/lipbufthick - else - sslipj=1.0d0 - ssgradlipj=0.0 - endif - else - sslipj=0.0d0 - ssgradlipj=0.0 - endif - isubchap=0 - dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - isubchap=1 - endif - enddo - enddo - enddo - if (isubchap.eq.1) then -!C print *,i,j - xj=xj_temp-xmedi - yj=yj_temp-ymedi - zj=zj_temp-zmedi - else - xj=xj_safe-xmedi - yj=yj_safe-ymedi - zj=zj_safe-zmedi - endif + 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 @@ -3609,7 +3935,7 @@ ! sss_ele_grad=0.0d0 ! print *,sss_ele_cut,sss_ele_grad,& ! (rij),r_cut_ele,rlamb_ele -! if (sss_ele_cut.le.0.0) go to 128 + if (sss_ele_cut.le.0.0) go to 128 rmij=1.0D0/rij r3ij=rrmij*rmij @@ -3825,11 +4151,11 @@ !grad enddo !grad enddo ! 9/28/08 AL Gradient compotents will be summed only at the end - ggg(1)=facvdw*xj & + ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) - ggg(2)=facvdw*yj & + ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) - ggg(3)=facvdw*zj & + ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) do k=1,3 @@ -3917,6 +4243,15 @@ do l=1,2 kkk=kkk+1 muij(kkk)=mu(k,i)*mu(l,j) +#ifdef NEWCORR + gmuij1(kkk)=gtb1(k,i+1)*mu(l,j) +!c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j) + gmuij2(kkk)=gUb2(k,i)*mu(l,j) + gmuji1(kkk)=mu(k,i)*gtb1(l,j+1) +!c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i) + gmuji2(kkk)=mu(k,i)*gUb2(l,j) +#endif + enddo enddo !d write (iout,*) 'EELEC: i',i,' j',j @@ -4143,6 +4478,67 @@ enddo endif +#ifdef NEWCORR + geel_loc_ij=(a22*gmuij1(1)& + +a23*gmuij1(2)& + +a32*gmuij1(3)& + +a33*gmuij1(4))& + *fac_shield(i)*fac_shield(j)& + *sss_ele_cut & + *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + + +!c write(iout,*) "derivative over thatai" +!c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3), +!c & a33*gmuij1(4) + gloc(nphi+i,icg)=gloc(nphi+i,icg)+& + geel_loc_ij*wel_loc +!c write(iout,*) "derivative over thatai-1" +!c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3), +!c & a33*gmuij2(4) + geel_loc_ij=& + a22*gmuij2(1)& + +a23*gmuij2(2)& + +a32*gmuij2(3)& + +a33*gmuij2(4) + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+& + geel_loc_ij*wel_loc& + *fac_shield(i)*fac_shield(j)& + *sss_ele_cut & + *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + + +!c Derivative over j residue + geel_loc_ji=a22*gmuji1(1)& + +a23*gmuji1(2)& + +a32*gmuji1(3)& + +a33*gmuji1(4) +!c write(iout,*) "derivative over thataj" +!c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3), +!c & a33*gmuji1(4) + + gloc(nphi+j,icg)=gloc(nphi+j,icg)+& + geel_loc_ji*wel_loc& + *fac_shield(i)*fac_shield(j)& + *sss_ele_cut & + *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + + + geel_loc_ji=& + +a22*gmuji2(1)& + +a23*gmuji2(2)& + +a32*gmuji2(3)& + +a33*gmuji2(4) +!c write(iout,*) "derivative over thataj-1" +!c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3), +!c & a33*gmuji2(4) + gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+& + geel_loc_ji*wel_loc& + *fac_shield(i)*fac_shield(j)& + *sss_ele_cut & + *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + +#endif ! write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij ! eel_loc_ij=0.0 @@ -4340,10 +4736,12 @@ ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) & *sss_ele_cut & *fac_shield(i)*fac_shield(j) +! *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) & *sss_ele_cut & *fac_shield(i)*fac_shield(j) +! *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) ! Diagnostics. Comment out or remove after debugging! ! ees0p(num_conti,i)=0.5D0*fac3*ees0pij @@ -4422,28 +4820,36 @@ 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*fac_shield(i)*fac_shield(j) + *sss_ele_cut*fac_shield(i)*fac_shield(j) ! & +! *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + 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*fac_shield(i)*fac_shield(j) + *sss_ele_cut*fac_shield(i)*fac_shield(j)! & +! *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + gacontp_hb3(k,num_conti,i)=gggp(k) & *sss_ele_cut*fac_shield(i)*fac_shield(j) +! *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) 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*fac_shield(i)*fac_shield(j) +! *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) 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*fac_shield(i)*fac_shield(j) +! *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) gacontm_hb3(k,num_conti,i)=gggm(k) & *sss_ele_cut*fac_shield(i)*fac_shield(j) +! *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) enddo ! Diagnostics. Comment out or remove after debugging! @@ -4485,7 +4891,7 @@ ! Third- and fourth-order contributions from turns use comm_locel -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.GEO' @@ -4501,7 +4907,9 @@ ! include 'COMMON.CONTROL' real(kind=8),dimension(3) :: ggg real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,& - e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2 + e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,& + gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2 + real(kind=8),dimension(2) :: auxvec,auxvec1 !el real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1 real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp @@ -4514,36 +4922,14 @@ !el num_conti,j1,j2 !el local variables integer :: i,j,l,k,ilist,iresshield - real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield - + real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield,xj,yj + xj=0.0d0 + yj=0.0d0 j=i+2 ! write (iout,*) "eturn3",i,j,j1,j2 zj=(c(3,j)+c(3,j+1))/2.0d0 - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - if ((zj.lt.0)) write (*,*) "CHUJ" - if ((zj.gt.bordlipbot) & - .and.(zj.lt.bordliptop)) then -!C the energy transfer exist - if (zj.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zj-bordlipbot)/lipbufthick) -!C lipbufthick is thickenes of lipid buffore - sslipj=sscalelip(fracinbuf) - ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick - elseif (zj.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick) - sslipj=sscalelip(fracinbuf) - ssgradlipj=sscagradlip(fracinbuf)/lipbufthick - else - sslipj=1.0d0 - ssgradlipj=0.0 - endif - else - sslipj=0.0d0 - ssgradlipj=0.0 - endif + call to_box(xj,yj,zj) + call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) a_temp(1,1)=a22 a_temp(1,2)=a23 @@ -4561,8 +4947,15 @@ !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC !d call checkint_turn3(i,a_temp,eello_turn3_num) call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1)) + call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1)) + call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1)) call transpose2(auxmat(1,1),auxmat1(1,1)) + call transpose2(auxgmat1(1,1),auxgmatt1(1,1)) + call transpose2(auxgmat2(1,1),auxgmatt2(1,1)) call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1)) + call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1)) + if (shield_mode.eq.0) then fac_shield(i)=1.0d0 fac_shield(j)=1.0d0 @@ -4577,6 +4970,23 @@ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & 'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2)) +!C#ifdef NEWCORR +!C Derivatives in theta + gloc(nphi+i,icg)=gloc(nphi+i,icg) & + +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3& + *fac_shield(i)*fac_shield(j) & + *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + + gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)& + +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3& + *fac_shield(i)*fac_shield(j) & + *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + + +!C#endif + + + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (shield_mode.gt.0)) then !C print *,i,j @@ -4698,7 +5108,7 @@ ! Third- and fourth-order contributions from turns use comm_locel -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.GEO' @@ -4714,8 +5124,14 @@ ! include 'COMMON.CONTROL' real(kind=8),dimension(3) :: ggg real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,& - e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2 - real(kind=8),dimension(2) :: auxvec,auxvec1 + e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,& + gte1t,gte2t,gte3t,& + gte1a,gtae3,gtae3e2, ae3gte2,& + gtEpizda1,gtEpizda2,gtEpizda3 + + real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,& + auxgEvec3,auxgvec + !el real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1 real(kind=8),dimension(2,2) :: auxmat3 !el a_temp !el real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,& @@ -4727,8 +5143,9 @@ !el local variables integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,& - rlocshield - + rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3,xj,yj + xj=0.0d0 + yj=0.0d0 j=i+3 ! if (j.ne.20) return ! print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1) @@ -4746,51 +5163,71 @@ !d call checkint_turn4(i,a_temp,eello_turn4_num) ! write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2 zj=(c(3,j)+c(3,j+1))/2.0d0 - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - if ((zj.gt.bordlipbot) & - .and.(zj.lt.bordliptop)) then -!C the energy transfer exist - if (zj.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zj-bordlipbot)/lipbufthick) -!C lipbufthick is thickenes of lipid buffore - sslipj=sscalelip(fracinbuf) - ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick - elseif (zj.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick) - sslipj=sscalelip(fracinbuf) - ssgradlipj=sscagradlip(fracinbuf)/lipbufthick - else - sslipj=1.0d0 - ssgradlipj=0.0 - endif - else - sslipj=0.0d0 - ssgradlipj=0.0 - endif + call to_box(xj,yj,zj) + call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) + a_temp(1,1)=a22 a_temp(1,2)=a23 a_temp(2,1)=a32 a_temp(2,2)=a33 - iti1=itortyp(itype(i+1,1)) - iti2=itortyp(itype(i+2,1)) - iti3=itortyp(itype(i+3,1)) + iti1=i+1 + iti2=i+2 + iti3=i+3 ! write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3 call transpose2(EUg(1,1,i+1),e1t(1,1)) call transpose2(Eug(1,1,i+2),e2t(1,1)) call transpose2(Eug(1,1,i+3),e3t(1,1)) +!C Ematrix derivative in theta + call transpose2(gtEUg(1,1,i+1),gte1t(1,1)) + call transpose2(gtEug(1,1,i+2),gte2t(1,1)) + call transpose2(gtEug(1,1,i+3),gte3t(1,1)) + call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1)) call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1)) + call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1)) + call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1)) +!c auxalary matrix of E i+1 + call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1)) s1=scalar2(b1(1,iti2),auxvec(1)) +!c derivative of theta i+2 with constant i+3 + gs23=scalar2(gtb1(1,i+2),auxvec(1)) +!c derivative of theta i+2 with constant i+2 + gs32=scalar2(b1(1,i+2),auxgvec(1)) +!c derivative of E matix in theta of i+1 + gsE13=scalar2(b1(1,i+2),auxgEvec1(1)) + call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1)) + call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1)) call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) - s2=scalar2(b1(1,iti1),auxvec(1)) +!c auxilary matrix auxgvec of Ub2 with constant E matirx + call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1)) +!c auxilary matrix auxgEvec1 of E matix with Ub2 constant + call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1)) + s2=scalar2(b1(1,i+1),auxvec(1)) +!c derivative of theta i+1 with constant i+3 + gs13=scalar2(gtb1(1,i+1),auxvec(1)) +!c derivative of theta i+2 with constant i+1 + gs21=scalar2(b1(1,i+1),auxgvec(1)) +!c derivative of theta i+3 with constant i+1 + gsE31=scalar2(b1(1,i+1),auxgEvec3(1)) + call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) + call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1)) +!c ae3gte2 is derivative over i+2 + call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1)) + call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) + call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1)) +!c i+2 + call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1)) +!c i+3 + call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1)) + s3=0.5d0*(pizda(1,1)+pizda(2,2)) + gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2)) + gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2)) + gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2)) if (shield_mode.eq.0) then fac_shield(i)=1.0 fac_shield(j)=1.0 @@ -4844,7 +5281,26 @@ ! print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1) enddo endif +#ifdef NEWCORR + gloc(nphi+i,icg)=gloc(nphi+i,icg)& + -(gs13+gsE13+gsEE1)*wturn4& + *fac_shield(i)*fac_shield(j) & + *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + + gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)& + -(gs23+gs21+gsEE2)*wturn4& + *fac_shield(i)*fac_shield(j)& + *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)& + -(gs32+gsE31+gsEE3)*wturn4& + *fac_shield(i)*fac_shield(j)& + *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + + +!c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)- +!c & gs2 +#endif if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & 'eturn4',i,j,-(s1+s2+s3) !d write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3), @@ -4853,7 +5309,7 @@ call transpose2(EUgder(1,1,i+1),e1tder(1,1)) call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1)) call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1)) - s1=scalar2(b1(1,iti2),auxvec(1)) + s1=scalar2(b1(1,i+1),auxvec(1)) call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) & @@ -5034,7 +5490,7 @@ ! peptide-group centers and side chains and its gradient in virtual-bond and ! side-chain vectors. ! -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.VAR' @@ -5062,6 +5518,7 @@ 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) @@ -5076,6 +5533,10 @@ xj=c(1,j)-xi yj=c(2,j)-yi zj=c(3,j)-zi + call to_box(xj,yj,zj) + xj=boxshift(xj-xi,boxxsize) + yj=boxshift(yj-yi,boxysize) + zj=boxshift(zj-zi,boxzsize) rij=xj*xj+yj*yj+zj*zj r0ij=r0_scp r0ijsq=r0ij*r0ij @@ -5136,7 +5597,7 @@ ! peptide-group centers and side chains and its gradient in virtual-bond and ! side-chain vectors. ! -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.VAR' @@ -5149,7 +5610,7 @@ ! include 'COMMON.CONTROL' real(kind=8),dimension(3) :: ggg !el local variables - integer :: i,iint,j,k,iteli,itypj,subchap + integer :: i,iint,j,k,iteli,itypj,subchap,iconta 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,& @@ -5160,22 +5621,22 @@ 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 i=iatscp_s,iatscp_e + if (nres_molec(1).eq.0) return + do iconta=g_listscp_start,g_listscp_end +! print *,"icont",iconta,g_listscp_start,g_listscp_end + i=newcontlistscpi(iconta) + j=newcontlistscpj(iconta) 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)) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - - do iint=1,nscp_gr(i) + call to_box(xi,yi,zi) +! print *,itel(i),i,j +! do iint=1,nscp_gr(i) - do j=iscpstart(i,iint),iscpend(i,iint) +! 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 @@ -5189,43 +5650,11 @@ xj=c(1,j) yj=c(2,j) zj=c(3,j) - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif + + 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) @@ -5287,9 +5716,9 @@ gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) enddo - enddo +! enddo - enddo ! iint +! enddo ! iint enddo ! i do i=1,nct do j=1,3 @@ -5314,7 +5743,7 @@ ! ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. ! -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.SBRIDGE' ! include 'COMMON.CHAIN' @@ -5322,18 +5751,19 @@ ! include 'COMMON.VAR' ! include 'COMMON.INTERACT' ! include 'COMMON.IOUNITS' - real(kind=8),dimension(3) :: ggg + real(kind=8),dimension(3) :: ggg,vec !el local variables - integer :: i,j,ii,jj,iii,jjj,k - real(kind=8) :: fac,eij,rdis,ehpb,dd,waga + integer :: i,j,ii,jj,iii,jjj,k,mnumii,mnumjj + real(kind=8) :: fac,eij,rdis,ehpb,dd,waga,xi,yi,zi,zj,yj,xj ehpb=0.0D0 -!d write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr -!d write(iout,*)'link_start=',link_start,' link_end=',link_end +! write(iout,*)'edis: nhpb=',nhpb!,' fbr=',fbr +! 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. @@ -5344,6 +5774,14 @@ iii=ii jjj=jj endif + do j=1,3 + vec(j)=c(j,jj)-c(j,ii) + enddo + mnumii=molnum(iii) + mnumjj=molnum(jjj) + if (energy_dec) write(iout,*) i,ii,jj,mnumii,mnumjj,itype(jjj,mnumjj),itype(iii,mnumii) + if ((itype(iii,mnumii).gt.ntyp_molec(mnumii)).or.(itype(jjj,mnumjj).gt.ntyp_molec(mnumjj))) cycle + ! 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 @@ -5356,7 +5794,7 @@ iabs(itype(jjj,1)).eq.1) then call ssbond_ene(iii,jjj,eij) ehpb=ehpb+2*eij -!d write (iout,*) "eij",eij +! write (iout,*) "eij",eij,iii,jjj endif else if (ii.gt.nres .and. jj.gt.nres) then !c Restraints from contact prediction @@ -5401,6 +5839,7 @@ 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)) @@ -5415,11 +5854,29 @@ !c write (iout,*) "alph nmr", !c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) else + xi=c(1,ii) + yi=c(2,ii) + zi=c(3,ii) + call to_box(xi,yi,zi) + xj=c(1,jj) + yj=c(2,jj) + zj=c(3,jj) + call to_box(xj,yj,zj) + xj=boxshift(xj-xi,boxxsize) + yj=boxshift(yj-yi,boxysize) + zj=boxshift(zj-zi,boxzsize) + vec(1)=xj + vec(2)=yj + vec(3)=zj + dd=sqrt(xj*xj+yj*yj+zj*zj) 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 + if (energy_dec) write (iout,'(a6,2i5,5f10.3)') "edis",ii,jj, & + ehpb,dd,dhpb(i),waga,rdis + !c write (iout,*) "alpha reg",dd,waga*rdis*rdis !C !C Evaluate gradient. @@ -5429,7 +5886,7 @@ endif do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) + ggg(j)=fac*vec(j) 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 @@ -5464,7 +5921,7 @@ ! ! A. Liwo and U. Kozlowska, 11/24/03 ! -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.SBRIDGE' ! include 'COMMON.CHAIN' @@ -5485,6 +5942,8 @@ 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) @@ -5493,9 +5952,13 @@ 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 + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) + 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) @@ -5520,9 +5983,9 @@ 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 +! 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 @@ -5555,7 +6018,7 @@ ! ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds ! -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.LOCAL' ! include 'COMMON.GEO' @@ -5580,6 +6043,10 @@ ! if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres) do i=ibondp_start,ibondp_end +#ifdef FIVEDIAG + if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) cycle + diff = vbld(i)-vbldp0 +#else 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) @@ -5593,6 +6060,7 @@ else diff = vbld(i)-vbldp0 endif +#endif if (energy_dec) write (iout,'(a7,i5,4f7.3)') & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff estr=estr+diff*diff @@ -5668,7 +6136,7 @@ ! angles gamma and its derivatives in consecutive thetas and gammas. ! use comm_calcthet -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.LOCAL' ! include 'COMMON.GEO' @@ -5809,7 +6277,7 @@ subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc) use comm_calcthet -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.LOCAL' ! include 'COMMON.IOUNITS' @@ -5897,14 +6365,14 @@ end subroutine theteng #else !----------------------------------------------------------------------------- - subroutine ebend(etheta,ethetacnstr) + 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) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.LOCAL' ! include 'COMMON.GEO' @@ -6103,34 +6571,6 @@ enddo !-----------thete constrains ! if (tor_mode.ne.2) then - ethetacnstr=0.0d0 - 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 -! endif return end subroutine ebend @@ -6143,7 +6583,7 @@ ! ALPHA and OMEGA. ! use comm_sccalc -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.LOCAL' @@ -6268,7 +6708,7 @@ subroutine enesc(x,escloci,dersc,ddersc,mixed) use comm_sccalc -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.LOCAL' @@ -6377,7 +6817,7 @@ subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) use comm_sccalc -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.LOCAL' @@ -6458,7 +6898,7 @@ ! added by Urszula Kozlowska. 07/11/2007 ! use comm_sccalc -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.GEO' ! include 'COMMON.LOCAL' @@ -6476,11 +6916,11 @@ 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) :: s1_t,s1_6_t,s2_t,s2_6_t,gradene 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 + integer :: i,j,k,iti !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 @@ -6499,6 +6939,9 @@ delta=0.02d0*pi escloc=0.0D0 do i=loc_start,loc_end + gscloc(:,i)=0.0d0 + gsclocx(:,i)=0.0d0 +! th_gsclocm1(:,i-1)=0.0d0 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)) @@ -6509,7 +6952,50 @@ sinfac2=0.5d0/(1.0d0-costtab(i+1)) sinfac=dsqrt(sinfac2) it=iabs(itype(i,1)) + iti=it + if (iti.eq.ntyp1 .or. iti.eq.10) cycle +!c AL 3/30/2022 handle the cases of an isolated-residue chain + if (i.eq.nnt .and. itype(i+1,1).eq.ntyp1) cycle + if (i.eq.nct .and. itype(i-1,1).eq.ntyp1) cycle +! costtab(i+1) =dcos(theta(i+1)) if (it.eq.10) goto 1 +#ifdef SC_END + if (i.eq.nct .or. itype(i+1,1).eq.ntyp1) then +!c AL 3/30/2022 handle a sidechain of a loose C-end + cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + sumene=arotam_end(0,1,iti)+& + tschebyshev(1,nterm_scend(1,iti),arotam_end(1,1,iti),cossc1) + escloc=escloc+sumene + gradene=gradtschebyshev(0,nterm_scend(1,iti)-1,& + arotam_end(1,1,iti),cossc1) + gscloc(:,i-1)=gscloc(:,i-1)+& + vbld_inv(i)*(dC_norm(:,i+nres)-dC_norm(:,i-1)& + *cossc1)*gradene + gsclocx(:,i)=gsclocx(:,i)+vbld_inv(i+nres)*& + (dC_norm(:,i-1)-dC_norm(:,i+nres)*cossc1)*gradene +#ifdef ENERGY_DEC + if (energy_dec) write (2,'(2hC ,a3,i6,2(a,f10.5))')& + restyp(iti,1),i," angle",rad2deg*dacos(cossc1)," escloc",sumene +#endif + else if (i.eq.nnt .or. itype(i-1,1).eq.ntyp1) then +!c AL 3/30/2022 handle a sidechain of a loose N-end + cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + sumene=arotam_end(0,2,iti)+& + tschebyshev(1,nterm_scend(2,iti),arotam_end(1,2,iti),cossc) + escloc=escloc+sumene + gradene=gradtschebyshev(0,nterm_scend(2,iti)-1,& + arotam_end(1,2,iti),cossc) + gscloc(:,i)=gscloc(:,i)+& + vbld_inv(i+1)*(dC_norm(:,i+nres)-dC_norm(:,i)& + *cossc)*gradene + gsclocx(:,i)=gsclocx(:,i)+vbld_inv(i+nres)*& + (dC_norm(:,i)-dC_norm(:,i+nres)*cossc)*gradene +#ifdef ENERGY_DEC + if (energy_dec) write (2,'(2hN ,a3,i6,2(a,f10.5))') + & restyp(iti),i," angle",rad2deg*dacos(cossc)," escloc",sumene +#endif + else +#endif ! ! Compute the axes of tghe local cartesian coordinates system; store in ! x_prime, y_prime and z_prime @@ -6608,6 +7094,8 @@ ! & 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 @@ -6786,7 +7274,9 @@ ! & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) ! to check gradient call subroutine check_grad - +#ifdef SC_END + endif +#endif 1 continue enddo return @@ -6867,7 +7357,7 @@ end subroutine gcont !----------------------------------------------------------------------------- subroutine splinthet(theti,delta,ss,ssder) -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.VAR' ! include 'COMMON.GEO' @@ -6916,7 +7406,7 @@ #ifdef CRYST_TOR !----------------------------------------------------------------------------- subroutine etor(etors,edihcnstr) -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.VAR' ! include 'COMMON.GEO' @@ -7017,10 +7507,19 @@ etors_d=0.0d0 return end subroutine etor_d +!----------------------------------------------------------------------------- +!c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA + subroutine e_modeller(ehomology_constr) + real(kind=8) :: ehomology_constr + ehomology_constr=0.0d0 + write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!" + return + end subroutine e_modeller +C !!!!!!!! NIE CZYTANE !!!!!!!!!!! #else !----------------------------------------------------------------------------- - subroutine etor(etors,edihcnstr) -! implicit real*8 (a-h,o-z) + subroutine etor(etors) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.VAR' ! include 'COMMON.GEO' @@ -7101,8 +7600,156 @@ ! write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) enddo ! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 -! do i=1,ndih_constr + 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 +! lprn=.true. + 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) @@ -7118,17 +7765,17 @@ else difi=0.0 endif -!d write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, -!d & rad2deg*phi0(i), rad2deg*drange(i), -!d & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) enddo -!d write (iout,*) 'edihcnstr',edihcnstr + + endif + return - end subroutine etor + + end subroutine etor_constr !----------------------------------------------------------------------------- subroutine etor_d(etors_d) ! 6/23/01 Compute double torsional energy -! implicit real*8 (a-h,o-z) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.VAR' ! include 'COMMON.GEO' @@ -7215,611 +7862,945 @@ return end subroutine etor_d #endif -!----------------------------------------------------------------------------- - subroutine eback_sc_corr(esccor) -! 7/21/2007 Correlations between the backbone-local and side-chain-local -! conformational states; temporarily implemented as differences -! between UNRES torsional potentials (dependent on three types of -! residues) and the torsional potentials dependent on all 20 types -! of residues computed from AM1 energy surfaces of terminally-blocked -! amino-acid residues. -! implicit real*8 (a-h,o-z) +!---------------------------------------------------------------------------- +!---------------------------------------------------------------------------- + subroutine e_modeller(ehomology_constr) +! implicit none ! 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)) + use MD_data, only: iset + real(kind=8) :: ehomology_constr + integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l + integer katy, odleglosci, test7 + real(kind=8) :: odleg, odleg2, odleg3, kat, kat2, kat3 + real(kind=8) :: Eval,Erot,min_odl + real(kind=8),dimension(constr_homology) :: distance,distancek,godl,dih_diff,gdih, & + gtheta,dscdiff, & + uscdiffk,guscdiff2,guscdiff3,& + theta_diff + + +! +! FP - 30/10/2014 Temporary specifications for homology restraints +! + real(kind=8) :: utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,& + sgtheta + real(kind=8), dimension (nres) :: guscdiff,usc_diff + real(kind=8) :: sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,& + sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,& + betai,sum_sgodl,dij,max_template +! real(kind=8) :: dist,pinorm +! +! include 'COMMON.SBRIDGE' +! include 'COMMON.CHAIN' +! include 'COMMON.GEO' +! include 'COMMON.DERIV' +! include 'COMMON.LOCAL' +! include 'COMMON.INTERACT' +! include 'COMMON.VAR' +! include 'COMMON.IOUNITS' +! include 'COMMON.MD' +! include 'COMMON.CONTROL' +! include 'COMMON.HOMOLOGY' +! include 'COMMON.QRESTR' +! +! From subroutine Econstr_back +! +! include 'COMMON.NAMES' +! include 'COMMON.TIME1' +! -! 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 + + do i=1,max_template + distancek(i)=9999999.9 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 + odleg=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 +! Pseudo-energy and gradient from homology restraints (MODELLER-like +! function) +! AL 5/2/14 - Introduce list of restraints +! write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d +#ifdef DEBUG + write(iout,*) "------- dist restrs start -------" +#endif + do ii = link_start_homo,link_end_homo + i = ires_homo(ii) + j = jres_homo(ii) + dij=dist(i,j) +! write (iout,*) "dij(",i,j,") =",dij + nexl=0 + do k=1,constr_homology +! write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii) + if(.not.l_homo(k,ii)) then + nexl=nexl+1 + cycle + endif + distance(k)=odl(k,ii)-dij +! write (iout,*) "distance(",k,") =",distance(k) +! +! For Gaussian-type Urestr +! + distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument +! write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii) +! write (iout,*) "distancek(",k,") =",distancek(k) +! distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii) +! +! For Lorentzian-type Urestr +! + if (waga_dist.lt.0.0d0) then + sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii)) + distancek(k)=distance(k)**2/(sigma_odlir(k,ii)* & + (distance(k)**2+sigma_odlir(k,ii)**2)) + endif + enddo - DO ISHIFT = 3,4 +! min_odl=minval(distancek) + if (nexl.gt.0) then + min_odl=0.0d0 + else + do kk=1,constr_homology + if(l_homo(kk,ii)) then + min_odl=distancek(kk) + exit + endif + enddo + do kk=1,constr_homology + if (l_homo(kk,ii) .and. distancek(kk).lt.min_odl) & + min_odl=distancek(kk) + enddo + endif - 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 +! write (iout,* )"min_odl",min_odl +#ifdef DEBUG + write (iout,*) "ij dij",i,j,dij + write (iout,*) "distance",(distance(k),k=1,constr_homology) + write (iout,*) "distancek",(distancek(k),k=1,constr_homology) + write (iout,* )"min_odl",min_odl +#endif +#ifdef OLDRESTR + odleg2=0.0d0 +#else + if (waga_dist.ge.0.0d0) then + odleg2=nexl + else + odleg2=0.0d0 + endif +#endif + do k=1,constr_homology +! Nie wiem po co to liczycie jeszcze raz! +! odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/ +! & (2*(sigma_odl(i,j,k))**2)) + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +! +! For Gaussian-type Urestr +! + godl(k)=dexp(-distancek(k)+min_odl) + odleg2=odleg2+godl(k) +! +! For Lorentzian-type Urestr +! + else + odleg2=odleg2+distancek(k) + endif - ENDDO ! ISHIFT +!cc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3, +!cc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=", +!cc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1), +!cc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k) - 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 +! write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents +! write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#ifdef DEBUG + write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents + write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#endif + if (waga_dist.ge.0.0d0) then +! +! For Gaussian-type Urestr +! + odleg=odleg-dLOG(odleg2/constr_homology)+min_odl +! +! For Lorentzian-type Urestr +! + else + odleg=odleg+odleg2/constr_homology + endif +! +! write (iout,*) "odleg",odleg ! sum of -ln-s +! Gradient +! +! For Gaussian-type Urestr +! + if (waga_dist.ge.0.0d0) sum_godl=odleg2 + sum_sgodl=0.0d0 + do k=1,constr_homology +! godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) +! & *waga_dist)+min_odl +! sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist +! + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +! For Gaussian-type Urestr +! + sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd +! +! For Lorentzian-type Urestr +! + else + sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ & + sigma_odlir(k,ii)**2)**2) + endif + sum_sgodl=sum_sgodl+sgodl + +! sgodl2=sgodl2+sgodl +! write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1" +! write(iout,*) "constr_homology=",constr_homology +! write(iout,*) i, j, k, "TEST K" + enddo +! print *, "ok",iset + if (waga_dist.ge.0.0d0) then +! +! For Gaussian-type Urestr +! + grad_odl3=waga_homology(iset)*waga_dist & + *sum_sgodl/(sum_godl*dij) +! print *, "ok" +! +! For Lorentzian-type Urestr +! + else +! Original grad expr modified by analogy w Gaussian-type Urestr grad +! grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl + grad_odl3=-waga_homology(iset)*waga_dist* & + sum_sgodl/(constr_homology*dij) +! print *, "ok2" + endif +! +! grad_odl3=sum_sgodl/(sum_godl*dij) + + +! write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2" +! write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2), +! & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) + +!cc write(iout,*) godl, sgodl, grad_odl3 + +! grad_odl=grad_odl+grad_odl3 + + do jik=1,3 + ggodl=grad_odl3*(c(jik,i)-c(jik,j)) +!cc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1)) +!cc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl, +!cc & ghpbc(jik,i+1), ghpbc(jik,j+1) + ghpbc(jik,i)=ghpbc(jik,i)+ggodl + ghpbc(jik,j)=ghpbc(jik,j)-ggodl +!cc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl, +!cc & ghpbc(jik,i+1), ghpbc(jik,j+1) +! if (i.eq.25.and.j.eq.27) then +! write(iout,*) "jik",jik,"i",i,"j",j +! write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl +! write(iout,*) "grad_odl3",grad_odl3 +! write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j) +! write(iout,*) "ggodl",ggodl +! write(iout,*) "ghpbc(",jik,i,")", +! & ghpbc(jik,i),"ghpbc(",jik,j,")", +! & ghpbc(jik,j) +! endif + enddo +!cc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=", +!cc & dLOG(odleg2),"-odleg=", -odleg + + enddo ! ii-loop for dist +#ifdef DEBUG + write(iout,*) "------- dist restrs end -------" +! if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or. +! & waga_d.eq.1.0d0) call sum_gradient +#endif +! Pseudo-energy and gradient from dihedral-angle restraints from +! homology templates +! write (iout,*) "End of distance loop" +! call flush(iout) + kat=0.0d0 +! write (iout,*) idihconstr_start_homo,idihconstr_end_homo +#ifdef DEBUG + write(iout,*) "------- dih restrs start -------" + do i=idihconstr_start_homo,idihconstr_end_homo + write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg) enddo - do m=i,j-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) - enddo +#endif + do i=idihconstr_start_homo,idihconstr_end_homo + kat2=0.0d0 +! betai=beta(i,i+1,i+2,i+3) + betai = phi(i) +! write (iout,*) "betai =",betai + do k=1,constr_homology + dih_diff(k)=pinorm(dih(k,i)-betai) +!d write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k) +!d & ,sigma_dih(k,i) +! if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)= +! & -(6.28318-dih_diff(i,k)) +! if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)= +! & 6.28318+dih_diff(i,k) +#ifdef OLD_DIHED + kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument +#else + kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument +#endif +! kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i) + gdih(k)=dexp(kat3) + kat2=kat2+gdih(k) +! write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3) +! write(*,*)"" + enddo +! write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps +! write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps +#ifdef DEBUG + write (iout,*) "i",i," betai",betai," kat2",kat2 + write (iout,*) "gdih",(gdih(k),k=1,constr_homology) +#endif + if (kat2.le.1.0d-14) cycle + kat=kat-dLOG(kat2/constr_homology) +! write (iout,*) "kat",kat ! sum of -ln-s + +!cc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=", +!cc & dLOG(kat2), "-kat=", -kat + +! ---------------------------------------------------------------------- +! Gradient +! ---------------------------------------------------------------------- + + sum_gdih=kat2 + sum_sgdih=0.0d0 + do k=1,constr_homology +#ifdef OLD_DIHED + sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd +#else + sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd +#endif +! sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle + sum_sgdih=sum_sgdih+sgdih + enddo +! grad_dih3=sum_sgdih/sum_gdih + grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih +! print *, "ok3" + +! write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3 +!cc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3, +!cc & gloc(nphi+i-3,icg) + gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3 +! if (i.eq.25) then +! write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg) +! endif +!cc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3, +!cc & gloc(nphi+i-3,icg) + + enddo ! i-loop for dih +#ifdef DEBUG + write(iout,*) "------- dih restrs end -------" +#endif + +! Pseudo-energy and gradient for theta angle restraints from +! homology templates +! FP 01/15 - inserted from econstr_local_test.F, loop structure +! adapted + +! +! For constr_homology reference structures (FP) +! +! Uconst_back_tot=0.0d0 + Eval=0.0d0 + Erot=0.0d0 +! Econstr_back legacy + do i=1,nres +! do i=ithet_start,ithet_end + dutheta(i)=0.0d0 enddo - do m=k,l-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) +! do i=loc_start,loc_end + do i=-1,nres + do j=1,3 + duscdiff(j,i)=0.0d0 + duscdiffx(j,i)=0.0d0 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 + enddo +! +! do iref=1,nref +! write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +! write (iout,*) "waga_theta",waga_theta + if (waga_theta.gt.0.0d0) then +#ifdef DEBUG + write (iout,*) "usampl",usampl + write(iout,*) "------- theta restrs start -------" +! do i=ithet_start,ithet_end +! write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg) +! enddo #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 +! write (iout,*) "maxres",maxres,"nres",nres -! 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)) + do i=ithet_start,ithet_end +! +! do i=1,nfrag_back +! ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) +! +! Deviation of theta angles wrt constr_homology ref structures +! + utheta_i=0.0d0 ! argument of Gaussian for single k + gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures +! do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop +! over residues in a fragment +! write (iout,*) "theta(",i,")=",theta(i) + do k=1,constr_homology +! +! dtheta_i=theta(j)-thetaref(j,iref) +! dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing + theta_diff(k)=thetatpl(k,i)-theta(i) +!d write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k) +!d & ,sigma_theta(k,i) + +! + utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument +! utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta? + gtheta(k)=dexp(utheta_i) ! + min_utheta_i? + gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk) +! Gradient for single Gaussian restraint in subr Econstr_back +! dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) +! + enddo +! write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps +! write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps + +! +! Gradient for multiple Gaussian restraint + sum_gtheta=gutheta_i + sum_sgtheta=0.0d0 + do k=1,constr_homology +! New generalized expr for multiple Gaussian from Econstr_back + sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd +! +! sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form? + sum_sgtheta=sum_sgtheta+sgtheta ! cum variable enddo +! Final value of gradient using same var as in Econstr_back + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg) & + +sum_sgtheta/sum_gtheta*waga_theta & + *waga_homology(iset) +! print *, "ok4" + +! dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta +! & *waga_homology(iset) +! dutheta(i)=sum_sgtheta/sum_gtheta +! +! Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight + Eval=Eval-dLOG(gutheta_i/constr_homology) +! write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps +! write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s +! Uconst_back=Uconst_back+utheta(i) + enddo ! (i-loop for theta) +#ifdef DEBUG + write(iout,*) "------- theta restrs end -------" +#endif 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)) +! +! Deviation of local SC geometry +! +! Separation of two i-loops (instructed by AL - 11/3/2014) +! +! write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +! write (iout,*) "waga_d",waga_d + +#ifdef DEBUG + write(iout,*) "------- SC restrs start -------" + write (iout,*) "Initial duscdiff,duscdiffx" + do i=loc_start,loc_end + write (iout,*) i,(duscdiff(jik,i),jik=1,3), & + (duscdiffx(jik,i),jik=1,3) 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 +#endif + do i=loc_start,loc_end + usc_diff_i=0.0d0 ! argument of Gaussian for single k + guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures +! do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy +! write(iout,*) "xxtab, yytab, zztab" +! write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i) + do k=1,constr_homology +! + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +! Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z +! write(iout,*) "dxx, dyy, dzz" +!d write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i) +! + usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument +! usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d? +! uscdiffk(k)=usc_diff(i) + guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff +! write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i), +! & " guscdiff2",guscdiff2(k) + guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk) +! write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), +! & xxref(j),yyref(j),zzref(j) 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) +! +! Gradient +! +! Generalized expression for multiple Gaussian acc to that for a single +! Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014) +! +! Original implementation +! sum_guscdiff=guscdiff(i) +! +! sum_sguscdiff=0.0d0 +! do k=1,constr_homology +! sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d? +! sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff +! sum_sguscdiff=sum_sguscdiff+sguscdiff +! enddo +! +! Implementation of new expressions for gradient (Jan. 2015) +! +! grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !? + do k=1,constr_homology +! +! New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong +! before. Now the drivatives should be correct +! + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +! Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z + sum_guscdiff=guscdiff2(k)* &!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong! + sigma_d(k,i) ! for the grad wrt r' +! sum_sguscdiff=sum_sguscdiff+sum_guscdiff + +! +! New implementation + sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff + do jik=1,3 + duscdiff(jik,i-1)=duscdiff(jik,i-1)+ & + sum_guscdiff*(dXX_C1tab(jik,i)*dxx+ & + dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i) + duscdiff(jik,i)=duscdiff(jik,i)+ & + sum_guscdiff*(dXX_Ctab(jik,i)*dxx+ & + dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i) + duscdiffx(jik,i)=duscdiffx(jik,i)+ & + sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+ & + dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i) +! print *, "ok5" +! +#ifdef DEBUG +! write(iout,*) "jik",jik,"i",i + write(iout,*) "dxx, dyy, dzz" + write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz + write(iout,*) "guscdiff2(",k,")",guscdiff2(k) + write(iout,*) "sum_sguscdiff",sum_guscdiff,waga_homology(iset),waga_d + write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i) + write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i) + write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i) + write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i) + write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i) + write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i) + write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i) + write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i) + write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i) + write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1) + write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i) + write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i) +! endif +#endif + enddo enddo +! print *, "ok6" +! +! uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required? +! usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ? +! +! 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(3,i,iset)*uscdiff(i) + Erot=Erot-dLOG(guscdiff(i)/constr_homology) +! write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps +! write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s +! Uconst_back=Uconst_back+usc_diff(i) +! +! Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?) +! +! New implment: multiplied by sum_sguscdiff +! + + enddo ! (i-loop for dscdiff) + +! endif + +#ifdef DEBUG + write(iout,*) "------- SC restrs end -------" + write (iout,*) "------ After SC loop in e_modeller ------" + do i=loc_start,loc_end + write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3) + write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3) + enddo + if (waga_theta.eq.1.0d0) then + write (iout,*) "in e_modeller after SC restr end: dutheta" + do i=ithet_start,ithet_end + write (iout,*) i,dutheta(i) 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 + if (waga_d.eq.1.0d0) then + write (iout,*) "e_modeller after SC loop: duscdiff/x" + do i=1,nres + write (iout,*) i,(duscdiff(j,i),j=1,3) + write (iout,*) i,(duscdiffx(j,i),j=1,3) 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 + +! Total energy from homology restraints +#ifdef DEBUG + write (iout,*) "odleg",odleg," kat",kat +#endif +! +! Addition of energy of theta angle and SC local geom over constr_homologs ref strs +! +! ehomology_constr=odleg+kat +! +! For Lorentzian-type Urestr +! + + if (waga_dist.ge.0.0d0) then +! +! For Gaussian-type Urestr +! + ehomology_constr=(waga_dist*odleg+waga_angle*kat+ & + waga_theta*Eval+waga_d*Erot)*waga_homology(iset) +! write (iout,*) "ehomology_constr=",ehomology_constr +! print *, "ok7" + else +! +! For Lorentzian-type Urestr +! + ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ & + waga_theta*Eval+waga_d*Erot)*waga_homology(iset) +! write (iout,*) "ehomology_constr=",ehomology_constr + print *, "ok8" endif - ecorr=0.0D0 +#ifdef DEBUG + write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat, & + "Eval",waga_theta,eval, & + "Erot",waga_d,Erot + write (iout,*) "ehomology_constr",ehomology_constr +#endif + return +! +! FP 01/15 end +! + 748 format(a8,f12.3,a6,f12.3,a7,f12.3) + 747 format(a12,i4,i4,i4,f8.3,f8.3) + 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3) + 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3) + 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, & + f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3) + end subroutine e_modeller -! 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 +!---------------------------------------------------------------------------- + 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 -! 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 + 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 add_hb_contact + end subroutine etheta_constr + !----------------------------------------------------------------------------- - 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) + 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(kind=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' - 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.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(kind=8) (a-h,o-z) +! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' ! 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 - + 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. - 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:' + 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(kind=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(kind=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 @@ -7838,15 +8819,17 @@ ! 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_eello(i,i+2,iturn3_sent_local(1,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_eello(i,i+3,iturn4_sent_local(1,i)) + call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) enddo do ii=1,nat_sent i=iat_sent(ii) @@ -7857,33 +8840,35 @@ 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 + 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)=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 + 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 @@ -7899,7 +8884,7 @@ 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) + write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) enddo enddo call flush(iout) @@ -7978,7 +8963,7 @@ " 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) + write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) enddo call flush(iout) endif @@ -7991,37 +8976,39 @@ 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 + 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,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)) + 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 @@ -8030,14 +9017,12 @@ 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)) + 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 - ecorr5=0.0d0 - ecorr6=0.0d0 ! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) ! if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres)) @@ -8048,1471 +9033,797 @@ 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 +! 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) - 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) + 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 +! 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 - 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 + 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 - 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 + end subroutine multibody_hb !----------------------------------------------------------------------------- - subroutine add_hb_contact_eello(ii,jj,itask) -! implicit real*8 (a-h,o-z) + subroutine add_hb_contact(ii,jj,itask) +! implicit real(kind=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) + 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,ind,jjc,kk,ll,mm - integer,dimension(4) ::itask + 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,*) "send turns i",ii," j",jj," jjc",jjc +! 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)=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 + 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_eello + end subroutine add_hb_contact !----------------------------------------------------------------------------- - real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) -! implicit real*8 (a-h,o-z) + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +! This subroutine calculates multi-body contributions to hydrogen-bonding +! implicit real(kind=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 - logical :: lprn + 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,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 + 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. - 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 + 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 -! 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 = itortyp(itype(j+1,1)) - else - itj1=ntortyp+1 + 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 - 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) + call flush(iout) + do i=1,ntask_cont_from + ncont_recv(i)=0 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 + do i=1,ntask_cont_to + ncont_sent(i)=0 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)) +! 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 - 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 - 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)) + 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 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)) + 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 - 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 +! 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 - 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 +! 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 - 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 + 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 -! 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)) + 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 - 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)) + 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 -! 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 + 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 -! 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 + 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 -! 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)) + 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 -!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 +! 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 - 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 +! 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 -!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 +! write (iout,*) "gradcorr5 in eello5" +! do iii=1,nres +! write (iout,'(i5,3f10.5)') +! & iii,(gradcorr5(jjj,iii),jjj=1,3) +! enddo return - end function eello4 + end subroutine multibody_eello !----------------------------------------------------------------------------- - 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)) + subroutine add_hb_contact_eello(ii,jj,itask) +! implicit real(kind=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 - enddo + endif 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 + return + end subroutine add_hb_contact_eello +!----------------------------------------------------------------------------- + real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) +! implicit real(kind=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 -!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 +! write (iout,*) !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 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 -!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 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 -!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.) +! 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 -! 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 + return + end function ehbcorr +#ifdef MOMENT +!----------------------------------------------------------------------------- + subroutine dipole(i,j,jj) +! implicit real(kind=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 - l1=l-1 - l2=l-2 + itj1=nloctyp 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 + 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 -!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 + end subroutine dipole +#endif !----------------------------------------------------------------------------- - real(kind=8) function eello6_graph1(i,j,k,l,imat,swap) + 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) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.CHAIN' @@ -9522,657 +9833,378 @@ ! 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 +! 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 - 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)))) +!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 - 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 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) 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 + 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 - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + iti=ntortyp+1 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 + itk1=itortyp(itype(k+1,1)) + itj=itortyp(itype(j,1)) + if (l.lt.nres-1) then + itl1=itortyp(itype(l+1,1)) else - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + itl1=ntortyp+1 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 +! 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 - 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 +! 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 - 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)) +! 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 - 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 +! Antiparallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itortyp(itype(i,1)) 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 + iti=ntortyp+1 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) + 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 - 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 +! 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 function eello6_graph4 + end subroutine kernel !----------------------------------------------------------------------------- - real(kind=8) function eello_turn6(i,jj,kk) -! implicit real*8 (a-h,o-z) + real(kind=8) function eello4(i,j,k,l,jj,kk) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' ! include 'COMMON.IOUNITS' ! include 'COMMON.CHAIN' @@ -10182,256 +10214,47 @@ ! 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(2,2) :: pizda 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 + 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 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) +!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_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 + 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 -#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 +!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 @@ -10447,14168 +10270,22735 @@ 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 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) -!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 + 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) -!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 + 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 -!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 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 gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) +!grad gradcorr(ll,m)=gradcorr(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 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 gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) +!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,g_corr6_loc(iii) +!d write (2,*) iii,gcorr_loc(iii) !d enddo - eello_turn6=ekont*eel_turn6 + eello4=ekont*eel4 !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) - +!d write (iout,*) 'eello4',ekont*eel4 return - end subroutine prodmat3 -!----------------------------------------------------------------------------- -! energy_p_new_barrier.F + end function eello4 !----------------------------------------------------------------------------- - subroutine sum_gradient -! implicit real*8 (a-h,o-z) - use io_base, only: pdbout + real(kind=8) function eello5(i,j,k,l,jj,kk) +! implicit real(kind=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 - 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.CHAIN' ! include 'COMMON.DERIV' ! include 'COMMON.INTERACT' -! include 'COMMON.SBRIDGE' -! include 'COMMON.CHAIN' +! include 'COMMON.CONTACTS' +! include 'COMMON.TORSION' ! include 'COMMON.VAR' -! include 'COMMON.CONTROL' -! include 'COMMON.TIME1' -! include 'COMMON.MAXGRAD' -! include 'COMMON.SCCOR' -#ifdef TIMING - time01=MPI_Wtime() -#endif -#ifdef DEBUG - write (iout,*) "sum_gradient gvdwc, gvdwx" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & - i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI - gradbufc=0.0d0 - gradbufx=0.0d0 - gradbufc_sum=0.0d0 - gloc_scbuf=0.0d0 - glocbuf=0.0d0 -! FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (nfgtasks.gt.1 .and. fg_rank.eq.0) & - call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif -! -! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient -! in virtual-bond-vector coordinates -! -#ifdef DEBUG -! write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" -! do i=1,nres-1 -! write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') -! & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) -! enddo -! write (iout,*) "gel_loc_tur3 gel_loc_turn4" -! do i=1,nres-1 -! write (iout,'(i5,3f10.5,2x,f10.5)') -! & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) -! enddo - write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & - i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),& - (gvdwc_scpp(j,i),j=1,3) - enddo - write (iout,*) "gelc_long gvdwpp gel_loc_long" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') & - i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),& - (gelc_loc_long(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef SPLITELE - do i=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) - - - - - - 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) - - - 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) +! 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 -! 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 +!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 -#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) +! 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 -#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 +!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 -#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 +! 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 - 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) +!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 - 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 +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 -!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,) & - +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) - - - - -#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) -! 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) +!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(kind=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 - do i=1,4*nres - glocbuf(i)=gloc(i,icg) - enddo -!#define DEBUG -#ifdef DEBUG - write (iout,*) "gloc_sc before reduce" - do i=1,nres - do j=1,1 - write (iout,*) i,j,gloc_sc(j,i,icg) - enddo enddo -#endif -!#undef DEBUG - do i=1,nres - do j=1,3 - gloc_scbuf(j,i)=gloc_sc(j,i,icg) - enddo - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_g=time_barrier_g+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(gradbufc(1,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,1),gloc_sc(1,1,icg),3*nres,& - MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -!#define DEBUG -! print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg) -#ifdef DEBUG - write (iout,*) "gloc_sc after reduce" - do i=1,nres - do j=1,1 - write (iout,*) i,j,gloc_sc(j,i,icg) - enddo - enddo -#endif -!#undef DEBUG -#ifdef DEBUG - write (iout,*) "gloc after reduce" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - endif -#endif - if (gnorm_check) then -! -! Compute the maximum elements of the gradient -! - gvdwc_max=0.0d0 - gvdwc_scp_max=0.0d0 - gelc_max=0.0d0 - gvdwpp_max=0.0d0 - gradb_max=0.0d0 - ghpbc_max=0.0d0 - gradcorr_max=0.0d0 - gel_loc_max=0.0d0 - gcorr3_turn_max=0.0d0 - gcorr4_turn_max=0.0d0 - gradcorr5_max=0.0d0 - gradcorr6_max=0.0d0 - gcorr6_turn_max=0.0d0 - gsccorc_max=0.0d0 - gscloc_max=0.0d0 - gvdwx_max=0.0d0 - gradx_scp_max=0.0d0 - ghpbx_max=0.0d0 - gradxorr_max=0.0d0 - gsccorx_max=0.0d0 - gsclocx_max=0.0d0 - do i=1,nct - gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) - if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm - gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i))) - if (gvdwc_scp_norm.gt.gvdwc_scp_max) & - gvdwc_scp_max=gvdwc_scp_norm - gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i))) - if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm - gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i))) - if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm - gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i))) - if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm - ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i))) - if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm - gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i))) - if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm - gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i))) - if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm - gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),& - gcorr3_turn(1,i))) - if (gcorr3_turn_norm.gt.gcorr3_turn_max) & - gcorr3_turn_max=gcorr3_turn_norm - gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),& - gcorr4_turn(1,i))) - if (gcorr4_turn_norm.gt.gcorr4_turn_max) & - gcorr4_turn_max=gcorr4_turn_norm - gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i))) - if (gradcorr5_norm.gt.gradcorr5_max) & - gradcorr5_max=gradcorr5_norm - gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) - if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm - gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),& - gcorr6_turn(1,i))) - if (gcorr6_turn_norm.gt.gcorr6_turn_max) & - gcorr6_turn_max=gcorr6_turn_norm - gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) - if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm - gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) - if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm - gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) - if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm - gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) - if (gradx_scp_norm.gt.gradx_scp_max) & - gradx_scp_max=gradx_scp_norm - ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) - if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm - gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) - if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm - gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) - if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm - gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) - if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm - enddo - if (gradout) then -#ifdef AIX - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif - write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,& - gelc_max,gvdwpp_max,gradb_max,ghpbc_max,& - gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,& - gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,& - gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,& - gsccorx_max,gsclocx_max - close(istat) - if (gvdwc_max.gt.1.0d4) then - write (iout,*) "gvdwc gvdwx gradb gradbx" - do i=nnt,nct - write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),& - gradb(j,i),gradbx(j,i),j=1,3) - enddo - call pdbout(0.0d0,'cipiszcze',iout) - call flush(iout) +!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 -!#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 + 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 subroutine sum_gradient + end function eello6 !----------------------------------------------------------------------------- - subroutine sc_grad -! implicit real*8 (a-h,o-z) - use calc_data + real(kind=8) function eello6_graph1(i,j,k,l,imat,swap) + use comm_kut +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' +! include 'COMMON.IOUNITS' ! 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) +! 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 subroutine sc_grad -#ifdef CRYST_THETA + end function eello6_graph1 !----------------------------------------------------------------------------- - subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) - - use comm_calcthet -! implicit real*8 (a-h,o-z) + real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap) + use comm_kut +! implicit real(kind=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) +! 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 - 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) + 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 - 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 + end function eello6_graph2 !----------------------------------------------------------------------------- - subroutine check_cartgrad -! Check the gradient of Cartesian coordinates in internal coordinates. -! implicit real*8 (a-h,o-z) + real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap) +! implicit real(kind=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 +! 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 ! -! 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) +! 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 - phi(i+3)=phii enddo return - end subroutine check_cartgrad + end function eello6_graph3 !----------------------------------------------------------------------------- - 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) + real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' -! include 'COMMON.CONTROL' +! include 'COMMON.IOUNITS' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' +! include 'COMMON.INTERACT' ! 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-4 - 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 +! 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 -!- 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 + itj1=ntortyp+1 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) + 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 subroutine check_ecartint -#else + end function eello6_graph4 !----------------------------------------------------------------------------- - subroutine check_ecartint -! Check the gradient of the energy in Cartesian coordinates. - use io_base, only: intout -! implicit real*8 (a-h,o-z) + real(kind=8) function eello_turn6(i,jj,kk) +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' -! include 'COMMON.CONTROL' +! include 'COMMON.IOUNITS' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' -! include 'COMMON.IOUNITS' -! include 'COMMON.VAR' +! include 'COMMON.INTERACT' ! 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=2.0D-5 - 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) +! 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 - 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 +!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 -!----------------------------------------------------------------------------- - 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 + 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 - 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 + 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 - 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) +#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 - 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 +#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 - sscale_grad=0d0 + j1=j-1 + j2=j-2 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) + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 else - sscale_ele=0d0 + 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 sscale_ele + end function eello_turn6 +!----------------------------------------------------------------------------- + subroutine MATVEC2(A1,V1,V2) +!DIR$ INLINEALWAYS MATVEC2 +#ifndef OSF +!DEC$ ATTRIBUTES FORCEINLINE::MATVEC2 +#endif +! implicit real(kind=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 - 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 + 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 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) + subroutine MATMAT2(A1,A2,A3) +#ifndef OSF +!DEC$ ATTRIBUTES FORCEINLINE::MATMAT2 +#endif +! implicit real(kind=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 -! 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) -! -! 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 - 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) + 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 -!****************************************************************************** -! -! 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 + end subroutine transpose !----------------------------------------------------------------------------- - 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) + 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(kind=8) (a-h,o-z) + use io_base, only: pdbout ! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' +#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.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 -! 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) -! 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) -! -! Calculate SC interaction energy. +! 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 ! - 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 - 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 +! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient +! in virtual-bond-vector coordinates ! - 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 +#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 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) + 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)+ & + wmartini*(gradlipbond(j,i)+gradlipang(j,i)+gradliplj(j,i)+gradlipelec(j,i))+& + wcat_tran*gradcattranc(j,i)+gradcatangc(j,i)+& + wlip_prot*gradpepmart(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)+& + wmartini*(gradlipbond(j,i)+gradlipang(j,i)+gradliplj(j,i)+gradlipelec(j,i))+& + wcat_tran*gradcattranc(j,i)+gradcatangc(j,i)+& + wlip_prot*gradpepmart(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 - 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 -! 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) -! -! 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 - 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 + call flush(iout) +#endif + do i=0,nres do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) + gradbufc_sum(j,i)=gradbufc(j,i) enddo enddo - return - end subroutine eljk_short -!----------------------------------------------------------------------------- - subroutine ebp_long(evdw) -! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the Berne-Pechukas potential of interaction. -! - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CALC' - use comm_srutu -!el integer :: icall -!el common /srutu/ icall -! double precision rrsave(maxdim) - logical :: lprn -!el local variables - integer :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi,fac - real(kind=8) :: sss,e1,e2,evdw,sigm,epsi - evdw=0.0D0 -! print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 -! if (icall.eq.0) then -! lprn=.true. -! else - lprn=.false. -! endif -!el ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i,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) -! 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 - 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) +! 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 ! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the Berne-Pechukas potential of interaction. +! Obsolete and inefficient code; we can make the effort O(n) and, therefore, +! do not parallelize this part. ! - use calc_data -! implicit real*8 (a-h,o-z) -! include 'DIMENSIONS' -! include 'COMMON.GEO' -! include 'COMMON.VAR' -! include 'COMMON.LOCAL' -! include 'COMMON.CHAIN' -! include 'COMMON.DERIV' -! include 'COMMON.NAMES' -! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CALC' - use comm_srutu -!el integer :: icall -!el common /srutu/ icall -! double precision rrsave(maxdim) - logical :: lprn -!el local variables - integer :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi - real(kind=8) :: sss,e1,e2,evdw - evdw=0.0D0 -! print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 -! if (icall.eq.0) then -! lprn=.true. -! else - lprn=.false. -! endif -!el ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i,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) -! dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) -! -! Calculate SC interaction energy. +! 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)!& +! + gradcattranc(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) ! - 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 - 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 +#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)!& +! + gradcattranc(j,i) -! 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) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - if ((zi.gt.bordlipbot) & - .and.(zi.lt.bordliptop)) then -!C the energy transfer exist - if (zi.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zi-bordlipbot)/lipbufthick) -!C 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 - - 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 +#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)& + +wcat_tran*gradcattranx(j,i)+gradcatangx(j,i)& + +wlip_prot*gradpepmartx(j,i) -!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 +! if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i) - 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 - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - if ((zj.gt.bordlipbot) & - .and.(zj.lt.bordliptop)) then -!C the energy transfer exist - if (zj.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zj-bordlipbot)/lipbufthick) -!C lipbufthick is thickenes of lipid buffore - sslipj=sscalelip(fracinbuf) - ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick - elseif (zj.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick) - sslipj=sscalelip(fracinbuf) - ssgradlipj=sscagradlip(fracinbuf)/lipbufthick - else - sslipj=1.0d0 - ssgradlipj=0.0 - endif - else - sslipj=0.0d0 - ssgradlipj=0.0 - endif - 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 - - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo + enddo + enddo +! write(iout,*), "const_homol",constr_homology + if (constr_homology.gt.0) then + do i=1,nct + do j=1,3 + gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i) +! write(iout,*) "duscdiff",duscdiff(j,i) + gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i) enddo + enddo + endif +!#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 - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif - - 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*sigma(itypi,itypj))) - sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj))) - 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& - /sigma(itypi,itypj)*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) + 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 ! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the Gay-Berne potential of interaction. +! 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(kind=8) (a-h,o-z) 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) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - if ((zi.gt.bordlipbot) & - .and.(zi.lt.bordliptop)) then -!C the energy transfer exist - if (zi.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zi-bordlipbot)/lipbufthick) -!C 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 - - 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) +! 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 - 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' - 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 + 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 -!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 + 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 -!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 +! 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 -! if (energy_dec) write (iout,*) & -! 'evdw',i,j,evdwij,' ss' - 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)-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 - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - if ((zj.gt.bordlipbot) & - .and.(zj.lt.bordliptop)) then -!C the energy transfer exist - if (zj.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zj-bordlipbot)/lipbufthick) -!C lipbufthick is thickenes of lipid buffore - sslipj=sscalelip(fracinbuf) - ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick - elseif (zj.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick) - sslipj=sscalelip(fracinbuf) - ssgradlipj=sscagradlip(fracinbuf)/lipbufthick - else - sslipj=1.0d0 - ssgradlipj=0.0 - endif - else - sslipj=0.0d0 - ssgradlipj=0.0 - endif - 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 - - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif + 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 - 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*sigma(itypi,itypj))) - sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj))) - if (sss_ele_cut.le.0.0) cycle + 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 - if (sss.gt.0.0d0) then + 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)) +! 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)*sss_ele_cut & + +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) & + +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss_ele_cut -! 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 +! 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 - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & - 'evdw',i,j,evdwij -! if (energy_dec) write (iout,*) & -! 'evdw',i,j,evdwij,"egb_short" +! 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)*sss_ele_cut + gradpepcat(l,j)=gradpepcat(l,j)+gg(l)*sss_ele_cut + enddo + end subroutine sc_grad_cat -! 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& - /sigma(itypi,itypj)*rij+sss_grad/sss*rij & - /sigmaii(itypi,itypj)) + 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 -! 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 + 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,*) "gg",(gg(k),k=1,3) + + 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) + gradpepcat(k,i)= gradpepcat(k,i) +sss_ele_cut*(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,i+1)= gradpepcat(k,i+1) +sss_ele_cut*(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)*sss_ele_cut + enddo + end subroutine sc_grad_cat_pep + +#ifdef CRYST_THETA !----------------------------------------------------------------------------- - 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) + subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) + + use comm_calcthet +! implicit real(kind=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 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 - integer :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij - real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift - evdw=0.0D0 -! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -! if (icall.eq.0) lprn=.true. -!el ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i,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) -! 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 - 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 + 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 !----------------------------------------------------------------------------- - subroutine egbv_short(evdw) +! 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. ! -! This subroutine calculates the interaction energy of nonbonded side chains -! assuming the Gay-Berne-Vorobjev potential of interaction. +! The derivatives are stored in the following arrays: ! - use calc_data -! implicit real*8 (a-h,o-z) +! 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(kind=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.GEO' +! include 'COMMON.LOCAL' ! include 'COMMON.INTERACT' -! include 'COMMON.IOUNITS' -! include 'COMMON.CALC' - use comm_srutu -!el integer :: icall -!el common /srutu/ icall - logical :: lprn + 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 :: iint,itypi,itypi1,itypj - real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift - real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm - evdw=0.0D0 -! print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - lprn=.false. -! if (icall.eq.0) lprn=.true. -!el ind=0 - do i=iatsc_s,iatsc_e - itypi=itype(i,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) -! dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(i+nres) + 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 +#ifdef FIVEDIAG + if(.not. allocated(fromto)) allocate(fromto(3,3)) +#else + if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim)) +#endif +! 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 ! -! Calculate SC interaction energy. +! maxdim=(nres-1)*(nres-2)/2 +! allocate(dcdv(6,maxdim),dxds(6,nres)) +! calculate the derivatives of transformation matrix elements in theta ! - 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 - 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) +!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 ! -! 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. +! derivatives in phi ! -! 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 + 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) +! +#ifndef FIVEDIAG + 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 -! 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 j=i+1,nres-2 + ind=indmat(i,j+1) do k=1,3 - dc_norm(k,i)=dc(k,i)*fac + 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 -! 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 +#endif ! +! Calculate derivatives. ! -! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms + ind1=0 + do i=1,nres-2 + ind1=ind1+1 ! -! Loop over i,i+2 and i,i+3 pairs of the peptide groups +! Derivatives of DC(i+1) in theta(i+2) ! - 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 - xmedi=dmod(xmedi,boxxsize) - if (xmedi.lt.0) xmedi=xmedi+boxxsize - ymedi=dmod(ymedi,boxysize) - if (ymedi.lt.0) ymedi=ymedi+boxysize - zmedi=dmod(zmedi,boxzsize) - if (zmedi.lt.0) zmedi=zmedi+boxzsize - 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 - xmedi=dmod(xmedi,boxxsize) - if (xmedi.lt.0) xmedi=xmedi+boxxsize - ymedi=dmod(ymedi,boxysize) - if (ymedi.lt.0) ymedi=ymedi+boxysize - zmedi=dmod(zmedi,boxzsize) - if (zmedi.lt.0) zmedi=zmedi+boxzsize - 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 + 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 ! -! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 +! 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 ! - 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 - xmedi=dmod(xmedi,boxxsize) - if (xmedi.lt.0) xmedi=xmedi+boxxsize - ymedi=dmod(ymedi,boxysize) - if (ymedi.lt.0) ymedi=ymedi+boxysize - zmedi=dmod(zmedi,boxzsize) - if (zmedi.lt.0) zmedi=zmedi+boxzsize -! 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 -! 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 - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - isubchap=0 - dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - isubchap=1 - endif - enddo - enddo - enddo - if (isubchap.eq.1) then -!C print *,i,j - xj=xj_temp-xmedi - yj=yj_temp-ymedi - zj=zj_temp-zmedi - else - xj=xj_safe-xmedi - yj=yj_safe-ymedi - zj=zj_safe-zmedi - endif - - 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 - +! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently +! than the other off-diagonal derivatives. ! -! Calculate contributions to the Cartesian gradient. + 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) ! -#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 +! Derivatives of DC(i+1) in phi(i+2) ! -! 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 j=1,3 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 + 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 ! -! Loop over residues i+1 thru j-1. +! Derivatives of SC(i+1) in phi(i+2) ! -!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) + 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 ! -! 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 +! Derivatives of SC(i+1) in phi(i+3). ! -! 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 j=1,3 + dxoiij=0.0D0 do k=1,3 - gelc_long(k,j)=gelc(k,j)+ggg(k) - gelc_long(k,i)=gelc(k,i)-ggg(k) + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) enddo + dxdv(j+3,ind1+1)=dxoiij + enddo ! -! Loop over residues i+1 thru j-1. +! 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). ! -!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 j=i+1,nres-2 + ind1=ind1+1 + ind=indmat(i+1,j+1) +!d print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 +#ifdef FIVEDIAG + call build_fromto(i+1,j+1,fromto) +!c write(iout,'(7hfromto 9f10.5)')((fromto(k,l),l=1,3),k=1,3) do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + do l=1,3 + tempkl=0.0D0 + do m=1,2 + tempkl=tempkl+prordt(k,m,i)*fromto(m,l) + enddo + temp(k,l)=tempkl + enddo 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) +#else 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 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 +#endif +!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 - ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut + dcdv(k,ind1)=vbld(i+1)*temp(k,1) 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 +!d print '(3f8.3)',(dcdv(k,ind1),k=1,3) +! Derivatives of SC vectors in theta 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) + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) + enddo + dxdv(k,ind1+1)=dxoijk 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. +!--- Calculate the derivatives in phi ! - 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) +#ifdef FIVEDIAG + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,3 + tempkl=tempkl+prodrt(k,m,i)*fromto(m,l) + enddo + temp(k,l)=tempkl 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)) + enddo +#else 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)) + 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 -! 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 +#endif + + 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 + dcdv(k+3,ind1)=vbld(i+1)*temp(k,1) + 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) + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) enddo + dxdv(k+3,ind1+1)=dxoijk 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 + 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 - 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) + dxds(jjj+k,i)=dj + enddo + jjj=jjj+3 + enddo + enddo + return + end subroutine cartder +#ifdef FIVEDIAG + subroutine build_fromto(i,j,fromto) + implicit none + integer i,j,jj,k,l,m + double precision fromto(3,3),temp(3,3),dp(3,3) + double precision dpkl + save temp +! +! generate the matrix products of type r(i)t(i)...r(j)t(j) on the fly +! +! write (iout,*) "temp on entry" +! write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3) +! do i=2,nres-2 +! ind=indmat(i,i+1) + if (j.eq.i+1) then + do k=1,3 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 + temp(k,l)=rt(k,l,i) 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 + enddo + do k=1,3 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 - + fromto(k,l)=temp(k,l) 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 + else +! 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-1) enddo + dp(k,l)=dpkl + fromto(k,l)=dpkl 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 + enddo + do k=1,3 + do l=1,3 + temp(k,l)=dp(k,l) + enddo + enddo + endif +! write (iout,*) "temp upon exit" +! write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3) +! enddo +! enddo return - end subroutine eelecij_scale + end subroutine build_fromto +#endif + !----------------------------------------------------------------------------- - subroutine evdwpp_short(evdw1) -! -! Compute Evdwpp -! -! implicit real*8 (a-h,o-z) +! checkder_p.F +!----------------------------------------------------------------------------- + subroutine check_cartgrad +! Check the gradient of Cartesian coordinates in internal coordinates. +! implicit real(kind=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.GEO' +! include 'COMMON.LOCAL' ! 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 - 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 - xmedi=dmod(xmedi,boxxsize) - if (xmedi.lt.0) xmedi=xmedi+boxxsize - ymedi=dmod(ymedi,boxysize) - if (ymedi.lt.0) ymedi=ymedi+boxysize - zmedi=dmod(zmedi,boxzsize) - if (zmedi.lt.0) zmedi=zmedi+boxzsize - 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 - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - isubchap=0 - dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - isubchap=1 - endif - enddo - enddo - enddo - if (isubchap.eq.1) then -!C print *,i,j - xj=xj_temp-xmedi - yj=yj_temp-ymedi - zj=zj_temp-zmedi - else - xj=xj_safe-xmedi - yj=yj_safe-ymedi - zj=zj_safe-zmedi - endif - - 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)) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - 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) - yj=c(2,j) - zj=c(3,j) - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif - 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. + 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 ! - 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 +! 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 - - 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) + 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 -!****************************************************************************** -! -! 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)) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - 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) - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif - - 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) + 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 - 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 + call chainbuild 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)=(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 - 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 + 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 -! -! 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) + 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 - 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' + 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(kind=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 +!#ifdef LBFGS +! use minimm, only: funcgrad +!#endif +!el integer :: icall +!el common /srutu/ icall +! real(kind=8) :: funcgrad + 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,ff + 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) +#ifdef LBFGS + ff=funcgrad(x,g) +#else +!el call enerprint(energia) + call gradient(nvar,x,nf,g,uiparm,urparm,fdum) +#endif + 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 + use MD_data, only: iset +! 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.LOCAL' +! include 'COMMON.CONTACTS' ! 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.) +! 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 + if (iset.eq.0) iset=1 + call intout +! call intcartderiv +! call checkintcartgrad + call zerograd + aincr=graddelta + write(iout,*) 'Calling CHECK_ECARTINT.,kupa' + 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 +#ifdef FIVEDIAG + call grad_transform #endif - endif -!elwrite(iout,*)"in etotal long" + 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) + write(iout,*) "before movement analytical gradient" + + enddo + enddo + 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 -#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 +!- split gradient check + call zerograd + call etotal_long(energia) +!el call enerprint(energia) + call cartgrad +#ifdef FIVEDIAG + call grad_transform #endif + 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 +#ifdef FIVEDIAG + call grad_transform #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.) + 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' +#ifdef FIVEDIAG + do i=1,nres #else - call int_from_cart1(.false.) + do i=nnt,nct #endif + 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 + use MD_data, only: iset +! 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 + if (iset.eq.0) iset=1 + 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) +! 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) + grad_s(j+3,0)=gxcart(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 + write(iout,*) "before movement analytical gradient" + 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 + + 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 -#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 + 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) +! call enerprint(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) +! call enerprint(energia1) + etot1=energia1(0) +! print *,"ene",energia1(0),energia1(57) + 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) +! call enerprint(energia1) +! print *,"ene",energia1(0),energia1(57) + 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(kind=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 +!#ifdef LBFGS +! use minimm, only : funcgrad +!#endif +!el integer :: icall +!el common /srutu/ icall +! real(kind=8) :: funcgrad + 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,ff + 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 +#ifdef LBFGS + ff=funcgrad(x,gana) +#else + +!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 +#endif + 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(kind=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 +!SCALINING MARTINI + real(kind=8) function sscale_martini(r) +! include "COMMON.SPLITELE" + real(kind=8) :: r,gamm +! print *,"here2",r_cut_mart,r + if(r.lt.r_cut_mart-rlamb_mart) then + sscale_martini=1.0d0 + else if(r.le.r_cut_mart.and.r.ge.r_cut_mart-rlamb_mart) then + gamm=(r-(r_cut_mart-rlamb_mart))/rlamb_mart + sscale_martini=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale_martini=0.0d0 + endif + return + end function sscale_martini + real(kind=8) function sscale_grad_martini(r) +! include "COMMON.SPLITELE" + real(kind=8) :: r,gamm + if(r.lt.r_cut_mart-rlamb_mart) then + sscale_grad_martini=0.0d0 + else if(r.le.r_cut_mart.and.r.ge.r_cut_mart-rlamb_mart) then + gamm=(r-(r_cut_mart-rlamb_mart))/rlamb_mart + sscale_grad_martini=gamm*(6*gamm-6.0d0)/rlamb_mart + else + sscale_grad_martini=0.0d0 + endif + return + end function sscale_grad_martini + real(kind=8) function sscale_martini_angle(r) +! include "COMMON.SPLITELE" + real(kind=8) :: r,gamm,r_cut_angle,rlamb_angle +! print *,"here2",r_cut_angle,r + r_cut_angle=3.12d0 + rlamb_angle=0.1d0 + if(r.lt.r_cut_angle-rlamb_angle) then + sscale_martini_angle=1.0d0 + else if(r.le.r_cut_angle.and.r.ge.r_cut_angle-rlamb_angle) then + gamm=(r-(r_cut_angle-rlamb_angle))/rlamb_angle + sscale_martini_angle=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale_martini_angle=0.0d0 + endif + return + end function sscale_martini_angle + real(kind=8) function sscale_grad_martini_angle(r) +! include "COMMON.SPLITELE" + real(kind=8) :: r,gamm,r_cut_angle,rlamb_angle + r_cut_angle=3.12d0 + rlamb_angle=0.1d0 + if(r.lt.r_cut_angle-rlamb_angle) then + sscale_grad_martini_angle=0.0d0 + else if(r.le.r_cut_angle.and.r.ge.r_cut_angle-rlamb_angle) then + gamm=(r-(r_cut_angle-rlamb_angle))/rlamb_angle + sscale_grad_martini_angle=gamm*(6*gamm-6.0d0)/rlamb_angle + else + sscale_grad_martini_angle=0.0d0 + endif + return + end function sscale_grad_martini_angle + + +!!!!!!!!!! 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 +!!!!!!!!!! PBCSCALE + real(kind=8) function sscale2(r,r_cc,r_ll) +! include "COMMON.SPLITELE" + real(kind=8) :: r,gamm,r_cc,r_ll + if(r.lt.r_cc-r_ll) then + sscale2=1.0d0 + else if(r.le.r_cc.and.r.ge.r_cc-r_ll) then + gamm=(r-(r_cc-r_ll))/r_ll + sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale2=0d0 + endif + return + end function sscale2 + + real(kind=8) function sscagrad2(r,r_cc,r_ll) + real(kind=8) :: r,gamm,r_cc,r_ll +! include "COMMON.SPLITELE" + if(r.lt.r_cc-r_ll) then + sscagrad2=0.0d0 + else if(r.le.r_cc.and.r.ge.r_cc-r_ll) then + gamm=(r-(r_cc-r_ll))/r_ll + sscagrad2=gamm*(6*gamm-6.0d0)/r_ll + else + sscagrad2=0.0d0 + endif + return + end function sscagrad2 + + 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(kind=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(kind=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(kind=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(kind=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(kind=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(kind=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(kind=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(kind=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,countss + 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. + countss=0 +! 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 + countss=countss+1 + call dyn_ssbond_ene(i,j,evdwij,countss) + 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(kind=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(kind=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(kind=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 catices" +#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(kind=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(kind=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(kind=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(kind=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(kind=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(kind=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, ehomology_constr +! 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" + ehomology_constr=0.0d0 +#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 + energia(51)=ehomology_constr + 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(kind=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, & + ehomology_constr + 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) +! 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 +! +! Homology restraints +! + if (constr_homology.ge.1) then + call e_modeller(ehomology_constr) +! print *,"tu" + else + ehomology_constr=0.0d0 + 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 + energia(51)=ehomology_constr +! 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 +!----------------------------------------------------------------------------- +#ifndef LBFGS + subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) + + use io_base, only:intout,briefout +! implicit real(kind=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 +#endif +!----------------------------------------------------------------------------- + subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F + + use comm_chu +! implicit real(kind=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(kind=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),4f10.5)') i,(gcart(j,i),j=1,3),& + (gxcart(j,i),j=1,3),gloc(i,icg),(gloc_sc(j,i,icg),j=1,3) +#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 +! call grad_transform +#endif +#ifdef TIMING + time_cartgrad=time_cartgrad+MPI_Wtime()-time00 +#endif +!#undef DEBUG + return + end subroutine cartgrad + +#ifdef FIVEDIAG + subroutine grad_transform + implicit none +#ifdef MPI + include 'mpif.h' +#endif + integer i,j,kk,mnum +#ifdef DEBUG + write (iout,*)"Converting virtual-bond gradient to CA/SC gradient" + write (iout,*) "dC/dX gradient" + do i=0,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif + do i=nres,1,-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 + do i=2,nres + mnum=molnum(i) + if (itype(i-1,mnum).eq.ntyp1_molec(mnum) .and.& + itype(i,mnum).ne.ntyp1_molec(mnum)) then + gcart(:,i)=gcart(:,i)+gcart(:,i-1) + else if (itype(i-1,mnum).ne.ntyp1_molec(mnum).and.& + itype(i,mnum).eq.ntyp1_molec(mnum)) then + gcart(:,i-1)=gcart(:,i-1)+gcart(:,i) + endif + enddo +! if (nnt.gt.1) then +! do j=1,3 +! 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 +#ifdef DEBUG + write (iout,*) "CA/SC gradient" + 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 +#endif + return + end subroutine grad_transform +#endif + + !----------------------------------------------------------------------------- + subroutine zerograd + ! implicit real(kind=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 + gradlipbond(j,i)=0.0d0 + gradlipang(j,i)=0.0d0 + gradliplj(j,i)=0.0d0 + gradlipelec(j,i)=0.0d0 + gradcattranc(j,i)=0.0d0 + gradcattranx(j,i)=0.0d0 + gradcatangx(j,i)=0.0d0 + gradcatangc(j,i)=0.0d0 + gradpepmart(j,i)=0.0d0 + gradpepmartx(j,i)=0.0d0 + duscdiff(j,i)=0.0d0 + duscdiffx(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(kind=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).and.(sint.ne.0.0d0))) & + 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).and.(sint.ne.0.0d0))& + 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).lt.4) 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)) + if ((sint*sint1).eq.0.0d0) then + fac0=0.0d0 + else + fac0=1.0d0/(sint1*sint) + endif + fac1=cost*fac0 + fac2=cost1*fac0 + if (sint1.ne.0.0d0) then + fac3=cosg*cost1/(sint1*sint1) + else + fac3=0.0d0 + endif + if (sint.ne.0.0d0) then + fac4=cosg*cost/(sint*sint) + else + fac4=0.0d0 + endif + ! 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 + if (sint.ne.0.0d0) then + ctgt=cost/sint + else + ctgt=0.0d0 + endif + if (sint1.ne.0.0d0) then + ctgt1=cost1/sint1 + else + ctgt1=0.0d0 + endif + 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 +! write(iout,*) "just after,close to pi",dphi(j,3,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) + + ! 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)) + ! write(iout,*) "faki",fac0,fac1,fac2,fac3,fac + if ((sint*sint1).eq.0.0d0) then + fac0=0.0d0 + else + fac0=1.0d0/(sint1*sint) + endif + fac1=cost*fac0 + fac2=cost1*fac0 + if (sint1.ne.0.0d0) then + fac3=cosg*cost1/(sint1*sint1) + else + fac3=0.0d0 + endif + if (sint.ne.0.0d0) then + fac4=cosg*cost/(sint*sint) + else + fac4=0.0d0 + endif + + ! 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)) + if ((sint*sint1).eq.0.0d0) then + fac0=0.0d0 + else + fac0=1.0d0/(sint1*sint) + endif + fac1=cost*fac0 + fac2=cost1*fac0 + if (sint1.ne.0.0d0) then + fac3=cosg*cost1/(sint1*sint1) + else + fac3=0.0d0 + endif + if (sint.ne.0.0d0) then + fac4=cosg*cost/(sint*sint) + else + fac4=0.0d0 + endif + ! 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)) + if ((sint*sint1).eq.0.0d0) then + fac0=0.0d0 + else + fac0=1.0d0/(sint1*sint) + endif + fac1=cost*fac0 + fac2=cost1*fac0 + if (sint1.ne.0.0d0) then + fac3=cosg*cost1/(sint1*sint1) + else + fac3=0.0d0 + endif + if (sint.ne.0.0d0) then + fac4=cosg*cost/(sint*sint) + else + fac4=0.0d0 + endif + ! 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(kind=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(kind=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(kind=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(kind=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(kind=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(kind=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,countss + real(kind=8) :: rmin,rmax + real(kind=8) :: eij + + real(kind=8) :: d + real(kind=8) :: wi,rij,tj,pj +! return + countss=1 + 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,countss) + enddo + enddo + call exit(1) + return + end subroutine check_energies +!----------------------------------------------------------------------------- + subroutine dyn_ssbond_ene(resi,resj,eij,countss) +! 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,countss + 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(countss)=eij + else if (.not.havebond .and. dyn_ssbond_ij(countss).lt.1.0d300) then + dyn_ssbond_ij(countss)=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,k + integer :: diff,allnss,newnss + integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2) + newihpb,newjhpb,aliass + 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 + k=0 + do i=1,nres-1 + do j=i+1,nres + if ((itype(i,1).eq.1).and.(itype(j,1).eq.1)) then + k=k+1 + if (dyn_ssbond_ij(k).lt.1.0d300) then + allnss=allnss+1 + allflag(allnss)=0 + allihpb(allnss)=i + alljhpb(allnss)=j + aliass(allnss)=k + endif + 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(aliass(allnss)).lt.emin) then + emin=dyn_ssbond_ij(aliass(allnss)) + 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 +#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) +! 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 + 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 +#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) +! 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 + enddo +!#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER) + nss=newnss + do i=1,nss + idssb(i)=newihpb(i) + jdssb(i)=newjhpb(i) + enddo +!#else +! nss=0 +!#endif + + 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) + use MD_data, only:totTafm + real(kind=8),dimension(3) :: vectube,cm + + 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,tubezcenter,xi,yi,zi!,& +! vecsim,vectrue + real(kind=8) :: eps,sig,aa_tub_lip,bb_tub_lip + integer:: i,j,iti,r,ilol,ityp +! totTafm=2.0 + Etube=0.0d0 + call to_box(tubecenter(1),tubecenter(2),tubecenter(3)) +! 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 + +! do j=-1,1 + xi=(c(1,i)+c(1,i+1))/2.0d0 + yi=(c(2,i)+c(2,i+1))/2.0d0 + zi=((c(3,i)+c(3,i+1))/2.0d0) + call to_box(xi,yi,zi) +! tubezcenter=totTafm*velNANOconst+tubecenter(3) + + vectube(1)=boxshift(xi-tubecenter(1),boxxsize) + vectube(2)=boxshift(yi-tubecenter(2),boxysize) + vectube(3)=boxshift(zi-tubecenter(3),boxzsize) + +!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,*),"ETUBE_PEP",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 + xi=c(1,i+nres) + yi=c(2,i+nres) + zi=c(3,i+nres) + call to_box(xi,yi,zi) + tubezcenter=totTafm*velNANOconst+tubecenter(3) + + vectube(1)=boxshift(xi-tubecenter(1),boxxsize) + vectube(2)=boxshift(yi-tubecenter(2),boxysize) + vectube(3)=boxshift(zi-tubecenter(3),boxzsize) + + +!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,*),"ETUBE",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=ilipbond_start_tub,ilipbond_end_tub + ityp=itype(i,4) +! print *,"ilipbond_start",ilipbond_start,i,ityp + if (ityp.gt.ntyp_molec(4)) cycle +!C now calculate distance from center of tube and direction vectors + eps=lip_sig(ityp,18)*4.0d0 + sig=lip_sig(ityp,18) + aa_tub_lip=eps/(sig**12) + bb_tub_lip=eps/(sig**6) +! do j=-1,1 + xi=c(1,i) + yi=c(2,i) + zi=c(3,i) + call to_box(xi,yi,zi) +! tubezcenter=totTafm*velNANOconst+tubecenter(3) + + vectube(1)=boxshift(xi-tubecenter(1),boxxsize) + vectube(2)=boxshift(yi-tubecenter(2),boxysize) + vectube(3)=boxshift(zi-tubecenter(3),boxzsize) + +!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)=aa_tub_lip/rdiff6**2.0d0+bb_tub_lip/rdiff6 + Etube=Etube+enetube(i) +!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*aa_tub_lip/rdiff6- & + 6.0d0*bb_tub_lip)/rdiff6/rdiff + do j=1,3 + gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac + enddo + if (energy_dec) write(iout,*) "ETUBLIP",i,rdiff,enetube(i+nres) + enddo + + +!----------------------------------------------------------------------- + if (fg_rank.eq.0) then + if (velNANOconst.ne.0) then + do j=1,3 + cm(j)=0.0d0 + enddo + do i=1,inanomove + ilol=inanotab(i) + do j=1,3 + cm(j)=cm(j)+c(j,ilol) + enddo + enddo + do j=1,3 + cm(j)=cm(j)/inanomove + enddo + vecsim=velNANOconst*totTafm+distnanoinit + vectrue=cm(3)-tubecenter(3) + etube=etube+0.5d0*forcenanoconst*( vectrue-vecsim)**2 + fac=forcenanoconst*(vectrue-vecsim)/inanomove + do i=1,inanomove + ilol=inanotab(i) + gg_tube(3,ilol-1)=gg_tube(3,ilol-1)+fac + enddo + endif + endif +! 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,cbeg,cend + real(kind=8) :: afmdist,Eafmforce + integer :: i,j +!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 + cbeg=0.0d0 + cend=0.0d0 + if (afmbeg.eq.-1) then + do i=1,nbegafmmat + do j=1,3 + cbeg(j)=cbeg(j)+c(j,afmbegcentr(i))/nbegafmmat + enddo + enddo + else + do j=1,3 + cbeg(j)=c(j,afmend) + enddo + endif + if (afmend.eq.-1) then + do i=1,nendafmmat + do j=1,3 + cend(j)=cend(j)+c(j,afmendcentr(i))/nendafmmat + enddo + enddo + else + cend(j)=c(j,afmend) + endif + + do i=1,3 + diffafm(i)=cend(i)-cbeg(i) + 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) + if (afmend.eq.-1) then + do i=1,nendafmmat + do j=1,3 + gradafm(j,afmendcentr(i)-1)=-forceAFMconst* & + (distafminit+totTafm*velAFMconst-afmdist) & + *diffafm(j)/afmdist/nendafmmat + enddo + enddo + else + do i=1,3 + gradafm(i,afmend-1)=-forceAFMconst* & + (distafminit+totTafm*velAFMconst-afmdist) & + *diffafm(i)/afmdist + enddo + endif + if (afmbeg.eq.-1) then + do i=1,nbegafmmat + do j=1,3 + gradafm(i,afmbegcentr(i)-1)=forceAFMconst* & + (distafminit+totTafm*velAFMconst-afmdist) & + *diffafm(i)/afmdist + enddo + enddo + else + do i=1,3 + gradafm(i,afmbeg-1)=forceAFMconst* & + (distafminit+totTafm*velAFMconst-afmdist) & + *diffafm(i)/afmdist + enddo + endif +! 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=100*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) +#ifndef NEWCORR + 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) +!(maxres) + allocate(jcont_hb(maxconts,nres)) +#endif + allocate(num_cont_hb(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) +#ifndef NEWCORR + print *,"before iint_sent allocate" + allocate(iint_sent(4,nres,nres)) + allocate(iint_sent_local(4,nres,nres)) + print *,"after iint_sent allocate" +#endif +!(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/ +#ifdef NEWCORR + print *,"before dcdv allocate" + allocate(dcdv(6,nres+2)) + allocate(dxdv(6,nres+2)) +#else + print *,"before dcdv allocate" + allocate(dcdv(6,maxdim)) + allocate(dxdv(6,maxdim)) +#endif +!(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(gradpepmart(3,-1:nres)) + allocate(gradpepmartx(3,-1:nres)) + allocate(gradcatcat(3,-1:nres)) + allocate(gradnuclcat(3,-1:nres)) + allocate(gradnuclcatx(3,-1:nres)) + allocate(gradlipbond(3,-1:nres)) + allocate(gradlipang(3,-1:nres)) + allocate(gradliplj(3,-1:nres)) + allocate(gradlipelec(3,-1:nres)) + allocate(gradcattranc(3,-1:nres)) + allocate(gradcattranx(3,-1:nres)) + allocate(gradcatangx(3,-1:nres)) + allocate(gradcatangc(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,-1:nres)) + allocate(duscdiffx(3,-1: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(10000)) +!(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) + print *,"before all 300" +! allocateion of lists JPRDLA + allocate(newcontlistppi(300*nres)) + allocate(newcontlistscpi(350*nres)) + allocate(newcontlisti(300*nres)) + allocate(newcontlistppj(300*nres)) + allocate(newcontlistscpj(350*nres)) + allocate(newcontlistj(300*nres)) + allocate(newcontlistmartpi(300*nres)) + allocate(newcontlistmartpj(300*nres)) + allocate(newcontlistmartsci(300*nres)) + allocate(newcontlistmartscj(300*nres)) + + allocate(newcontlistcatsctrani(300*nres)) + allocate(newcontlistcatsctranj(300*nres)) + allocate(newcontlistcatptrani(300*nres)) + allocate(newcontlistcatptranj(300*nres)) + allocate(newcontlistcatscnormi(300*nres)) + allocate(newcontlistcatscnormj(300*nres)) + allocate(newcontlistcatpnormi(300*nres)) + allocate(newcontlistcatpnormj(300*nres)) + allocate(newcontlistcatcatnormi(900*nres)) + allocate(newcontlistcatcatnormj(900*nres)) + + allocate(newcontlistcatscangi(300*nres)) + allocate(newcontlistcatscangj(300*nres)) + allocate(newcontlistcatscangfi(300*nres)) + allocate(newcontlistcatscangfj(300*nres)) + allocate(newcontlistcatscangfk(300*nres)) + allocate(newcontlistcatscangti(300*nres)) + allocate(newcontlistcatscangtj(300*nres)) + allocate(newcontlistcatscangtk(300*nres)) + allocate(newcontlistcatscangtl(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)& + .and.itype(i,2).eq.ntyp1_molec(2)) cycle + if (itype(i-1,2).eq.ntyp1_molec(2)& + .or. itype(i,2).eq.ntyp1_molec(2)) 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_nucl endif -! write (iout,*),"Processor",myrank," BROADCAST weights" - call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST c" - call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST dc" - call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST dc_norm" - call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST theta" - call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST phi" - call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST alph" - call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST omeg" - call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) -! write (iout,*) "Processor",myrank," BROADCAST vbld" - call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,& - king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -! write (iout,*) "Processor",myrank," BROADCAST vbld_inv" - endif -! write (iout,*) 'Processor',myrank, -! & ' calling etotal_short ipot=',ipot -! call flush(iout) -! print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#endif -! call int_from_cart1(.false.) -! -! Compute the side-chain and electrostatic interaction energy -! - goto (101,102,103,104,105,106) ipot -! Lennard-Jones potential. - 101 call elj_short(evdw) -!d print '(a)','Exit ELJ' - goto 107 -! Lennard-Jones-Kihara potential (shifted). - 102 call eljk_short(evdw) - goto 107 -! Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp_short(evdw) - goto 107 -! Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb_short(evdw) - goto 107 -! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv_short(evdw) - goto 107 -! Soft-sphere potential - already dealt with in the long-range part - 106 evdw=0.0d0 -! 106 call e_softsphere_short(evdw) -! -! Calculate electrostatic (H-bonding) energy of the main chain. -! - 107 continue -! -! Calculate the short-range part of Evdwpp -! - call evdwpp_short(evdw1) -! -! Calculate the short-range part of ESCp -! - if (ipot.lt.6) then - call escp_short(evdw2,evdw2_14) - endif -! -! Calculate the bond-stretching energy -! - call ebond(estr) -! -! Calculate the disulfide-bridge and other energy and the contributions -! from other distance constraints. - call edis(ehpb) -! -! Calculate the virtual-bond-angle energy. -! - call ebend(ebe,ethetacnstr) -! -! Calculate the SC local energy. -! - call vec_and_deriv - call esc(escloc) -! -! Calculate the virtual-bond torsional energy. -! - call etor(etors,edihcnstr) -! -! 6/23/01 Calculate double-torsional energy -! - call etor_d(etors_d) -! -! 21/5/07 Calculate local sicdechain correlation energy -! - if (wsccor.gt.0.0d0) then - call eback_sc_corr(esccor) - else - esccor=0.0d0 +! 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) + + 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 -! -! 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 +!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 - energia(2)=evdw2 - energia(18)=0.0d0 + phii=phi(i) #endif -#ifdef SPLITELE - energia(16)=evdw1 + 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 - energia(3)=evdw1 + phii1=phi(i+1) #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) + 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(kind=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 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 + 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 - gnmr1=0.0d0 + cosa=om12 + cosb=om1 + cosg=om2 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 + 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 - 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 + +!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 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 + 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 function rlornmr1prim + 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 - real(kind=8) function harmonic(y,ymax) -! implicit none - real(kind=8) :: y,ymax - real(kind=8) :: wykl=2.0d0 - harmonic=(y-ymax)**wykl + 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 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 + 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 harmonicprim -!----------------------------------------------------------------------------- -! gradient_p.F + end function enesc_nucl !----------------------------------------------------------------------------- - 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 + 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)) -!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 + 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 - 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 + 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 -! -! Add the components corresponding to local energy terms. -! + enddo + mm=mod(fg_rank,2) +!c write (*,*) 'MyRank',MyRank,' mm',mm + if (mm) 20,20,10 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) +!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 -! 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) +!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 gradient -!----------------------------------------------------------------------------- - subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F - - use comm_chu -! implicit real*8 (a-h,o-z) + end subroutine multibody_hb_nucl +!----------------------------------------------------------- + real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm) +! implicit real(kind=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 +! 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 subroutine func -!----------------------------------------------------------------------------- - subroutine cartgrad -! implicit real*8 (a-h,o-z) + end function ehbcorr_nucl +!------------------------------------------------------------------------- + + real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm) +! implicit real(kind=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.IOUNITS' ! include 'COMMON.DERIV' -! include 'COMMON.VAR' ! include 'COMMON.INTERACT' -! include 'COMMON.FFIELD' -! include 'COMMON.MD' -! include 'COMMON.IOUNITS' -! include 'COMMON.TIME1' -! - integer :: i,j +! 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 -! This subrouting calculates total Cartesian coordinate gradient. -! The subroutine chainbuild_cart and energy MUST be called beforehand. -! -!#define DEBUG -#ifdef TIMING - time00=MPI_Wtime() -#endif - icg=1 - call sum_gradient -#ifdef TIMING -#endif -!#define DEBUG -!el write (iout,*) "After sum_gradient" -#ifdef DEBUG -!el write (iout,*) "After sum_gradient" - do i=1,nres-1 - write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) - write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) + 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 -#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 + 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 - 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) + 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) + use MD_data, only: t_bath + integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj,irdiff,& + ii + 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) :: awat,bwat,cwat,dwat,sss2min2,sss2mingrad2,rdiff,ewater + real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,& + gg,r + + ecationcation=0.0d0 + if (nres_molec(5).le.1) 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",g_listcatcatnorm_start, g_listcatcatnorm_end +! do i=itmp+1,itmp+nres_molec(5)-1 + do ii=g_listcatcatnorm_start, g_listcatcatnorm_end + i=newcontlistcatcatnormi(ii) + j=newcontlistcatcatnormj(ii) + + 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) + if ((itypi.gt.1).or.(itypj.gt.1)) then + if (sss2min2.eq.0.0d0) cycle + sss2min2=sscale2(ract,12.0d0,1.0d0) + sss2mingrad2=sscagrad2(ract,12.0d0,1.0d0) +! 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 -#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) + do k=1,3 + gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k) + gradcatcat(k,i)=gradcatcat(k,i)-(gg(k)*sss2min2+(Evan1cat+Evan2cat+Eeleccat)*sss2mingrad2) + gradcatcat(k,j)=gradcatcat(k,j)+gg(k)*sss2min2+(Evan1cat+Evan2cat+Eeleccat)*sss2mingrad2 + enddo + if (energy_dec) write (iout,*) "ecatcat",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)*sss2min2 + else !this is water part and other non standard molecules + + sss2min2=sscale2(ract,10.0d0,1.0d0)! cutoff for water interaction is 15A + if (sss2min2.eq.0.0d0) cycle + sss2mingrad2=sscagrad2(ract,10.0d0,1.0d0) + irdiff=int((ract-2.06d0)*50.0d0)+1 + + rdiff=ract-((irdiff-1)*0.02d0+2.06d0) + if (irdiff.le.0) then + irdiff=0 + rdiff=ract + endif +! print *,rdiff,ract,irdiff,sss2mingrad2 + awat=awaterenta(irdiff)-awaterentro(irdiff)*t_bath/1000.0d0 + bwat=bwaterenta(irdiff)-bwaterentro(irdiff)*t_bath/1000.0d0 + cwat=cwaterenta(irdiff)-cwaterentro(irdiff)*t_bath/1000.0d0 + dwat=dwaterenta(irdiff)-dwaterentro(irdiff)*t_bath/1000.0d0 + r(1)=xj + r(2)=yj + r(3)=zj + + ewater=awat+bwat*rdiff+cwat*rdiff*rdiff+dwat*rdiff*rdiff*rdiff + ecationcation=ecationcation+ewater*sss2min2 + do k=1,3 + gg(k)=(bwat+2.0d0*cwat*rdiff+dwat*3.0d0*rdiff*rdiff)*r(k)/ract + gradcatcat(k,i)=gradcatcat(k,i)-gg(k)*sss2min2-sss2mingrad2*ewater*r(k)/ract + gradcatcat(k,j)=gradcatcat(k,j)+gg(k)*sss2min2+sss2mingrad2*ewater*r(k)/ract + enddo + if (energy_dec) write(iout,'(2f8.2,f10.2,2i5)') rdiff,ract,ecationcation,i,j + endif ! end water + 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 -#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) + 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,ki + 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) + real(kind=8) ::locbox(3) + locbox(1)=boxxsize + locbox(2)=boxysize + locbox(3)=boxzsize - ! 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) + evdw=0.0D0 + if (nres_molec(5).eq.0) return + eps_out=80.0d0 +! sss_ele_cut=1.0d0 - ! if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres) + 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 + do ki=g_listcatscnorm_start,g_listcatscnorm_end + i=newcontlistcatscnormi(ki) + j=newcontlistcatscnormj(ki) - ! allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres)) - ! allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres)) +! 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) - ! if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres) - ! if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres) +! 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) +! write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,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) +! write(iout,*) "xj,yj,zj", xj,yj,zj,boxxsize + + dxj=0.0 + dyj=0.0 + dzj=0.0 +! 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=0.0d0 +! 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) + +! b1cav=0.0d0 +! b2cav=0.0d0 +! b3cav=0.0d0 +! b4cav=0.0d0 + +! 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 - ! 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) + 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 + call to_box(ctail(1,1),ctail(2,1),ctail(3,1)) + call to_box(ctail(1,2),ctail(2,2),ctail(3,2)) +!c! tail distances will be themselves usefull elswhere +!c1 (in Gcav, for example) + do k=1,3 + Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k)) + enddo + 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) + enddo + call to_box(chead(1,1),chead(2,1),chead(3,1)) + call to_box(chead(1,2),chead(2,2),chead(3,2)) +! write(iout,*) "TEST",chead(1,1),chead(2,1),chead(3,1),dc_norm(k, i+nres),d1 +! distance +! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) +! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) + do k=1,3 + Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k)) + 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 + Fisocav=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) + sss_ele_cut=sscale_ele(1.0d0/(rij)) + sss_ele_grad=sscagrad_ele(1.0d0/(rij)) +! print *,sss_ele_cut,sss_ele_grad,& +! 1.0d0/(rij),r_cut_ele,rlamb_ele + if (sss_ele_cut.le.0.0) cycle + 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 + if (evdw.gt.1.0d6) then + write (*,'(2(1x,a3,i3),7f7.2)') & + restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,& + 1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij,sigsq + write(*,*) facsig,faceps1_inv,om1,chiom1,chi1 + write(*,*) "ANISO?!",chi1 +!evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,& +! Equad,evdwij+Fcav+eheadtail,evdw + endif + 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) - ! 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) - - +! 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*sss_ele_cut +!#endif + c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 + fac = -expon * (c1 + evdwij) * rij_shift + sigder = fac * sigder +! Calculate distance derivative + gg(1) = fac*sss_ele_cut+evdwij*sss_ele_grad + gg(2) = fac*sss_ele_cut+evdwij*sss_ele_grad + gg(3) = fac*sss_ele_cut+evdwij*sss_ele_grad +! print *,"GG(1),distance grad",gg(1) + 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*sss_ele_cut+& + Fcav*sss_ele_grad + Fcav=Fcav*sss_ele_cut + 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) + 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)) +! 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 +!! if (.false.) then ! turn off electrostatic + if (itype(j,5).gt.0) then ! the normal cation case + isel = iabs(Qi) + 1 ! ion is always charged so iabs(Qj) +! print *,i,itype(i,1),isel + IF (isel.eq.0) THEN + eheadtail = 0.0d0 + ELSE IF (isel.eq.1) THEN + 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 + CALL enq_cat(epol) + eheadtail = epol + ELSE IF (isel.eq.3) THEN + 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 + CALL edq_cat(ecl, elj, epol) + eheadtail = ECL + elj + epol + ELSE IF ((isel.eq.2)) THEN + 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 + CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj) + eheadtail = ECL + Egb + Epol + Fisocav + Elj + END IF ! this endif ends the "catch the gly-gly" at the beggining of Fcav + else ! here is water and other molecules + isel = iabs(Qi)+2 +! isel=2 +! if (isel.eq.4) isel=2 + if (isel.eq.2) then + eheadtail = 0.0d0 + else if (isel.eq.3) then + 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 + call eqd_cat(ecl,elj,epol) + eheadtail = ECL + elj + epol + else if (isel.eq.4) then + call edd_cat(ecl) + eheadtail = ECL + endif +! write(iout,*) "not yet implemented",j,itype(j,5) + endif +!! endif ! turn off electrostatic + evdw = evdw + Fcav + eheadtail +! if (evdw.gt.1.0d6) then +! write (*,'(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 +! endif + + 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 (energy_dec) write(iout,*) "FCAV", & + sig1,sig2,b1cav,b2cav,b3cav,b4cav +! print *,"before sc_grad_cat", i,j, gradpepcat(1,j) +! iF (nstate(itypi,itypj).eq.1) THEN + CALL sc_grad_cat +! print *,"after sc_grad_cat", i,j, gradpepcat(1,j) + +! 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 +! go to 23 +! do i=ibond_start,ibond_end + + do ki=g_listcatpnorm_start,g_listcatpnorm_end + i=newcontlistcatpnormi(ki) + j=newcontlistcatpnormj(ki) + +! 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) + xj=boxshift(xj-xi,boxxsize) + yj=boxshift(yj-yi,boxysize) + zj=boxshift(zj-zi,boxzsize) + + 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=0.0 +! 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 - ! gradc(j,i,icg)=0.0d0 - ! gradx(j,i,icg)=0.0d0 + eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) +! Rtail = 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 - 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 + DO k = 1, 3 + ctail(k,1)=(c(k,i)+c(k,i+1))/2.0 + ctail(k,2)=c(k,j) + END DO + call to_box(ctail(1,1),ctail(2,1),ctail(3,1)) + call to_box(ctail(1,2),ctail(2,2),ctail(3,2)) +!c! tail distances will be themselves usefull elswhere +!c1 (in Gcav, for example) + do k=1,3 + Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k)) + 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) +!c! tail distances will be themselves usefull elswhere +!c1 (in Gcav, for example) + 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) + ENDDO +! distance +! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) +! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) + call to_box(chead(1,1),chead(2,1),chead(3,1)) + call to_box(chead(1,2),chead(2,2),chead(3,2)) - do i=1,4*nres - gloc(i,icg)=0.0D0 - enddo - do i=1,nres - gel_loc_loc(i)=0.0d0 - gcorr_loc(i)=0.0d0 - g_corr5_loc(i)=0.0d0 - g_corr6_loc(i)=0.0d0 - gel_loc_turn3(i)=0.0d0 - gel_loc_turn4(i)=0.0d0 - gel_loc_turn6(i)=0.0d0 - gsccor_loc(i)=0.0d0 - enddo - ! initialize gcart and gxcart - ! allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES) - do i=0,nres - do j=1,3 - gcart(j,i)=0.0d0 - gxcart(j,i)=0.0d0 - enddo - enddo - return - end subroutine zerograd - !----------------------------------------------------------------------------- - real(kind=8) function fdum() - fdum=0.0D0 - return - end function fdum - !----------------------------------------------------------------------------- - ! intcartderiv.F - !----------------------------------------------------------------------------- - subroutine intcartderiv - ! implicit real*8 (a-h,o-z) - ! include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - ! include 'COMMON.SETUP' - ! include 'COMMON.CHAIN' - ! include 'COMMON.VAR' - ! include 'COMMON.GEO' - ! include 'COMMON.INTERACT' - ! include 'COMMON.DERIV' - ! include 'COMMON.IOUNITS' - ! include 'COMMON.LOCAL' - ! include 'COMMON.SCCOR' - real(kind=8) :: pi4,pi34 - real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres) - real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,& - dcosomega,dsinomega !(3,3,maxres) - real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n - - integer :: i,j,k - real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,& - fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,& - fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,& - fac17,coso_inv,fac10,fac11,fac12,fac13,fac14 - integer :: nres2 - nres2=2*nres +! distance +! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) +! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) + do k=1,3 + Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k)) + END DO - !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)) +! 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 = 0.0d0 ! 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) + sss_ele_cut=sscale_ele(1.0d0/(rij)) + sss_ele_grad=sscagrad_ele(1.0d0/(rij)) +! print *,sss_ele_cut,sss_ele_grad,& +! 1.0d0/(rij),r_cut_ele,rlamb_ele + if (sss_ele_cut.le.0.0) cycle + 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 + om2=0.0d0 + om12=0.0d0 + sqom1 = om1 * om1 + sqom2 = om2 * om2 + sqom12 = om12 * om12 - !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)) +! 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 +! if (evdw.gt.1.0d6) then +! write (*,'(2(1x,a3,i3),6f6.2)') & +! restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,& +! 1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij +!evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,& +! Equad,evdwij+Fcav+eheadtail,evdw +! endif + 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*sss_ele_cut +!#endif + c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 + fac = -expon * (c1 + evdwij) * rij_shift + sigder = fac * sigder +! Calculate distance derivative + gg(1) = fac*sss_ele_cut+evdwij*sss_ele_grad + gg(2) = fac*sss_ele_cut+evdwij*sss_ele_grad + gg(3) = fac*sss_ele_cut+evdwij*sss_ele_grad + 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 -#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 + dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf)) + dbot = 12.0d0 * b4cav * bat * Lambf + dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow*sss_ele_cut+& + Fcav*sss_ele_grad + Fcav=Fcav*sss_ele_cut + 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 ) + dCAVdOM2=0.0d0 + dCAVdOM12=0.0d0 - ! allocate(dtheta(3,2,nres)) !(3,2,maxres) - ! allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres) + 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 + if (itype(j,5).gt.0) then +!c! Compute head-head and head-tail energies for each state + isel = 3 +!c! Dipole-charge interactions + CALL edq_cat_pep(ecl, elj, epol) + eheadtail = ECL + elj + epol +! print *,"i,",i,eheadtail +! eheadtail = 0.0d0 + else +!HERE WATER and other types of molecules solvents will be added +! write(iout,*) "not yet implemented" + CALL edd_cat_pep(ecl) + eheadtail=ecl +! CALL edd_cat_pep +! eheadtail=0.0d0 + endif + evdw = evdw + Fcav + eheadtail +! if (evdw.gt.1.0d6) then +! write (*,'(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 +! endif + 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 - ! write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end - do i=1,nres - do j=1,3 - dtheta(j,1,i)=0.0d0 - dtheta(j,2,i)=0.0d0 - dphi(j,1,i)=0.0d0 - dphi(j,2,i)=0.0d0 - dphi(j,3,i)=0.0d0 - enddo - enddo - ! Derivatives of theta's -#if defined(MPI) && defined(PARINTDER) - ! We need dtheta(:,:,i-1) to compute dphi(:,:,i) - do i=max0(ithet_start-1,3),ithet_end -#else - do i=3,nres -#endif - cost=dcos(theta(i)) - sint=sqrt(1-cost*cost) - do j=1,3 - dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/& - vbld(i-1) - if (itype(i-1,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)) 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 +! 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 + 23 continue +! print *,"before leave sc_grad_cat", i,j, gradpepcat(1,nres-1) - !CC third case SC...Ca...Ca...SC -#ifdef PARINTDER + return + end subroutine ecats_prot_amber - 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 +!--------------------------------------------------------------------------- +! 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 + 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 -#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 + 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 - do j=1,3 - do k=1,3 - dalpha(k,j,i)=0.0d0 - domega(k,j,i)=0.0d0 - enddo - enddo + vcat(1)=xj_safe + vcat(2)=yj_safe + vcat(3)=zj_safe 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,*) + 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 -! 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,*) + do k=1,3 + v1(k)=(vcm(k)-valpha(k)) + v2(k)=(vcat(k)-valpha(k)) 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 + 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) -!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 +! 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 - 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 + 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 - 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) + 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 - 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 + dscvec(k) = dc(k,i+nres) + dscmag = dscmag+dscvec(k)*dscvec(k) 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 + 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 - 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 + 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 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 + + do k=1,3 + dx(k) = vcat(k)-vcm(k) 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 + do k=1,3 + v1(k)=(vcm(k)-valpha(k)) + v2(k)=(vcat(k)-valpha(k)) 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 + 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 -! 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 + 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 -! 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 + 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,boxik + real(kind=8),dimension(14) :: vcatnuclprm + ecation_nucl=0.0d0 + boxik(1)=boxxsize + boxik(2)=boxysize + boxik(3)=boxzsize + + if (nres_molec(5).eq.0) return + itmp=0 + do i=1,4 + itmp=itmp+nres_molec(i) + enddo +! print *,nres_molec(2),"nres2" + do i=ibond_nucl_start,ibond_nucl_end +! 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) +! print *,i,j,itmp +! write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,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) +! write(iout,*) 'after shift', xj,yj,zj + 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 + call to_box(vcm(1),vcm(2),vcm(3)) + call to_box(vsug(1),vsug(2),vsug(3)) + call to_box(vcat(1),vcat(2),vcat(3)) + do k=1,3 +! dx(k) = vcat(k)-vcm(k) +! enddo + dx(k)=boxshift(vcat(k)-vcm(k),boxik(k)) +! do k=1,3 + v1(k)=dc(k,i+nres) + v2(k)=boxshift(vcat(k)-vsug(k),boxik(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 dEconstrQ_num -! Calculating numerical dUconst/ddc and dUconst/ddx -! implicit real*8 (a-h,o-z) +!----------------------------------------------------------------------------- + subroutine eprot_sc_base(escbase) + use calc_data +! implicit real(kind=8) (a-h,o-z) ! include 'DIMENSIONS' -! include 'COMMON.CONTROL' +! include 'COMMON.GEO' ! include 'COMMON.VAR' -! include 'COMMON.MD' - use MD_data -!#ifndef LANG0 -! include 'COMMON.LANGEVIN' -!#else -! include 'COMMON.LANGEVIN.lang0' -!#endif +! include 'COMMON.LOCAL' ! include 'COMMON.CHAIN' ! include 'COMMON.DERIV' -! include 'COMMON.GEO' -! include 'COMMON.LOCAL' +! include 'COMMON.NAMES' ! 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 +! include 'COMMON.CALC' +! include 'COMMON.CONTROL' +! include 'COMMON.SBRIDGE' + logical :: lprn !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) + 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 ) + if (sig0ij.lt.0.2) print *,"KURWA",sig0ij,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=dsqrt(sig1**2.0d0 + sig2**2.0d0) + if (b1.eq.0.0d0) sparrow=1.0d0 + sparrow = 1.0d0 / sparrow +! write (*,*) "sparrow = ", sparrow,sig1,sig2,b1 + 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 + if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), & + "escbase:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escbase + if (energy_dec) write (iout,*) "evdwij,", evdwij, 1.0/rij, sig, sig0ij + call sc_grad_scbase + enddo 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 + 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 + if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), & + "epepbase:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,epepbase + call sc_grad_pepbase + enddo + enddo + END SUBROUTINE epep_sc_base + SUBROUTINE sc_grad_pepbase + use calc_data -! use random, only: ran_number + real (kind=8) :: dcosom1(3),dcosom2(3) + eom1 = & + eps2der * eps2rt_om1 & + - 2.0D0 * alf1 * eps3der & + + sigder * sigsq_om1 & + + dCAVdOM1 & + + dGCLdOM1 & + + dPOLdOM1 -! implicit none -! Includes + 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(kind=8) (a-h,o-z) ! include 'DIMENSIONS' -! include 'COMMON.CHAIN' +! 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' -! 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 + 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) - real(kind=8) :: d - real(kind=8) :: wi,rij,tj,pj -! return +! 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) - i=5 - j=14 + 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 - d=dsc(1) - rmin=2.0D0 - rmax=12.0D0 +! 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 ) - lmax=10000 - pmax=1 + 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 - 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 + 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 ) - do l=1,lmax + gvdwc_scpho(k,i) = gvdwc_scpho(k,i) & + - (( dFdR + gg(k) ) * ertail(k)) +!c! & - ( dFdR * ertail(k)) -!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 + gvdwc_scpho(k,j) = gvdwc_scpho(k,j) & + + (( dFdR + gg(k) ) * ertail(k))/2.0 - do p=1,pmax -!t rij=ran_number(rmin,rmax) + gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) & + + (( dFdR + gg(k) ) * ertail(k))/2.0 - c(1,j)=d*sin(pj)*cos(tj) - c(2,j)=d*sin(pj)*sin(tj) - c(3,j)=d*cos(pj) +!c! & + ( dFdR * ertail(k)) - c(3,nres+i)=-rij + 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(1,i)=d*sin(wi) - c(3,i)=-rij-d*cos(wi) +!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)) - 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 +!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 - 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 +!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) -! Input arguments - integer :: resi,resj + 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) -! Output arguments - real(kind=8) :: eij + 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 -! 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 + 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) -!-------TESTING CODE -!el logical :: checkstop,transgrad -!el common /sschecks/ checkstop,transgrad + 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)) - integer :: icheck,nicheck,jcheck,njcheck - real(kind=8),dimension(-1:1) :: echeck - real(kind=8) :: deps,ssx0,ljx0 -!-------END TESTING CODE +! 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 - eij=0.0d0 - i=resi - j=resj + 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 -!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) + gvdwc_scpho(k,i) = gvdwc_scpho(k,i) & + - dGCLdR * erhead(k) & + - dPOLdR1 * erhead_tail(k,1) +! & - dGLJdR * erhead(k) - 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) + 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 - 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) +! & + dGLJdR * erhead(k) +! if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i - 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 + 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 - sig0ij=sigma(itypi,itypj) - sig=sig0ij*dsqrt(1.0D0/sigsq) + enddo - 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) + return + end subroutine eprot_sc_phosphate + SUBROUTINE sc_grad_scpho + use calc_data - 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 + real (kind=8) :: dcosom1(3),dcosom2(3) + eom1 = & + eps2der * eps2rt_om1 & + - 2.0D0 * alf1 * eps3der & + + sigder * sigsq_om1 & + + dCAVdOM1 & + + dGCLdOM1 & + + dPOLdOM1 -!-------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 + eom2 = & + eps2der * eps2rt_om2 & + + 2.0D0 * alf2 * eps3der & + + sigder * sigsq_om2 & + + dCAVdOM2 & + + dGCLdOM2 & + + dPOLdOM2 -!-------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 + 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(kind=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!------------------------------------------------------------------- - 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 +!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)) - 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 +!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 - 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 + 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 + if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), & + "epeppho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,epeppho - d_ssxm(1)=0.5D0*akct/ssA - d_ssxm(2)=-d_ssxm(1) - d_ssxm(3)=0.0D0 + 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(kind=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,countss + 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,icont + 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 + countss=0 +! print *,"EVDW KURW",evdw,nres +! do i=iatsc_s,iatsc_e +! print *,"I am in EVDW",i + do icont=g_listscsc_start,g_listscsc_end + i=newcontlisti(icont) + j=newcontlistj(icont) - 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 + 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,countss) + 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 -!-------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 +!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 -!-------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 +!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) - endif +! 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) + Rreal(1)=xj + Rreal(2)=yj + Rreal(3)=zj + 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 - 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 + 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 + call to_box (ctail(1,1),ctail(2,1),ctail(3,1)) + call to_box (ctail(1,2),ctail(2,2),ctail(3,2)) -!-------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 +!c! tail distances will be themselves usefull elswhere +!c1 (in Gcav, for example) + Rtail_distance(1)=boxshift(ctail( 1, 2 ) - ctail( 1,1 ),boxxsize) + Rtail_distance(2)=boxshift(ctail( 2, 2 ) - ctail( 2,1 ),boxysize) + Rtail_distance(3)=boxshift(ctail( 3, 2 ) - ctail( 3,1 ),boxzsize) + 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 - 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 + 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 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 + if (energy_dec) write(iout,*) "before",chead(1,1),chead(2,1),chead(3,1) + if (energy_dec) write(iout,*) "before",chead(1,2),chead(2,2),chead(3,2) + call to_box (chead(1,1),chead(2,1),chead(3,1)) + call to_box (chead(1,2),chead(2,2),chead(3,2)) - do l=1,3 - gvdwc(l,i)=gvdwc(l,i)-gg(l) - gvdwc(l,j)=gvdwc(l,j)+gg(l) - enddo +!c! head distances will be themselves usefull elswhere +!c1 (in Gcav, for example) + if (energy_dec) write(iout,*) "after",chead(1,1),chead(2,1),chead(3,1) + if (energy_dec) write(iout,*) "after",chead(1,2),chead(2,2),chead(3,2) - 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 + Rhead_distance(1)=boxshift(chead( 1, 2 ) - chead( 1,1 ),boxxsize) + Rhead_distance(2)=boxshift(chead( 2, 2 ) - chead( 2,1 ),boxysize) + Rhead_distance(3)=boxshift(chead( 3, 2 ) - chead( 3,1 ),boxzsize) + if (energy_dec) write(iout,*) "after,rdi",(Rhead_distance(k),k=1,3) +! 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) + sss_ele_cut=sscale_ele(1.0d0/(rij)) + sss_ele_grad=sscagrad_ele(1.0d0/(rij)) +! sss_ele_cut=1.0d0 +! sss_ele_grad=0.0d0 +! print *,sss_ele_cut,sss_ele_grad,& +! 1.0d0/(rij),r_cut_ele,rlamb_ele + if (sss_ele_cut.le.0.0) cycle -!c Input arguments - integer resi,resj,resk,m,itypi,itypj,itypk +!---------------------------- + 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 -!c Output arguments - double precision eij,eij1,eij2,eij3 +! 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) -!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) - itypj=itype(j,1) - xj=c(1,nres+j) - yj=c(2,nres+j) - zj=c(3,nres+j) +! 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*sss_ele_cut +!#endif - 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) + 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*sss_ele_cut + gg(2) = fac*sss_ele_cut + gg(3) = fac*sss_ele_cut +! 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 - 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 + dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf)) + dbot = 12.0d0 * b4cav * bat * Lambf + dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow*sss_ele_cut + 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 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 + 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)& + -sss_ele_grad*Rreal(k)*rij*(Fcav+evdwij) +!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) & + +sss_ele_grad*Rreal(k)*rij*(Fcav+evdwij) +!c! & + ( dFdR * pom ) + gvdwc(k,i) = gvdwc(k,i) & + - (( dFdR + gg(k) ) * ertail(k)) & + -sss_ele_grad*Rreal(k)*rij*(Fcav+evdwij) -!----------------------------------------------------------------------------- - 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 +!c! & - ( dFdR * ertail(k)) -! Input arguments - real(kind=8) :: x + gvdwc(k,j) = gvdwc(k,j) & + + (( dFdR + gg(k) ) * ertail(k)) & + +sss_ele_grad*Rreal(k)*rij*(Fcav+evdwij) + +!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 -! Output arguments - real(kind=8) :: deriv + 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 -! Local variables - real(kind=8) :: xsq +! isel=0 +! if (isel.eq.2) isel=0 +! if (isel.eq.3) isel=0 +! if (iabs(Qj).eq.1) isel=0 +! nstate(itypi,itypj)=1 + 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 -! 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 + 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 -! Third degree polynomial. First derivative zero at extrema - h_base=x*x*(3.0d0-2.0d0*x) - deriv=6.0d0*x*(1.0d0-x) + CALL eqn(epol) + eheadtail = epol +! eheadtail = 0.0d0 -! 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 + 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 - 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 + CALL enq(epol) + eheadtail = epol +! eheadtail = 0.0d0 - 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 + 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 -!mc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + CALL eqd(ecl, elj, epol) + eheadtail = ECL + elj + epol +! eheadtail = 0.0d0 - 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 + 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 -!mc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + 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 - 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 + CALL eqq(Ecl,Egb,Epol,Fisocav,Elj) + eheadtail = ECL + Egb + Epol + Fisocav + Elj +! eheadtail = 0.0d0 -#ifdef MPI - if (nfgtasks.gt.1)then + 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 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 + 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*sss_ele_cut + eheadtail*sss_ele_cut - diff=newnss-nss + 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 -!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 + 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 - 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 + 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,sgrad +! 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) - nss=newnss - do i=1,nss - idssb(i)=newihpb(i) - jdssb(i)=newjhpb(i) - enddo +!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)) - 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 +!c!------------------------------------------------------------------- +!c! Coulomb electrostatic interaction + Ecl = (332.0d0 * Qij) / Rhead +!c! derivative of Ecl is Gcl... + dGCLdR = (-332.0d0 * Qij ) / Rhead_sq*sss_ele_cut + 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*sss_ele_cut +!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*sss_ele_cut +!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*sss_ele_cut +!c! dPOLdR1 = 0.0d0 + dPOLdR2 = dPOLdFGB2 * dFGBdR2*sss_ele_cut +!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)))*sss_ele_cut +!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 - 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 + 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 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! 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))) + sgrad=(Ecl+Egb+Epol+Fisocav+Elj)*sss_ele_grad*rreal(k)*rij + 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-sgrad -!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) + 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+sgrad + + 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)-sgrad + + 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)+sgrad -!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" + 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 = alphapolcat2(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)) - 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!------------------------------------------------------------------- +!c! Coulomb electrostatic interaction + Ecl = (332.0d0 * Qij) / Rhead +!c! derivative of Ecl is Gcl... + dGCLdR = (-332.0d0 * Qij ) / Rhead_sq*sss_ele_cut+ECL*sss_ele_grad + ECL=ECL*sss_ele_cut + 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) + if (energy_dec) write(iout,*) "egb",Qij,debkap,Fgb,a12sq,ee0 + 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*sss_ele_cut+Egb*sss_ele_grad + Egb=Egb*sss_ele_grad +!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*sss_ele_cut& + +FisoCav*sss_ele_grad + FisoCav=FisoCav*sss_ele_cut +!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!*sss_ele_cut+epol*sss_ele_grad +!c! dPOLdR1 = 0.0d0 + dPOLdR2 = dPOLdFGB2 * dFGBdR2!*sss_ele_cut+epol*sss_ele_grad +!c! dPOLdR2 = 0.0d0 + dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 +!c! dPOLdOM1 = 0.0d0 + dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 +! epol=epol*sss_ele_cut +!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)))*sss_ele_cut& + +(Elj+epol)*sss_ele_grad + Elj=Elj*sss_ele_cut + epol=epol*sss_ele_cut +!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 -!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 + 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 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! 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 -!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 + 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,sgrad + 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)*sss_ele_cut & + + (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)*sss_ele_cut & + + (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 +!c! this acts on Calpha + gvdwc(k,i)=gvdwc(k,i)-gg(k)*sss_ele_cut + gvdwc(k,j)=gvdwc(k,j)+gg(k)*sss_ele_cut + 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) +! distance 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 + call to_box (chead(1,1),chead(2,1),chead(3,1)) + call to_box (chead(1,2),chead(2,2),chead(3,2)) -!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 +!c! head distances will be themselves usefull elswhere +!c1 (in Gcav, for example) - 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 + Rhead_distance(1)=boxshift(chead( 1, 2 ) - chead( 1,1 ),boxxsize) + Rhead_distance(2)=boxshift(chead( 2, 2 ) - chead( 2,1 ),boxysize) + Rhead_distance(3)=boxshift(chead( 3, 2 ) - chead( 3,1 ),boxzsize) +! 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))) + +! 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 - 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 +!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)) - 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) + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) +!c! this acts on hydrophobic center of interaction +! sgrad=sss_ele_grad*(Ecl+Egb+FisoCav+epol+Elj)*rij*rreal(k) + 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*sss_ele_cut - 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 + 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*sss_ele_cut - 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 +!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 - Etube=0.0d0 -! print *,itube_start,itube_end,"poczatek" - do i=itube_start,itube_end - enetube(i)=0.0d0 - enetube(i+nres)=0.0d0 + 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)*sss_ele_cut + gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)*sss_ele_cut + gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)*sss_ele_cut + gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)*sss_ele_cut + DO l = 1, 4 + gheadtail(k,l,1) = 0.0d0 + gheadtail(k,l,2) = 0.0d0 + END DO + END DO + eheadtail = (-dlog(eheadtail)) / betaT + do k=1,3 + gvdwx(k,i) = gvdwx(k,i) - eheadtail*sss_ele_grad*rreal(k)*rij + gvdwx(k,j) = gvdwx(k,j) + eheadtail*sss_ele_grad*rreal(k)*rij + gvdwc(k,i) = gvdwc(k,i) - eheadtail*sss_ele_grad*rreal(k)*rij + gvdwc(k,j) = gvdwc(k,j) + eheadtail*sss_ele_grad*rreal(k)*rij 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 + 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) - xminact=dabs(vectube(1)-tubecenter(1)) - yminact=dabs(vectube(2)-tubecenter(2)) - zminact=dabs(vectube(3)-tubecenter(3)) +!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*sss_ele_cut +! epol=epol*sss_ele_cut +!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) - 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 + DO k = 1, 3 + hawk = (erhead_tail(k,1) + & + facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres))) - vectube(1)=vectube(1)-tubecenter(1) - vectube(2)=vectube(2)-tubecenter(2) - vectube(3)=vectube(3)-tubecenter(3) + gvdwx(k,i) = gvdwx(k,i) & + - dPOLdR1 * hawk-epol*sss_ele_grad*rreal(k)*rij + gvdwx(k,j) = gvdwx(k,j) & + + dPOLdR1 * (erhead_tail(k,1) & + -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))& + +epol*sss_ele_grad*rreal(k)*rij -!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 + gvdwc(k,i) = gvdwc(k,i) - dPOLdR1 * erhead_tail(k,1)& + -epol*sss_ele_grad*rreal(k)*rij + gvdwc(k,j) = gvdwc(k,j) + dPOLdR1 * erhead_tail(k,1)& + +epol*sss_ele_grad*rreal(k)*rij - 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 + 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 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! 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*sss_ele_cut +! epol=epol*sss_ele_cut +!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))) -!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 + gvdwx(k,i) = gvdwx(k,i) & + - dPOLdR2 * (erhead_tail(k,2) & + -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))& + -epol*sss_ele_grad*rreal(k)*rij + gvdwx(k,j) = gvdwx(k,j) & + + dPOLdR2 * condor+epol*sss_ele_grad*rreal(k)*rij + gvdwc(k,i) = gvdwc(k,i) & + - dPOLdR2 * erhead_tail(k,2)-epol*sss_ele_grad*rreal(k)*rij - 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 + gvdwc(k,j) = gvdwc(k,j) & + + dPOLdR2 * erhead_tail(k,2)+epol*sss_ele_grad*rreal(k)*rij -! 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 + END DO + RETURN + END SUBROUTINE enq - 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 + SUBROUTINE enq_cat(Epol) + use calc_data + use comm_momo + double precision facd3, adler,epol + alphapol2 = alphapolcat(itypi,itypj) +!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 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) +!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*sss_ele_cut+epol*sss_ele_grad + epol=epol*sss_ele_cut +!c! dPOLdR2 = 0.0d0 + dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 +!c! dPOLdOM1 = 0.0d0 + dPOLdOM2 = 0.0d0 - 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 +!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))) -!----------------------------------------------------------------------------- -#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 + 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 - 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 + gradpepcat(k,i) = gradpepcat(k,i) & + - dPOLdR2 * erhead_tail(k,2) + gradpepcat(k,j) = gradpepcat(k,j) & + + dPOLdR2 * erhead_tail(k,2) - 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 + END DO + RETURN + END SUBROUTINE enq_cat - 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=nres - elseif(nres.lt.200) then - maxconts=0.8*nres ! Max. number of contacts per residue - else - maxconts=0.6*nres ! (maxconts=maxres/4) - endif - maxcont=12*nres ! Max. number of SC contacts - maxvar=6*nres ! Max. number of variables -!el maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond - maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond -!---------------------- -! arrays in subroutine init_int_table -!el#ifdef MPI -!el allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1) -!el allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1) -!el#endif - allocate(nint_gr(nres)) - allocate(nscp_gr(nres)) - allocate(ielstart(nres)) - allocate(ielend(nres)) -!(maxres) - allocate(istart(nres,maxint_gr)) - allocate(iend(nres,maxint_gr)) -!(maxres,maxint_gr) - allocate(iscpstart(nres,maxint_gr)) - allocate(iscpend(nres,maxint_gr)) -!(maxres,maxint_gr) - allocate(ielstart_vdw(nres)) - allocate(ielend_vdw(nres)) -!(maxres) - allocate(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)) + SUBROUTINE eqd(Ecl,Elj,Epol) + use calc_data + use comm_momo + double precision facd4, federmaus,ecl,elj,epol,sgrad + 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) - 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) -! 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)) +!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)*sss_ele_cut +!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*sss_ele_cut +!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)))*sss_ele_cut + DO k = 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) + END DO - 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) + 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))) + sgrad=(epol+elj+ecl)*sss_ele_grad*rreal(k)*rij + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i) & + - dGCLdR * pom& + - dPOLdR1 * hawk & + - dGLJdR * pom & + -sgrad + + 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+sgrad -!---------------------- -! 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)) -!(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)) + gvdwc(k,i) = gvdwc(k,i) & + - dGCLdR * erhead(k) & + - dPOLdR1 * erhead_tail(k,1) & + - dGLJdR * erhead(k)-sgrad - 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) -!---------------------- + gvdwc(k,j) = gvdwc(k,j) & + + dGCLdR * erhead(k) & + + dPOLdR1 * erhead_tail(k,1) & + + dGLJdR * erhead(k)+sgrad -! 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 + END DO + RETURN + END SUBROUTINE eqd + + SUBROUTINE eqd_cat(Ecl,Elj,Epol) + use calc_data + use comm_momo + double precision facd4, federmaus,ecl,elj,epol + alphapol1 = alphapolcat(itypi,itypj) + w1 = wqdipcat(1,itypi,itypj) + w2 = wqdipcat(2,itypi,itypj) + pis = sig0headcat(itypi,itypj) + eps_head = epsheadcat(itypi,itypj) +! eps_head=0.0d0 +! w2=0.0d0 +! alphapol1=0.0d0 +!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 =sss_ele_cut*(-2.0d0 * sparrow / Rhead**3.0d0 & + + 4.0d0 * hawk / Rhead**5.0d0)+sss_ele_grad*ECL + ECL=ECL*sss_ele_cut +!c! dF/dom1 + dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) +!c! dF/dom2 + dGCLdOM2 = 0.0d0 ! + +!(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 = 0.0d0 ! as om2 is 0 +! (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) & +! * (2.0d0 - 0.5d0 * ee1) ) & +! / (2.0d0 * fgb1) + dPOLdR1 = dPOLdFGB1 * dFGBdR1*sss_ele_cut+epol*sss_ele_grad +!c! dPOLdR1 = 0.0d0 + dPOLdOM1 = 0.0d0 +! dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 + dPOLdOM2 = 0.0d0 + epol=epol*sss_ele_cut +!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*sss_ele_cut & + * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) & + + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0)))+Elj*sss_ele_grad + Elj=Elj*sss_ele_cut + DO k = 1, 3 + erhead(k) = Rhead_distance(k)/Rhead + erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1) + END DO -! 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)) + erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) ) + facd1 = d1 * vbld_inv(i+nres) -!(maxres) - dyn_ss_mask(:)=.false. -!---------------------- -! common.sccor -! Parameters of the SCCOR term -! common/sccor/ -!el in io_conf: parmread -! allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) -! allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp) -! allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp) -! allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp) -! allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp)) -! allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp) -! allocate(vlor1sccor(maxterm_sccor,20,20)) -! allocate(vlor2sccor(maxterm_sccor,20,20)) -! allocate(vlor3sccor(maxterm_sccor,20,20)) !(maxterm_sccor,20,20) -!---------------- - allocate(gloc_sc(3,0:2*nres,0:10)) -!(3,0:maxres2,10)maxres2=2*maxres - allocate(dcostau(3,3,3,2*nres)) - allocate(dsintau(3,3,3,2*nres)) - allocate(dtauangle(3,3,3,2*nres)) - allocate(dcosomicron(3,3,3,2*nres)) - allocate(domicron(3,3,3,2*nres)) -!(3,3,3,maxres2)maxres2=2*maxres -!---------------------- -! common.var -! common /restr/ - allocate(varall(maxvar)) -!(maxvar)(maxvar=6*maxres) - allocate(mask_theta(nres)) - allocate(mask_phi(nres)) - allocate(mask_side(nres)) -!(maxres) -!---------------------- -! common.vectors -! common /vectors/ - allocate(uy(3,nres)) - allocate(uz(3,nres)) -!(3,maxres) - allocate(uygrad(3,3,2,nres)) - allocate(uzgrad(3,3,2,nres)) -!(3,3,2,maxres) + DO k = 1, 3 + hawk = (erhead_tail(k,1) + & + facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+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) + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gradpepcatx(k,i) = gradpepcatx(k,i) & + - dGCLdR * pom& + - dPOLdR1 * hawk & + - dGLJdR * pom - 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 +! pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) +! gradpepcatx(k,j) = gradpepcatx(k,j) & +! + dGCLdR * pom & +! + dPOLdR1 * (erhead_tail(k,1) & +! -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) & +! + dGLJdR * pom - 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) + gradpepcat(k,i) = gradpepcat(k,i) & + - dGCLdR * erhead(k) & + - dPOLdR1 * erhead_tail(k,1) & + - dGLJdR * erhead(k) - 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 + gradpepcat(k,j) = gradpepcat(k,j) & + + dGCLdR * erhead(k) & + + dPOLdR1 * erhead_tail(k,1) & + + dGLJdR * erhead(k) -!----------------------------------------------------------------------------- - 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 + END DO + RETURN + END SUBROUTINE eqd_cat + + SUBROUTINE edq(Ecl,Elj,Epol) +! IMPLICIT NONE + use comm_momo + use calc_data + + double precision facd3, adler,ecl,elj,epol,sgrad + 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 =sss_ele_cut*(- 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*sss_ele_cut +!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)))*sss_ele_cut +!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))) + sgrad=(epol+elj+ecl)*sss_ele_grad*rreal(k)*rij + 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-sgrad + + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j) & + + dGCLdR * pom & + + dPOLdR2 * condor & + + dGLJdR * pom+sgrad - 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,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,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 - xmedi=dmod(xmedi,boxxsize) - if (xmedi.lt.0) xmedi=xmedi+boxxsize - ymedi=dmod(ymedi,boxysize) - if (ymedi.lt.0) ymedi=ymedi+boxysize - zmedi=dmod(zmedi,boxzsize) - if (zmedi.lt.0) zmedi=zmedi+boxzsize - - 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 - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - isubchap=0 - dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - isubchap=1 - endif - enddo - enddo - enddo - if (isubchap.eq.1) then -!C print *,i,j - xj=xj_temp-xmedi - yj=yj_temp-ymedi - zj=zj_temp-zmedi - else - xj=xj_safe-xmedi - yj=yj_safe-ymedi - zj=zj_safe-zmedi - endif - 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 + gvdwc(k,i) = gvdwc(k,i) & + - dGCLdR * erhead(k) & + - dPOLdR2 * erhead_tail(k,2) & + - dGLJdR * erhead(k)-sgrad + + gvdwc(k,j) = gvdwc(k,j) & + + dGCLdR * erhead(k) & + + dPOLdR2 * erhead_tail(k,2) & + + dGLJdR * erhead(k)+sgrad + + 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(itypi,itypj) + 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)) -!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)) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - do iint=1,nscp_gr_nucl(i) +!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)*sss_ele_cut+ECL*sss_ele_grad +!c! dF/dom1 + dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0) +!c! dF/dom2 + dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0) + ECL=ECL*sss_ele_cut +!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*sss_ele_cut+epol*sss_ele_grad +!c! dPOLdR2 = 0.0d0 + dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 +!c! dPOLdOM1 = 0.0d0 + dPOLdOM2 = 0.0d0 + epol=epol*sss_ele_cut +!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)))*sss_ele_cut+& + Elj*sss_ele_grad + Elj=Elj*sss_ele_cut +!c!------------------------------------------------------------------- - 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) - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif +!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))) - 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 + 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 - 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 + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j)) +! gradpepcatx(k,j) = gradpepcatx(k,j) & +! + dGCLdR * pom & +! + dPOLdR2 * condor & +! + dGLJdR * pom -!------------------------------------------------------ - 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) - xi=dmod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=dmod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=dmod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - 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) - xj=dmod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=dmod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=dmod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif + gradpepcat(k,i) = gradpepcat(k,i) & + - dGCLdR * erhead(k) & + - dPOLdR2 * erhead_tail(k,2) & + - dGLJdR * erhead(k) - 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 + gradpepcat(k,j) = gradpepcat(k,j) & + + dGCLdR * erhead(k) & + + dPOLdR2 * erhead_tail(k,2) & + + dGLJdR * erhead(k) - if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') & - 'evdw',i,j,evdwij,"tu3" + END DO + RETURN + END SUBROUTINE edq_cat + SUBROUTINE edq_cat_pep(Ecl,Elj,Epol) + use comm_momo + use calc_data -!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 + double precision facd3, adler,ecl,elj,epol + alphapol2 = alphapolcat(itypi,itypj) + 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)*sss_ele_cut+& + ECL*sss_ele_grad + ECL=ECL*sss_ele_cut +!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*sss_ele_cut+epol*sss_ele_grad + epol=epol*sss_ele_grad +!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*sss_ele_cut & + * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) & + + (( 6.0d0*pis**6.0d0) /(Rhead**7.0d0)))+Elj*sss_ele_grad + Elj=Elj*sss_ele_cut +!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 -!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 + 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)*sss_ele_cut!+ECL*sss_ele_grad +!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 - 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 + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gvdwx(k,i) = gvdwx(k,i)- dGCLdR * pom-(ecl*sss_ele_grad*Rreal(k)*rij) + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) + gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom+(ecl*sss_ele_grad*Rreal(k)*rij) -!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.maxconts) 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(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 + gvdwc(k,i) = gvdwc(k,i)- dGCLdR * erhead(k)-(ecl*sss_ele_grad*Rreal(k)*rij) + gvdwc(k,j) = gvdwc(k,j)+ dGCLdR * erhead(k)+(ecl*sss_ele_grad*Rreal(k)*rij) + END DO + RETURN + END SUBROUTINE edd + SUBROUTINE edd_cat(ECL) +! IMPLICIT NONE + use comm_momo + use calc_data - if (num_conti.gt.maxconts) then - write (iout,*) 'WARNING - max. # of contacts exceeded;',& - ' will skip next contacts for this conf.' - else - jcont_hb(num_conti,i)=j -!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 + double precision ecl +!c! csig = sigiso(itypi,itypj) + w1 = wqdipcat(1,itypi,itypj) + w2 = wqdipcat(2,itypi,itypj) +! w2=0.0d0 +!c!------------------------------------------------------------------- +!c! ECL +! print *,"om1",om1,om2,om12 + fac = - 3.0d0 * om1 !after integer and simplify + c1 = (w1 / (Rhead**3.0d0)) * fac + c2 = (w2 / Rhead ** 6.0d0) & + * (4.0d0 + 6.0d0*sqom1 ) !after integration and simplification + ECL = c1 - c2 +!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 + 6.0d0*sqom1) + dGCLdR = (c1 - c2)*sss_ele_cut+ECL*sss_ele_grad +!c! dECL/dom1 + c1 = (-3.0d0 * w1) / (Rhead**3.0d0) + c2 = (12.0d0 * w2*om1) / (Rhead**6.0d0) + dGCLdOM1 = c1 - c2 +!c! dECL/dom2 +! c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0) + c1=0.0 ! this is because om2 is 0 +! c2 = (-6.0d0 * w2) / (Rhead**6.0d0) & +! * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 ) + c2=0.0 !om is 0 + dGCLdOM2 = c1 - c2 +!c! dECL/dom12 +! c1 = w1 / (Rhead ** 3.0d0) + c1=0.0d0 ! this is because om12 is 0 +! c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 + c2=0.0d0 !om12 is 0 + 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 -!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 + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gradpepcatx(k,i) = gradpepcatx(k,i) - dGCLdR * pom +! pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) +! gradpepcatx(k,j) = gradpepcatx(k,j) + dGCLdR * pom - 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 + gradpepcat(k,i) = gradpepcat(k,i) - dGCLdR * erhead(k) + gradpepcat(k,j) = gradpepcat(k,j) + dGCLdR * erhead(k) + END DO + RETURN + END SUBROUTINE edd_cat + SUBROUTINE edd_cat_pep(ECL) +! IMPLICIT NONE + use comm_momo + use calc_data - 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 + double precision ecl +!c! csig = sigiso(itypi,itypj) + w1 = wqdipcat(1,itypi,itypj) + w2 = wqdipcat(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! 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)*sss_ele_cut+ECL*sss_ele_grad + ECL=ECL*sss_ele_cut +!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 + dGCLdOM2=0.0d0 ! this is because om2=0 +!c! dECL/dom12 + c1 = w1 / (Rhead ** 3.0d0) + c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 + dGCLdOM12 = c1 - c2 + dGCLdOM12=0.0d0 !this is because om12=0.0 +!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) ) + erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) + facd1 = d1 * vbld_inv(i) + facd2 = d2 * vbld_inv(j+nres) + DO k = 1, 3 - 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) + pom = facd1*(erhead(k)-erdxi*dC_norm(k,i)) + gradpepcat(k,i) = gradpepcat(k,i) + dGCLdR * pom + gradpepcat(k,i+1) = gradpepcat(k,i+1) - dGCLdR * pom +! pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) +! gradpepcatx(k,j) = gradpepcatx(k,j) + dGCLdR * pom + + gradpepcat(k,i) = gradpepcat(k,i) - dGCLdR * erhead(k)*0.5d0 + gradpepcat(k,i+1) = gradpepcat(k,i+1)- dGCLdR * erhead(k)*0.5d0 + gradpepcat(k,j) = gradpepcat(k,j) + dGCLdR * erhead(k) + END DO + RETURN + END SUBROUTINE edd_cat_pep + + 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) -!C to check gradient call subroutine check_grad + 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 - 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 + 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 = 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 = 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) - 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 -!------------------------------------------------------------------------- + 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 - 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 + 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) - 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 - real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,& - r7,r4,ecationcation,k0,rcal - 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) - - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - - do j=i+1,itmp+nres_molec(5) -! print *,i,j,'catcat' - xj=c(1,j) - yj=c(2,j) - zj=c(3,j) - xj=dmod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=dmod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=dmod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize -! write(iout,*) c(1,i),xi,xj,"xy",boxxsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif - 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 + 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 -! write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj - ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat - enddo - enddo - return - end subroutine ecatcat -!--------------------------------------------------------------------------- - subroutine ecat_prot(ecation_prot) - 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 - 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 - wconst=78 - 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 - 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)) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - - do j=itmp+1,itmp+nres_molec(5) - xj=c(1,j) - yj=c(2,j) - zj=c(3,j) - xj=dmod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=dmod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=dmod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi + 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 lipid_bond(elipbond) + real(kind=8) :: elipbond,fac,dist_sub,sumdist + real(kind=8), dimension(3):: dist + integer(kind=8) :: i,j,k,ibra,ityp,jtyp,ityp1 + elipbond=0.0d0 +! print *,"before",ilipbond_start,ilipbond_end + do i=ilipbond_start,ilipbond_end +! print *,i,i+1,"i,i+1" + ityp=itype(i,4) + ityp1=itype(i+1,4) +! print *,ityp,ityp1,"itype" + j=i+1 + if (ityp.eq.12) ibra=i + if ((ityp.eq.ntyp1_molec(4)).or.(ityp1.ge.ntyp1_molec(4)-1)) cycle + if (ityp.eq.(ntyp1_molec(4)-1)) then + !cofniecie do ostatnie GL1 +! i=ibra + j=ibra else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif -! 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 + j=i + endif + jtyp=itype(j,4) do k=1,3 - dcmag=dcmag+dc(k,i)**2 + dist(k)=c(k,j)-c(k,i+1) enddo - dcmag=dsqrt(dcmag) + sumdist=0.0d0 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 - 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)) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - 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) - xj=c(1,j) - yj=c(2,j) - zj=c(3,j) - xj=dmod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=dmod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=dmod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo + sumdist=sumdist+dist(k)**2 enddo + dist_sub=sqrt(sumdist) +! print *,"before",i,j,ityp1,ityp,jtyp + elipbond=elipbond+kbondlip*((dist_sub-lip_bond(jtyp,ityp1))**2) + fac=kbondlip*(dist_sub-lip_bond(jtyp,ityp1)) + do k=1,3 + gradlipbond(k,i+1)= gradlipbond(k,i+1)-fac*dist(k)/dist_sub + gradlipbond(k,j)=gradlipbond(k,j)+fac*dist(k)/dist_sub enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif -! enddo -! enddo - if(itype(i,1).eq.15.or.itype(i,1).eq.16) 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 + if (energy_dec) write(iout,*) "lipbond",j,i+1,dist_sub,lip_bond(jtyp,ityp1),kbondlip,fac + enddo + elipbond=elipbond*0.5d0 + return + end subroutine lipid_bond +!--------------------------------------------------------------------------------------- + subroutine lipid_angle(elipang) + real(kind=8) :: elipang,alfa,xa(3),xb(3),alfaact,alfa0,force,fac,& + scalara,vnorm,wnorm,sss,sss_grad,eangle + integer :: i,j,k,l,m,ibra,ityp1,itypm1,itypp1 + elipang=0.0d0 +! print *,"ilipang_start,ilipang_end",ilipang_start,ilipang_end + do i=ilipang_start,ilipang_end +! do i=4,4 + +! the loop is centered on the central residue + itypm1=itype(i-1,4) + ityp1=itype(i,4) + itypp1=itype(i+1,4) +! print *,i,i,j,"processor",fg_rank + j=i-1 + k=i + l=i+1 + if (ityp1.eq.12) ibra=i + if ((itypm1.eq.ntyp1_molec(4)).or.(ityp1.eq.ntyp1_molec(4))& + .or.(itypp1.eq.ntyp1_molec(4))) cycle !cycle if any of the angles is dummy + if ((itypm1.eq.ntyp1_molec(4)-1).or.(itypp1.eq.ntyp1_molec(4)-1)) cycle + ! branching is only to one angle + if (ityp1.eq.ntyp1_molec(4)-1) then + k=ibra + j=ibra-1 + endif + itypm1=itype(j,4) + ityp1=itype(k,4) + do m=1,3 + xa(m)=c(m,j)-c(m,k) + xb(m)=c(m,l)-c(m,k) +! xb(m)=1.0d0 + enddo + vnorm=dsqrt(xa(1)*xa(1)+xa(2)*xa(2)+xa(3)*xa(3)) + wnorm=dsqrt(xb(1)*xb(1)+xb(2)*xb(2)+xb(3)*xb(3)) + scalara=(xa(1)*xb(1)+xa(2)*xb(2)+xa(3)*xb(3))/(vnorm*wnorm) +! if (((scalar*scalar).gt.0.99999999d0).and.(alfa0.eq.180.0d0)) cycle + + alfaact=scalara +! sss=sscale_martini_angle(alfaact) +! sss_grad=sscale_grad_martini_angle(alfaact) +! print *,sss_grad,"sss_grad",sss +! if (sss.le.0.0) cycle +! if (sss_grad.ne.0.0) print *,sss_grad,"sss_grad" + force=lip_angle_force(itypm1,ityp1,itypp1) + alfa0=lip_angle_angle(itypm1,ityp1,itypp1) + eangle=force*(alfaact-dcos(alfa0))*(alfaact-dcos(alfa0))*0.5d0 + elipang=elipang+eangle!*(1001.0d0-1000.0d0*sss) + fac=force*(alfaact-dcos(alfa0))!*(1001.0d0-1000.0d0*sss)-sss_grad*eangle*1000.0d0 + do m=1,3 + gradlipang(m,j)=gradlipang(m,j)+(fac &!/dsqrt(1.0d0-scalar*scalar)& + *(xb(m)-scalara*wnorm*xa(m)/vnorm)& + /(vnorm*wnorm))!-sss_grad*eangle*xa(m)/vnorm -! 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) + gradlipang(m,l)=gradlipang(m,l)+(fac & !/dsqrt(1.0d0-scalar*scalar)& + *(xa(m)-scalara*vnorm*xb(m)/wnorm)& + /(vnorm*wnorm))!+sss_grad*eangle*xb(m)/wnorm -! 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) + gradlipang(m,k)=gradlipang(m,k)-(fac)& !/dsqrt(1.0d0-scalar*scalar)& + *(xb(m)-scalara*wnorm*xa(m)/vnorm)& + /((vnorm*wnorm))-(fac & !/dsqrt(1.0d0-scalar*scalar)& + *(xa(m)-scalara*vnorm*xb(m)/wnorm)& + /(vnorm*wnorm))!-sss_grad*eangle*xa(m)/vnorm& + !-sss_grad*eangle*xb(m)/wnorm -! The weights of the energy function calculated from -!The quantum mechanical GAMESS simulations of calcium with ASP/GLU - wh2o=78 - 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 + +! *(xb(m)*vnorm*wnorm)& + +!-xa(m)*xa(m)*xb(m)*wnorm/vnorm)& + enddo + if (energy_dec) write(iout,*) "elipang",j,k,l,force,alfa0,alfaact,elipang + enddo + return + end subroutine lipid_angle +!-------------------------------------------------------------------- + subroutine lipid_lj(eliplj) + real(kind=8) :: eliplj,fac,sumdist,dist_sub,LJ1,LJ2,LJ,& + xj,yj,zj,xi,yi,zi,sss,sss_grad + real(kind=8), dimension(3):: dist + integer :: i,j,k,inum,ityp,jtyp + eliplj=0.0d0 + do inum=iliplj_start,iliplj_end + i=mlipljlisti(inum) + j=mlipljlistj(inum) +! print *,inum,i,j,"processor",fg_rank + ityp=itype(i,4) + jtyp=itype(j,4) + xi=c(1,i) + yi=c(2,i) + zi=c(3,i) + call to_box(xi,yi,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(1)=xj + dist(2)=yj + dist(3)=zj + ! do k=1,3 + ! dist(k)=c(k,j)-c(k,i) + ! enddo + sumdist=0.0d0 + do k=1,3 + sumdist=sumdist+dist(k)**2 + enddo + + dist_sub=sqrt(sumdist) + sss=sscale_martini(dist_sub) + if (energy_dec) write(iout,*) "LJ LIP bef",i,j,ityp,jtyp,dist_sub + if (sss.le.0.0) cycle + sss_grad=sscale_grad_martini(dist_sub) + LJ1 = (lip_sig(ityp,jtyp)/dist_sub)**6 + LJ2 = LJ1**2 + LJ = LJ2 - LJ1 + LJ = 4.0d0*lip_eps(ityp,jtyp)*LJ + eliplj = eliplj + LJ*sss + fac=4.0d0*lip_eps(ityp,jtyp)*(-6.0d0*LJ1/dist_sub+12.0d0*LJ2/dist_sub) + do k=1,3 + gradliplj(k,i)=gradliplj(k,i)+fac*dist(k)/dist_sub*sss-sss_grad*LJ*dist(k)/dist_sub + gradliplj(k,j)=gradliplj(k,j)-fac*dist(k)/dist_sub*sss+sss_grad*LJ*dist(k)/dist_sub + enddo + if (energy_dec) write(iout,'(a7,4i5,2f8.3)') "LJ LIP",i,j,ityp,jtyp,LJ,dist_sub 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) + return + end subroutine lipid_lj +!-------------------------------------------------------------------------------------- + subroutine lipid_elec(elipelec) + real(kind=8) :: elipelec,fac,sumdist,dist_sub,xj,yj,zj,xi,yi,zi,EQ,& + sss,sss_grad + real(kind=8), dimension(3):: dist + integer :: i,j,k,inum,ityp,jtyp + elipelec=0.0d0 +! print *,"processor",fg_rank,ilip_elec_start,ilipelec_end + do inum=ilip_elec_start,ilipelec_end + i=mlipeleclisti(inum) + j=mlipeleclistj(inum) +! print *,inum,i,j,"processor",fg_rank + ityp=itype(i,4) + jtyp=itype(j,4) + xi=c(1,i) + yi=c(2,i) + zi=c(3,i) + call to_box(xi,yi,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(1)=xj + dist(2)=yj + dist(3)=zj +! do k=1,3 +! dist(k)=c(k,j)-c(k,i) +! enddo + sumdist=0.0d0 + do k=1,3 + sumdist=sumdist+dist(k)**2 + enddo + dist_sub=sqrt(sumdist) + sss=sscale_martini(dist_sub) +! print *,sss,dist_sub + if (energy_dec) write(iout,*) "EQ LIP",sss,dist_sub,i,j + if (sss.le.0.0) cycle + sss_grad=sscale_grad_martini(dist_sub) +! print *,"sss",sss,sss_grad + EQ=k_coulomb_lip*(ichargelipid(ityp)*ichargelipid(jtyp)/dist_sub) + elipelec=elipelec+EQ*sss + fac=k_coulomb_lip*(ichargelipid(ityp)*ichargelipid(jtyp)/sumdist)*sss + do k=1,3 + gradlipelec(k,i)=gradlipelec(k,i)+fac*dist(k)/dist_sub& + -sss_grad*EQ*dist(k)/dist_sub + gradlipelec(k,j)=gradlipelec(k,j)-fac*dist(k)/dist_sub& + +sss_grad*EQ*dist(k)/dist_sub + enddo + if (energy_dec) write(iout,*) "EQ LIP",i,j,ityp,jtyp,EQ,dist_sub,elipelec 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 + return + end subroutine lipid_elec +!------------------------------------------------------------------------- + subroutine make_SCSC_inter_list + include 'mpif.h' + real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp + real(kind=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) +! print *,"is it wrong", iint,i + do j=istart(i,iint),iend(i,iint) + itypj=iabs(itype(j,1)) + if (energy_dec) write(iout,*) "LISTA ZAKRES",istart(i,iint),iend(i,iint),iatsc_s,iatsc_e + 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(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp + real(kind=8) :: dist_init, dist_temp,r_buff_list + integer:: contlistscpi(350*nres),contlistscpj(350*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 - 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) +#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) - 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 - wh2o=78 - 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 + else + g_ilist_scp=ilist_scp - 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) + 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(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp + real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj + real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi + real(kind=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 - endif ! 13-16 residues - enddo !j - enddo !i - return - end subroutine ecat_prot + 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 -!---------------------------------------------------------------------------- -!----------------------------------------------------------------------------- -!----------------------------------------------------------------------------- - 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) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - 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) - xj=dmod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=dmod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=dmod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif - 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 + 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) -! 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 ) + else + g_ilist_pp=ilist_pp - gvdwc_scbase(k,i) = gvdwc_scbase(k,i) & - - (( dFdR + gg(k) ) * ertail(k)) -!c! & - ( dFdR * ertail(k)) + 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 +!--------------------------------------------------------------------------- + subroutine make_cat_pep_list + include 'mpif.h' + real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp + real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj + real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi + real(kind=8) :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj + real(kind=8) :: xja,yja,zja + integer:: contlistcatpnormi(300*nres),contlistcatpnormj(300*nres) + integer:: contlistcatscnormi(250*nres),contlistcatscnormj(250*nres) + integer:: contlistcatptrani(250*nres),contlistcatptranj(250*nres) + integer:: contlistcatsctrani(250*nres),contlistcatsctranj(250*nres) + integer:: contlistcatscangi(250*nres),contlistcatscangj(250*nres) + integer:: contlistcatscangfi(250*nres),contlistcatscangfj(250*nres),& + contlistcatscangfk(250*nres) + integer:: contlistcatscangti(250*nres),contlistcatscangtj(250*nres) + integer:: contlistcatscangtk(250*nres),contlistcatscangtl(250*nres) + + +! integer :: newcontlistppi(200*nres),newcontlistppj(200*nres) + integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_catscnorm,& + ilist_catsctran,ilist_catpnorm,ilist_catptran,itmp,ilist_catscang,& + ilist_catscangf,ilist_catscangt,k + integer displ(0:nprocs),i_ilist_catscnorm(0:nprocs),ierr,& + i_ilist_catpnorm(0:nprocs),i_ilist_catsctran(0:nprocs),& + i_ilist_catptran(0:nprocs),i_ilist_catscang(0:nprocs),& + i_ilist_catscangf(0:nprocs),i_ilist_catscangt(0:nprocs) +! write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list + ilist_catpnorm=0 + ilist_catscnorm=0 + ilist_catptran=0 + ilist_catsctran=0 + ilist_catscang=0 + + + r_buff_list=6.0 + 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 - gvdwc_scbase(k,j) = gvdwc_scbase(k,j) & - + (( dFdR + gg(k) ) * ertail(k)) -!c! & + ( dFdR * ertail(k)) +! print *,"I am in EVDW",i + itypi=iabs(itype(i,1)) - gg(k) = 0.0d0 -!c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) -!c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) - END DO +! 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) + dxi=dc_norm(1,i) + dyi=dc_norm(2,i) + dzi=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) -! else +! dsci_inv=vbld_inv(i+nres) + do j=itmp+1,itmp+nres_molec(5) + 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) + yj=c(2,j) + zj=c(3,j) + call to_box(xj,yj,zj) +! call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) +! faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0 + xja=boxshift(xj-xmedi,boxxsize) + yja=boxshift(yj-ymedi,boxysize) + zja=boxshift(zj-zmedi,boxzsize) + dist_init=xja**2+yja**2+zja**2 + if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then +! Here the list is created + if (itype(j,5).le.5) then + ilist_catpnorm=ilist_catpnorm+1 +! this can be substituted by cantor and anti-cantor + contlistcatpnormi(ilist_catpnorm)=i + contlistcatpnormj(ilist_catpnorm)=j + else + ilist_catptran=ilist_catptran+1 +! this can be substituted by cantor and anti-cantor + contlistcatptrani(ilist_catptran)=i + contlistcatptranj(ilist_catptran)=j + endif + endif + xja=boxshift(xj-xi,boxxsize) + yja=boxshift(yj-yi,boxysize) + zja=boxshift(zj-zi,boxzsize) + dist_init=xja**2+yja**2+zja**2 + if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then +! Here the list is created + if (itype(j,5).le.5) then + ilist_catscnorm=ilist_catscnorm+1 +! this can be substituted by cantor and anti-cantor +! write(iout,*) "have contact",i,j,ilist_catscnorm + contlistcatscnormi(ilist_catscnorm)=i + contlistcatscnormj(ilist_catscnorm)=j +! write(iout,*) "have contact2",i,j,ilist_catscnorm,& +! contlistcatscnormi(ilist_catscnorm),contlistcatscnormj(ilist_catscnorm) -! 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 + else + ilist_catsctran=ilist_catsctran+1 +! this can be substituted by cantor and anti-cantor + contlistcatsctrani(ilist_catsctran)=i + contlistcatsctranj(ilist_catsctran)=j +! print *,"KUR**",i,j,itype(i,1) + if (((itype(i,1).eq.1).or.(itype(i,1).eq.15).or.& + (itype(i,1).eq.16).or.(itype(i,1).eq.17)).and.& + ((sqrt(dist_init).le.(r_cut_ang+r_buff_list)))) then +! print *,"KUR**2",i,j,itype(i,1),ilist_catscang+1 + + ilist_catscang=ilist_catscang+1 + contlistcatscangi(ilist_catscang)=i + contlistcatscangj(ilist_catscang)=j + endif + + endif + endif +! enddo + enddo + enddo +#ifdef DEBUG + write (iout,*) "before MPIREDUCE",ilist_catsctran,ilist_catptran,& + ilist_catscnorm,ilist_catpnorm,ilist_catscang - 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) + do i=1,ilist_catsctran + write (iout,*) i,contlistcatsctrani(i),contlistcatsctranj(i),& + itype(j,contlistcatsctranj(i)) + enddo + do i=1,ilist_catptran + write (iout,*) i,contlistcatptrani(i),contlistcatsctranj(i) + enddo + do i=1,ilist_catscnorm + write (iout,*) i,contlistcatscnormi(i),contlistcatscnormj(i) + enddo + do i=1,ilist_catpnorm + write (iout,*) i,contlistcatpnormi(i),contlistcatscnormj(i) + enddo + do i=1,ilist_catscang + write (iout,*) i,contlistcatscangi(i),contlistcatscangi(i) + enddo -!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 +#endif + if (nfgtasks.gt.1)then - 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) + call MPI_Reduce(ilist_catsctran,g_ilist_catsctran,1,& + MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) +! write(iout,*) "before bcast",g_ilist_sc + call MPI_Gather(ilist_catsctran,1,MPI_INTEGER,& + i_ilist_catsctran,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_ilist_catsctran(i-1)+displ(i-1) + enddo +! write(iout,*) "before gather",displ(0),displ(1) + call MPI_Gatherv(contlistcatsctrani,ilist_catsctran,MPI_INTEGER,& + newcontlistcatsctrani,i_ilist_catsctran,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistcatsctranj,ilist_catsctran,MPI_INTEGER,& + newcontlistcatsctranj,i_ilist_catsctran,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Bcast(g_ilist_catsctran,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(newcontlistcatsctrani,g_ilist_catsctran,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistcatsctranj,g_ilist_catsctran,MPI_INT,king,FG_COMM,IERR) + + + call MPI_Reduce(ilist_catptran,g_ilist_catptran,1,& + MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) +! write(iout,*) "before bcast",g_ilist_sc + call MPI_Gather(ilist_catptran,1,MPI_INTEGER,& + i_ilist_catptran,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_ilist_catptran(i-1)+displ(i-1) + enddo +! write(iout,*) "before gather",displ(0),displ(1) + call MPI_Gatherv(contlistcatptrani,ilist_catptran,MPI_INTEGER,& + newcontlistcatptrani,i_ilist_catptran,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistcatptranj,ilist_catptran,MPI_INTEGER,& + newcontlistcatptranj,i_ilist_catptran,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Bcast(g_ilist_catptran,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(newcontlistcatptrani,g_ilist_catptran,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistcatptranj,g_ilist_catptran,MPI_INT,king,FG_COMM,IERR) + +! call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM) + + call MPI_Reduce(ilist_catscnorm,g_ilist_catscnorm,1,& + MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) +! write(iout,*) "before bcast",g_ilist_sc + call MPI_Gather(ilist_catscnorm,1,MPI_INTEGER,& + i_ilist_catscnorm,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_ilist_catscnorm(i-1)+displ(i-1) + enddo +! write(iout,*) "before gather",displ(0),displ(1) + call MPI_Gatherv(contlistcatscnormi,ilist_catscnorm,MPI_INTEGER,& + newcontlistcatscnormi,i_ilist_catscnorm,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistcatscnormj,ilist_catscnorm,MPI_INTEGER,& + newcontlistcatscnormj,i_ilist_catscnorm,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Bcast(g_ilist_catscnorm,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(newcontlistcatscnormi,g_ilist_catscnorm,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistcatscnormj,g_ilist_catscnorm,MPI_INT,king,FG_COMM,IERR) - 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 + call MPI_Reduce(ilist_catpnorm,g_ilist_catpnorm,1,& + MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) +! write(iout,*) "before bcast",g_ilist_sc + call MPI_Gather(ilist_catpnorm,1,MPI_INTEGER,& + i_ilist_catpnorm,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_ilist_catpnorm(i-1)+displ(i-1) + enddo +! write(iout,*) "before gather",displ(0),displ(1) + call MPI_Gatherv(contlistcatpnormi,ilist_catpnorm,MPI_INTEGER,& + newcontlistcatpnormi,i_ilist_catpnorm,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistcatpnormj,ilist_catpnorm,MPI_INTEGER,& + newcontlistcatpnormj,i_ilist_catpnorm,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Bcast(g_ilist_catpnorm,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(newcontlistcatpnormi,g_ilist_catpnorm,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistcatpnormj,g_ilist_catpnorm,MPI_INT,king,FG_COMM,IERR) - 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 + call MPI_Reduce(ilist_catscang,g_ilist_catscang,1,& + MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) +! write(iout,*) "before bcast",g_ilist_sc + call MPI_Gather(ilist_catscang,1,MPI_INTEGER,& + i_ilist_catscang,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_ilist_catscang(i-1)+displ(i-1) + enddo +! write(iout,*) "before gather",displ(0),displ(1) + call MPI_Gatherv(contlistcatscangi,ilist_catscang,MPI_INTEGER,& + newcontlistcatscangi,i_ilist_catscang,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistcatscangj,ilist_catscang,MPI_INTEGER,& + newcontlistcatscangj,i_ilist_catscang,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Bcast(g_ilist_catscang,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(newcontlistcatscangi,g_ilist_catscang,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistcatscangj,g_ilist_catscang,MPI_INT,king,FG_COMM,IERR) + + + else + g_ilist_catscnorm=ilist_catscnorm + g_ilist_catsctran=ilist_catsctran + g_ilist_catpnorm=ilist_catpnorm + g_ilist_catptran=ilist_catptran + g_ilist_catscang=ilist_catscang + + + do i=1,ilist_catscnorm + newcontlistcatscnormi(i)=contlistcatscnormi(i) + newcontlistcatscnormj(i)=contlistcatscnormj(i) + enddo + do i=1,ilist_catpnorm + newcontlistcatpnormi(i)=contlistcatpnormi(i) + newcontlistcatpnormj(i)=contlistcatpnormj(i) + enddo + do i=1,ilist_catsctran + newcontlistcatsctrani(i)=contlistcatsctrani(i) + newcontlistcatsctranj(i)=contlistcatsctranj(i) + enddo + do i=1,ilist_catptran + newcontlistcatptrani(i)=contlistcatptrani(i) + newcontlistcatptranj(i)=contlistcatptranj(i) + enddo + + do i=1,ilist_catscang + newcontlistcatscangi(i)=contlistcatscangi(i) + newcontlistcatscangj(i)=contlistcatscangj(i) + enddo + + + endif + call int_bounds(g_ilist_catsctran,g_listcatsctran_start,g_listcatsctran_end) + call int_bounds(g_ilist_catptran,g_listcatptran_start,g_listcatptran_end) + call int_bounds(g_ilist_catscnorm,g_listcatscnorm_start,g_listcatscnorm_end) + call int_bounds(g_ilist_catpnorm,g_listcatpnorm_start,g_listcatpnorm_end) + call int_bounds(g_ilist_catscang,g_listcatscang_start,g_listcatscang_end) +! make new ang list + ilist_catscangf=0 + do i=g_listcatscang_start,g_listcatscang_end + do j=2,g_ilist_catscang +! print *,"RWA",i,j,contlistcatscangj(i),contlistcatscangj(j) + if (j.le.i) cycle + if (newcontlistcatscangj(i).ne.newcontlistcatscangj(j)) cycle + ilist_catscangf=ilist_catscangf+1 + contlistcatscangfi(ilist_catscangf)=newcontlistcatscangi(i) + contlistcatscangfj(ilist_catscangf)=newcontlistcatscangj(i) + contlistcatscangfk(ilist_catscangf)=newcontlistcatscangi(j) +! print *,"TUTU",g_listcatscang_start,g_listcatscang_end,i,j,g_ilist_catscangf,myrank enddo - enddo + enddo + if (nfgtasks.gt.1)then - return - end subroutine eprot_sc_base - SUBROUTINE sc_grad_scbase - use calc_data + call MPI_Reduce(ilist_catscangf,g_ilist_catscangf,1,& + MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) +! write(iout,*) "before bcast",g_ilist_sc + call MPI_Gather(ilist_catscangf,1,MPI_INTEGER,& + i_ilist_catscangf,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_ilist_catscangf(i-1)+displ(i-1) + enddo +! write(iout,*) "before gather",displ(0),displ(1) + call MPI_Gatherv(contlistcatscangfi,ilist_catscangf,MPI_INTEGER,& + newcontlistcatscangfi,i_ilist_catscangf,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistcatscangfj,ilist_catscangf,MPI_INTEGER,& + newcontlistcatscangfj,i_ilist_catscangf,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistcatscangfk,ilist_catscangf,MPI_INTEGER,& + newcontlistcatscangfk,i_ilist_catscangf,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + + call MPI_Bcast(g_ilist_catscangf,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(newcontlistcatscangfi,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistcatscangfj,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistcatscangfk,g_ilist_catscangf,MPI_INT,king,FG_COMM,IERR) + else + g_ilist_catscangf=ilist_catscangf + do i=1,ilist_catscangf + newcontlistcatscangfi(i)=contlistcatscangfi(i) + newcontlistcatscangfj(i)=contlistcatscangfj(i) + newcontlistcatscangfk(i)=contlistcatscangfk(i) + enddo + endif + call int_bounds(g_ilist_catscangf,g_listcatscangf_start,g_listcatscangf_end) - 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 + ilist_catscangt=0 + do i=g_listcatscang_start,g_listcatscang_end + do j=1,g_ilist_catscang + do k=1,g_ilist_catscang +! print *,"TUTU1",g_listcatscang_start,g_listcatscang_end,i,j - eom12 = & - evdwij * eps1_om12 & - + eps2der * eps2rt_om12 & - - 2.0D0 * alf12 * eps3der & - + sigder *sigsq_om12 & - + dCAVdOM12 & - + dGCLdOM12 + if (newcontlistcatscangj(i).ne.newcontlistcatscangj(j)) cycle + if (newcontlistcatscangj(i).ne.newcontlistcatscangj(k)) cycle + if (newcontlistcatscangj(k).ne.newcontlistcatscangj(j)) cycle + if (newcontlistcatscangi(i).eq.newcontlistcatscangi(j)) cycle + if (newcontlistcatscangi(i).eq.newcontlistcatscangi(k)) cycle + if (newcontlistcatscangi(k).eq.newcontlistcatscangi(j)) cycle +! print *,"TUTU2",g_listcatscang_start,g_listcatscang_end,i,j -! 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 + ilist_catscangt=ilist_catscangt+1 + contlistcatscangti(ilist_catscangt)=newcontlistcatscangi(i) + contlistcatscangtj(ilist_catscangt)=newcontlistcatscangj(i) + contlistcatscangtk(ilist_catscangt)=newcontlistcatscangi(j) + contlistcatscangtl(ilist_catscangt)=newcontlistcatscangi(k) + enddo + enddo + enddo + if (nfgtasks.gt.1)then - 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 - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - 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) - xj=dmod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=dmod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=dmod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif - 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 + call MPI_Reduce(ilist_catscangt,g_ilist_catscangt,1,& + MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) +! write(iout,*) "before bcast",g_ilist_sc + call MPI_Gather(ilist_catscangt,1,MPI_INTEGER,& + i_ilist_catscangt,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_ilist_catscangt(i-1)+displ(i-1) + enddo +! write(iout,*) "before gather",displ(0),displ(1) + call MPI_Gatherv(contlistcatscangti,ilist_catscangt,MPI_INTEGER,& + newcontlistcatscangti,i_ilist_catscangt,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistcatscangtj,ilist_catscangt,MPI_INTEGER,& + newcontlistcatscangtj,i_ilist_catscangt,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistcatscangtk,ilist_catscangt,MPI_INTEGER,& + newcontlistcatscangtk,i_ilist_catscangt,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistcatscangtl,ilist_catscangt,MPI_INTEGER,& + newcontlistcatscangtl,i_ilist_catscangt,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + + call MPI_Bcast(g_ilist_catscangt,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(newcontlistcatscangti,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistcatscangtj,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistcatscangtk,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistcatscangtl,g_ilist_catscangt,MPI_INT,king,FG_COMM,IERR) -! 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) + else + g_ilist_catscangt=ilist_catscangt + do i=1,ilist_catscangt + newcontlistcatscangti(i)=contlistcatscangti(i) + newcontlistcatscangtj(i)=contlistcatscangtj(i) + newcontlistcatscangtk(i)=contlistcatscangtk(i) + newcontlistcatscangtl(i)=contlistcatscangtl(i) + enddo + endif + call int_bounds(g_ilist_catscangt,g_listcatscangt_start,g_listcatscangt_end) - 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 +#ifdef DEBUG + write (iout,*) "after MPIREDUCE",ilist_catsctran,ilist_catptran, & + ilist_catscnorm,ilist_catpnorm + + do i=1,g_ilist_catsctran + write (iout,*) i,newcontlistcatsctrani(i),newcontlistcatsctranj(i) + enddo + do i=1,g_ilist_catptran + write (iout,*) i,newcontlistcatptrani(i),newcontlistcatsctranj(i) + enddo + do i=1,g_ilist_catscnorm + write (iout,*) i,newcontlistcatscnormi(i),newcontlistcatscnormj(i) + enddo + do i=1,g_ilist_catpnorm + write (iout,*) i,newcontlistcatpnormi(i),newcontlistcatscnormj(i) + enddo + do i=1,g_ilist_catscang + write (iout,*) i,newcontlistcatscangi(i),newcontlistcatscangj(i) + enddo +#endif + return + end subroutine make_cat_pep_list + + subroutine make_lip_pep_list + include 'mpif.h' + real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp + real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj + real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi + real(kind=8) :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj + real(kind=8) :: xja,yja,zja + integer:: contlistmartpi(300*nres),contlistmartpj(300*nres) + integer:: contlistmartsci(250*nres),contlistmartscj(250*nres) + + +! integer :: newcontlistppi(200*nres),newcontlistppj(200*nres) + integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_martsc,& + ilist_martp,k,itmp + integer displ(0:nprocs),i_ilist_martsc(0:nprocs),ierr,& + i_ilist_martp(0:nprocs) +! write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list + ilist_martp=0 + ilist_martsc=0 + + + r_buff_list=6.0 + itmp=0 + do i=1,3 + 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) + dxi=dc_norm(1,i) + dyi=dc_norm(2,i) + dzi=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) + +! dsci_inv=vbld_inv(i+nres) + do j=itmp+1,itmp+nres_molec(4) + 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) + yj=c(2,j) + zj=c(3,j) + call to_box(xj,yj,zj) +! call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) +! faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0 + xja=boxshift(xj-xmedi,boxxsize) + yja=boxshift(yj-ymedi,boxysize) + zja=boxshift(zj-zmedi,boxzsize) + dist_init=xja**2+yja**2+zja**2 + if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then +! Here the list is created + ilist_martp=ilist_martp+1 +! this can be substituted by cantor and anti-cantor + contlistmartpi(ilist_martp)=i + contlistmartpj(ilist_martp)=j + endif + xja=boxshift(xj-xi,boxxsize) + yja=boxshift(yj-yi,boxysize) + zja=boxshift(zj-zi,boxzsize) + dist_init=xja**2+yja**2+zja**2 + if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then +! Here the list is created + ilist_martsc=ilist_martsc+1 +! this can be substituted by cantor and anti-cantor +! write(iout,*) "have contact",i,j,ilist_martsc + contlistmartsci(ilist_martsc)=i + contlistmartscj(ilist_martsc)=j +! write(iout,*) "have contact2",i,j,ilist_martsc,& +! contlistmartsci(ilist_martsc),contlistmartscj(ilist_martsc) + endif +! enddo + enddo + enddo +#ifdef DEBUG + write (iout,*) "before MPIREDUCE",ilist_catsctran,ilist_catptran,& + ilist_catscnorm,ilist_catpnorm,ilist_catscang + + do i=1,ilist_catsctran + write (iout,*) i,contlistcatsctrani(i),contlistcatsctranj(i),& + itype(j,contlistcatsctranj(i)) + enddo + do i=1,ilist_catptran + write (iout,*) i,contlistcatptrani(i),contlistcatsctranj(i) + enddo + do i=1,ilist_catscnorm + write (iout,*) i,contlistcatscnormi(i),contlistcatscnormj(i) + enddo + do i=1,ilist_catpnorm + write (iout,*) i,contlistcatpnormi(i),contlistcatscnormj(i) + enddo + do i=1,ilist_catscang + write (iout,*) i,contlistcatscangi(i),contlistcatscangi(i) + enddo -!c! & - ( dFdR * ertail(k)) - gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) & - + (( dFdR + gg(k) ) * ertail(k)) -!c! & + ( dFdR * ertail(k)) +#endif + if (nfgtasks.gt.1)then - gg(k) = 0.0d0 -!c! write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i) -!c! write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j) - END DO +! write(iout,*) "before bcast",g_ilist_sc +! call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM) + call MPI_Reduce(ilist_martsc,g_ilist_martsc,1,& + MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) +! write(iout,*) "before bcast",g_ilist_sc + call MPI_Gather(ilist_martsc,1,MPI_INTEGER,& + i_ilist_martsc,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_ilist_martsc(i-1)+displ(i-1) + enddo +! write(iout,*) "before gather",displ(0),displ(1) + call MPI_Gatherv(contlistmartsci,ilist_martsc,MPI_INTEGER,& + newcontlistmartsci,i_ilist_martsc,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistmartscj,ilist_martsc,MPI_INTEGER,& + newcontlistmartscj,i_ilist_martsc,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Bcast(g_ilist_martsc,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(newcontlistmartsci,g_ilist_martsc,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistmartscj,g_ilist_martsc,MPI_INT,king,FG_COMM,IERR) - 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)) + call MPI_Reduce(ilist_martp,g_ilist_martp,1,& + MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) +! write(iout,*) "before bcast",g_ilist_sc + call MPI_Gather(ilist_martp,1,MPI_INTEGER,& + i_ilist_martp,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_ilist_martp(i-1)+displ(i-1) + enddo +! write(iout,*) "before gather",displ(0),displ(1) + call MPI_Gatherv(contlistmartpi,ilist_martp,MPI_INTEGER,& + newcontlistmartpi,i_ilist_martp,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistmartpj,ilist_martp,MPI_INTEGER,& + newcontlistmartpj,i_ilist_martp,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Bcast(g_ilist_martp,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(newcontlistmartpi,g_ilist_martp,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistmartpj,g_ilist_martp,MPI_INT,king,FG_COMM,IERR) - 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 + else + g_ilist_martsc=ilist_martsc + g_ilist_martp=ilist_martp - 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 + do i=1,ilist_martsc + newcontlistmartsci(i)=contlistmartsci(i) + newcontlistmartscj(i)=contlistmartscj(i) + enddo + do i=1,ilist_martp + newcontlistmartpi(i)=contlistmartpi(i) + newcontlistmartpj(i)=contlistmartpj(i) + enddo + endif + call int_bounds(g_ilist_martsc,g_listmartsc_start,g_listmartsc_end) + call int_bounds(g_ilist_martp,g_listmartp_start,g_listmartp_end) +! print *,"TUTU",g_listcatscang_start,g_listcatscang_end,i,j,g_ilist_catscangf,myrank - eom2 = & - eps2der * eps2rt_om2 & - + 2.0D0 * alf2 * eps3der & - + sigder * sigsq_om2 & - + dCAVdOM2 & - + dGCLdOM2 & - + dPOLdOM2 +#ifdef DEBUG + write (iout,*) "after MPIREDUCE",ilist_catsctran,ilist_catptran, & + ilist_catscnorm,ilist_catpnorm - 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 - 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,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) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - 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 - xj=dmod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=dmod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=dmod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif - dxj = dc_norm( 1,j ) - dyj = dc_norm( 2,j ) - dzj = dc_norm( 3,j ) - dscj_inv = vbld_inv(j+1) + do i=1,g_ilist_catsctran + write (iout,*) i,newcontlistcatsctrani(i),newcontlistcatsctranj(i) + enddo + do i=1,g_ilist_catptran + write (iout,*) i,newcontlistcatptrani(i),newcontlistcatsctranj(i) + enddo + do i=1,g_ilist_catscnorm + write (iout,*) i,newcontlistcatscnormi(i),newcontlistcatscnormj(i) + enddo + do i=1,g_ilist_catpnorm + write (iout,*) i,newcontlistcatpnormi(i),newcontlistcatscnormj(i) + enddo + do i=1,g_ilist_catscang + write (iout,*) i,newcontlistcatscangi(i),newcontlistcatscangj(i) +#endif + return + end subroutine make_lip_pep_list -! 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 + subroutine make_cat_cat_list + include 'mpif.h' + real(kind=8) :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp + real(kind=8) :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj + real(kind=8) :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi + real(kind=8) :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj + real(kind=8) :: xja,yja,zja + integer,dimension(:),allocatable:: contlistcatpnormi,contlistcatpnormj +! integer :: newcontlistppi(200*nres),newcontlistppj(200*nres) + integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_catscnorm,& + ilist_catsctran,ilist_catpnorm,ilist_catptran,itmp,ilist_catscang,& + ilist_catscangf,ilist_catscangt,k + integer displ(0:nprocs),i_ilist_catscnorm(0:nprocs),ierr,& + i_ilist_catpnorm(0:nprocs),i_ilist_catsctran(0:nprocs),& + i_ilist_catptran(0:nprocs),i_ilist_catscang(0:nprocs),& + i_ilist_catscangf(0:nprocs),i_ilist_catscangt(0:nprocs) +! write(iout,*),"START make_catcat" + ilist_catpnorm=0 + ilist_catscnorm=0 + ilist_catptran=0 + ilist_catsctran=0 + ilist_catscang=0 + + if (.not.allocated(contlistcatpnormi)) then + allocate(contlistcatpnormi(900*nres)) + allocate(contlistcatpnormj(900*nres)) + endif + r_buff_list=3.0 + 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=icatb_start,icatb_end + xi=c(1,i) + yi=c(2,i) + zi=c(3,i) + 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+nres) + do j=i+1,itmp+nres_molec(5) + 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) + yj=c(2,j) + zj=c(3,j) + call to_box(xj,yj,zj) +! call lipid_layer(xj,yj,zj,sslipj,ssgradlipj) +! faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0 + xja=boxshift(xj-xi,boxxsize) + yja=boxshift(yj-yi,boxysize) + zja=boxshift(zj-zi,boxzsize) + dist_init=xja**2+yja**2+zja**2 + if (sqrt(dist_init).le.(10.0+r_buff_list)) then +! Here the list is created +! if (i.eq.2) then +! print *,i,j,dist_init,ilist_catpnorm +! endif + ilist_catpnorm=ilist_catpnorm+1 + +! this can be substituted by cantor and anti-cantor + contlistcatpnormi(ilist_catpnorm)=i + contlistcatpnormj(ilist_catpnorm)=j + endif +! enddo + enddo + enddo +#ifdef DEBUG + write (iout,*) "before MPIREDUCE",ilist_catsctran,ilist_catptran,& + ilist_catscnorm,ilist_catpnorm,ilist_catscang -! 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 ) + do i=1,ilist_catpnorm + write (iout,*) i,contlistcatpnormi(i) + enddo - 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 ) +#endif + if (nfgtasks.gt.1)then - gvdwc_scpho(k,i) = gvdwc_scpho(k,i) & - - (( dFdR + gg(k) ) * ertail(k)) -!c! & - ( dFdR * ertail(k)) + call MPI_Reduce(ilist_catpnorm,g_ilist_catcatnorm,1,& + MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) +! write(iout,*) "before bcast",g_ilist_sc + call MPI_Gather(ilist_catpnorm,1,MPI_INTEGER,& + i_ilist_catpnorm,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_ilist_catpnorm(i-1)+displ(i-1) + enddo +! write(iout,*) "before gather",displ(0),displ(1) + call MPI_Gatherv(contlistcatpnormi,ilist_catpnorm,MPI_INTEGER,& + newcontlistcatcatnormi,i_ilist_catpnorm,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Gatherv(contlistcatpnormj,ilist_catpnorm,MPI_INTEGER,& + newcontlistcatcatnormj,i_ilist_catpnorm,displ,MPI_INTEGER,& + king,FG_COMM,IERR) + call MPI_Bcast(g_ilist_catcatnorm,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(newcontlistcatcatnormi,g_ilist_catcatnorm,MPI_INT,king,FG_COMM,IERR) + call MPI_Bcast(newcontlistcatcatnormj,g_ilist_catcatnorm,MPI_INT,king,FG_COMM,IERR) + + + else + g_ilist_catcatnorm=ilist_catpnorm + do i=1,ilist_catpnorm + newcontlistcatcatnormi(i)=contlistcatpnormi(i) + newcontlistcatcatnormj(i)=contlistcatpnormj(i) + enddo + endif + call int_bounds(g_ilist_catcatnorm,g_listcatcatnorm_start,g_listcatcatnorm_end) + +#ifdef DEBUG + write (iout,*) "after MPIREDUCE",g_ilist_catcatnorm - gvdwc_scpho(k,j) = gvdwc_scpho(k,j) & - + (( dFdR + gg(k) ) * ertail(k))/2.0 + do i=1,g_ilist_catcatnorm + write (iout,*) i,newcontlistcatcatnormi(i),newcontlistcatcatnormj(i) + enddo +#endif +! write(iout,*),"END make_catcat" + return + end subroutine make_cat_cat_list - gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) & - + (( dFdR + gg(k) ) * ertail(k))/2.0 -!c! & + ( dFdR * ertail(k)) +!----------------------------------------------------------------------------- + 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 +!------------------------------------------------------------- + subroutine ecat_prot_transition(ecation_prottran) + integer:: itypi,itypj,ityptrani,ityptranj,k,l,i,j + real(kind=8),dimension(3):: cjtemp,citemp,diff,dsctemp,vecsc,& + diffnorm,boxx,r,dEvan1Cm,dEvan2Cm,dEtotalCm + real(kind=8):: ecation_prottran,dista,sdist,De,ene,x0left,& + alphac,grad,sumvec,simplesum,pom,erdxi,facd1,& + sss_ele_cut,sss_ele_cut_grad,sss2min,sss2mingrad,& + ene1,ene2,grad1,grad2,evan1,evan2,rcal,r4,r7,r0p,& + r06,r012,epscalc,rocal,ract + ecation_prottran=0.0d0 + boxx(1)=boxxsize + boxx(2)=boxysize + boxx(3)=boxzsize + write(iout,*) "start ecattran",g_listcatsctran_start,g_listcatsctran_end + do k=g_listcatsctran_start,g_listcatsctran_end + i=newcontlistcatsctrani(k) + j=newcontlistcatsctranj(k) +! print *,i,j,"in new tran" + do l=1,3 + citemp(l)=c(l,i+nres) + cjtemp(l)=c(l,j) + enddo + + itypi=itype(i,1) !as the first is the protein part + itypj=itype(j,5) !as the second part is always cation +! remapping to internal types +! read (iiontran,*,err=123,end=123) (agamacattran(k,j,i),k=1,3),& +! (athetacattran(k,j,i),k=1,6),acatshiftdsc(j,i),bcatshiftdsc(j,i),& +! demorsecat(j,i),alphamorsecat(j,i),x0catleft(j,i),x0catright(j,i),& +! x0cattrans(j,i) + + if (itypj.eq.6) then + ityptranj=1 !as now only Zn2+ is this needs to be modified for other ions + endif + if (itypi.eq.16) then + ityptrani=1 + elseif (itypi.eq.1) then + ityptrani=2 + elseif (itypi.eq.15) then + ityptrani=3 + elseif (itypi.eq.17) then + ityptrani=4 + elseif (itypi.eq.2) then + ityptrani=5 + else + ityptrani=6 + endif - gg(k) = 0.0d0 - ENDDO + if (ityptrani.gt.ntrantyp(ityptranj)) then +! do l=1,3 +! write(iout,*),gradcattranc(l,j),gradcattranx(l,i) +! enddo +!volume excluded + call to_box(cjtemp(1),cjtemp(2),cjtemp(3)) + call to_box(citemp(1),citemp(2),citemp(3)) + rcal=0.0d0 + do l=1,3 + r(l)=boxshift(cjtemp(l)-citemp(l),boxx(l)) + rcal=rcal+r(l)*r(l) + enddo + ract=sqrt(rcal) + if (ract.gt.r_cut_ele) cycle + sss_ele_cut=sscale_ele(ract) + sss_ele_cut_grad=sscagrad_ele(ract) + 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 l=1,3 + dEvan1Cm(l) = 12*r(l)*epscalc*r012/r7 + dEvan2Cm(l) = 12*r(l)*epscalc*r06/r4 + enddo + do l=1,3 + dEtotalCm(l)=(dEvan1Cm(l)+dEvan2Cm(l))*sss_ele_cut-& + (Evan1+Evan2)*sss_ele_cut_grad*r(l)/ract + enddo + ecation_prottran = ecation_prottran+& + (Evan1+Evan2)*sss_ele_cut + do l=1,3 + gradcattranx(l,i)=gradcattranx(l,i)+dEtotalCm(l) + gradcattranc(l,i)=gradcattranc(l,i)+dEtotalCm(l) + gradcattranc(l,j)=gradcattranc(l,j)-dEtotalCm(l) + enddo + + ene=0.0d0 + else +! cycle + sumvec=0.0d0 + simplesum=0.0d0 + do l=1,3 + vecsc(l)=citemp(l)-c(l,i) + sumvec=sumvec+vecsc(l)**2 + simplesum=simplesum+vecsc(l) + enddo + sumvec=dsqrt(sumvec) + call to_box(cjtemp(1),cjtemp(2),cjtemp(3)) + call to_box(citemp(1),citemp(2),citemp(3)) +! sumvec=2.0d0 + do l=1,3 + dsctemp(l)=c(l,i+nres)& + +(acatshiftdsc(ityptrani,ityptranj)-1.0d0)*vecsc(l)& + +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec + enddo + call to_box(dsctemp(1),dsctemp(2),dsctemp(3)) + sdist=0.0d0 + do l=1,3 + diff(l)=boxshift(dsctemp(l)-cjtemp(l),boxx(l)) + sdist=sdist+diff(l)*diff(l) + enddo + dista=sqrt(sdist) + if (dista.gt.r_cut_ele) cycle + + sss_ele_cut=sscale_ele(dista) + sss_ele_cut_grad=sscagrad_ele(dista) + sss2min=sscale2(dista,x0cattrans(ityptrani,ityptranj)-0.1d0,0.2d0) + De=demorsecat(ityptrani,ityptranj) + alphac=alphamorsecat(ityptrani,ityptranj) + if (sss2min.eq.1.0d0) then +! print *,"ityptrani",ityptrani,ityptranj + x0left=x0catleft(ityptrani,ityptranj) ! to mn + ene=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2) + grad=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*& + (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut& + +ene/sss_ele_cut*sss_ele_cut_grad + else if (sss2min.eq.0.0d0) then + x0left=x0catright(ityptrani,ityptranj) + ene=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2) + grad=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*& + (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut& + +ene/sss_ele_cut*sss_ele_cut_grad + else + sss2mingrad=sscagrad2(dista,x0cattrans(ityptrani,ityptranj)-0.1d0,0.2d0) + x0left=x0catleft(ityptrani,ityptranj) + ene1=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2) + grad1=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*& + (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut& + +ene/sss_ele_cut*sss_ele_cut_grad + x0left=x0catright(ityptrani,ityptranj) + ene2=sss_ele_cut*(-De+De*(1.0d0-dexp(-alphac*(dista-x0left)))**2) + grad2=2.0d0*alphac*De*dexp(-alphac*(dista-x0left))*& + (1.0d0-dexp(-alphac*(dista-x0left)))*sss_ele_cut& + +ene/sss_ele_cut*sss_ele_cut_grad + ene=sss2min*ene1+(1.0d0-sss2min)*ene2 + grad=sss2min*grad1+(1.0d0-sss2min)*grad2+sss2mingrad*(ene1-ene2) + endif + do l=1,3 + diffnorm(l)= diff(l)/dista + enddo + erdxi=scalar(diffnorm(1),dc_norm(1,i+nres)) + facd1=bcatshiftdsc(ityptrani,ityptranj)/sumvec + + do l=1,3 +! 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) -! 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!------------------------------------------------------------------- +! pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) +! gvdwx(k,i) = gvdwx(k,i) & +! - (( dFdR + gg(k) ) * pom) + pom=diffnorm(l)+facd1*(diffnorm(l)-erdxi*dc_norm(l,i+nres)) +! write(iout,*),gradcattranc(l,j),gradcattranx(l,i),grad*diff(l)/dista + + gradcattranx(l,i)=gradcattranx(l,i)+grad*pom& + +grad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0) +! *( bcatshiftdsc(ityptrani,ityptranj)*& +! (1.0d0/sumvec-(vecsc(l)*simplesum)*(sumvec**(-3.0d0)))) + gradcattranc(l,i)=gradcattranc(l,i)+grad*diff(l)/dista +! +sss_ele_cut_grad*ene*diff(l)/dista/sss_ele_cut + gradcattranc(l,j)=gradcattranc(l,j)-grad*diff(l)/dista +! -sss_ele_cut_grad*ene*diff(l)/dista/sss_ele_cut + enddo + ecation_prottran=ecation_prottran+ene + if (energy_dec) write(iout,*) "etrancat",i,j,ene,x0left,De,dista,& + alphac + endif + enddo +! do k=g_listcatptran_start,g_listcatptran_end +! ene=0.0d0 this will be used if peptide group interaction is needed +! enddo -!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 + return + end subroutine + subroutine ecat_prot_ang(ecation_protang) + integer:: itypi,itypj,ityptrani,ityptranj,k,l,i,j,n,m,& + ityptrani1,ityptranj1,ityptrani2,ityptranj2,& + i1,i2,j1,j2,k1,k2,k3,i3,j3,ityptrani3,ityptranj3 + + real(kind=8),dimension(3):: cjtemp,citemp,diff,dsctemp,vecsc,& + diffnorm,boxx,dscvec,dscvecnorm,diffnorm2,& + dscvec2,dscvecnorm2,cjtemp2,citemp2,diff2,dsctemp2,& + vecsc2,diff1,diffnorm1,diff3,mindiffnorm2 + real(kind=8),dimension(3):: dscvec1,dscvecnorm1,cjtemp1,citemp1,vecsc1,dsctemp1,& + dscvec3,dscvecnorm3,cjtemp3,citemp3,vecsc3,dsctemp3,& + diffnorm3,diff4,diffnorm4 + + real(kind=8):: ecation_protang,dista,sdist,De,ene,x0left,& + alphac,grad,sumvec,sumdscvec,pom,erdxi,facd1,& + sss_ele_cut,sss_ele_cut_grad,sss2min,sss2mingrad,& + simplesum,cosval,part1,part2a,part2,part2b,part3,& + part4a,part4b,part4,bottom,dista2,sdist2,sumvec2,& + sumdscvec2,simplesum2,dista1,sdist1,sumvec1,simplesum1,& + sumdscvec1,facd2,scal1a,scal1b,scal2a,scal2b,& + sss2mingrad1,sss2mingrad2,sss2min1,sss2min2,pom1,pom2,& + det1ij,det2ij,cosom1,cosom2,cosom12,cosphij,dista3,& + sumvec3 + real(kind=8):: sinom1,sinom2,sinaux,dephiij,sumdscvec3,sumscvec3,& + cosphi,sdist3,simplesum3,det1t2ij,sss2mingrad3,sss2min3,& + scal1c,scal2c,scal3a,scal3b,scal3c,facd3,facd2b,scal3d,& + scal3e,dista4,sdist4,pom3,sssmintot + + ecation_protang=0.0d0 + boxx(1)=boxxsize + boxx(2)=boxysize + boxx(3)=boxzsize +! print *,"KUR**3",g_listcatscang_start,g_listcatscang_end +! go to 19 +! go to 21 + do k=g_listcatscang_start,g_listcatscang_end + ene=0.0d0 + i=newcontlistcatscangi(k) + j=newcontlistcatscangj(k) + itypi=itype(i,1) !as the first is the protein part + itypj=itype(j,5) !as the second part is always cation +! print *,"KUR**4",i,j,itypi,itypj +! remapping to internal types +! read (iiontran,*,err=123,end=123) (agamacattran(k,j,i),k=1,3),& +! (athetacattran(k,j,i),k=1,6),acatshiftdsc(j,i),bcatshiftdsc(j,i),& +! demorsecat(j,i),alphamorsecat(j,i),x0catleft(j,i),x0catright(j,i),& +! x0cattrans(j,i) + if (itypj.eq.6) then + ityptranj=1 !as now only Zn2+ is this needs to be modified for other ions + endif + if (itypi.eq.16) then + ityptrani=1 + elseif (itypi.eq.1) then + ityptrani=2 + elseif (itypi.eq.15) then + ityptrani=3 + elseif (itypi.eq.17) then + ityptrani=4 + elseif (itypi.eq.2) then + ityptrani=5 + else + ityptrani=6 + endif + if (ityptrani.gt.ntrantyp(ityptranj)) cycle + do l=1,3 + citemp(l)=c(l,i+nres) + cjtemp(l)=c(l,j) + enddo + sumvec=0.0d0 + simplesum=0.0d0 + do l=1,3 + vecsc(l)=citemp(l)-c(l,i) + sumvec=sumvec+vecsc(l)**2 + simplesum=simplesum+vecsc(l) + enddo + sumvec=dsqrt(sumvec) + sumdscvec=0.0d0 + do l=1,3 + dsctemp(l)=c(l,i)& +! +1.0d0 + +(acatshiftdsc(ityptrani,ityptranj))*vecsc(l)& + +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec + dscvec(l)= & +!1.0d0 + (acatshiftdsc(ityptrani,ityptranj))*vecsc(l)& + +bcatshiftdsc(ityptrani,ityptranj)*vecsc(l)/sumvec + sumdscvec=sumdscvec+dscvec(l)**2 + enddo + sumdscvec=dsqrt(sumdscvec) + do l=1,3 + dscvecnorm(l)=dscvec(l)/sumdscvec + enddo + call to_box(dsctemp(1),dsctemp(2),dsctemp(3)) + call to_box(cjtemp(1),cjtemp(2),cjtemp(3)) + sdist=0.0d0 + do l=1,3 + diff(l)=boxshift(dsctemp(l)-cjtemp(l),boxx(l)) + sdist=sdist+diff(l)*diff(l) + enddo + dista=sqrt(sdist) + do l=1,3 + diffnorm(l)= diff(l)/dista + enddo + cosval=scalar(diffnorm(1),dc_norm(1,i+nres)) + grad=0.0d0 + sss2min=sscale2(dista,r_cut_ang,1.0d0) + sss2mingrad=sscagrad2(dista,r_cut_ang,1.0d0) + ene=ene& + +tschebyshev(1,6,athetacattran(1,ityptrani,ityptranj),cosval) + grad=gradtschebyshev(0,5,athetacattran(1,ityptrani,ityptranj),cosval)*sss2min + + facd1=bcatshiftdsc(ityptrani,ityptranj)/sumvec + erdxi=scalar(diffnorm(1),dc_norm(1,i+nres)) + part1=0.0d0 + part2=0.0d0 + part3=0.0d0 + part4=0.0d0 + do l=1,3 + bottom=sumvec**2*sdist + part1=diff(l)*sumvec*dista + part2a=(acatshiftdsc(ityptrani,ityptranj))*vecsc(l) + part2b=0.0d0 + !bcatshiftdsc(ityptrani,ityptranj)/sumvec*& + !(vecsc(l)-cosval*dista*dc_norm(l,i+nres)) + part2=(part2a+part2b)*sumvec*dista + part3=cosval*sumvec*dista*dc_norm(l,i+nres)*dista + part4a=diff(l)*acatshiftdsc(ityptrani,ityptranj) + part4b=bcatshiftdsc(ityptrani,ityptranj)/sumvec*& + (diff(l)-cosval*dista*dc_norm(l,i+nres)) + part4=cosval*sumvec*(part4a+part4b)*sumvec +! gradlipang(m,l)=gradlipang(m,l)+(fac & +! *(xa(m)-scalar*vnorm*xb(m)/wnorm)& +! /(vnorm*wnorm)) + +! 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) + pom=diffnorm(l)+facd1*(diffnorm(l)-erdxi*dc_norm(l,i+nres)) -!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) + gradcatangc(l,j)=gradcatangc(l,j)-grad*& + (dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)-& + ene*sss2mingrad*diffnorm(l) - 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) + gradcatangc(l,i)=gradcatangc(l,i)+grad*& + (dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)+& + ene*sss2mingrad*diffnorm(l) - 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 + gradcatangx(l,i)=gradcatangx(l,i)+grad*& + (part1+part2-part3-part4)/bottom+& + ene*sss2mingrad*pom+& + ene*sss2mingrad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0) +! +grad*(dscvec(l)-cosval*diffnorm(l)*sumdscvec)/(sumdscvec*dista)& +! +grad*pom+grad*diffnorm(l)*(acatshiftdsc(ityptrani,ityptranj)-1.0d0) +!& +! (diff(l)-cosval*dscvecnorm(l)*dista)/(sumdscvec*dista) - 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 + enddo +! print *,i,j,cosval,tschebyshev(1,3,aomicattr(1,ityptranj),cosval)& +! ,aomicattr(0,ityptranj),ene + if (energy_dec) write(iout,*) i,j,ityptrani,ityptranj,ene,cosval + ecation_protang=ecation_protang+ene*sss2min + enddo + 19 continue +! print *,"KUR**",g_listcatscangf_start,g_listcatscangf_end + do k=g_listcatscangf_start,g_listcatscangf_end + ene=0.0d0 + i1=newcontlistcatscangfi(k) + j1=newcontlistcatscangfj(k) + itypi=itype(i1,1) !as the first is the protein part + itypj=itype(j1,5) !as the second part is always cation + if (itypj.eq.6) then + ityptranj1=1 !as now only Zn2+ is this needs to be modified for other ions + endif + if (itypi.eq.16) then + ityptrani1=1 + elseif (itypi.eq.1) then + ityptrani1=2 + elseif (itypi.eq.15) then + ityptrani1=3 + elseif (itypi.eq.17) then + ityptrani1=4 + elseif (itypi.eq.2) then + ityptrani1=5 + else + ityptrani1=6 + endif + do l=1,3 + citemp1(l)=c(l,i1+nres) + cjtemp1(l)=c(l,j1) + enddo + sumvec1=0.0d0 + simplesum1=0.0d0 + do l=1,3 + vecsc1(l)=citemp1(l)-c(l,i1) + sumvec1=sumvec1+vecsc1(l)**2 + simplesum1=simplesum1+vecsc1(l) + enddo + sumvec1=dsqrt(sumvec1) + sumdscvec1=0.0d0 + do l=1,3 + dsctemp1(l)=c(l,i1)& +! +1.0d0 + +(acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)& + +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1 + dscvec1(l)= & +!1.0d0 + (acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)& + +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1 + sumdscvec1=sumdscvec1+dscvec1(l)**2 + enddo + sumdscvec1=dsqrt(sumdscvec1) + do l=1,3 + dscvecnorm1(l)=dscvec1(l)/sumdscvec1 + enddo + call to_box(dsctemp1(1),dsctemp1(2),dsctemp1(3)) + call to_box(cjtemp1(1),cjtemp1(2),cjtemp1(3)) + sdist1=0.0d0 + do l=1,3 + diff1(l)=boxshift(dsctemp1(l)-cjtemp1(l),boxx(l)) + sdist1=sdist1+diff1(l)*diff1(l) + enddo + dista1=sqrt(sdist1) + do l=1,3 + diffnorm1(l)= diff1(l)/dista1 + enddo + sss2min1=sscale2(dista1,r_cut_ang,1.0d0) + sss2mingrad1=sscagrad2(dista1,r_cut_ang,1.0d0) + if (ityptrani1.gt.ntrantyp(ityptranj1)) cycle + +!----------------------------------------------------------------- +! do m=k+1,g_listcatscang_end + ene=0.0d0 + i2=newcontlistcatscangfk(k) + j2=j1 + if (j1.ne.j2) cycle + itypi=itype(i2,1) !as the first is the protein part + itypj=itype(j2,5) !as the second part is always cation + if (itypj.eq.6) then + ityptranj2=1 !as now only Zn2+ is this needs to be modified for other ions + endif + if (itypi.eq.16) then + ityptrani2=1 + elseif (itypi.eq.1) then + ityptrani2=2 + elseif (itypi.eq.15) then + ityptrani2=3 + elseif (itypi.eq.17) then + ityptrani2=4 + elseif (itypi.eq.2) then + ityptrani2=5 + else + ityptrani2=6 + endif + if (ityptrani2.gt.ntrantyp(ityptranj2)) cycle + + do l=1,3 + citemp2(l)=c(l,i2+nres) + cjtemp2(l)=c(l,j2) + enddo + sumvec2=0.0d0 + simplesum2=0.0d0 + do l=1,3 + vecsc2(l)=citemp2(l)-c(l,i2) + sumvec2=sumvec2+vecsc2(l)**2 + simplesum2=simplesum2+vecsc2(l) + enddo + sumvec2=dsqrt(sumvec2) + sumdscvec2=0.0d0 + do l=1,3 + dsctemp2(l)=c(l,i2)& +! +1.0d0 + +(acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)& + +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2 + dscvec2(l)= & +!1.0d0 + (acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)& + +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2 + sumdscvec2=sumdscvec2+dscvec2(l)**2 + enddo + sumdscvec2=dsqrt(sumdscvec2) + do l=1,3 + dscvecnorm2(l)=dscvec2(l)/sumdscvec2 + enddo + call to_box(dsctemp2(1),dsctemp2(2),dsctemp2(3)) + call to_box(cjtemp2(1),cjtemp2(2),cjtemp2(3)) + sdist2=0.0d0 + do l=1,3 + diff2(l)=boxshift(dsctemp2(l)-cjtemp2(l),boxx(l)) +! diff2(l)=1.0d0 + sdist2=sdist2+diff2(l)*diff2(l) + enddo + dista2=sqrt(sdist2) + do l=1,3 + diffnorm2(l)= diff2(l)/dista2 + enddo +! print *,i1,i2,diffnorm2(1) + cosval=scalar(diffnorm1(1),diffnorm2(1)) + grad=0.0d0 + sss2min2=sscale2(dista2,r_cut_ang,1.0d0) + sss2mingrad2=sscagrad2(dista2,r_cut_ang,1.0d0) + ene=ene+tschebyshev(1,3,aomicattr(1,ityptranj1),cosval) + grad=gradtschebyshev(0,2,aomicattr(1,ityptranj1),cosval)*sss2min2*sss2min1 + part1=0.0d0 + part2=0.0d0 + part3=0.0d0 + part4=0.0d0 + ecation_protang=ecation_protang+ene*sss2min2*sss2min1 + facd1=bcatshiftdsc(ityptrani1,ityptranj1)/sumvec1 + facd2=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec2 + scal1a=scalar(diffnorm1(1),dc_norm(1,i1+nres)) + scal1b=scalar(diffnorm2(1),dc_norm(1,i1+nres)) + scal2a=scalar(diffnorm1(1),dc_norm(1,i2+nres)) + scal2b=scalar(diffnorm2(1),dc_norm(1,i2+nres)) + + if (energy_dec) write(iout,*) "omi", i,j,ityptrani,ityptranj,ene,cosval,aomicattr(1,ityptranj1),& + aomicattr(2,ityptranj1),aomicattr(3,ityptranj1),tschebyshev(1,3,aomicattr(1,ityptranj1),cosval) + +!*sss2min + do l=1,3 + pom1=diffnorm1(l)+facd1*(diffnorm1(l)-scal1a*dc_norm(l,i1+nres)) + pom2=diffnorm2(l)+facd2*(diffnorm2(l)-scal2b*dc_norm(l,i2+nres)) + + + gradcatangc(l,i1)=gradcatangc(l,i1)+grad*(diff2(l)-& + cosval*diffnorm1(l)*dista2)/(dista2*dista1)+& + ene*sss2mingrad1*diffnorm1(l)*sss2min2 + + + gradcatangx(l,i1)=gradcatangx(l,i1)+grad/(dista2*dista1)*& + (acatshiftdsc(ityptrani1,ityptranj1)*diff2(l)+& + facd1*(diff2(l)-scal1b*dc_norm(l,i1+nres)*dista2)-& + cosval*dista2/dista1*& + (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+& + facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1)))+& + ene*sss2mingrad1*sss2min2*(pom1+& + diffnorm1(l)*(acatshiftdsc(ityptrani1,ityptranj1)-1.0d0)) + + + gradcatangx(l,i2)=gradcatangx(l,i2)+grad/(dista2*dista1)*& + (acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)+& + facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1)-& + cosval*dista1/dista2*& + (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+& + facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)))+& + ene*sss2mingrad2*sss2min1*(pom2+& + diffnorm2(l)*(acatshiftdsc(ityptrani2,ityptranj2)-1.0d0)) + + + gradcatangx(l,i2)=gradcatangx(l,i2) + gradcatangc(l,i2)=gradcatangc(l,i2)+grad*(diff1(l)-& + cosval*diffnorm2(l)*dista1)/(dista2*dista1)+& + ene*sss2mingrad2*diffnorm2(l)*sss2min1 + + gradcatangc(l,j2)=gradcatangc(l,j2)-grad*(diff2(l)/dista2/dista1-& + cosval*diff1(l)/dista1/dista1+diff1(l)/dista2/dista1-& + cosval*diff2(l)/dista2/dista2)-& + ene*sss2mingrad1*diffnorm1(l)*sss2min2-& + ene*sss2mingrad2*diffnorm2(l)*sss2min1 + + + enddo + + enddo +! enddo +!#ifdef DUBUG + 21 continue +! do k1=g_listcatscang_start,g_listcatscang_end +! print *,"KURNA",g_listcatscangt_start,g_listcatscangt_end + do k1=g_listcatscangt_start,g_listcatscangt_end + i1=newcontlistcatscangti(k1) + j1=newcontlistcatscangtj(k1) + itypi=itype(i1,1) !as the first is the protein part + itypj=itype(j1,5) !as the second part is always cation + if (itypj.eq.6) then + ityptranj1=1 !as now only Zn2+ is this needs to be modified for other ions + endif + if (itypi.eq.16) then + ityptrani1=1 + elseif (itypi.eq.1) then + ityptrani1=2 + elseif (itypi.eq.15) then + ityptrani1=3 + elseif (itypi.eq.17) then + ityptrani1=4 + elseif (itypi.eq.2) then + ityptrani1=5 + else + ityptrani1=6 + endif + do l=1,3 + citemp1(l)=c(l,i1+nres) + cjtemp1(l)=c(l,j1) + enddo + sumvec1=0.0d0 + simplesum1=0.0d0 + do l=1,3 + vecsc1(l)=citemp1(l)-c(l,i1) + sumvec1=sumvec1+vecsc1(l)**2 + simplesum1=simplesum1+vecsc1(l) + enddo + sumvec1=dsqrt(sumvec1) + sumdscvec1=0.0d0 + do l=1,3 + dsctemp1(l)=c(l,i1)& + +(acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)& + +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1 + dscvec1(l)= & + (acatshiftdsc(ityptrani1,ityptranj1))*vecsc1(l)& + +bcatshiftdsc(ityptrani1,ityptranj1)*vecsc1(l)/sumvec1 + sumdscvec1=sumdscvec1+dscvec1(l)**2 + enddo + sumdscvec1=dsqrt(sumdscvec1) + do l=1,3 + dscvecnorm1(l)=dscvec1(l)/sumdscvec1 + enddo + call to_box(dsctemp1(1),dsctemp1(2),dsctemp1(3)) + call to_box(cjtemp1(1),cjtemp1(2),cjtemp1(3)) + sdist1=0.0d0 + do l=1,3 + diff1(l)=boxshift(dsctemp1(l)-cjtemp1(l),boxx(l)) + sdist1=sdist1+diff1(l)*diff1(l) + enddo + dista1=sqrt(sdist1) + do l=1,3 + diffnorm1(l)= diff1(l)/dista1 + enddo + sss2min1=sscale2(dista1,r_cut_ang,1.0d0) + sss2mingrad1=sscagrad2(dista1,r_cut_ang,1.0d0) + if (ityptrani1.gt.ntrantyp(ityptranj1)) cycle +!---------------before second loop +! do k2=k1+1,g_listcatscang_end + i2=newcontlistcatscangtk(k1) + j2=j1 +! print *,"TUTU3",i1,i2,j1,j2 + if (i2.eq.i1) cycle + if (j2.ne.j1) cycle + itypi=itype(i2,1) !as the first is the protein part + itypj=itype(j2,5) !as the second part is always cation + if (itypj.eq.6) then + ityptranj2=1 !as now only Zn2+ is this needs to be modified for other ions + endif + if (itypi.eq.16) then + ityptrani2=1 + elseif (itypi.eq.1) then + ityptrani2=2 + elseif (itypi.eq.15) then + ityptrani2=3 + elseif (itypi.eq.17) then + ityptrani2=4 + elseif (itypi.eq.2) then + ityptrani2=5 + else + ityptrani2=6 + endif + if (ityptrani2.gt.ntrantyp(ityptranj2)) cycle + do l=1,3 + citemp2(l)=c(l,i2+nres) + cjtemp2(l)=c(l,j2) + enddo + sumvec2=0.0d0 + simplesum2=0.0d0 + do l=1,3 + vecsc2(l)=citemp2(l)-c(l,i2) + sumvec2=sumvec2+vecsc2(l)**2 + simplesum2=simplesum2+vecsc2(l) + enddo + sumvec2=dsqrt(sumvec2) + sumdscvec2=0.0d0 + do l=1,3 + dsctemp2(l)=c(l,i2)& + +(acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)& + +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2 + dscvec2(l)= & + (acatshiftdsc(ityptrani2,ityptranj2))*vecsc2(l)& + +bcatshiftdsc(ityptrani2,ityptranj2)*vecsc2(l)/sumvec2 + sumdscvec2=sumdscvec2+dscvec2(l)**2 + enddo + sumdscvec2=dsqrt(sumdscvec2) + do l=1,3 + dscvecnorm2(l)=dscvec2(l)/sumdscvec2 + enddo + call to_box(dsctemp2(1),dsctemp2(2),dsctemp2(3)) + call to_box(cjtemp2(1),cjtemp2(2),cjtemp2(3)) + sdist2=0.0d0 + do l=1,3 + diff2(l)=boxshift(dsctemp2(l)-cjtemp2(l),boxx(l)) +! diff2(l)=1.0d0 + sdist2=sdist2+diff2(l)*diff2(l) + enddo + dista2=sqrt(sdist2) + do l=1,3 + diffnorm2(l)= diff2(l)/dista2 + mindiffnorm2(l)=-diffnorm2(l) + enddo +! print *,i1,i2,diffnorm2(1) + cosom1=scalar(diffnorm1(1),diffnorm2(1)) + sss2min2=sscale2(dista2,r_cut_ang,1.0d0) + sss2mingrad2=sscagrad2(dista2,r_cut_ang,1.0d0) + +!---------------- before third loop +! do k3=g_listcatscang_start,g_listcatscang_end + ene=0.0d0 + i3=newcontlistcatscangtl(k1) + j3=j1 +! print *,"TUTU4",i1,i2,i3,j1,j2,j3 + + if (i3.eq.i2) cycle + if (i3.eq.i1) cycle + if (j3.ne.j1) cycle + itypi=itype(i3,1) !as the first is the protein part + itypj=itype(j3,5) !as the second part is always cation + if (itypj.eq.6) then + ityptranj3=1 !as now only Zn2+ is this needs to be modified for other ions + endif + if (itypi.eq.16) then + ityptrani3=1 + elseif (itypi.eq.1) then + ityptrani3=2 + elseif (itypi.eq.15) then + ityptrani3=3 + elseif (itypi.eq.17) then + ityptrani3=4 + elseif (itypi.eq.2) then + ityptrani3=5 + else + ityptrani3=6 + endif + if (ityptrani3.gt.ntrantyp(ityptranj3)) cycle + do l=1,3 + citemp3(l)=c(l,i3+nres) + cjtemp3(l)=c(l,j3) + enddo + sumvec3=0.0d0 + simplesum3=0.0d0 + do l=1,3 + vecsc3(l)=citemp3(l)-c(l,i3) + sumvec3=sumvec3+vecsc3(l)**2 + simplesum3=simplesum3+vecsc3(l) + enddo + sumvec3=dsqrt(sumvec3) + sumdscvec3=0.0d0 + do l=1,3 + dsctemp3(l)=c(l,i3)& + +(acatshiftdsc(ityptrani3,ityptranj3))*vecsc3(l)& + +bcatshiftdsc(ityptrani3,ityptranj3)*vecsc3(l)/sumvec3 + dscvec3(l)= & + (acatshiftdsc(ityptrani3,ityptranj3))*vecsc3(l)& + +bcatshiftdsc(ityptrani3,ityptranj3)*vecsc3(l)/sumvec3 + sumdscvec3=sumdscvec3+dscvec3(l)**2 + enddo + sumdscvec3=dsqrt(sumdscvec3) + do l=1,3 + dscvecnorm3(l)=dscvec3(l)/sumdscvec3 + enddo + call to_box(dsctemp3(1),dsctemp3(2),dsctemp3(3)) + call to_box(cjtemp3(1),cjtemp3(2),cjtemp3(3)) + sdist3=0.0d0 + do l=1,3 + diff3(l)=boxshift(dsctemp3(l)-dsctemp2(l),boxx(l)) + sdist3=sdist3+diff3(l)*diff3(l) + enddo + dista3=sqrt(sdist3) + do l=1,3 + diffnorm3(l)= diff3(l)/dista3 + enddo + sdist4=0.0d0 + do l=1,3 + diff4(l)=boxshift(dsctemp3(l)-cjtemp2(l),boxx(l)) +! diff2(l)=1.0d0 + sdist4=sdist4+diff4(l)*diff4(l) + enddo + dista4=sqrt(sdist4) + do l=1,3 + diffnorm4(l)= diff4(l)/dista4 + enddo + + sss2min3=sscale2(dista4,r_cut_ang,1.0d0) + sss2mingrad3=sscagrad2(dista4,r_cut_ang,1.0d0) + sssmintot=sss2min3*sss2min2*sss2min1 + if (ityptrani3.gt.ntrantyp(ityptranj3)) cycle + cosom12=scalar(diffnorm3(1),diffnorm1(1)) + cosom2=scalar(diffnorm3(1),mindiffnorm2(1)) + sinom1=dsqrt(1.0d0-cosom1*cosom1) + sinom2=dsqrt(1.0d0-cosom2*cosom2) + cosphi=cosom12-cosom1*cosom2 + sinaux=sinom1*sinom2 + ene=ene+mytschebyshev(1,3,agamacattran(1,ityptrani2,ityptranj2),cosphi,sinaux) + call mygradtschebyshev(1,3,agamacattran(1,ityptrani2,ityptranj2)& + ,cosphi,sinaux,dephiij,det1t2ij) + + det1ij=-det1t2ij*sinom2*cosom1/sinom1-dephiij*cosom2 + det2ij=-det1t2ij*sinom1*cosom2/sinom2-dephiij*cosom1 + facd1=bcatshiftdsc(ityptrani1,ityptranj1)/sumvec1 + facd2=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec2 +! facd2b=bcatshiftdsc(ityptrani2,ityptranj2)/sumvec3 + facd3=bcatshiftdsc(ityptrani3,ityptranj3)/sumvec3 + scal1a=scalar(diffnorm1(1),dc_norm(1,i1+nres)) + scal1b=scalar(diffnorm2(1),dc_norm(1,i1+nres)) + scal1c=scalar(diffnorm3(1),dc_norm(1,i1+nres)) + scal2a=scalar(diffnorm1(1),dc_norm(1,i2+nres)) + scal2b=scalar(diffnorm2(1),dc_norm(1,i2+nres)) + scal2c=scalar(diffnorm3(1),dc_norm(1,i2+nres)) + scal3a=scalar(diffnorm1(1),dc_norm(1,i3+nres)) + scal3b=scalar(mindiffnorm2(1),dc_norm(1,i3+nres)) + scal3d=scalar(diffnorm2(1),dc_norm(1,i3+nres)) + scal3c=scalar(diffnorm3(1),dc_norm(1,i3+nres)) + scal3e=scalar(diffnorm4(1),dc_norm(1,i3+nres)) - 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 + do l=1,3 + pom1=diffnorm1(l)+facd1*(diffnorm1(l)-scal1a*dc_norm(l,i1+nres)) + pom2=diffnorm2(l)+facd2*(diffnorm2(l)-scal2b*dc_norm(l,i2+nres)) + pom3=diffnorm4(l)+facd3*(diffnorm4(l)-scal3e*dc_norm(l,i3+nres)) + + gradcatangc(l,i1)=gradcatangc(l,i1)& + +det1ij*sssmintot*(diff2(l)-diffnorm1(l)*cosom1*dista2)/(dista2*dista1)+& + dephiij*sssmintot*(diff3(l)-diffnorm1(l)*cosom12*dista3)/(dista3*dista1)& + +ene*sss2mingrad1*diffnorm1(l)*sss2min2*sss2min3 + + + gradcatangc(l,i2)=gradcatangc(l,i2)+(& + det1ij*(diff1(l)-diffnorm2(l)*cosom1*dista1)/(dista2*dista1)+& + det2ij*(-diff3(l)+mindiffnorm2(l)*cosom2*dista3)/(dista3*dista2)& + -det2ij*(-diff2(l)-diffnorm3(l)*cosom2*dista2)/(dista3*dista2)& + -dephiij*(diff1(l)-diffnorm3(l)*cosom12*dista1)/(dista3*dista1))*sssmintot& + +ene*sss2mingrad2*diffnorm2(l)*sss2min1*sss2min3 + + + + gradcatangc(l,i3)=gradcatangc(l,i3)& + +det2ij*(-diff2(l)-diffnorm3(l)*cosom2*dista2)/(dista3*dista2)*sssmintot& + +dephiij*(diff1(l)-diffnorm3(l)*cosom12*dista1)/(dista3*dista1)*sssmintot& + +ene*sss2mingrad3*diffnorm4(l)*sss2min1*sss2min2 + + + gradcatangc(l,j1)=gradcatangc(l,j1)-& + sssmintot*(det1ij*(diff2(l)-diffnorm1(l)*cosom1*dista2)/(dista2*dista1)+& + dephiij*(diff3(l)-diffnorm1(l)*cosom12*dista3)/(dista3*dista1))& + -(det1ij*(diff1(l)-diffnorm2(l)*cosom1*dista1)/(dista1*dista2)+& + det2ij*(-diff3(l)+mindiffnorm2(l)*cosom2*dista3)/(dista3*dista2))*sssmintot& + -ene*sss2mingrad1*diffnorm1(l)*sss2min2*sss2min3& + -ene*sss2mingrad2*diffnorm2(l)*sss2min1*sss2min3& + -ene*sss2mingrad3*diffnorm4(l)*sss2min1*sss2min2 + + + gradcatangx(l,i1)=gradcatangx(l,i1)+(det1ij/(dista2*dista1)*& + (acatshiftdsc(ityptrani1,ityptranj1)*diff2(l)+& + facd1*(diff2(l)-scal1b*dc_norm(l,i1+nres)*dista2)-& + cosom1*dista2/dista1*& + (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+& + facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1)))& + +dephiij/(dista3*dista1)*& + (acatshiftdsc(ityptrani1,ityptranj1)*diff3(l)+& + facd1*(diff3(l)-scal1c*dc_norm(l,i1+nres)*dista3)-& + cosom12*dista3/dista1*& + (acatshiftdsc(ityptrani1,ityptranj1)*diff1(l)+& + facd1*(diff1(l)-scal1a*dc_norm(l,i1+nres)*dista1))))*sssmintot& + +ene*sss2mingrad1*sss2min2*sss2min3*(pom1+& + diffnorm1(l)*(acatshiftdsc(ityptrani1,ityptranj1)-1.0d0)) + + + gradcatangx(l,i3)=gradcatangx(l,i3)+(& + det2ij/(dista3*dista2)*& + (acatshiftdsc(ityptrani3,ityptranj3)*(-diff2(l))+& + facd3*(-diff2(l)-scal3b*dc_norm(l,i3+nres)*dista2)-& + cosom2*dista2/dista3*& + (acatshiftdsc(ityptrani3,ityptranj3)*diff3(l)+& + facd3*(diff3(l)-scal3c*dc_norm(l,i3+nres)*dista3)))& + +dephiij/(dista3*dista1)*& + (acatshiftdsc(ityptrani3,ityptranj3)*diff1(l)+& + facd3*(diff1(l)-scal3a*dc_norm(l,i3+nres)*dista1)-& + cosom12*dista1/dista3*& + (acatshiftdsc(ityptrani3,ityptranj3)*diff3(l)+& + facd3*(diff3(l)-scal3c*dc_norm(l,i3+nres)*dista3))))*sssmintot& + +ene*sss2mingrad3*sss2min2*sss2min1*(pom3+& + diffnorm4(l)*(acatshiftdsc(ityptrani3,ityptranj3)-1.0d0)) + + + gradcatangx(l,i2)=gradcatangx(l,i2)+(&! + det1ij/(dista2*dista1)*&! + (acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)&! + +facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1)& + -cosom1*dista1/dista2*&! + (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&! + facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)))+& + det2ij/(dista3*dista2)*&! + (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&! + facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2)& + -(acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&! + facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3))& + -cosom2*dista3/dista2*&! + (acatshiftdsc(ityptrani2,ityptranj2)*diff2(l)+&! + facd2*(diff2(l)-scal2b*dc_norm(l,i2+nres)*dista2))& + +cosom2*dista2/dista3*&! + (acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&! + facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3)))& + +dephiij/(dista3*dista1)*&! + (-(acatshiftdsc(ityptrani2,ityptranj2)*diff1(l)+&! + facd2*(diff1(l)-scal2a*dc_norm(l,i2+nres)*dista1))+& + cosom12*dista1/dista3*&! + (acatshiftdsc(ityptrani2,ityptranj2)*diff3(l)+&! + facd2*(diff3(l)-scal2c*dc_norm(l,i2+nres)*dista3))))*sssmintot& + +ene*sss2mingrad2*sss2min3*sss2min1*(pom2+& + diffnorm2(l)*(acatshiftdsc(ityptrani2,ityptranj2)-1.0d0)) -! & + 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 +! print *,i1,i2,i3,j1,j2,j3,"tors",ene,sinaux,cosphi +! print *,"param",agamacattran(1,ityptrani2,ityptranj2),ityptranj2,ityptrani2 + ecation_protang=ecation_protang+ene*sssmintot enddo - +! enddo +! enddo +!#endif + return + end subroutine +!-------------------------------------------------------------------------- +!c------------------------------------------------------------------------------ + double precision function mytschebyshev(m,n,x,y,yt) + implicit none + integer i,m,n + double precision x(n),y,yt,yy(0:100),aux +!c Tschebyshev polynomial in y multiplied by sin(t1)sin(t2) (yt). +!c 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)*yt*yt + enddo + aux=0.0d0 + do i=m,n + aux=aux+x(i)*yy(i) + enddo +!c print *,(yy(i),i=1,n) + mytschebyshev=aux + return + end function +!C-------------------------------------------------------------------------- +!C-------------------------------------------------------------------------- + subroutine mygradtschebyshev(m,n,x,y,yt,fy,fyt) + implicit none + integer i,m,n + double precision x(n+1),y,yt,fy,fyt,yy(0:100),yb(0:100), & + ybt(0:100) +!c Derivative of Tschebyshev polynomial in y multiplied by sin(t1)sin(t2) (yt). +!c 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 + yb(0)=0.0d0 + yb(1)=1.0d0 + ybt(0)=0.0d0 + ybt(1)=0.0d0 + do i=2,n + yy(i)=2*yy(1)*yy(i-1)-yy(i-2)*yt*yt + yb(i)=2*yy(i-1)+2*yy(1)*yb(i-1)-yb(i-2)*yt*yt + ybt(i)=2*yy(1)*ybt(i-1)-ybt(i-2)*yt*yt-2*yy(i-2)*yt enddo + fy=0.0d0 + fyt=0.0d0 + do i=m,n + fy=fy+x(i)*yb(i) + fyt=fyt+x(i)*ybt(i) + enddo + return + end subroutine + subroutine fodstep(nsteps) + use geometry_data, only: c, nres, theta, alph + use geometry, only:alpha,beta,dist + integer, intent(in) :: nsteps + integer idxtomod, j, i + double precision RD0, RD1, fi +! double precision alpha +! double precision beta +! double precision dist +! double precision compute_RD + double precision TT + real :: r21(5) +!c ! Założenia: dla łańcucha zapisanego w tablicy c zawierającego +!c ! nres elementów CA i CB da się wyznaczyć kąty płaskie +!c ! theta (procedura Alpha) i kąty torsyjne (procedura beta), +!c ! zapisywane w tablicach theta i alph. +!c ! Na podstawie danych z tych tablic da się odtworzyć +!c ! strukturę 3D łańcucha procedurą chainbuild. +!c ! +! print *,"fodstep: nres=",nres + RD0 = compute_RD() +! print *, "RD0before step: ",RD0 + do j=1,nsteps +!c ! Wyznaczenie kątów theta na podstawie struktury +!c ! zapisanej w tablicy c + do i=3,nres + TT=alpha(i-2,i-1,i) + theta(i)=TT +!c print *,"TT=",TT + end do +!c ! Wyznaczenie kątów phi na podstawie struktury +!c ! zapisanej w tablicy c + do i=4,nres + phi(i)=beta(i-3,i-2,i-1,i) + end do +!c ! Wyznaczenie odległości między atomami +!c ! vbld(i)=dist(i-1,i) + do i=2,nres + vbld(i)=dist(i-1,i) + end do +!c ! losujemy kilka liczb + call random_number(r21) +!c ! r21(1): indeks pozycji do zmiany +!c ! r21(2): kąt (r21(2)/20.0-1/40.0) +!c ! r21(3): wybór tablicy + RD0 = compute_RD() +!c print *, "RD before step: ",RD0 + fi = (r21(2)/20.0-1.0/40.0) ! o tyle radianów zmienimy losowy kąt + if (r21(3) .le. 0.5) then + idxtomod = 3+r21(1)*(nres - 2) + theta(idxtomod) = theta(idxtomod)+fi +! print *,"Zmiana kąta theta(",& +! idxtomod,") o fi = ",fi + else + idxtomod = 4+r21(1)*(nres - 3) + phi(idxtomod) = phi(idxtomod)+fi +! print *,"Zmiana kąta phi(",& +! idxtomod,") o fi = ",fi + end if +!c ! odtwarzamy łańcuch + call chainbuild +!c ! czy coś się polepszyło? + RD1 = compute_RD() + if (RD1 .gt. RD0) then ! nie, wycofujemy zmianę +! print *, "RD after step: ",RD1," rejected" + if (r21(3) .le. 0.5) then + theta(idxtomod) = theta(idxtomod)-fi + else + phi(idxtomod) = phi(idxtomod)-fi + end if + call chainbuild ! odtworzenie pierwotnej wersji (bez zmienionego kąta) + else +! print *, "RD after step: ",RD1," accepted" + continue + end if + end do + end subroutine +!c----------------------------------------------------------------------------------------- + subroutine orientation_matrix(res) ! obliczenie macierzy oraz przygotowanie ea z tymi przeksztalceniami + use geometry_data, only: c, nres + use energy_data, only: itype + double precision, intent(out) :: res(4,4) + double precision resM(4,4) + double precision M(4,4) + double precision M2(4,4) + integer i, j, maxi, maxj +! double precision sq + double precision maxd, dd + double precision v1(3) + double precision v2(3) + double precision vecnea(3) + double precision mean_ea(3) + double precision fi +!c ! liczymy atomy efektywne i zapisujemy w tablicy ea + do i=1,nres +!c if (itype(i,1) .ne. 10) then + if (itype(i,1) .ne. 10) then + ea(1,i) = c(1,i+nres) + ea(2,i) = c(2,i+nres) + ea(3,i) = c(3,i+nres) + else + ea(1,i) = c(1,i) + ea(2,i) = c(2,i) + ea(3,i) = c(3,i) + end if + end do + call IdentityM(resM) + if (nres .le. 2) then + print *, "nres too small (should be at least 2), stopping" + stop + end if + do i=1,3 + v1(i)=ea(i,1) + v2(i)=ea(i,2) + end do +!c ! szukamy najwiekszej odleglosci miedzy atomami efektywnymi ea + call Dist3d(maxd,v1,v2) +!c ! odleglosc miedzy pierwsza para atomow efektywnych + maxi = 1 + maxj = 2 + do i=1,nres-1 + do j=i+1,nres + v1(1)=ea(1,i) + v1(2)=ea(2,i) + v1(3)=ea(3,i) + v2(1)=ea(1,j) + v2(2)=ea(2,j) + v2(3)=ea(3,j) + call Dist3d(dd,v1,v2) + if (dd .gt. maxd) then + maxd = dd + maxi = i + maxj = j + end if + end do + end do + vecnea(1)=ea(1,maxi)-ea(1,maxj) + vecnea(2)=ea(2,maxi)-ea(2,maxj) + vecnea(3)=ea(3,maxi)-ea(3,maxj) + if (vecnea(1) .lt. 0) then + vecnea(1) = -vecnea(1) + vecnea(2) = -vecnea(2) + vecnea(3) = -vecnea(3) + end if +!c ! obliczenie kata obrotu wokol osi Z + fi = -atan2(vecnea(2),vecnea(1)) + call RotateZ(M,fi) +!c ! obliczenie kata obrotu wokol osi Y + fi = atan2(vecnea(3), sqrt(sq(vecnea(1))+sq(vecnea(2)))) + call RotateY(M2,fi) + M = matmul(M2,M) +!c ! Przeksztalcamy wszystkie atomy efektywne +!c ! uzyskujac najwieksza odleglosc ulożona wzdluz OX +!c ! ea = transform_eatoms(ea,M) + do i=1,nres + v1(1)=ea(1,i) + v1(2)=ea(2,i) + v1(3)=ea(3,i) + call tranform_point(v2,v1,M) + ea(1,i)=v2(1) + ea(2,i)=v2(2) + ea(3,i)=v2(3) + end do + resM = M +!c ! Teraz szukamy najdluzszego rzutu na plaszczyzne YZ +!c ! (czyli w liczeniu odleglosci bierzemy pod uwage tylko wsp. y, z) + maxd = sqrt( sq(ea(2,1)-ea(2,2)) + sq(ea(3,1)-ea(3,2))) ! aktualnie max odl + maxi = 1 ! indeksy atomow + maxj = 2 ! miedzy ktorymi jest max odl (chwilowe) + do i=1,nres-1 + do j=i+1,nres + dd = sqrt( (ea(2,i)-ea(2,j))**2 + (ea(3,i)-ea(3,j))**2) + if (dd .gt. maxd) then + maxd = dd + maxi = i + maxj = j + end if + end do + end do +!c ! Teraz obrocimy wszystko wokol OX tak, zeby znaleziony rzut +!c ! byl rownolegly do OY + vecnea(1) = ea(1,maxi)-ea(1,maxj) + vecnea(2) = ea(2,maxi)-ea(2,maxj) + vecnea(3) = ea(3,maxi)-ea(3,maxj) +!c ! jeśli współrzędna vecnea.y < 0, to robimy odwrotnie + if (vecnea(2) .lt. 0) then + vecnea(1) = -vecnea(1) + vecnea(2) = -vecnea(2) + vecnea(3) = -vecnea(3) + end if +!c ! obliczenie kąta obrotu wokół osi X + fi = -atan2(vecnea(3),vecnea(2)) + call RotateX(M,fi) +!c ! Przeksztalcamy wszystkie atomy efektywne + do i=1,nres + v1(1)=ea(1,i) + v1(2)=ea(2,i) + v1(3)=ea(3,i) + call tranform_point(v2,v1,M) + ea(1,i)=v2(1) + ea(2,i)=v2(2) + ea(3,i)=v2(3) + end do + resM = matmul(M,resM) ! zbieramy wynik (sprawdzic kolejnosc M,resM) +!c ! centrujemy + mean_ea(1) = 0 + mean_ea(2) = 0 + mean_ea(3) = 0 + do i=1,nres + mean_ea(1) = mean_ea(1) + ea(1,i) + mean_ea(2) = mean_ea(2) + ea(2,i) + mean_ea(3) = mean_ea(3) + ea(3,i) + end do + v1(1) = -mean_ea(1)/nres + v1(2) = -mean_ea(2)/nres + v1(3) = -mean_ea(3)/nres + call TranslateV(M,v1) + resM = matmul(M,resM) +!c ! przesuwamy + do i=1,nres + ea(1,i) = ea(1,i) + v1(1) + ea(2,i) = ea(2,i) + v1(2) + ea(3,i) = ea(3,i) + v1(3) + end do + res = resM +!c ! wynikowa macierz przeksztalcenia lancucha +!c ! (ale lancuch w ea juz mamy przeksztalcony) + return + end subroutine + double precision function compute_rd + use geometry_data, only: nres + use energy_data, only: itype + implicit none + double precision or_mat(4,4) +! double precision hydrophobicity + integer neatoms + double precision cutoff + double precision ho(70000) + double precision ht(70000) + double precision hosum, htsum + double precision marg, sigmax, sigmay, sigmaz + integer i, j + double precision v1(3) + double precision v2(3) + double precision rijdivc, coll, tmpkwadrat, tmppotega, dist + double precision OdivT, OdivR, ot_one, or_one, RD_classic + call orientation_matrix(or_mat) +!c ! tam juz liczy sie tablica ea + neatoms = nres + cutoff = 8.99d0 +!c ! granica oddzialywania w A (powyzej ignorujemy oddzialywanie) +!c ! Najpierw liczymy "obserwowana hydrofobowosc" + hosum = 0.0d0 ! na sume pol ho, do celow pozniejszej normalizacji + do j=1,neatoms + ho(j)=0.0d0 + do i=1,neatoms + if (j .eq. i) then ! nie uwzgledniamy oddzialywania atomu z samym soba + cycle + end if + v1(1)=ea(1,i) + v1(2)=ea(2,i) + v1(3)=ea(3,i) + v2(1)=ea(1,j) + v2(2)=ea(2,j) + v2(3)=ea(3,j) + call Dist3d(dist,v1,v2) ! odleglosc miedzy atomami + if (dist .gt. cutoff) then ! za daleko, nie uwzgledniamy + cycle + end if + rijdivc = dist / cutoff + coll = 0.0d0 + tmppotega = rijdivc*rijdivc + tmpkwadrat = tmppotega + coll = coll + 7*tmpkwadrat + tmppotega = tmppotega * tmpkwadrat ! do potęgi 4 + coll = coll - 9*tmppotega + tmppotega = tmppotega * tmpkwadrat ! do potęgi 6 + coll = coll + 5*tmppotega + tmppotega = tmppotega * tmpkwadrat ! do potęgi 8 + coll = coll - tmppotega +!c ! Wersja: Bryliński 2007 +!c ! EAtoms[j].collectedhp += EAtoms[i].hyphob*(1 - 0.5 * coll); +!c ! ea$ho[j] = ea$ho[j] + hydrophobicity(ea$resid[i])*(1-0.5*coll) +!c ! Wersja: Banach Konieczny Roterman 2014 +!c ! EAtoms[j].collectedhp += (EAtoms[i].hyphob+EAtoms[j].hyphob)*(1 - 0.5 * coll); +!c ponizej bylo itype(i,1) w miejscu itype(i) oraz itype(j,1) w miejscu itype(j) + ho(j) = ho(j) + (hydrophobicity(itype(i,1))+& + hydrophobicity(itype(j,1)))*(1.0d0-0.5_8*coll) + end do + hosum = hosum + ho(j) + end do +!c ! Normalizujemy + do i=1,neatoms + ho(i) = ho(i) / hosum + end do +!c ! Koniec liczenia hydrofobowosci obserwowanej (profil ho) +!c ! Teraz liczymy "teoretyczna hydrofobowosc", wedlug kropli i rozkladu Gaussa + htsum = 0.0d0 +!c ! tu zbieramy sume ht, uzyjemy potem do normalizacji +!c ! Ustalimy teraz parametry rozkladu Gaussa, czyli sigmy (srodek jest w (0,0,0)). +!c ! To bedzie (max odl od srodka + margines) / 3, oddzielnie dla kazdej wspolrzednej. + marg = 9.0d0 + htsum = 0.0d0 +!c ! jeszcze raz zerujemy +!c ! szukamy ekstremalnej wartosci wspolrzednej x (max wart bezwzgl) + sigmax = ea(1,1) + do i=2,neatoms + if (abs(ea(1,i))>sigmax) then + sigmax = abs(ea(1,i)) + end if + end do + sigmax = (marg + sigmax) / 3.0d0 +!c ! szukamy ekstremalnej wartosci wspolrzednej y (max wart bezwzgl) + sigmay = ea(2,1) + do i=2,neatoms + if (abs(ea(2,i))>sigmay) then + sigmay = abs(ea(2,i)) + end if + end do + sigmay = (marg + sigmay) / 3.0d0 +!c ! szukamy ekstremalnej wartosci wspolrzednej z (max wart bezwzgl) + sigmaz = ea(3,1) + do i=2,neatoms + if (abs(ea(3,i))>sigmaz) then + sigmaz = abs(ea(3,i)) + end if + end do + sigmaz = (marg + sigmaz) / 3.0d0 +!c !sigmax = (marg + max(abs(max(ea$acoor[,1])), abs(min(ea$acoor[,1]))))/3.0 +!c !sigmay = (marg + max(abs(max(ea$acoor[,2])), abs(min(ea$acoor[,2]))))/3.0 +!c !sigmaz = (marg + max(abs(max(ea$acoor[,3])), abs(min(ea$acoor[,3]))))/3.0 +!c ! print *,"sigmax =",sigmax," sigmay =",sigmay," sigmaz = ",sigmaz + do j=1,neatoms + ht(j)= exp(-(ea(1,j))**2/(2*sigmax**2))& + * exp(-(ea(2,j))**2/(2*sigmay**2)) & + * exp(-(ea(3,j))**2/(2*sigmaz**2)) + htsum = htsum + ht(j) + end do +!c ! Normalizujemy + do i=1, neatoms + ht(i) = ht(i) / htsum + end do +!c ! Teraz liczymy RD + OdivT = 0.0d0 + OdivR = 0.0d0 + do j=1,neatoms + if (ho(j) .ne. 0) then + ot_one = ho(j) * log(ho(j)/ht(j)) / log(2.0d0) + OdivT = OdivT + ot_one + or_one = ho(j) * log(ho(j)/ (1.0d0/neatoms)) / log(2.0_8) + OdivR = OdivR + or_one + endif + end do + RD_classic = OdivT / (OdivT+OdivR) + compute_rd = RD_classic + return + end function + function hydrophobicity(id) ! do przepisania (bylo: identyfikowanie aa po nazwach) + integer id + double precision hydrophobicity + hydrophobicity = 0.0d0 + if (id .eq. 1) then + hydrophobicity = 1.000d0 ! CYS + return + endif + if (id .eq. 2) then + hydrophobicity = 0.828d0 ! MET + return + endif + if (id .eq. 3) then + hydrophobicity = 0.906d0 ! PHE + return + endif + if (id .eq. 4) then + hydrophobicity = 0.883d0 ! ILE + return + endif + if (id .eq. 5) then + hydrophobicity = 0.783d0 ! LEU + return + endif + if (id .eq. 6) then + hydrophobicity = 0.811d0 ! VAL + return + endif + if (id .eq. 7) then + hydrophobicity = 0.856d0 ! TRP + return + endif + if (id .eq. 8) then + hydrophobicity = 0.700d0 ! TYR + return + endif + if (id .eq. 9) then + hydrophobicity = 0.572d0 ! ALA + return + endif + if (id .eq. 10) then + hydrophobicity = 0.550d0 ! GLY + return + endif + if (id .eq. 11) then + hydrophobicity = 0.478d0 ! THR + return + endif + if (id .eq. 12) then + hydrophobicity = 0.422d0 ! SER + return + endif + if (id .eq. 13) then + hydrophobicity = 0.250d0 ! GLN + return + endif + if (id .eq. 14) then + hydrophobicity = 0.278d0 ! ASN + return + endif + if (id .eq. 15) then + hydrophobicity = 0.083d0 ! GLU + return + endif + if (id .eq. 16) then + hydrophobicity = 0.167d0 ! ASP + return + endif + if (id .eq. 17) then + hydrophobicity = 0.628d0 ! HIS + return + endif + if (id .eq. 18) then + hydrophobicity = 0.272d0 ! ARG + return + endif + if (id .eq. 19) then + hydrophobicity = 0.000d0 ! LYS + return + endif + if (id .eq. 20) then + hydrophobicity = 0.300d0 ! PRO + return + endif + return + end function hydrophobicity + subroutine mycrossprod(res,b,c) + implicit none + double precision, intent(out) :: res(3) + double precision, intent(in) :: b(3) + double precision, intent(in) :: c(3) +!c ! Tylko dla wektorów trójwymiarowych, ale nie sprawdzamy tego tutaj + res(1) = b(2)*c(3)-b(3)*c(2) + res(2) = b(3)*c(1)-b(1)*c(3) + res(3) = b(1)*c(2)-b(2)*c(1) + return + end subroutine + subroutine mydotprod(res,b,c) + implicit none + double precision, intent(out) :: res + double precision, intent(in) :: b(3) + double precision, intent(in) :: c(3) +!c ! Tylko dla wektorów trójwymiarowych, ale nie sprawdzamy tego tutaj + res = b(1)*c(1)+b(2)*c(2)+b(3)*c(3) + return + end subroutine +!c ! cosinus k¹ta miêdzy wektorami trójwymiarowymi + subroutine cosfi(res, x, y) + implicit none + double precision, intent(out) :: res + double precision, intent(in) :: x(3) + double precision, intent(in) :: y(3) + double precision LxLy + LxLy=sqrt(x(1)*x(1)+x(2)*x(2)+x(3)*x(3)) *& + sqrt(y(1)*y(1)+y(2)*y(2)+y(3)*y(3)) + if (LxLy==0.0) then + res = 0.0d0 + else + call mydotprod(res,x,y) + res = res / LxLy + end if + return + end subroutine + + + subroutine Dist3d(res,v1,v2) + implicit none + double precision, intent(out) :: res + double precision, intent(in) :: v1(3) + double precision, intent(in) :: v2(3) +! double precision sq + res = sqrt( sq(v1(1)-v2(1)) + sq(v1(2)-v2(2)) + sq(v1(3)-v2(3))) + return + end subroutine +!c ! Przeksztalca wsp. 3d uzywajac macierzy przeksztalcenia M (4x4) + subroutine tranform_point(res,v3d,M) + implicit none + double precision, intent(out) :: res(3) + double precision, intent(in) :: v3d(3) + double precision, intent(in) :: M(4,4) + + res(1) = M(1,1)*v3d(1) + M(1,2)*v3d(2) + M(1,3)*v3d(3) + M(1,4) + res(2) = M(2,1)*v3d(1) + M(2,2)*v3d(2) + M(2,3)*v3d(3) + M(2,4) + res(3) = M(3,1)*v3d(1) + M(3,2)*v3d(2) + M(3,3)*v3d(3) + M(3,4) + return + end subroutine +!c ! TranslateV: macierz translacji o wektor V + subroutine TranslateV(res,V) + implicit none + double precision, intent(out) :: res(4,4) + double precision, intent(in) :: v(3) + res(1,1) = 1.0d0 + res(1,2) = 0 + res(1,3) = 0 + res(1,4) = v(1) + res(2,1) = 0 + res(2,2) = 1.0d0 + res(2,3) = 0 + res(2,4) = v(2) + res(3,1) = 0 + res(3,2) = 0 + res(3,3) = 1.0d0 + res(3,4) = v(3) + res(4,1) = 0 + res(4,2) = 0 + res(4,3) = 0 + res(4,4) = 1.0d0 + return + end subroutine +!c ! RotateX: macierz obrotu wokol osi OX o kat fi + subroutine RotateX(res,fi) + implicit none + double precision, intent(out) :: res(4,4) + double precision, intent(in) :: fi + res(1,1) = 1.0d0 + res(1,2) = 0 + res(1,3) = 0 + res(1,4) = 0 + res(2,1) = 0 + res(2,2) = cos(fi) + res(2,3) = -sin(fi) + res(2,4) = 0 + res(3,1) = 0 + res(3,2) = sin(fi) + res(3,3) = cos(fi) + res(3,4) = 0 + res(4,1) = 0 + res(4,2) = 0 + res(4,3) = 0 + res(4,4) = 1.0d0 + return + end subroutine +!c ! RotateY: macierz obrotu wokol osi OY o kat fi + subroutine RotateY(res,fi) + implicit none + double precision, intent(out) :: res(4,4) + double precision, intent(in) :: fi + res(1,1) = cos(fi) + res(1,2) = 0 + res(1,3) = sin(fi) + res(1,4) = 0 + res(2,1) = 0 + res(2,2) = 1.0d0 + res(2,3) = 0 + res(2,4) = 0 + res(3,1) = -sin(fi) + res(3,2) = 0 + res(3,3) = cos(fi) + res(3,4) = 0 + res(4,1) = 0 + res(4,2) = 0 + res(4,3) = 0 + res(4,4) = 1.0d0 + return + end subroutine +!c ! RotateZ: macierz obrotu wokol osi OZ o kat fi + subroutine RotateZ(res,fi) + implicit none + double precision, intent(out) :: res(4,4) + double precision, intent(in) :: fi + res(1,1) = cos(fi) + res(1,2) = -sin(fi) + res(1,3) = 0 + res(1,4) = 0 + res(2,1) = sin(fi) + res(2,2) = cos(fi) + res(2,3) = 0 + res(2,4) = 0 + res(3,1) = 0 + res(3,2) = 0 + res(3,3) = 1.0d0 + res(3,4) = 0 + res(4,1) = 0 + res(4,2) = 0 + res(4,3) = 0 + res(4,4) = 1.0d0 + return + end subroutine +!c ! IdentityM + subroutine IdentityM(res) + implicit none + double precision, intent(out) :: res(4,4) + res(1,1) = 1.0d0 + res(1,2) = 0 + res(1,3) = 0 + res(1,4) = 0 + res(2,1) = 0 + res(2,2) = 1.0d0 + res(2,3) = 0 + res(2,4) = 0 + res(3,1) = 0 + res(3,2) = 0 + res(3,3) = 1.0d0 + res(3,4) = 0 + res(4,1) = 0 + res(4,2) = 0 + res(4,3) = 0 + res(4,4) = 1.0d0 + return + end subroutine + double precision function sq(x) + double precision x + sq = x*x + return + end function sq +#ifdef LBFGS + double precision function funcgrad(x,g) + use MD_data, only: totT,usampl + implicit none + double precision energia(0:n_ene) + double precision x(nvar),g(nvar) + integer i + call var_to_geom(nvar,x) + call zerograd + call chainbuild + call etotal(energia(0)) + call sum_gradient + funcgrad=energia(0) + call cart2intgrad(nvar,g) + if (usampl) then + 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 + do i=1,nvar + g(i)=g(i)+gloc(i,icg) + enddo return - end subroutine eprot_sc_phosphate - SUBROUTINE sc_grad_scpho - use calc_data + end function funcgrad + subroutine cart2intgrad(n,g) + integer n + double precision g(n) + double precision drt(3,3,nres),rdt(3,3,nres),dp(3,3),& + temp(3,3),prordt(3,3,nres),prodrt(3,3,nres) + double precision xx(3),xx1(3),alphi,omegi,xj,dpjk,yp,xp,xxp,yyp + double precision cosalphi,sinalphi,cosomegi,sinomegi,theta2,& + cost2,sint2,rj,dxoiij,tempkl,dxoijk,dsci,zzp,dj,dpkl + double precision fromto(3,3),aux(6) + integer i,ii,j,jjj,k,l,m,indi,ind,ind1 + logical sideonly + sideonly=.false. + g=0.0d0 + if (sideonly) goto 10 + 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 + 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 + ind1=0 + do i=1,nres-2 + ind1=ind1+1 + if (n.gt.nphi) then - real (kind=8) :: dcosom1(3),dcosom2(3) - eom1 = & - eps2der * eps2rt_om1 & - - 2.0D0 * alf1 * eps3der & - + sigder * sigsq_om1 & - + dCAVdOM1 & - + dGCLdOM1 & - + dPOLdOM1 + 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 + g(nphi+i)=g(nphi+i)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg) + enddo + 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 + g(nphi+i)=g(nphi+i)+rj*gradx(j,i+1,icg) + enddo + if (i.lt.nres-2) then + do j=1,3 + dxoiij=0.0D0 + do k=1,3 + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) + enddo + g(nphi+i)=g(nphi+i)+dxoiij*gradx(j,i+2,icg) + enddo + endif - eom2 = & - eps2der * eps2rt_om2 & - + 2.0D0 * alf2 * eps3der & - + sigder * sigsq_om2 & - + dCAVdOM2 & - + dGCLdOM2 & - + dPOLdOM2 + endif - 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 - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - 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 - xj=dmod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=dmod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=dmod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 + if (i.gt.1) then + 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 + g(i-1)=g(i-1)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg) + enddo + endif + 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) + if (i.gt.1) then + do j=1,3 + rj=0.0D0 + do k=2,3 + rj=rj+prod(j,k,i)*xx(k) + enddo + g(i-1)=g(i-1)-rj*gradx(j,i+1,icg) + enddo + endif + if (i.gt.1) then + do j=1,3 + dxoiij=0.0D0 + do k=1,3 + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) + enddo + g(i-1)=g(i-1)+dxoiij*gradx(j,i+2,icg) + enddo + endif + do j=i+1,nres-2 + ind1=ind1+1 + call build_fromto(i+1,j+1,fromto) + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,2 + tempkl=tempkl+prordt(k,m,i)*fromto(m,l) + enddo + temp(k,l)=tempkl + enddo + enddo + if (n.gt.nphi) then + do k=1,3 + g(nphi+i)=g(nphi+i)+vbld(j+2)*temp(k,1)*gradc(k,j+1,icg) + enddo + do k=1,3 + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) + enddo + g(nphi+i)=g(nphi+i)+dxoijk*gradx(k,j+2,icg) + enddo endif + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,3 + tempkl=tempkl+prodrt(k,m,i)*fromto(m,l) + enddo + temp(k,l)=tempkl + enddo enddo + if (i.gt.1) then + do k=1,3 + g(i-1)=g(i-1)+vbld(j+2)*temp(k,1)*gradc(k,j+1,icg) enddo + do k=1,3 + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) + enddo + g(i-1)=g(i-1)+dxoijk*gradx(k,j+2,icg) enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi endif - 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)) + enddo + enddo -!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 + if (nvar.le.nphi+ntheta) return - 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 + 10 continue + do i=2,nres-1 + if (iabs(itype(i,1)).eq.10 .or. itype(i,1).eq.ntyp1& !) cycle + .or. mask_side(i).eq.0 ) cycle + ii=ialph(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 + 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 + 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 + aux(jjj+k)=dj + enddo + jjj=jjj+3 enddo - epeppho=epeppho+evdwij+Fcav+ECL -! print *,i,j,evdwij,Fcav,ECL,rij_shift - enddo - enddo - end subroutine eprot_pep_phosphate -!!!!!!!!!!!!!!!!------------------------------------------------------------- - subroutine emomo(evdw) + do k=1,3 + g(ii)=g(ii)+aux(k)*gradx(k,i,icg) + g(ii+nside)=g(ii+nside)+aux(k+3)*gradx(k,i,icg) + enddo + enddo + return + end subroutine cart2intgrad + + +#endif + +!-----------LIPID-MARTINI-UNRES-PROTEIN + +! new for K+ + subroutine elip_prot(evdw) +! subroutine emart_prot2(emartion_prot) 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 + integer :: iint,itypi1,subchap,isel,itmp real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi - real(kind=8) :: evdw + 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 + dist_temp, dist_init,ssgradlipi,ssgradlipj, & + sslipi,sslipj,faclip,alpha_sco + integer :: ii,ki 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) :: 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,& + emartions_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) - 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) - xi=dmod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=dmod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=dmod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize - - if ((zi.gt.bordlipbot) & - .and.(zi.lt.bordliptop)) then -!C the energy transfer exist - if (zi.lt.buflipbot) then -!C what fraction I am in - fracinbuf=1.0d0- & - ((zi-bordlipbot)/lipbufthick) -!C 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 -! 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 + real(kind=8) :: facd4, adler, Fgb, facd3 + integer troll,jj,istate + real (kind=8) :: dcosom1(3),dcosom2(3) + real(kind=8) ::locbox(3) + locbox(1)=boxxsize + locbox(2)=boxysize + locbox(3)=boxzsize + + evdw=0.0D0 + if (nres_molec(4).eq.0) return + eps_out=80.0d0 +! sss_ele_cut=1.0d0 -!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) + 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 + do ki=g_listmartsc_start,g_listmartsc_end + i=newcontlistmartsci(ki) + j=newcontlistmartscj(ki) -! 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) - xj=dmod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=dmod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=dmod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif - 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 ) +! 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,4)) + if ((itypj.gt.ntyp_molec(4))) cycle + CALL elgrad_init_mart(eheadtail,Egb,Ecl,Elj,Equad,Epol) +! print *,i,j,"after elgrad" + dscj_inv=0.0 + xj=c(1,j) + yj=c(2,j) + zj=c(3,j) + + call to_box(xj,yj,zj) +! write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,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) +! write(iout,*) "xj,yj,zj", xj,yj,zj,boxxsize + rreal(1)=xj + rreal(2)=yj + rreal(3)=zj + dxj=0.0 + dyj=0.0 + dzj=0.0 +! 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,4) +! 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 = chi1mart(itypi,itypj) + chis1 = chis1mart(itypi,itypj) + chip1 = chipp1mart(itypi,itypj) ! chi1=0.0d0 -! chi2=0.0d0 +! chis1=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 + chi2=0.0 + chip2=0.0 + chis2=0.0 +! chis2 = chis(itypj,itypi) + chis12 = chis1 * chis2 + sig1 = sigmap1mart(itypi,itypj) + sig2=0.0d0 +! sig2 = sigmap2(itypi,itypj) ! 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) + b1cav = alphasurmart(1,itypi,itypj) + b2cav = alphasurmart(2,itypi,itypj) + b3cav = alphasurmart(3,itypi,itypj) + b4cav = alphasurmart(4,itypi,itypj) + +! b1cav=0.0d0 +! b2cav=0.0d0 +! b3cav=0.0d0 +! b4cav=0.0d0 + ! used to determine whether we want to do quadrupole calculations - eps_in = epsintab(itypi,itypj) + eps_in = epsintabmart(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 +! 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) + ctail(k,1)=c(k,i+nres) + ctail(k,2)=c(k,j) END DO + call to_box(ctail(1,1),ctail(2,1),ctail(3,1)) + call to_box(ctail(1,2),ctail(2,2),ctail(3,2)) !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 ) + do k=1,3 + Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k)) + enddo 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) - + (Rtail_distance(1)*Rtail_distance(1)) & + + (Rtail_distance(2)*Rtail_distance(2)) & + + (Rtail_distance(3)*Rtail_distance(3))) +! tail lomartion and distance calculations +! dhead1 + d1 = dheadmart(1, 1, itypi, itypj) +! d2 = dhead(2, 1, itypi, itypj) DO k = 1,3 -! location of polar head is computed by taking hydrophobic centre +! lomartion 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) +! see unres publimartions for very informative images + chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres) + chead(k,2) = c(k, j) + enddo + call to_box(chead(1,1),chead(2,1),chead(3,1)) + call to_box(chead(1,2),chead(2,2),chead(3,2)) +! write(iout,*) "TEST",chead(1,1),chead(2,1),chead(3,1),dc_norm(k, i+nres),d1 ! 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) +! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) + do k=1,3 + Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k)) 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_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 @@ -24623,49 +33013,64 @@ 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) + Fcav = 0.0d0 + Fisocav=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 + rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj) + rij = dsqrt(rrij) + sss_ele_cut=sscale_ele(1.0d0/(rij)) + sss_ele_grad=sscagrad_ele(1.0d0/(rij)) +! print *,sss_ele_cut,sss_ele_grad,& +! 1.0d0/(rij),r_cut_ele,rlamb_ele + if (sss_ele_cut.le.0.0) cycle + 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 + 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) + 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) + rij_shift = Rtail - sig + sig0ij + IF (rij_shift.le.0.0D0) THEN + evdw = 1.0D20 + if (evdw.gt.1.0d6) then + write (*,'(2(1x,a3,i3),7f7.2)') & + restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,& + 1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij,sigsq + write(*,*) facsig,faceps1_inv,om1,chiom1,chi1 + write(*,*) "ANISO?!",chi1 +!evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,& +! Equad,evdwij+Fcav+eheadtail,evdw + endif + + RETURN + END IF + sigder = -sig * sigsq + rij_shift = 1.0D0 / rij_shift + fac = rij_shift**expon + c1 = fac * fac * aa_aq_mart(itypi,itypj) ! print *,"ADAM",aa_aq(itypi,itypj) ! c1 = 0.0d0 - c2 = fac * bb_aq(itypi,itypj) + c2 = fac * bb_aq_mart(itypi,itypj) ! c2 = 0.0d0 - evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) - eps2der = eps3rt * evdwij - eps3der = eps2rt * evdwij + evdwij = eps1 * eps2rt * eps3rt * ( c1 + c2 ) + eps2der = eps3rt * evdwij + eps3der = eps2rt * evdwij ! evdwij = 4.0d0 * eps2rt * eps3rt * evdwij - evdwij = eps2rt * eps3rt * evdwij + evdwij = eps2rt * eps3rt * evdwij !#ifdef TSCSC ! IF (bb_aq(itypi,itypj).gt.0) THEN ! evdw_p = evdw_p + evdwij @@ -24673,833 +33078,688 @@ ! evdw_m = evdw_m + evdwij ! END IF !#else - evdw = evdw & - + evdwij + evdw = evdw & + + evdwij*sss_ele_cut !#endif - - c1 = c1 * eps1 * eps2rt**2 * eps3rt**2 - fac = -expon * (c1 + evdwij) * rij_shift - sigder = fac * sigder -! fac = rij * fac + 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 -! 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) -! 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 - CALL eqn(epol) - eheadtail = epol -! eheadtail = 0.0d0 - - ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN -!c! Nonpolar-charge interactions - CALL enq(epol) - eheadtail = epol -! eheadtail = 0.0d0 - - ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN -!c! Charge-dipole interactions - 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 - 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 -/- ) - 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 -/+ ) - 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 -! 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) - Egb = -(332.0d0 * Qij * eps_inout_fac) / 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 * eps_inout_fac) / (Fgb * 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 + gg(1) = fac +!*sss_ele_cut+evdwij*sss_ele_grad + gg(2) = fac +!*sss_ele_cut+evdwij*sss_ele_grad + gg(3) = fac +!*sss_ele_cut+evdwij*sss_ele_grad +! print *,"GG(1),distance grad",gg(1) + 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 - 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) + 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 ) -!c! Now we add appropriate partial derivatives (one in each dimension) + 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 = dtailmart(1,itypi,itypj) * vbld_inv(i+nres) + facd2 = dtailmart(2,itypi,itypj) * vbld_inv(j) 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 = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres)) + gradpepmartx(k,i) = gradpepmartx(k,i) & + - (( dFdR + gg(k) ) * pom)*sss_ele_cut& + -(evdwij+Fcav)*rij*sss_ele_grad*rreal(k) - 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) + pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j)) +! gvdwx(k,j) = gvdwx(k,j) & +! + (( dFdR + gg(k) ) * pom) + gradpepmart(k,i) = gradpepmart(k,i) & + - (( dFdR + gg(k) ) * ertail(k))*sss_ele_cut& + -(evdwij+Fcav)*rij*sss_ele_grad*rreal(k) - END DO - RETURN - END SUBROUTINE eqq -!c!------------------------------------------------------------------- - SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad) - use comm_momo - use calc_data + gradpepmart(k,j) = gradpepmart(k,j) & + + (( dFdR + gg(k) ) * ertail(k))*sss_ele_cut& + +(evdwij+Fcav)*rij*sss_ele_grad*rreal(k) - 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 + gg(k) = 0.0d0 + ENDDO +!c! Compute head-head and head-tail energies for each state +!! if (.false.) then ! turn off electrostatic + isel = iabs(Qi)+iabs(Qj) + if ((itype(j,4).gt.4).and.(itype(j,4).lt.14)) isel=isel+2 +! isel=0 +! if (isel.eq.2) isel=0 + IF (isel.le.1) THEN + eheadtail = 0.0d0 + ELSE IF (isel.eq.3) THEN + if (iabs(Qj).eq.1) then + CALL edq_mart(ecl, elj, epol) + eheadtail = ECL + elj + epol + else + 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 + call eqd_mart(ecl,elj,epol) + eheadtail = ECL + elj + epol + endif + ELSE IF ((isel.eq.2)) THEN + if (iabs(Qi).ne.1) then + eheadtail=0.0d0 + else + 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 + CALL eqq_mart(Ecl,Egb,Epol,Fisocav,Elj) + eheadtail = ECL + Egb + Epol + Fisocav + Elj + endif + ELSE IF (isel.eq.4) then + call edd_mart(ecl) + eheadtail = ECL + ENDIF +! write(iout,*) "not yet implemented",j,itype(j,5) +!! endif ! turn off electrostatic + evdw = evdw + (Fcav + eheadtail)*sss_ele_cut +! if (evdw.gt.1.0d6) then +! write (*,'(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 +! endif -!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 + 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 (energy_dec) write(iout,*) "FCAV", & + sig1,sig2,b1cav,b2cav,b3cav,b4cav +! print *,"before sc_grad_mart", i,j, gradpepmart(1,j) +! iF (nstate(itypi,itypj).eq.1) THEN + CALL sc_grad_mart +! print *,"after sc_grad_mart", i,j, gradpepmart(1,j) + +! 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 +!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 +! go to 23 +! do i=ibond_start,ibond_end - 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 + do ki=g_listmartp_start,g_listmartp_end + i=newcontlistmartpi(ki) + j=newcontlistmartpj(ki) -!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 +! 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,4)) + if ((itypj.gt.ntyp_molec(4))) cycle + CALL elgrad_init_mart_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) + xj=boxshift(xj-xi,boxxsize) + yj=boxshift(yj-yi,boxysize) + zj=boxshift(zj-zi,boxzsize) + rreal(1)=xj + rreal(2)=yj + rreal(3)=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,4) +! 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 = chi1mart(itypi,itypj) + chis1 = chis1mart(itypi,itypj) + chip1 = chipp1mart(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 = sigmap1mart(itypi,itypj) + sig2=0.0 +! sig2 = sigmap2(itypi,itypj) +! alpha factors from Fcav/Gcav + b1cav = alphasurmart(1,itypi,itypj) + b2cav = alphasurmart(2,itypi,itypj) + b3cav = alphasurmart(3,itypi,itypj) + b4cav = alphasurmart(4,itypi,itypj) + +! used to determine whether we want to do quadrupole calculations + eps_in = epsintabmart(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 - 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 + ctail(k,1)=(c(k,i)+c(k,i+1))/2.0 + ctail(k,2)=c(k,j) 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 + call to_box(ctail(1,1),ctail(2,1),ctail(3,1)) + call to_box(ctail(1,2),ctail(2,2),ctail(3,2)) +!c! tail distances will be themselves usefull elswhere +!c1 (in Gcav, for example) + do k=1,3 + Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k)) + enddo - 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 +!c! tail distances will be themselves usefull elswhere +!c1 (in Gcav, for example) + Rtail = dsqrt( & + (Rtail_distance(1)*Rtail_distance(1)) & + + (Rtail_distance(2)*Rtail_distance(2)) & + + (Rtail_distance(3)*Rtail_distance(3))) +! tail lomartion and distance calculations +! dhead1 + d1 = dheadmart(1, 1, itypi, itypj) +! print *,"d1",d1 +! d1=0.0d0 +! d2 = dhead(2, 1, itypi, itypj) + DO k = 1,3 +! lomartion of polar head is computed by taking hydrophobic centre +! and moving by a d1 * dc_norm vector +! see unres publimartions 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) + ENDDO +! distance +! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) +! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) + call to_box(chead(1,1),chead(2,1),chead(3,1)) + call to_box(chead(1,2),chead(2,2),chead(3,2)) + +! distance +! Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres)) +! Rsc(k) = Rsc_distance(k) * Rsc_distance(k) + do k=1,3 + Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k)) 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 +! 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 = 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) + dPOLdOM2 = 0.0d0 + Fcav = 0.0d0 + dFdR = 0.0d0 + dCAVdOM1 = 0.0d0 + dCAVdOM2 = 0.0d0 + dCAVdOM12 = 0.0d0 + dscj_inv = 0.0d0 ! 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) + sss_ele_cut=sscale_ele(1.0d0/(rij)) + sss_ele_grad=sscagrad_ele(1.0d0/(rij)) +! print *,sss_ele_cut,sss_ele_grad,& +! 1.0d0/(rij),r_cut_ele,rlamb_ele + if (sss_ele_cut.le.0.0) cycle + 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 + om2=0.0d0 + om12=0.0d0 + 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 +! if (evdw.gt.1.0d6) then +! write (*,'(2(1x,a3,i3),6f6.2)') & +! restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,& +! 1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij +!evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,& +! Equad,evdwij+Fcav+eheadtail,evdw +! endif + RETURN + END IF + sigder = -sig * sigsq + rij_shift = 1.0D0 / rij_shift + fac = rij_shift**expon + c1 = fac * fac * aa_aq_mart(itypi,itypj) +! print *,"ADAM",aa_aq(itypi,itypj) + +! c1 = 0.0d0 + c2 = fac * bb_aq_mart(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*sss_ele_cut +!#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 ) + dCAVdOM2=0.0d0 + dCAVdOM12=0.0d0 + + 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 = dtailmart(1,itypi,itypj) * vbld_inv(i) + facd2 = dtailmart(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 = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i)) +! gradpepmartx(k,i) = gradpepmartx(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) + gradpepmart(k,i) = gradpepmart(k,i) & + - (( dFdR + gg(k) ) * ertail(k))/2.0d0*sss_ele_cut& + -(evdwij+Fcav)*rij*sss_ele_grad*rreal(k)*0.5d0 + gradpepmart(k,i+1) = gradpepmart(k,i+1) & + - (( dFdR + gg(k) ) * ertail(k))/2.0d0*sss_ele_cut& + -(evdwij+Fcav)*rij*sss_ele_grad*rreal(k)*0.5d0 + + gradpepmart(k,j) = gradpepmart(k,j) & + + (( dFdR + gg(k) ) * ertail(k))*sss_ele_cut& + +(evdwij+Fcav)*rij*sss_ele_grad*rreal(k) + + gg(k) = 0.0d0 + ENDDO +!c! Compute head-head and head-tail energies for each state +!c! Dipole-charge interactions + isel = 2+iabs(Qj) + if ((itype(j,4).gt.4).and.(itype(j,4).lt.14)) isel=isel+2 +! if (isel.eq.4) isel=0 + if (isel.le.2) then + eheadtail=0.0d0 + ELSE if (isel.eq.3) then + CALL edq_mart_pep(ecl, elj, epol) + eheadtail = ECL + elj + epol +! print *,"i,",i,eheadtail +! eheadtail = 0.0d0 + else +!HERE WATER and other types of molecules solvents will be added +! write(iout,*) "not yet implemented" + CALL edd_mart_pep(ecl) + eheadtail=ecl +! CALL edd_mart_pep +! eheadtail=0.0d0 + endif + evdw = evdw +( Fcav + eheadtail)*sss_ele_cut +! if (evdw.gt.1.0d6) then +! write (*,'(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 +! endif + 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 - 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))) +! iF (nstate(itypi,itypj).eq.1) THEN + CALL sc_grad_mart_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 + 23 continue +! print *,"before leave sc_grad_mart", i,j, gradpepmart(1,nres-1) - gvdwc(k,i) = gvdwc(k,i) - dPOLdR1 * erhead_tail(k,1) - gvdwc(k,j) = gvdwc(k,j) + dPOLdR1 * erhead_tail(k,1) + return + end subroutine elip_prot - END DO - RETURN - END SUBROUTINE eqn - SUBROUTINE enq(Epol) + SUBROUTINE eqq_mart(Ecl,Egb,Epol,Fisocav,Elj) use calc_data use comm_momo - double precision facd3, adler,epol - alphapol2 = alphapol(itypj,itypi) + real (kind=8) :: facd3, facd4, federmaus, adler,& + Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap +! integer :: k +!c! Epol and Gpol analytical parameters + alphapol1 = alphapolmart(itypi,itypj) + alphapol2 = alphapolmart2(itypj,itypi) +!c! Fisocav and Gisocav analytical parameters + al1 = alphisomart(1,itypi,itypj) + al2 = alphisomart(2,itypi,itypj) + al3 = alphisomart(3,itypi,itypj) + al4 = alphisomart(4,itypi,itypj) + csig = (1.0d0 & + / dsqrt(sigiso1mart(itypi, itypj)**2.0d0 & + + sigiso2mart(itypi,itypj)**2.0d0)) +!c! + pis = sig0headmart(itypi,itypj) + eps_head = epsheadmart(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 - R2=R2+(chead(k,2)-ctail(k,1))**2 +!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 Polarization energy + +!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=debaykapmart(itypi,itypj) + if (energy_dec) write(iout,*) "egb",Qij,debkap,Fgb,a12sq,ee0 + 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) - 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 + 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!*sss_ele_cut+epol*sss_ele_grad +!c! dPOLdR1 = 0.0d0 + dPOLdR2 = dPOLdFGB2 * dFGBdR2!*sss_ele_cut+epol*sss_ele_grad !c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 !c! dPOLdOM1 = 0.0d0 - dPOLdOM2 = 0.0d0 + dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 +! epol=epol*sss_ele_cut +!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! (See comments in Eqq) +!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_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2) + 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 - 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) + 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 = dtailmart(1,itypi,itypj) * vbld_inv(i+nres) + facd4 = dtailmart(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)) + gradpepmartx(k,i) = gradpepmartx(k,i) & + +sss_ele_cut*(- 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)-& + sss_ele_grad*rij*rreal(k)*(Ecl+Egb+Epol+Fisocav+Elj) + + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j)) +! gradpepmartx(k,j) = gradpepmartx(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 + + gradpepmart(k,i) = gradpepmart(k,i) + & + sss_ele_cut*(- dGCLdR * erhead(k)& + - dGGBdR * erhead(k)& + - dGCVdR * erhead(k)& + - dPOLdR1 * erhead_tail(k,1)& + - dPOLdR2 * erhead_tail(k,2)& + - dGLJdR * erhead(k))& + - sss_ele_grad*rij*rreal(k)*(Ecl+Egb+Epol+Fisocav+Elj) + + + gradpepmart(k,j) = gradpepmart(k,j) + & + sss_ele_cut*( dGCLdR * erhead(k) & + + dGGBdR * erhead(k) & + + dGCVdR * erhead(k) & + + dPOLdR1 * erhead_tail(k,1) & + + dPOLdR2 * erhead_tail(k,2)& + + dGLJdR * erhead(k))& + +sss_ele_grad*rij*rreal(k)*(Ecl+Egb+Epol+Fisocav+Elj) END DO - RETURN - END SUBROUTINE enq - SUBROUTINE eqd(Ecl,Elj,Epol) + RETURN + END SUBROUTINE eqq_mart + + SUBROUTINE eqd_mart(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) + alphapol1 = alphapolmart(itypi,itypj) + w1 = wqdipmart(1,itypi,itypj) + w2 = wqdipmart(2,itypi,itypj) + pis = sig0headmart(itypi,itypj) + eps_head = epsheadmart(itypi,itypj) +! eps_head=0.0d0 +! w2=0.0d0 +! alphapol1=0.0d0 !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 + R1=R1+(ctail(k,2)-chead(k,1))**2 END DO !c! Pitagoras R1 = dsqrt(R1) @@ -25514,13 +33774,16 @@ 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 + - hawk / Rhead**4.0d0 + dGCLdR =sss_ele_cut*(-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) + dGCLdOM2 = 0.0d0 ! + +!(2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) + !c-------------------------------------------------------------------- !c Polarization energy !c Epol @@ -25533,87 +33796,214 @@ !c!------------------------------------------------------------------ !c! derivative of Epol is Gpol... dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) & - / (fgb1 ** 5.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 + * ( 2.0d0 - (0.5d0 * ee1) ) ) & + / ( 2.0d0 * fgb1 ) + dFGBdOM2 = 0.0d0 ! as om2 is 0 +! (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) & +! * (2.0d0 - 0.5d0 * ee1) ) & +! / (2.0d0 * fgb1) + dPOLdR1 = dPOLdFGB1 * dFGBdR1*sss_ele_cut !c! dPOLdR1 = 0.0d0 dPOLdOM1 = 0.0d0 - dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 -!c! dPOLdOM2 = 0.0d0 +! dPOLdOM2 = dPOLdFGB1 * dFGBdOM2 + 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))) + dGLJdR = 4.0d0 * eps_head*sss_ele_cut & + * (((-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) + 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))) + 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)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gradpepmartx(k,i) = gradpepmartx(k,i) & + - dGCLdR * pom& + - dPOLdR1 * hawk & + - dGLJdR * pom& + -(Ecl+Elj+Epol)*sss_ele_grad*rreal(k)*rij - 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 + +! pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) +! gradpepmartx(k,j) = gradpepmartx(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) + gradpepmart(k,i) = gradpepmart(k,i) & + - dGCLdR * erhead(k) & + - dPOLdR1 * erhead_tail(k,1) & + - dGLJdR * erhead(k)& + -(Ecl+Elj+Epol)*sss_ele_grad*rreal(k)*rij + + + gradpepmart(k,j) = gradpepmart(k,j) & + + dGCLdR * erhead(k) & + + dPOLdR1 * erhead_tail(k,1) & + + dGLJdR * erhead(k)& + +(Ecl+Elj+Epol)*sss_ele_grad*rreal(k)*rij - 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 + END SUBROUTINE eqd_mart + + SUBROUTINE edq_mart(Ecl,Elj,Epol) + 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) + alphapol2 = alphapolmart(itypi,itypj) + w1 = wqdipmart(1,itypi,itypj) + w2 = wqdipmart(2,itypi,itypj) + pis = sig0headmart(itypi,itypj) + eps_head = epsheadmart(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)*sss_ele_cut +!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*sss_ele_cut +!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)))*sss_ele_cut +!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 = dtailmart(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)) + gradpepmartx(k,i) = gradpepmartx(k,i) & + - dGCLdR * pom & + - dPOLdR2 * (erhead_tail(k,2) & + -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) & + - dGLJdR * pom& + -(Ecl+Elj+Epol)*sss_ele_grad*rreal(k)*rij + + + pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j)) +! gradpepmartx(k,j) = gradpepmartx(k,j) & +! + dGCLdR * pom & +! + dPOLdR2 * condor & +! + dGLJdR * pom + + + gradpepmart(k,i) = gradpepmart(k,i) & + - dGCLdR * erhead(k) & + - dPOLdR2 * erhead_tail(k,2) & + - dGLJdR * erhead(k)& + -(Ecl+Elj+Epol)*sss_ele_grad*rreal(k)*rij + + + gradpepmart(k,j) = gradpepmart(k,j) & + + dGCLdR * erhead(k) & + + dPOLdR2 * erhead_tail(k,2) & + + dGLJdR * erhead(k)& + +(Ecl+Elj+Epol)*sss_ele_grad*rreal(k)*rij + + END DO + RETURN + END SUBROUTINE edq_mart + + SUBROUTINE edq_mart_pep(Ecl,Elj,Epol) + use comm_momo + use calc_data + + double precision facd3, adler,ecl,elj,epol + alphapol2 = alphapolmart(itypi,itypj) + w1 = wqdipmart(1,itypi,itypj) + w2 = wqdipmart(2,itypi,itypj) + pis = sig0headmart(itypi,itypj) + eps_head = epsheadmart(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 + R2=R2+(chead(k,2)-ctail(k,1))**2 END DO !c! Pitagoras R2 = dsqrt(R2) @@ -25626,19 +34016,22 @@ !c!------------------------------------------------------------------- !c! ecl - sparrow = w1 * Qi * om1 - hawk = w2 * Qi * Qi * (1.0d0 - sqom2) + 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 + - 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 + dGCLdR = (- 2.0d0 * sparrow / Rhead**3.0d0 & + + 4.0d0 * hawk / Rhead**5.0d0)*sss_ele_cut !c! dF/dom1 - dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0) + dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0) !c! dF/dom2 - dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0) + dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0) +!c-------------------------------------------------------------------- !c-------------------------------------------------------------------- !c Polarization energy !c Epol @@ -25648,14 +34041,14 @@ 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) + / (fgb2 ** 5.0d0) dFGBdR2 = ( (R2 / MomoFac2) & - * ( 2.0d0 - (0.5d0 * ee2) ) ) & - / (2.0d0 * fgb2) + * ( 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 + * (2.0d0 - 0.5d0 * ee2) ) & + / (2.0d0 * fgb2) + dPOLdR2 = dPOLdFGB2 * dFGBdR2*sss_ele_cut !c! dPOLdR2 = 0.0d0 dPOLdOM1 = dPOLdFGB2 * dFGBdOM1 !c! dPOLdOM1 = 0.0d0 @@ -25665,134 +34058,204 @@ 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))) + dGLJdR = 4.0d0 * eps_head*sss_ele_cut & + * (((-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) + 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) ) + facd1 = d1 * vbld_inv(i+1) + DO k = 1, 3 + pom = facd1*(erhead(k)-erdxi*dC_norm(k,i)) +! gradpepmartx(k,i) = gradpepmartx(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)) +! gradpepmartx(k,j) = gradpepmartx(k,j) & +! + dGCLdR * pom & +! + dPOLdR2 * condor & +! + dGLJdR * pom + + gradpepmart(k,i) = gradpepmart(k,i)+pom*(dGCLdR+dGLJdR) + gradpepmart(k,i+1) = gradpepmart(k,i+1)-pom*(dGCLdR+dGLJdR) + + gradpepmart(k,i) = gradpepmart(k,i) +0.5d0*( & + - dGCLdR * erhead(k) & + - dPOLdR2 * erhead_tail(k,2) & + - dGLJdR * erhead(k))& + -(Ecl+Elj+Epol)*sss_ele_grad*rreal(k)*rij + gradpepmart(k,i+1) = gradpepmart(k,i+1) +0.5d0*( & + - dGCLdR * erhead(k) & + - dPOLdR2 * erhead_tail(k,2) & + - dGLJdR * erhead(k))& + -(Ecl+Elj+Epol)*sss_ele_grad*rreal(k)*rij + + + + gradpepmart(k,j) = gradpepmart(k,j) & + + dGCLdR * erhead(k) & + + dPOLdR2 * erhead_tail(k,2) & + + dGLJdR * erhead(k)& + +(Ecl+Elj+Epol)*sss_ele_grad*rreal(k)*rij + + + END DO + RETURN + END SUBROUTINE edq_mart_pep +!-------------------------------------------------------------------------- + + SUBROUTINE edd_mart(ECL) +! IMPLICIT NONE + use comm_momo + use calc_data + + double precision ecl +!c! csig = sigiso(itypi,itypj) + w1 = wqdipmart(1,itypi,itypj) + w2 = wqdipmart(2,itypi,itypj) +! w2=0.0d0 +!c!------------------------------------------------------------------- +!c! ECL +! print *,"om1",om1,om2,om12 + fac = - 3.0d0 * om1 !after integer and simplify + c1 = (w1 / (Rhead**3.0d0)) * fac + c2 = (w2 / Rhead ** 6.0d0) & + * (4.0d0 + 6.0d0*sqom1 ) !after integration and simplifimartion + ECL = c1 - c2 +!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 + 6.0d0*sqom1) + dGCLdR = (c1 - c2)*sss_ele_cut +!c! dECL/dom1 + c1 = (-3.0d0 * w1) / (Rhead**3.0d0) + c2 = (12.0d0 * w2*om1) / (Rhead**6.0d0) + dGCLdOM1 = c1 - c2 +!c! dECL/dom2 +! c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0) + c1=0.0 ! this is because om2 is 0 +! c2 = (-6.0d0 * w2) / (Rhead**6.0d0) & +! * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 ) + c2=0.0 !om is 0 + dGCLdOM2 = c1 - c2 +!c! dECL/dom12 +! c1 = w1 / (Rhead ** 3.0d0) + c1=0.0d0 ! this is because om12 is 0 +! c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 + c2=0.0d0 !om12 is 0 + 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) ) - 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 + pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres)) + gradpepmartx(k,i) = gradpepmartx(k,i) - dGCLdR * pom& + -ecl*sss_ele_grad*rij*rreal(k) +! pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) +! gradpepmartx(k,j) = gradpepmartx(k,j) + dGCLdR * pom + gradpepmart(k,i) = gradpepmart(k,i) - dGCLdR * erhead(k)& + -ecl*sss_ele_grad*rij*rreal(k) - 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) + gradpepmart(k,j) = gradpepmart(k,j) + dGCLdR * erhead(k)& + +ecl*sss_ele_grad*rij*rreal(k) END DO RETURN - END SUBROUTINE edq - SUBROUTINE edd(ECL) + END SUBROUTINE edd_mart + SUBROUTINE edd_mart_pep(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) + w1 = wqdipmart(1,itypi,itypj) + w2 = wqdipmart(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)) + * (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 + * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2)) + dGCLdR = (c1 - c2)*sss_ele_cut !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 ) + * ( 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 ) + * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 ) dGCLdOM2 = c1 - c2 + dGCLdOM2=0.0d0 ! this is because om2=0 !c! dECL/dom12 c1 = w1 / (Rhead ** 3.0d0) c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0 dGCLdOM12 = c1 - c2 + dGCLdOM12=0.0d0 !this is because om12=0.0 !c!------------------------------------------------------------------- !c! Return the results !c! (see comments in Eqq) DO k= 1, 3 - erhead(k) = Rhead_distance(k)/Rhead + erhead(k) = Rhead_distance(k)/Rhead END DO - erdxi = scalar( erhead(1), dC_norm(1,i+nres) ) + erdxi = scalar( erhead(1), dC_norm(1,i) ) erdxj = scalar( erhead(1), dC_norm(1,j+nres) ) - facd1 = d1 * vbld_inv(i+nres) + facd1 = d1 * vbld_inv(i) 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 + pom = facd1*(erhead(k)-erdxi*dC_norm(k,i)) + gradpepmart(k,i) = gradpepmart(k,i) + dGCLdR * pom + gradpepmart(k,i+1) = gradpepmart(k,i+1) - dGCLdR * pom +! pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres)) +! gradpepmartx(k,j) = gradpepmartx(k,j) + dGCLdR * pom + + gradpepmart(k,i) = gradpepmart(k,i) - dGCLdR * erhead(k)*0.5d0& + -ECL*sss_ele_grad*rreal(k)*rij + gradpepmart(k,i+1) = gradpepmart(k,i+1)- dGCLdR * erhead(k)*0.5d0& + -ECL*sss_ele_grad*rreal(k)*rij + + gradpepmart(k,j) = gradpepmart(k,j) + dGCLdR * erhead(k)& + +ECL*sss_ele_grad*rreal(k)*rij - 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 + END SUBROUTINE edd_mart_pep + + SUBROUTINE elgrad_init_mart(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,1) + itypj = itype(j,4) +! print *,"in elegrad",i,j,itypi,itypj !c! 1/(Gas Constant * Thermostate temperature) = BetaT !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!! !c! t_bath = 300 @@ -25800,69 +34263,58 @@ 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 + sig0ij = sigmamart( itypi,itypj ) + chi1 = chi1mart( itypi, itypj ) + chi2 = 0.0d0 + chi12 = 0.0d0 + chip1 = chipp1mart( 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 -!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 ) + dxj = 0.0d0 !dc_norm( 1, nres+j ) + dyj = 0.0d0 !dc_norm( 2, nres+j ) + dzj = 0.0d0 !dc_norm( 3, nres+j ) +! print *,"before dheadmart" !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) + d1 = dheadmart(1, 1, itypi, itypj) + d2 = dheadmart(2, 1, itypi, itypj) !c! ai*aj from Fgb - a12sq = rborn(itypi,itypj) * rborn(itypj,itypi) + a12sq = rborn1mart(itypi,itypj) * rborn2mart(itypi,itypj) !c! a12sq = a12sq * a12sq !c! charge of amino acid itypi is... +! print *,"after dheadmart" Qi = icharge(itypi) - Qj = icharge(itypj) + Qj = ichargelipid(itypj) Qij = Qi * Qj +! print *,"after icharge" + !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 + chis1 = chis1mart(itypi,itypj) + chis2 = 0.0d0 + chis12 = 0.0d0 + sig1 = sigmap1mart(itypi,itypj) + sig2 = sigmap2mart(itypi,itypj) +! print *,"before alphasurmart" !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) + b1cav = alphasurmart(1,itypi,itypj) + b2cav = alphasurmart(2,itypi,itypj) + b3cav = alphasurmart(3,itypi,itypj) + b4cav = alphasurmart(4,itypi,itypj) + wqd = wquadmart(itypi, itypj) +! print *,"after alphasurmar n wquad" !c! used by Fgb - eps_in = epsintab(itypi,itypj) + eps_in = epsintabmart(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 +!c! tail lomartion 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) + ctail(k,1)=c(k,i+nres)-dtailmart(1,itypi,itypj)*dc_norm(k,nres+i) + ctail(k,2)=c(k,j)!-dtailmart(2,itypi,itypj)*dc_norm(k,nres+j) END DO !c! tail distances will be themselves usefull elswhere !c1 (in Gcav, for example) @@ -25870,32 +34322,32 @@ 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))) + (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! Calculate lomartion 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) + d1 = dheadmart(1, 1, itypi, itypj) + d2 = dheadmart(2, 1, itypi, itypj) DO k = 1,3 -!c! location of polar head is computed by taking hydrophobic centre +!c! lomartion 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! see unres publimartions 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) + 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))) + (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 @@ -25910,5 +34362,198 @@ dPOLdOM1 = 0.0d0 dPOLdOM2 = 0.0d0 RETURN - END SUBROUTINE elgrad_init + END SUBROUTINE elgrad_init_mart + + SUBROUTINE elgrad_init_mart_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,4) +!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 = sigmamart( itypi,itypj ) + chi1 = chi1mart( itypi, itypj ) + chi2 = 0.0d0 + chi12 = 0.0d0 + chip1 = chipp1mart( 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 = dheadmart(1, 1, itypi, itypj) + d2 = dheadmart(2, 1, itypi, itypj) +!c! ai*aj from Fgb + a12sq = rborn1mart(itypi,itypj) * rborn2mart(itypi,itypj) +!c! a12sq = a12sq * a12sq +!c! charge of amino acid itypi is... + Qi = 0 + Qj = ichargelipid(itypj) +! Qij = Qi * Qj +!c! chis1,2,12 + chis1 = chis1mart(itypi,itypj) + chis2 = 0.0d0 + chis12 = 0.0d0 + sig1 = sigmap1mart(itypi,itypj) + sig2 = sigmap2mart(itypi,itypj) +!c! alpha factors from Fcav/Gcav + b1cav = alphasurmart(1,itypi,itypj) + b2cav = alphasurmart(2,itypi,itypj) + b3cav = alphasurmart(3,itypi,itypj) + b4cav = alphasurmart(4,itypi,itypj) + wqd = wquadmart(itypi, itypj) +!c! used by Fgb + eps_in = epsintabmart(itypi,itypj) + eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out)) +!c!------------------------------------------------------------------- +!c! tail lomartion and distance calculations + Rtail = 0.0d0 + DO k = 1, 3 + ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailmart(1,itypi,itypj)*dc_norm(k,i) + ctail(k,2)=c(k,j)!-dtailmart(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 lomartion and distance between polar heads +!c! distance between heads +!c! for each one of our three dimensional space... + d1 = dheadmart(1, 1, itypi, itypj) + d2 = dheadmart(2, 1, itypi, itypj) + + DO k = 1,3 +!c! lomartion of polar head is computed by taking hydrophobic centre +!c! and moving by a d1 * dc_norm vector +!c! see unres publimartions 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_mart_pep + + subroutine sc_grad_mart + 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)) +! 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 + gradpepmartx(k,i)=gradpepmartx(k,i)-gg(k)*sss_ele_cut & + +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) & + +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss_ele_cut + +! 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 + gradpepmart(l,i)=gradpepmart(l,i)-gg(l)*sss_ele_cut + gradpepmart(l,j)=gradpepmart(l,j)+gg(l)*sss_ele_cut + enddo + end subroutine sc_grad_mart + + subroutine sc_grad_mart_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 +! write (iout,*) "gg",(gg(k),k=1,3) + + 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) + gradpepmart(k,i)= gradpepmart(k,i) +sss_ele_cut*(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) + gradpepmart(k,i+1)= gradpepmart(k,i+1) +sss_ele_cut*(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) + gradpepmart(k,j)=gradpepmart(k,j)+gg(k)*sss_ele_cut + enddo + end subroutine sc_grad_mart_pep end module energy