From fb31d9cf50bce06dbfae62c92c11f3e9c836f405 Mon Sep 17 00:00:00 2001 From: Cezary Czaplewski Date: Tue, 24 Mar 2020 08:01:06 +0100 Subject: [PATCH] src-HCD-5D update --- source/unres/src-HCD-5D/COMMON.CONTMAT | 39 + source/unres/src-HCD-5D/COMMON.CONTROL.org | 32 + source/unres/src-HCD-5D/COMMON.CORRMAT | 47 + source/unres/src-HCD-5D/COMMON.FRAG | 7 + source/unres/src-HCD-5D/COMMON.HOMOLOGY | 31 + source/unres/src-HCD-5D/COMMON.LAGRANGE | 15 + source/unres/src-HCD-5D/COMMON.LAGRANGE.5diag | 16 + .../unres/src-HCD-5D/COMMON.LANGEVIN.lang0.5diag | 16 + source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0.org | 11 + source/unres/src-HCD-5D/COMMON.LANGEVIN.org | 21 + source/unres/src-HCD-5D/COMMON.MD.org | 97 + source/unres/src-HCD-5D/COMMON.QRESTR | 23 + source/unres/src-HCD-5D/COMMON.SAXS | 6 + source/unres/src-HCD-5D/TODO.AFTER.CASP14 | 9 + source/unres/src-HCD-5D/cart2intgrad.F | 377 + source/unres/src-HCD-5D/cartder.F.org | 468 + source/unres/src-HCD-5D/cartder.F.orig | 314 + source/unres/src-HCD-5D/check_cartgrad.F | 179 + source/unres/src-HCD-5D/check_ecartint_CASC_NC.F | 256 + source/unres/src-HCD-5D/check_vecgrad.F | 83 + source/unres/src-HCD-5D/contact_cp.F | 1007 ++ .../unres/src-HCD-5D/energy_p_new_barrier.F.chuj |13471 +++++++++++++++++++ .../unres/src-HCD-5D/energy_p_new_barrier.F.safe |13539 ++++++++++++++++++++ source/unres/src-HCD-5D/fdiag.f | 316 + source/unres/src-HCD-5D/fdisy.f | 321 + source/unres/src-HCD-5D/gradient_p.F.new | 523 + source/unres/src-HCD-5D/gradient_p.F.org | 571 + source/unres/src-HCD-5D/gradient_p.F.org.debug | 574 + source/unres/src-HCD-5D/inform.f | 38 + source/unres/src-HCD-5D/iounit.f | 24 + source/unres/src-HCD-5D/keys.f | 28 + source/unres/src-HCD-5D/kinetic_CASC.F | 108 + source/unres/src-HCD-5D/kinetic_lesyng.F | 212 + source/unres/src-HCD-5D/kinetic_lesyng.F.safe | 109 + source/unres/src-HCD-5D/lbfgs.F | 434 + source/unres/src-HCD-5D/linmin.f | 32 + source/unres/src-HCD-5D/machpd.f | 8 + source/unres/src-HCD-5D/map.F | 99 + source/unres/src-HCD-5D/math.f | 40 + source/unres/src-HCD-5D/minima.f | 28 + source/unres/src-HCD-5D/moments.F | 723 ++ source/unres/src-HCD-5D/muca_md.F | 365 + source/unres/src-HCD-5D/optsave.f | 224 + source/unres/src-HCD-5D/optsave_dum.f | 7 + source/unres/src-HCD-5D/output.f | 36 + source/unres/src-HCD-5D/sc_minimize.F | 85 + source/unres/src-HCD-5D/scales.f | 24 + source/unres/src-HCD-5D/search.f | 360 + source/wham/src-HCD-5D/COMMON.CONTMAT | 39 + source/wham/src-HCD-5D/COMMON.CORRMAT | 47 + source/wham/src-HCD-5D/chainbuild.rrr | Bin 0 -> 20568 bytes .../src-HCD-5D/include_unres/COMMON.CONTACTS.safe | 71 + .../wham/src-HCD-5D/include_unres/COMMON.CONTMAT | 39 + .../wham/src-HCD-5D/include_unres/COMMON.CORRMAT | 47 + source/wham/src-HCD-5D/readpdb.unr | 513 + 55 files changed, 36109 insertions(+) create mode 100644 source/unres/src-HCD-5D/COMMON.CONTMAT create mode 100644 source/unres/src-HCD-5D/COMMON.CONTROL.org create mode 100644 source/unres/src-HCD-5D/COMMON.CORRMAT create mode 100644 source/unres/src-HCD-5D/COMMON.FRAG create mode 100644 source/unres/src-HCD-5D/COMMON.HOMOLOGY create mode 100644 source/unres/src-HCD-5D/COMMON.LAGRANGE create mode 100644 source/unres/src-HCD-5D/COMMON.LAGRANGE.5diag create mode 100644 source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0.5diag create mode 100644 source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0.org create mode 100644 source/unres/src-HCD-5D/COMMON.LANGEVIN.org create mode 100644 source/unres/src-HCD-5D/COMMON.MD.org create mode 100644 source/unres/src-HCD-5D/COMMON.QRESTR create mode 100644 source/unres/src-HCD-5D/COMMON.SAXS create mode 100644 source/unres/src-HCD-5D/MD_A-MTS.optrpt create mode 100644 source/unres/src-HCD-5D/TODO.AFTER.CASP14 create mode 100644 source/unres/src-HCD-5D/cart2intgrad.F create mode 100644 source/unres/src-HCD-5D/cartder.F.org create mode 100644 source/unres/src-HCD-5D/cartder.F.orig create mode 100644 source/unres/src-HCD-5D/check_cartgrad.F create mode 100644 source/unres/src-HCD-5D/check_ecartint_CASC_NC.F create mode 100644 source/unres/src-HCD-5D/check_vecgrad.F create mode 100644 source/unres/src-HCD-5D/contact_cp.F create mode 100644 source/unres/src-HCD-5D/energy_p_new-sep_barrier.optrpt create mode 100644 source/unres/src-HCD-5D/energy_p_new_barrier.F.chuj create mode 100644 source/unres/src-HCD-5D/energy_p_new_barrier.F.safe create mode 100644 source/unres/src-HCD-5D/energy_p_new_barrier.optrpt create mode 100644 source/unres/src-HCD-5D/fdiag.f create mode 100644 source/unres/src-HCD-5D/fdisy.f create mode 100644 source/unres/src-HCD-5D/gradient_p.F.new create mode 100644 source/unres/src-HCD-5D/gradient_p.F.org create mode 100644 source/unres/src-HCD-5D/gradient_p.F.org.debug create mode 100644 source/unres/src-HCD-5D/gradient_p.optrpt create mode 100644 source/unres/src-HCD-5D/inform.f create mode 100644 source/unres/src-HCD-5D/iounit.f create mode 100644 source/unres/src-HCD-5D/keys.f create mode 100644 source/unres/src-HCD-5D/kinetic_CASC.F create mode 100644 source/unres/src-HCD-5D/kinetic_lesyng.F create mode 100644 source/unres/src-HCD-5D/kinetic_lesyng.F.safe create mode 100644 source/unres/src-HCD-5D/lagrangian_lesyng.optrpt create mode 100644 source/unres/src-HCD-5D/lbfgs.F create mode 100644 source/unres/src-HCD-5D/linmin.f create mode 100644 source/unres/src-HCD-5D/machpd.f create mode 100644 source/unres/src-HCD-5D/map.F create mode 100644 source/unres/src-HCD-5D/math.f create mode 100644 source/unres/src-HCD-5D/minima.f create mode 100644 source/unres/src-HCD-5D/moments.F create mode 100644 source/unres/src-HCD-5D/muca_md.F create mode 100644 source/unres/src-HCD-5D/optsave.f create mode 100644 source/unres/src-HCD-5D/optsave_dum.f create mode 100644 source/unres/src-HCD-5D/output.f create mode 100644 source/unres/src-HCD-5D/sc_minimize.F create mode 100644 source/unres/src-HCD-5D/scales.f create mode 100644 source/unres/src-HCD-5D/search.f create mode 100644 source/wham/src-HCD-5D/COMMON.CONTMAT create mode 100644 source/wham/src-HCD-5D/COMMON.CORRMAT create mode 100644 source/wham/src-HCD-5D/chainbuild.rrr create mode 100644 source/wham/src-HCD-5D/include_unres/COMMON.CONTACTS.safe create mode 100644 source/wham/src-HCD-5D/include_unres/COMMON.CONTMAT create mode 100644 source/wham/src-HCD-5D/include_unres/COMMON.CORRMAT create mode 100644 source/wham/src-HCD-5D/module create mode 100644 source/wham/src-HCD-5D/readpdb.unr diff --git a/source/unres/src-HCD-5D/COMMON.CONTMAT b/source/unres/src-HCD-5D/COMMON.CONTMAT new file mode 100644 index 0000000..e681360 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.CONTMAT @@ -0,0 +1,39 @@ +C Change 12/1/95 - common block CONTACTS1 included. + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + double precision gacontp_hb1,gacontp_hb2,gacontp_hb3,gacont_hbr, + & gacontm_hb1,gacontm_hb2,gacontm_hb3,grij_hb_cont,facont_hb, + & ees0p,ees0m,d_cont + integer num_cont_hb,jcont_hb + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +c 7/25/08 Commented out; not needed when cumulants used +C Interactions of pseudo-dipoles generated by loc-el interactions. +c double precision dip,dipderg,dipderx +c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), +c & dipderx(3,5,4,maxconts,maxres) +C 12/13/2008 (again Poland-Jaruzel war anniversary) +C RE: Parallelization of 4th and higher order loc-el correlations + integer ncont_sent,ncont_recv,iint_sent,iisent_local, + & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to, + & nat_sent,iat_sent,iint_sent_local + integer iturn3_sent,iturn4_sent,iturn3_sent_local, + & iturn4_sent_local + common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres), + & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres), + & nat_sent,iat_sent(maxres),itask_cont_from(0:max_fg_procs-1), + & itask_cont_to(0:max_fg_procs-1),ntask_cont_from,ntask_cont_to, + & iturn3_sent(4,maxres),iturn4_sent(4,maxres), + & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres) diff --git a/source/unres/src-HCD-5D/COMMON.CONTROL.org b/source/unres/src-HCD-5D/COMMON.CONTROL.org new file mode 100644 index 0000000..0a21e09 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.CONTROL.org @@ -0,0 +1,32 @@ + integer modecalc,iscode,indpdb,indback,indphi,iranconf,icheckgrad, + & inprint,i2ndstr,mucadyn,constr_dist,symetr,AFMlog,selfguide, + & shield_mode,tor_mode,tubelog,constr_homology,homol_nset, + & nsaxs,saxs_mode,iprint + logical minim,refstr,pdbref,outpdb,outmol2,overlapsc,energy_dec, + & mremd_dec,sideadd,lsecondary,read_cart,unres_pdb, + & vdisulf,searchsc,lmuca,dccart,extconf,out1file, + & gnorm_check,gradout,split_ene,with_theta_constr, + & with_dihed_constr,read2sigma,start_from_model,read_homol_frag, + & out_template_coord,out_template_restr + real*8 Psaxs(maxsaxs),distsaxs(maxsaxs),CSAXS(3,maxsaxs),wsaxs0, + & scal_rad, saxs_cutoff + real*8 waga_homology + real*8 waga_dist, waga_angle, waga_theta, waga_d, dist_cut, + & dist2_cut + double precision aincr + common /cntrl/ aincr,modecalc,iscode,indpdb,indback,indphi, + & iranconf, + & icheckgrad,minim,i2ndstr,refstr,pdbref,outpdb,outmol2,iprint, + & overlapsc,energy_dec,mremd_dec,sideadd,lsecondary,read_cart, + & unres_pdb,vdisulf,searchsc,lmuca,dccart,mucadyn,extconf,out1file, + & selfguide,AFMlog,shield_mode,tor_mode,tubelog, + & constr_dist,gnorm_check,gradout,split_ene,with_theta_constr, + & with_dihed_constr,symetr, + & constr_homology,homol_nset,read2sigma,start_from_model, + & read_homol_frag,out_template_coord,out_template_restr + common /homol/ waga_homology(maxprocs/20), + & waga_dist, waga_angle, waga_theta, waga_d, dist_cut,dist2_cut + common /saxsretr/Psaxs,distsaxs,csaxs,Wsaxs0,scal_rad,saxs_cutoff, + & nsaxs,saxs_mode +C... minim = .true. means DO minimization. +C... energy_dec = .true. means print energy decomposition matrix diff --git a/source/unres/src-HCD-5D/COMMON.CORRMAT b/source/unres/src-HCD-5D/COMMON.CORRMAT new file mode 100644 index 0000000..5f154e0 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.CORRMAT @@ -0,0 +1,47 @@ +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,gmu,gUb2, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der, + & gtEug + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres), + & gmu(2,maxres),gUb2(2,maxres), + & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres), + & Dtobr2(2,maxres),Dtobr2der(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),gtEUg(2,2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder,Ug2DtEUg,Ug2DtEUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), + & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont,EAEA,EAEAderg,EAEAderx, + & ADtEA1,AdTEA1derg,ADtEA1derx + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/unres/src-HCD-5D/COMMON.FRAG b/source/unres/src-HCD-5D/COMMON.FRAG new file mode 100644 index 0000000..f9e5385 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.FRAG @@ -0,0 +1,7 @@ + integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0, + 1 lvar_frag,svar_frag,avar_frag + COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3) + COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3), + 1 lvar_frag(mxio,3),svar_frag(mxio,3), + 2 avar_frag(mxio,5) + diff --git a/source/unres/src-HCD-5D/COMMON.HOMOLOGY b/source/unres/src-HCD-5D/COMMON.HOMOLOGY new file mode 100644 index 0000000..f19f0c6 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.HOMOLOGY @@ -0,0 +1,31 @@ +! General homology parameters + double precision waga_homology,waga_dist,waga_angle,waga_theta, + & waga_d,dist_cut,dist2_cut + common /homol/ waga_homology(maxprocs/20), + & waga_dist,waga_angle,waga_theta,waga_d,dist_cut,dist2_cut +! Restraint parameters + double precision odl(max_template,maxdim), + & sigma_odl(max_template,maxdim),dih(max_template,maxres), + & sigma_dih(max_template,maxres),sigma_odlir(max_template,maxdim) +! +! Specification of new variables used in subroutine e_modeller +! modified by FP (Nov.,2014) + double precision xxtpl(max_template,maxres), + & yytpl(max_template,maxres),zztpl(max_template,maxres), + & thetatpl(max_template,maxres),sigma_theta(max_template,maxres), + & sigma_d(max_template,maxres) +! + integer ires_homo(maxdim),jres_homo(maxdim), + & idomain(max_template,maxres),lim_odl,lim_dih,link_start_homo, + & link_end_homo,idihconstr_start_homo,idihconstr_end_homo + logical l_homo(max_template,maxdim) +! + common /homrestr/ odl,dih,sigma_dih,sigma_odl, + & lim_odl,lim_dih,ires_homo,jres_homo,link_start_homo, + & link_end_homo,idihconstr_start_homo,idihconstr_end_homo, + & idomain,l_homo +! +! FP (30/10/2014,04/03/2015) +! + common /homrestr_double/ + & xxtpl,yytpl,zztpl,thetatpl,sigma_theta,sigma_d,sigma_odlir diff --git a/source/unres/src-HCD-5D/COMMON.LAGRANGE b/source/unres/src-HCD-5D/COMMON.LAGRANGE new file mode 100644 index 0000000..7272b24 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.LAGRANGE @@ -0,0 +1,15 @@ + double precision IP,ISC(ntyp+1),mp,msc(ntyp+1), + & d_t_work(MAXRES6),d_t_work_new(MAXRES6),d_t(3,0:MAXRES2), + & d_t_new(3,0:MAXRES2),vtot(maxres2), + & d_af_work(MAXRES6),d_as_work(MAXRES6), + & d_t_old(3,0:MAXRES2),d_a_old(3,0:MAXRES2),d_a_short(3,0:MAXRES2), + & Gmat(MAXRES2,MAXRES2),Ginv(MAXRES2,MAXRES2),A(MAXRES2,MAXRES2), + & d_a(3,0:MAXRES2),d_a_work(6*MAXRES), + & Gsqrp(MAXRES2,MAXRES2),Gsqrm(MAXRES2,MAXRES2), + & Gvec(maxres2,maxres2),Geigen(maxres2) + integer dimen,dimen1,dimen3 + common /inertia/ IP,ISC,mp,MSC + common /lagrange/ d_t,d_t_old,d_t_new,d_t_work,d_t_work_new,d_a, + & d_a_old,d_a_work,d_af_work,d_as_work,d_a_short, + & A,Ginv,Gmat,Gvec,Geigen,Gsqrp,Gsqrm, + & vtot,dimen,dimen1,dimen3 diff --git a/source/unres/src-HCD-5D/COMMON.LAGRANGE.5diag b/source/unres/src-HCD-5D/COMMON.LAGRANGE.5diag new file mode 100644 index 0000000..52ec0c7 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.LAGRANGE.5diag @@ -0,0 +1,16 @@ + double precision IP,ISC(ntyp+1),mp,msc(ntyp+1), + & d_t_work(MAXRES6),d_t_work_new(MAXRES6),d_t(3,0:MAXRES2), + & d_t_new(3,0:MAXRES2),vtot(maxres2), + & d_af(3,maxres2),d_as(3,maxres2), + & d_af_work(MAXRES6),d_as_work(MAXRES6), + & d_t_old(3,0:MAXRES2),d_a_old(3,0:MAXRES2),d_a_short(3,0:MAXRES2), + & d_a(3,0:MAXRES2),d_a_work(6*MAXRES), + & DM(MAXRES2),DU1(MAXRES2),DU2(MAXRES2),DMorig(MAXRES2), + & DU1orig(MAXRES2),DU2orig(MAXRES2) + integer dimen,dimen1,dimen3,dimenp,dimen_chain,iposd_chain + common /inertia/ IP,ISC,mp,MSC + common /lagrange/ d_t,d_t_old,d_t_new,d_t_work,d_t_work_new,d_a, + & d_a_old,d_a_work,d_af,d_as,d_af_work,d_as_work,d_a_short, + & DM,DU1,DU2,DMorig,DU1orig,DU2orig, + & vtot,dimen,dimen1,dimen3,dimenp,dimen_chain(maxchain), + & iposd_chain(maxchain) diff --git a/source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0.5diag b/source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0.5diag new file mode 100644 index 0000000..85fa980 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0.5diag @@ -0,0 +1,16 @@ +! Basic Langevin dynamics parameters + logical surfarea + integer reset_fricmat + double precision scal_fric,rwat,etawat,gamp, + & gamsc(ntyp1),stdfp,stdfsc(ntyp),stdforcp(MAXRES), + & stdforcsc(MAXRES),pstok,restok(ntyp+1),cPoise,Rb + common /langevin/ pstok,restok,gamp,gamsc, + & stdfp,stdfsc,stdforcp,stdforcsc,rwat,etawat,scal_fric, + & cPoise,Rb,surfarea,reset_fricmat +! Variables used in Langevin dynamics calculations + double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), + & fric_work(MAXRES6),stoch_work(MAXRES6),fricgam(MAXRES6), + & DMfric(MAXRES2),DU1fric(MAXRES2),DU2fric(MAXRES2) + logical flag_stoch(0:maxflag_stoch) + common /langforc/ friction,stochforc,DMfric,DU1fric,DU2fric, + & fric_work,fricgam,stoch_work,flag_stoch diff --git a/source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0.org b/source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0.org new file mode 100644 index 0000000..354a0c4 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0.org @@ -0,0 +1,11 @@ + double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), + & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6), + & stoch_work(MAXRES6), + & fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2) + logical flag_stoch(0:maxflag_stoch) + common /langforc/ friction,stochforc, + & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1, + & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat, + & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1, + & vrand0_mat2,flag_stoch + common /langmat/ mt1,mt2,mt3 diff --git a/source/unres/src-HCD-5D/COMMON.LANGEVIN.org b/source/unres/src-HCD-5D/COMMON.LANGEVIN.org new file mode 100644 index 0000000..6a703e2 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.LANGEVIN.org @@ -0,0 +1,21 @@ + double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), + & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6), + & stoch_work(MAXRES6), + & fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2), + & pfric_mat(MAXRES2,MAXRES2),vfric_mat(MAXRES2,MAXRES2), + & afric_mat(MAXRES2,MAXRES2),prand_mat(MAXRES2,MAXRES2), + & vrand_mat1(MAXRES2,MAXRES2),vrand_mat2(MAXRES2,MAXRES2), + & pfric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), + & afric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), + & vfric0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), + & prand0_mat(MAXRES2,MAXRES2,0:maxflag_stoch), + & vrand0_mat1(MAXRES2,MAXRES2,0:maxflag_stoch), + & vrand0_mat2(MAXRES2,MAXRES2,0:maxflag_stoch), + & mt1(maxres2,maxres2),mt2(maxres2,maxres2),mt3(maxres2,maxres2) + logical flag_stoch(0:maxflag_stoch) + common /langforc/ friction,stochforc, + & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1, + & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat, + & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1, + & vrand0_mat2,flag_stoch + common /langmat/ mt1,mt2,mt3 diff --git a/source/unres/src-HCD-5D/COMMON.MD.org b/source/unres/src-HCD-5D/COMMON.MD.org new file mode 100644 index 0000000..8e3203e --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.MD.org @@ -0,0 +1,97 @@ + double precision gcart, gxcart, gradcag,gradxag + common /mdgrad/ gcart(3,0:MAXRES), gxcart(3,0:MAXRES), + & gradcag(3,MAXRES),gradxag(3,MAXRES) + integer dimen,dimen1, dimen3, ifrag(2,50,maxprocs/20), + & ipair(2,100,maxprocs/20),iset, + & mset(maxprocs/20),nset + logical loc_qlike,adaptive + double precision IP,ISC(ntyp+1),mp, + & msc(ntyp+1),d_t_work(MAXRES6), + & d_t_work_new(MAXRES6),d_t(3,0:MAXRES2),d_t_new(3,0:MAXRES2), + & d_af_work(MAXRES6),d_as_work(MAXRES6), + & d_t_old(3,0:MAXRES2),d_a_old(3,0:MAXRES2),d_a_short(3,0:MAXRES2), + & Gmat(MAXRES2,MAXRES2),Ginv(MAXRES2,MAXRES2),A(MAXRES2,MAXRES2), + & d_a(3,0:MAXRES2),d_a_work(6*MAXRES),kinetic_force(MAXRES6), + & Gsqrp(MAXRES2,MAXRES2),Gsqrm(MAXRES2,MAXRES2), + & vtot(MAXRES2),Gvec(maxres2,maxres2),Geigen(maxres2) + + real*8 odl(max_template,maxdim),sigma_odl(max_template,maxdim), + & dih(max_template,maxres),sigma_dih(max_template,maxres), + & sigma_odlir(max_template,maxdim) +c +c Specification of new variables used in subroutine e_modeller +c modified by FP (Nov.,2014) + real*8 xxtpl(max_template,maxres),yytpl(max_template,maxres), + & zztpl(max_template,maxres),thetatpl(max_template,maxres), + & sigma_theta(max_template,maxres), + & sigma_d(max_template,maxres) +c + + integer ires_homo(maxdim), + & jres_homo(maxdim),idomain(max_template,maxres) + + double precision v_ini,d_time,d_time0,t_bath,tau_bath, + & EK,potE,potEcomp(0:n_ene+8),totE,totT,amax,kinetic_T,dvmax,damax, + & edriftmax, + & eq_time,wfrag(50,maxprocs/20),wpair(100,maxprocs/20), + & qfrag(50),qpair(100), + & qinfrag(50,maxprocs/20),qinpair(100,maxprocs/20), + & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst, + & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES), + & utheta(maxfrag_back),ugamma(maxfrag_back),uscdiff(maxfrag_back), + & dutheta(maxres),dugamma(maxres),duscdiff(3,maxres), + & duscdiffx(3,maxres),wfrag_back(3,maxfrag_back,maxprocs/20), + & qloc(3,maxfrag_back), + & qin_back(3,maxfrag_back,maxprocs/20), + & uconst_back + integer n_timestep,ntwx,ntwe,lang,count_reset_moment, + & count_reset_vel,reset_fricmat,nfrag,npair,nfrag_back, + & ifrag_back(3,maxfrag_back,maxprocs/20),ntime_split,ntime_split0, + & maxtime_split,lim_odl,lim_dih,link_start_homo,link_end_homo, + & idihconstr_start_homo,idihconstr_end_homo + logical large,print_compon,tbf,rest,reset_moment,reset_vel, + & surfarea,rattle,usampl,mdpdb,RESPA,preminim, + & l_homo(max_template,maxdim) + integer igmult_start,igmult_end,my_ng_count,ng_start,ng_counts, + & nginv_start,nginv_counts,myginv_ng_count + common /back_constr/ uconst_back,utheta,ugamma,uscdiff, + & dutheta,dugamma,duscdiff,duscdiffx, + & qin_back,qloc,wfrag_back,nfrag_back,ifrag_back + + common /homrestr/ odl,dih,sigma_dih,sigma_odl, + & lim_odl,lim_dih,ires_homo,jres_homo,link_start_homo, + & link_end_homo,idihconstr_start_homo,idihconstr_end_homo, + & idomain,l_homo +c +c FP (30/10/2014,04/03/2015) +c + common /homrestr_double/ + & xxtpl,yytpl,zztpl,thetatpl,sigma_theta,sigma_d,sigma_odlir +c + common /qmeas/ qfrag,qpair,qinfrag,qinpair,wfrag,wpair,eq_time, + & Ucdfrag,Ucdpair,dUdconst,dUdxconst,dqwol,dxqwol,Uconst, + & iset,mset,nset,usampl,ifrag,ipair,npair,nfrag,loc_qlike,adaptive + common /mdpar/ v_ini,d_time,d_time0,scal_fric, + & t_bath,tau_bath,dvmax,damax,n_timestep,mdpdb, + & ntime_split,ntime_split0,maxtime_split, + & ntwx,ntwe,large,print_compon,tbf,rest,preminim + common /MDcalc/ totT,totE,potE,potEcomp,EK,amax,edriftmax, + & kinetic_T + common /lagrange/ d_t,d_t_old,d_t_new,d_t_work, + & d_t_work_new,d_a,d_a_old,d_a_work,d_af_work,d_as_work,d_a_short, + & kinetic_force, + & A,Ginv,Gmat,Gvec,Geigen,Gsqrp,Gsqrm, + & vtot,dimen,dimen1,dimen3,lang, + & reset_moment,reset_vel,count_reset_moment,count_reset_vel, + & rattle,RESPA + common /inertia/ IP,ISC,mp,MSC + double precision scal_fric,rwat,etawat,gamp, + & gamsc(ntyp1),stdfp,stdfsc(ntyp),stdforcp(MAXRES), + & stdforcsc(MAXRES),pstok,restok(ntyp+1),cPoise,Rb + common /langevin/ pstok,restok,gamp,gamsc, + & stdfp,stdfsc,stdforcp,stdforcsc,rwat,etawat,cPoise,Rb,surfarea, + & reset_fricmat + common /mdpmpi/ igmult_start,igmult_end,my_ng_count, + & myginv_ng_count, + & ng_start(0:MaxProcs-1),ng_counts(0:MaxProcs-1), + & nginv_start(0:MaxProcs),nginv_counts(0:MaxProcs-1) diff --git a/source/unres/src-HCD-5D/COMMON.QRESTR b/source/unres/src-HCD-5D/COMMON.QRESTR new file mode 100644 index 0000000..7f0c6ea --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.QRESTR @@ -0,0 +1,23 @@ +! Variables corresponding to umbrella sampling with restraints on Q and +! angles +! Q on interresidue distances + integer nfrag,npair,ifrag(2,50,maxprocs/20), + & ipair(2,100,maxprocs/20),iset,mset(maxprocs/20),nset + double precision eq_time,wfrag(50,maxprocs/20), + & wpair(100,maxprocs/20),qfrag(50),qpair(100), + & qinfrag(50,maxprocs/20),qinpair(100,maxprocs/20), + & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst, + & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES) + common /qmeas/ qfrag,qpair,qinfrag,qinpair,wfrag,wpair,eq_time, + & Ucdfrag,Ucdpair,dUdconst,dUdxconst,dqwol,dxqwol,Uconst, + & iset,mset,nset,ifrag,ipair,npair,nfrag +! Local restraints + double precision qloc(3,maxfrag_back),qin_back(3,maxfrag_back, + & maxprocs/20),uconst_back, + & utheta(maxfrag_back),ugamma(maxfrag_back),uscdiff(maxfrag_back), + & dutheta(maxres),dugamma(maxres),duscdiff(3,maxres), + & duscdiffx(3,maxres),wfrag_back(3,maxfrag_back,maxprocs/20) + integer nfrag_back,ifrag_back(3,maxfrag_back,maxprocs/20) + common /back_constr/ uconst_back,utheta,ugamma,uscdiff, + & dutheta,dugamma,duscdiff,duscdiffx, + & qin_back,qloc,wfrag_back,nfrag_back,ifrag_back diff --git a/source/unres/src-HCD-5D/COMMON.SAXS b/source/unres/src-HCD-5D/COMMON.SAXS new file mode 100644 index 0000000..26a48fb --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.SAXS @@ -0,0 +1,6 @@ +! SAXS restraint parameters + integer nsaxs,saxs_mode + double precision Psaxs(maxsaxs),distsaxs(maxsaxs), + & CSAXS(3,maxsaxs),wsaxs0,scal_rad,saxs_cutoff + common /saxsretr/Psaxs,distsaxs,csaxs,Wsaxs0,scal_rad,saxs_cutoff, + & nsaxs,saxs_mode diff --git a/source/unres/src-HCD-5D/MD_A-MTS.optrpt b/source/unres/src-HCD-5D/MD_A-MTS.optrpt new file mode 100644 index 0000000..e69de29 diff --git a/source/unres/src-HCD-5D/TODO.AFTER.CASP14 b/source/unres/src-HCD-5D/TODO.AFTER.CASP14 new file mode 100644 index 0000000..cacb8a0 --- /dev/null +++ b/source/unres/src-HCD-5D/TODO.AFTER.CASP14 @@ -0,0 +1,9 @@ +1. Replace SUMSL with LBFGS everywhere (currently only minim_ecart) +2. Parallelize the transformation of Cartesian derivatives to backbone-angle + derivatives (cart2int.F) +3. Parallelize usampl +4. HREMD +5. Fourbody interactions - eliminate pp-contact etc. storage (currently 4body + switched off by default, -DFOURBODY flag switches on). +6. Fix LBFGS - the linesearch (search) subroutine does not handle difficult + cases when changing variables can result in nans. diff --git a/source/unres/src-HCD-5D/cart2intgrad.F b/source/unres/src-HCD-5D/cart2intgrad.F new file mode 100644 index 0000000..d6da6bb --- /dev/null +++ b/source/unres/src-HCD-5D/cart2intgrad.F @@ -0,0 +1,377 @@ + subroutine cart2intgrad(n,g) +*********************************************************************** +* This subroutine thransforms the gradient in virtual-bond vectors to +* that in the backbone and side-chain angular variables. +* Adapted from the cartder subroutine. +* +* 03/11/20 Adam. Array fromto eliminated, computed on the fly +* Fixed the problem with vbld indices, which caused errors in +* derivatives when the backbone virtual bond lengths were not equal. +*********************************************************************** + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + integer n + double precision g(n) + double precision drt(3,3,maxres),rdt(3,3,maxres),dp(3,3), + &temp(3,3),prordt(3,3,maxres),prodrt(3,3,maxres) + 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 +* get the position of the jth ijth fragment of the chain coordinate system +* in the fromto array. +c integer indmat +c indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 +c call chainbuild_extconf +c call cartprint +c call intout + g=0.0d0 +* 3/13/20 Adam: Skip calculating backbone derivatives if SC only +* requested. + if (sideonly) goto 10 +* +* calculate the derivatives of transformation matrix elements in theta +* + 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 +* +* Calculate backbone derivatives. +* This code invlves N^2 effort and should be parallelized, to be done +* later. + ind1=0 + do i=1,nres-2 + ind1=ind1+1 +* +* Derivatives of DC(i+1) in theta(i+2) +* +c write (iout,*) "theta i",i +c write(iout,'(7hprod 9f10.5)')((prod(k,l,i),l=1,3),k=1,3) +c write(iout,'(7hrdt 9f10.5)')((rdt(k,l,i),l=1,3),k=1,3) +c write(iout,*) "vbld",vbld(i+2) + if (n.gt.nphi) then + + 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 +c dcdv(j,ind1)=vbld(i+2)*dp(j,1) + g(nphi+i)=g(nphi+i)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg) + enddo +c write(iout,'(7hdcdv 3f10.5)')(dcdv(k,ind1),k=1,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 +c dxdv(j,ind1)=rj +c write (iout,*) "1:i",i," j",i+1,"ind1",ind1," dxdthet",rj, +c & " gradx",gradx(j,i+1,icg) + g(nphi+i)=g(nphi+i)+rj*gradx(j,i+1,icg) + enddo +c write (iout,*) "dxdv",(dxdv(j,ind1),j=1,3) +* +* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently +* than the other off-diagonal derivatives. +* + 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 +c dxdv(j,ind1+1)=dxoiij +c write (iout,*) "2:i",i," j",i+1,"ind1",ind1+1, +c & " dxdthet",dxoiij," gradx",gradx(j,i+2,icg) + g(nphi+i)=g(nphi+i)+dxoiij*gradx(j,i+2,icg) + enddo + endif +c write(iout,*)ind1+1,(dxdv(j,ind1+1),j=1,3) + + endif +* +* Derivatives of DC(i+1) in phi(i+2) +* + 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 +c dcdv(j+3,ind1)=vbld(i+2)*dp(j,1) + g(i-1)=g(i-1)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg) + enddo + endif +* +* 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) + 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 +c dxdv(j+3,ind1)=-rj +c write (iout,*) "1:i",i," j",i+1,"ind1",ind1," dxdphi",-rj, +c & " gradx",gradx(j,i+1,icg) + g(i-1)=g(i-1)-rj*gradx(j,i+1,icg) + enddo + endif +* +* Derivatives of SC(i+1) in phi(i+3). +* + 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 +c dxdv(j+3,ind1+1)=dxoiij + g(i-1)=g(i-1)+dxoiij*gradx(j,i+2,icg) +c write (iout,*) "2:i",i," j",i+2," ind1",ind1+1, +c & " dxdphi",dxoiij," gradx",gradx(j,i+2,icg) + enddo + endif +* +* 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 +c ind=indmat(i+1,j+1) +c write(iout,*)'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 + 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 + 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 +c write(iout,'(7hfromto 9f10.5)')((fromto(k,l,ind),l=1,3),k=1,3) +c write(iout,'(7hprod 9f10.5)')((prod(k,l,i),l=1,3),k=1,3) +c write(iout,'(7htemp 9f10.5)')((temp(k,l),l=1,3),k=1,3) + if (n.gt.nphi) then +* Derivatives of virtual-bond vectors in theta + do k=1,3 +c dcdv(k,ind1)=vbld(j+2)*temp(k,1) + g(nphi+i)=g(nphi+i)+vbld(j+2)*temp(k,1)*gradc(k,j+1,icg) + enddo +c write(iout,'(7hdcdv 3f10.5)')(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 +c dxdv(k,ind1+1)=dxoijk +c write (iout,*) "3:i",i+1," j",j+2,"ind1",ind1+1, +c & " dxdthet",dxoijk," gradx",gradx(k,j+2,icg) + g(nphi+i)=g(nphi+i)+dxoijk*gradx(k,j+2,icg) + enddo +c write(iout,'(7htheta 3f10.5)')(dxdv(k,ind1),k=1,3) + endif +* +*--- 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) + enddo + temp(k,l)=tempkl + enddo + enddo + if (i.gt.1) then + do k=1,3 +c dcdv(k+3,ind1)=vbld(j+2)*temp(k,1) + 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 +c dxdv(k+3,ind1+1)=dxoijk + g(i-1)=g(i-1)+dxoijk*gradx(k,j+2,icg) +c write (iout,*) "3:i",i," j",j+2," ind1",ind1+1, +c & " dxdphi",dxoijk," gradx",gradx(k,j+2,icg) + enddo + endif + enddo + enddo + + if (nvar.le.nphi+ntheta) return + + 10 continue +* +* Derivatives in alpha and omega: +* + do i=2,nres-1 + if (iabs(itype(i)).eq.10 .or. itype(i).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 +cd 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 +cd 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 +c dxds(jjj+k,i)=dj + aux(jjj+k)=dj + enddo + jjj=jjj+3 + enddo + 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 +c----------------------------------------------------------------------------- + subroutine build_fromto(i,j,fromto) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + 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 +* +c write (iout,*) "temp on entry" +c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3) +c do i=2,nres-2 +c ind=indmat(i,i+1) + if (j.eq.i+1) then + 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)=temp(k,l) + enddo + enddo + else +c do j=i+1,nres-2 +c 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 + enddo + do k=1,3 + do l=1,3 + temp(k,l)=dp(k,l) + enddo + enddo + endif +c write (iout,*) "temp upon exit" +c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3) +c enddo +c enddo + return + end diff --git a/source/unres/src-HCD-5D/cartder.F.org b/source/unres/src-HCD-5D/cartder.F.org new file mode 100644 index 0000000..38aec9e --- /dev/null +++ b/source/unres/src-HCD-5D/cartder.F.org @@ -0,0 +1,468 @@ + 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 none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + double precision drt(3,3,maxres),rdt(3,3,maxres),dp(3,3), + &temp(3,3),prordt(3,3,maxres),prodrt(3,3,maxres) + 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 +#ifdef FIVEDIAG + double precision fromto(3,3) +#else + double precision fromto(3,3,maxdim) +c common /przechowalnia/ fromto +#endif + integer i,ii,j,jjj,k,l,m,indi,ind,ind1 +* get the position of the jth ijth fragment of the chain coordinate system +* in the fromto array. + integer indmat + indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 + call chainbuild_extconf + call cartprint + call intout +* +* calculate the derivatives of transformation matrix elements in theta +* + 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 +#ifndef FIVEDIAG +* +* 3/10/2020 Adam: The fromto array to be created only for smaller +* systems; for large ones its elements to be calculated on the fly. +* +* generate the matrix products of type r(i)t(i)...r(j)t(j) +* + do i=2,nres-2 + ind=indmat(i,i+1) + write(iout,*) i,i+1,ind + 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 +c write(iout,'(7hfromto 9f10.5)')((fromto(k,l,ind),l=1,3),k=1,3) + do j=i+1,nres-2 + ind=indmat(i,j+1) + write(iout,*) i,j+1,ind +c write(iout,'(7htemp 9f10.5)')((temp(k,l),l=1,3),k=1,3) +c write(iout,'(7hrt 9f10.5)')((rt(k,l,j),l=1,3),k=1,3) + 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 +c write(iout,'(7hfromto 9f10.5)')((fromto(k,l,ind),l=1,3),k=1,3) + do k=1,3 + do l=1,3 + temp(k,l)=dp(k,l) + enddo + enddo + enddo + enddo +#endif +* +* Calculate derivatives. +* + ind1=0 + do i=1,nres-2 + ind1=ind1+1 +* +* Derivatives of DC(i+1) in theta(i+2) +* +c write (iout,*) "theta i",i +c write(iout,'(7hprod 9f10.5)')((prod(k,l,i),l=1,3),k=1,3) +c write(iout,'(7hrdt 9f10.5)')((rdt(k,l,i),l=1,3),k=1,3) +c write(iout,*) "vbld",vbld(i+2) + do j=1,3 + do k=1,2 + dpjk=0.0D0 + do l=1,3 + dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) + enddo + dp(j,k)=dpjk + prordt(j,k,i)=dp(j,k) + enddo + dp(j,3)=0.0D0 +c dcdv(j,ind1)=vbld(i+1)*dp(j,1) + dcdv(j,ind1)=vbld(i+2)*dp(j,1) + enddo +c write(iout,'(7hdcdv 3f10.5)')(dcdv(k,ind1),k=1,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 +c write (iout,*) "dxdv",(dxdv(j,ind1),j=1,3) +* +* 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 +c write(iout,*)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 +c dcdv(j+3,ind1)=vbld(i+1)*dp(j,1) + dcdv(j+3,ind1)=vbld(i+2)*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) +#ifdef FIVEDIAG +c write(iout,*)'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 + 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 + 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 +#else + 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 +#endif +c write(iout,'(7hfromto 9f10.5)')((fromto(k,l,ind),l=1,3),k=1,3) +c write(iout,'(7hprod 9f10.5)')((prod(k,l,i),l=1,3),k=1,3) +c write(iout,'(7htemp 9f10.5)')((temp(k,l),l=1,3),k=1,3) +* Derivatives of virtual-bond vectors in theta + do k=1,3 +c dcdv(k,ind1)=vbld(i+1)*temp(k,1) + dcdv(k,ind1)=vbld(j+2)*temp(k,1) + enddo +c write(iout,'(7hdcdv 3f10.5)')(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 +c write(iout,'(7htheta 3f10.5)')(dxdv(k,ind1),k=1,3) +* +*--- Calculate the derivatives in phi +* +#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 +#else + 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 +#endif + do k=1,3 +c dcdv(k+3,ind1)=vbld(i+1)*temp(k,1) + dcdv(k+3,ind1)=vbld(j+2)*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 +#ifdef DEBUG + write (iout,*) + write (iout,'(a)') '****************** ddc/dtheta' + write (iout,*) + do i=1,nres-2 + do j=i+1,nres-1 + ii = indmat(i,j) + write (iout,'(2i4,3e14.6)') i,j,(dcdv(k,ii),k=1,3) + enddo + enddo + write (iout,*) + write (iout,'(a)') '******************* ddc/dphi' + write (iout,*) + do i=1,nres-3 + do j=i+2,nres-1 + ii = indmat(i+1,j) + write (iout,'(2i4,3e14.6)') i,j,(dcdv(k+3,ii),k=1,3) + write (iout,'(a)') + enddo + enddo + write (iout,'(a)') + write (iout,'(a)') '**************** dx/dtheta' + write (iout,'(a)') + do i=3,nres + do j=i-1,nres-1 + ii = indmat(i-2,j) + write (iout,'(2i4,3e14.6)') i,j,(dxdv(k,ii),k=1,3) + enddo + enddo + write (iout,'(a)') + write (iout,'(a)') '***************** dx/dphi' + write (iout,'(a)') + do i=4,nres + do j=i-1,nres-1 + ii = indmat(i-2,j) + write (iout,'(2i4,3e14.6)') i,j,(dxdv(k+3,ii),k=1,3) + write(iout,'(a)') + enddo + enddo +#endif +* +* Derivatives in alpha and omega: +* + do i=2,nres-1 +c dsci=dsc(itype(i)) + dsci=vbld(i+nres) +#ifdef OSF + alphi=alph(i) + omegi=omeg(i) + if(alphi.ne.alphi) alphi=100.0 + if(omegi.ne.omegi) omegi=-100.0 +#else + alphi=alph(i) + omegi=omeg(i) +#endif +cd 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 +cd 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 +#ifdef FIVEDIAG + subroutine build_fromto(i,j,fromto) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + 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 +* +c write (iout,*) "temp on entry" +c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3) +c do i=2,nres-2 +c ind=indmat(i,i+1) + if (j.eq.i+1) then + 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)=temp(k,l) + enddo + enddo + else +c do j=i+1,nres-2 +c 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 + enddo + do k=1,3 + do l=1,3 + temp(k,l)=dp(k,l) + enddo + enddo + endif +c write (iout,*) "temp upon exit" +c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3) +c enddo +c enddo + return + end +#endif diff --git a/source/unres/src-HCD-5D/cartder.F.orig b/source/unres/src-HCD-5D/cartder.F.orig new file mode 100644 index 0000000..dd2b3f1 --- /dev/null +++ b/source/unres/src-HCD-5D/cartder.F.orig @@ -0,0 +1,314 @@ + 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' + dimension drt(3,3,maxres),rdt(3,3,maxres),dp(3,3),temp(3,3), + & fromto(3,3,maxdim),prordt(3,3,maxres),prodrt(3,3,maxres) + dimension xx(3),xx1(3) + common /przechowalnia/ fromto +* 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 the derivatives of transformation matrix elements in theta +* + do i=1,nres-2 + rdt(1,1,i)=-rt(1,2,i) + rdt(1,2,i)= rt(1,1,i) + rdt(1,3,i)= 0.0d0 + rdt(2,1,i)=-rt(2,2,i) + rdt(2,2,i)= rt(2,1,i) + rdt(2,3,i)= 0.0d0 + rdt(3,1,i)=-rt(3,2,i) + rdt(3,2,i)= rt(3,1,i) + rdt(3,3,i)= 0.0d0 + enddo +* +* derivatives in phi +* + do i=2,nres-2 + drt(1,1,i)= 0.0d0 + drt(1,2,i)= 0.0d0 + drt(1,3,i)= 0.0d0 + drt(2,1,i)= rt(3,1,i) + drt(2,2,i)= rt(3,2,i) + drt(2,3,i)= rt(3,3,i) + drt(3,1,i)=-rt(2,1,i) + drt(3,2,i)=-rt(2,2,i) + drt(3,3,i)=-rt(2,3,i) + enddo +* +* generate the matrix products of type r(i)t(i)...r(j)t(j) +* + do i=2,nres-2 + ind=indmat(i,i+1) + do k=1,3 + do l=1,3 + temp(k,l)=rt(k,l,i) + enddo + enddo + do k=1,3 + do l=1,3 + fromto(k,l,ind)=temp(k,l) + enddo + enddo + do j=i+1,nres-2 + ind=indmat(i,j+1) + do k=1,3 + do l=1,3 + dpkl=0.0d0 + do m=1,3 + dpkl=dpkl+temp(k,m)*rt(m,l,j) + enddo + dp(k,l)=dpkl + fromto(k,l,ind)=dpkl + enddo + enddo + do k=1,3 + do l=1,3 + temp(k,l)=dp(k,l) + enddo + enddo + enddo + enddo +* +* Calculate derivatives. +* + ind1=0 + do i=1,nres-2 + ind1=ind1+1 +* +* Derivatives of DC(i+1) in theta(i+2) +* + do j=1,3 + do k=1,2 + dpjk=0.0D0 + do l=1,3 + dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) + enddo + dp(j,k)=dpjk + prordt(j,k,i)=dp(j,k) + enddo + dp(j,3)=0.0D0 + dcdv(j,ind1)=vbld(i+1)*dp(j,1) + enddo +* +* Derivatives of SC(i+1) in theta(i+2) +* + xx1(1)=-0.5D0*xloc(2,i+1) + xx1(2)= 0.5D0*xloc(1,i+1) + do j=1,3 + xj=0.0D0 + do k=1,2 + xj=xj+r(j,k,i)*xx1(k) + enddo + xx(j)=xj + enddo + do j=1,3 + rj=0.0D0 + do k=1,3 + rj=rj+prod(j,k,i)*xx(k) + enddo + dxdv(j,ind1)=rj + enddo +* +* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently +* than the other off-diagonal derivatives. +* + do j=1,3 + dxoiij=0.0D0 + do k=1,3 + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) + enddo + dxdv(j,ind1+1)=dxoiij + enddo +cd 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) +cd 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 +cd print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) +cd print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) +cd 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 +cd 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 +c dsci=dsc(itype(i)) + dsci=vbld(i+nres) +#ifdef OSF + alphi=alph(i) + omegi=omeg(i) + if(alphi.ne.alphi) alphi=100.0 + if(omegi.ne.omegi) omegi=-100.0 +#else + alphi=alph(i) + omegi=omeg(i) +#endif +cd 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 +cd 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 + diff --git a/source/unres/src-HCD-5D/check_cartgrad.F b/source/unres/src-HCD-5D/check_cartgrad.F new file mode 100644 index 0000000..f8894d6 --- /dev/null +++ b/source/unres/src-HCD-5D/check_cartgrad.F @@ -0,0 +1,179 @@ + subroutine check_cartgrad +C Check the gradient of Cartesian coordinates in internal coordinates. + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.DERIV' + double precision temp(6,maxres),xx(3),gg(3),thet,theti,phii,alphi, + & omegi,aincr2 + integer indmat + integer i,ii,j,k + indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 + integer nf +* +* Check the gradient of the virtual-bond and SC vectors in the internal +* coordinates. +* + print '("Calling CHECK_ECART",1pd12.3)',aincr + write (iout,'("Calling CHECK_ECART",1pd12.3)') aincr + aincr2=0.5d0*aincr + call chainbuild_extconf + 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_extconf + 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_extconf + 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_extconf + 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_extconf + 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_extconf + do j=i-1,nres-1 + ii = indmat(i-2,j) +c 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_extconf + 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_extconf + do j=i-1,nres-1 + ii = indmat(i-2,j) +c 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_extconf + 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_extconf + do j=i+1,nres-1 + ii = indmat(i,j) +c 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_extconf + do j=i+2,nres-1 + ii = indmat(i+1,j) +c 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 diff --git a/source/unres/src-HCD-5D/check_ecartint_CASC_NC.F b/source/unres/src-HCD-5D/check_ecartint_CASC_NC.F new file mode 100644 index 0000000..51386f8 --- /dev/null +++ b/source/unres/src-HCD-5D/check_ecartint_CASC_NC.F @@ -0,0 +1,256 @@ + subroutine check_ecartint +! Check the gradient of the energy in Cartesian coordinates. + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CONTACTS' + include 'COMMON.MD' + include 'COMMON.LOCAL' + include 'COMMON.SPLITELE' + integer icall + common /srutu/ icall + double precision ggg(6),ggg1(6),cc(3),xx(3),ddc(3),ddx(3), + & x(maxvar),g(maxvar) + double precision dcnorm_safe(3),dxnorm_safe(3) + double precision grad_s(6,0:maxres),grad_s1(6,0:maxres) + double precision phi_temp(maxres),theta_temp(maxres), + & alph_temp(maxres),omeg_temp(maxres) + double precision ddc1(3),ddcn(3),dcnorm_safe1(3),dcnorm_safe2(3) + double precision energia(0:n_ene),energia1(0:n_ene) + integer uiparm(1) + double precision urparm(1) + double precision fdum + external fdum + integer i,j,k,nf + double precision etot,etot1,etot2,etot11,etot12,etot21,etot22 + double precision dist,alpha,beta + icg=1 + nf=0 + nfl=0 + call intout +! call intcartderiv +! call checkintcartgrad + call zerograd + aincr=1.0D-5 + write(iout,*) 'Calling CHECK_ECARTINT.' + nf=0 + icall=0 + write (iout,*) "Before geom_to_var" + call geom_to_var(nvar,x) + write (iout,*) "after geom_to_var" + write (iout,*) "split_ene ",split_ene + call flush(iout) + if (.not.split_ene) then + write(iout,*) 'Calling CHECK_ECARTINT if' + call etotal(energia) +!elwrite(iout,*) 'Calling CHECK_ECARTINT if' + etot=energia(0) + write (iout,*) "etot",etot + call enerprint(energia(0)) + call flush(iout) +!el call enerprint(energia) +!elwrite(iout,*) 'Calling CHECK_ECARTINT if' +c call flush(iout) +c write (iout,*) "enter cartgrad" +c call flush(iout) + call cartgrad +c Transform the gradient to the CA-SC basis + call grad_transform +!elwrite(iout,*) 'Calling CHECK_ECARTINT if' +c write (iout,*) "exit cartgrad" +c call flush(iout) + icall =1 +c do i=1,nres +c write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) +c enddo + do j=1,3 + grad_s(j,0)=gcart(j,0) + enddo +!elwrite(iout,*) 'Calling CHECK_ECARTINT if' + do i=1,nres + do j=1,3 + grad_s(j,i)=gcart(j,i) + grad_s(j+3,i)=gxcart(j,i) + enddo + enddo + else +c write(iout,*) 'Calling CHECK_ECARTIN else.' +!- split gradient check + call zerograd + call etotal_long(energia) + call enerprint(energia(0)) +!el call enerprint(energia) +c call flush(iout) +c write (iout,*) "enter cartgrad" +c call flush(iout) + call cartgrad +c Transform the gradient to CA-SC coordinates + call grad_transform +c write (iout,*) "exit cartgrad" +c call flush(iout) + icall =1 + write (iout,*) "longrange grad" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo + do j=1,3 + grad_s(j,0)=gcart(j,0) + enddo + do i=1,nres + do j=1,3 + grad_s(j,i)=gcart(j,i) + grad_s(j+3,i)=gxcart(j,i) + enddo + enddo + call zerograd + call etotal_short(energia) + call enerprint(energia(0)) + call flush(iout) +c write (iout,*) "enter cartgrad" +c call flush(iout) + call cartgrad +c write (iout,*) "exit cartgrad" +c call flush(iout) +c Transform the gradient to CA-SC basis + call grad_transform + icall =1 + write (iout,*) "shortrange grad" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo + do j=1,3 + grad_s1(j,0)=gcart(j,0) + enddo + do i=1,nres + do j=1,3 + grad_s1(j,i)=gcart(j,i) + grad_s1(j+3,i)=gxcart(j,i) + enddo + enddo + endif + write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors' +! do i=1,nres +c do i=nnt,nct + do i=1,nres + 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 etotal(energia1) + etot1=energia1(0) +c 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 etotal(energia1) + etot2=energia1(0) +c 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 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 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 diff --git a/source/unres/src-HCD-5D/check_vecgrad.F b/source/unres/src-HCD-5D/check_vecgrad.F new file mode 100644 index 0000000..5ddf421 --- /dev/null +++ b/source/unres/src-HCD-5D/check_vecgrad.F @@ -0,0 +1,83 @@ + subroutine check_vecgrad + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.VECTORS' + dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres) + dimension uyt(3,maxres),uzt(3,maxres) + dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3) + double precision delta /1.0d-7/ + call vec_and_deriv +cd do i=1,nres +crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i) +crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i) +crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i) +cd write(iout,'(2i5,2(3f10.5,5x))') i,1, +cd & (dc_norm(if90,i),if90=1,3) +cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3) +cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3) +cd write(iout,'(a)') +cd enddo + do i=1,nres + do j=1,2 + do k=1,3 + do l=1,3 + uygradt(l,k,j,i)=uygrad(l,k,j,i) + uzgradt(l,k,j,i)=uzgrad(l,k,j,i) + enddo + enddo + enddo + enddo + call vec_and_deriv + do i=1,nres + do j=1,3 + uyt(j,i)=uy(j,i) + uzt(j,i)=uz(j,i) + enddo + enddo + do i=1,nres +cd write (iout,*) 'i=',i + do k=1,3 + erij(k)=dc_norm(k,i) + enddo + do j=1,3 + do k=1,3 + dc_norm(k,i)=erij(k) + enddo + dc_norm(j,i)=dc_norm(j,i)+delta +c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))) +c do k=1,3 +c dc_norm(k,i)=dc_norm(k,i)/fac +c enddo +c write (iout,*) (dc_norm(k,i),k=1,3) +c write (iout,*) (erij(k),k=1,3) + call vec_and_deriv + do k=1,3 + uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta + uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta + uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta + uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta + enddo +c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') +c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3), +c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3) + enddo + do k=1,3 + dc_norm(k,i)=erij(k) + enddo +cd do k=1,3 +cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') +cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3), +cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3) +cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') +cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3), +cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3) +cd write (iout,'(a)') +cd enddo + enddo + return + end diff --git a/source/unres/src-HCD-5D/contact_cp.F b/source/unres/src-HCD-5D/contact_cp.F new file mode 100644 index 0000000..f2101e6 --- /dev/null +++ b/source/unres/src-HCD-5D/contact_cp.F @@ -0,0 +1,1007 @@ + subroutine contact_cp(var,var2,iff,ieval,in_pdb) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.FRAG' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.MINIM' + + character*50 linia + integer nf,ij(4) + double precision energy(0:n_ene) + double precision var(maxvar),var2(maxvar) + double precision time0,time1 + integer iff(maxres),ieval + double precision theta1(maxres),phi1(maxres),alph1(maxres), + & omeg1(maxres) + logical debug + + debug=.false. +c debug=.true. + if (ieval.eq.-1) debug=.true. + + +c +c store selected dist. constrains from 1st structure +c +#ifdef OSF +c Intercept NaNs in the coordinates +c write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,nvar + x_sum=x_sum+var(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** contact_cp : Found NaN in coordinates" + call flush(iout) + print *," *** contact_cp : Found NaN in coordinates" + return + endif +#endif + + + call var_to_geom(nvar,var) + call chainbuild + nhpb0=nhpb + ind=0 + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if ( iff(i).eq.1.and.iff(j).eq.1 ) then +c d0(ind)=DIST(i,j) +c w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=DIST(i,j) + else +c w(ind)=0.0 + endif + enddo + enddo + call hpb_partition + + do i=1,nres + theta1(i)=theta(i) + phi1(i)=phi(i) + alph1(i)=alph(i) + omeg1(i)=omeg(i) + enddo + +c +c freeze sec.elements from 2nd structure +c + do i=1,nres + mask_phi(i)=1 + mask_theta(i)=1 + mask_side(i)=1 + enddo + + call var_to_geom(nvar,var2) + call secondary2(debug) + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) +c mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) +c mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + else + do i=bfrag(4,j),bfrag(3,j) +c mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + endif + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) +c mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + enddo + mask_r=.true. + +c +c copy selected res from 1st to 2nd structure +c + + do i=1,nres + if ( iff(i).eq.1 ) then + theta(i)=theta1(i) + phi(i)=phi1(i) + alph(i)=alph1(i) + omeg(i)=omeg1(i) + endif + enddo + + if(debug) then +c +c prepare description in linia variable +c + iwsk=0 + nf=0 + if (iff(1).eq.1) then + iwsk=1 + nf=nf+1 + ij(nf)=1 + endif + do i=2,nres + if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then + iwsk=1 + nf=nf+1 + ij(nf)=i + endif + if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then + iwsk=0 + nf=nf+1 + ij(nf)=i-1 + endif + enddo + if (iff(nres).eq.1) then + nf=nf+1 + ij(nf)=nres + endif + + write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') + & "SELECT",ij(1)-1,"-",ij(2)-1, + & ",",ij(3)-1,"-",ij(4)-1 + + endif +c +c run optimization +c + call contact_cp_min(var,ieval,in_pdb,linia,debug) + + return + end + + subroutine contact_cp_min(var,ieval,in_pdb,linia,debug) +c +c input : theta,phi,alph,omeg,in_pdb,linia,debug +c output : var,ieval +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.FRAG' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.MINIM' + + character*50 linia + integer nf,ij(4) + double precision energy(0:n_ene) + double precision var(maxvar) + double precision time0,time1 + integer ieval,info(3) + logical debug,fail,check_var,reduce,change + + write(iout,'(a20,i6,a20)') + & '------------------',in_pdb,'-------------------' + + if (debug) then + call chainbuild + call write_pdb(1000+in_pdb,'combined structure',0d0) +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + endif + +c +c run optimization of distances +c +c uses d0(),w() and mask() for frozen 2D +c +ctest--------------------------------------------- +ctest NX=NRES-3 +ctest NY=((NRES-4)*(NRES-5))/2 +ctest call distfit(debug,5000) + + do i=1,nres + mask_side(i)=0 + enddo + + ipot01=ipot + maxmin01=maxmin + maxfun01=maxfun +c wstrain01=wstrain + wsc01=wsc + wscp01=wscp + welec01=welec + wvdwpp01=wvdwpp +c wang01=wang + wscloc01=wscloc + wtor01=wtor + wtor_d01=wtor_d + + ipot=6 + maxmin=2000 + maxfun=4000 +c wstrain=1.0 + wsc=0.0 + wscp=0.0 + welec=0.0 + wvdwpp=0.0 +c wang=0.0 + wscloc=0.0 + wtor=0.0 + wtor_d=0.0 + + call geom_to_var(nvar,var) +cde change=reduce(var) + if (check_var(var,info)) then + write(iout,*) 'cp_min error in input' + print *,'cp_min error in input' + return + endif + +cd call etotal(energy(0)) +cd call enerprint(energy(0)) +cd call check_eint + +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif +cdtest call minimize(etot,var,iretcode,nfun) +cdtest write(iout,*)'SUMSL return code is',iretcode,' eval SDIST',nfun +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + +cd call etotal(energy(0)) +cd call enerprint(energy(0)) +cd call check_eint + + do i=1,nres + mask_side(i)=1 + enddo + + ipot=ipot01 + maxmin=maxmin01 + maxfun=maxfun01 +c wstrain=wstrain01 + wsc=wsc01 + wscp=wscp01 + welec=welec01 + wvdwpp=wvdwpp01 +c wang=wang01 + wscloc=wscloc01 + wtor=wtor01 + wtor_d=wtor_d01 +ctest-------------------------------------------------- + + if(debug) then +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,a)')' Time for distfit ',time1-time0,' sec' + call write_pdb(2000+in_pdb,'distfit structure',0d0) + endif + + + ipot0=ipot + maxmin0=maxmin + maxfun0=maxfun + wstrain0=wstrain +c +c run soft pot. optimization +c with constrains: +c nhpb,ihpb(),jhpb(),forcon(),dhpb() and hpb_partition +c and frozen 2D: +c mask_phi(),mask_theta(),mask_side(),mask_r +c + ipot=6 + maxmin=2000 + maxfun=4000 + +cde change=reduce(var) +cde if (check_var(var,info)) write(iout,*) 'error before soft' +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + + write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, + & nfun/(time1-time0),' SOFT eval/s' + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(3000+in_pdb,'soft structure',etot) + endif +c +c run full UNRES optimization with constrains and frozen 2D +c the same variables as soft pot. optimizatio +c + ipot=ipot0 + maxmin=maxmin0 + maxfun=maxfun0 +c +c check overlaps before calling full UNRES minim +c + call var_to_geom(nvar,var) + call chainbuild + call etotal(energy(0)) +#ifdef OSF + write(iout,*) 'N7 ',energy(0) + if (energy(0).ne.energy(0)) then + write(iout,*) 'N7 error - gives NaN',energy(0) + endif +#endif + ieval=1 + if (energy(1).eq.1.0d20) then + write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw=1d20',energy(1) + call overlap_sc(fail) + if(.not.fail) then + call etotal(energy(0)) + ieval=ieval+1 + write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw after',energy(1) + else + mask_r=.false. + nhpb= nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + return + endif + endif + call flush(iout) +c +cdte time0=MPI_WTIME() +cde change=reduce(var) +cde if (check_var(var,info)) then +cde write(iout,*) 'error before mask dist' +cde call var_to_geom(nvar,var) +cde call chainbuild +cde call write_pdb(10000+in_pdb,'before mask dist',etot) +cde endif +cdte call minimize(etot,var,iretcode,nfun) +cdte write(iout,*)'SUMSL MASK DIST return code is',iretcode, +cdte & ' eval ',nfun +cdte ieval=ieval+nfun +cdte +cdte time1=MPI_WTIME() +cdte write (iout,'(a,f6.2,f8.2,a)') +cdte & ' Time for mask dist min.',time1-time0, +cdte & nfun/(time1-time0),' eval/s' +cdte call flush(iout) + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(4000+in_pdb,'mask dist',etot) + endif +c +c switch off freezing of 2D and +c run full UNRES optimization with constrains +c + mask_r=.false. +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif +cde change=reduce(var) +cde if (check_var(var,info)) then +cde write(iout,*) 'error before dist' +cde call var_to_geom(nvar,var) +cde call chainbuild +cde call write_pdb(11000+in_pdb,'before dist',etot) +cde endif + + call minimize(etot,var,iretcode,nfun) + +cde change=reduce(var) +cde if (check_var(var,info)) then +cde write(iout,*) 'error after dist',ico +cde call var_to_geom(nvar,var) +cde call chainbuild +cde call write_pdb(12000+in_pdb+ico*1000,'after dist',etot) +cde endif + write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun + ieval=ieval+nfun + +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for dist min.',time1-time0, + & nfun/(time1-time0),' eval/s' +cde call etotal(energy(0)) +cde write(iout,*) 'N7 after dist',energy(0) +c call flush(iout) + + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(in_pdb,linia,etot) + endif +c +c reset constrains +c + nhpb= nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + + return + end +c-------------------------------------------------------- + subroutine softreg + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.GEO' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.SBRIDGE' + include 'COMMON.FFIELD' + include 'COMMON.MINIM' + include 'COMMON.INTERACT' +c + include 'COMMON.FRAG' + integer iff(maxres) + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision var(maxvar) + integer ieval +c + logical debug,ltest,fail + character*50 linia +c + linia='test' + debug=.true. + in_pdb=0 + + + +c------------------------ +c +c freeze sec.elements +c + do i=1,nres + mask_phi(i)=1 + mask_theta(i)=1 + mask_side(i)=1 + iff(i)=0 + enddo + + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + else + do i=bfrag(4,j),bfrag(3,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + endif + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + enddo + mask_r=.true. + + + + nhpb0=nhpb +c +c store dist. constrains +c + do i=1,nres-3 + do j=i+3,nres + if ( iff(i).eq.1.and.iff(j).eq.1 ) then + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=0.1 + dhpb(nhpb)=DIST(i,j) + endif + enddo + enddo + call hpb_partition + + if (debug) then + call chainbuild + call write_pdb(100+in_pdb,'input reg. structure',0d0) + endif + + + ipot0=ipot + maxmin0=maxmin + maxfun0=maxfun + wstrain0=wstrain + wang0=wang +c +c run soft pot. optimization +c + ipot=6 + wang=3.0 + maxmin=2000 + maxfun=4000 + call geom_to_var(nvar,var) +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + + write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, + & nfun/(time1-time0),' SOFT eval/s' + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(300+in_pdb,'soft structure',etot) + endif +c +c run full UNRES optimization with constrains and frozen 2D +c the same variables as soft pot. optimizatio +c + ipot=ipot0 + wang=wang0 + maxmin=maxmin0 + maxfun=maxfun0 +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'SUMSL MASK DIST return code is',iretcode, + & ' eval ',nfun + ieval=nfun + +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)') + & ' Time for mask dist min.',time1-time0, + & nfun/(time1-time0),' eval/s' + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(400+in_pdb,'mask & dist',etot) + endif +c +c switch off constrains and +c run full UNRES optimization with frozen 2D +c + +c +c reset constrains +c + nhpb_c=nhpb + nhpb=nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + + +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'SUMSL MASK return code is',iretcode,' eval ',nfun + ieval=ieval+nfun + +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for mask min.',time1-time0, + & nfun/(time1-time0),' eval/s' + + + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(500+in_pdb,'mask 2d frozen',etot) + endif + + mask_r=.false. + + +c +c run full UNRES optimization with constrains and NO frozen 2D +c + + nhpb=nhpb_c + link_start=1 + link_end=nhpb + maxfun=maxfun0/5 + + do ico=1,5 + + wstrain=wstrain0/ico + +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,'(a10,f6.3,a14,i3,a6,i5)') + & ' SUMSL DIST',wstrain,' return code is',iretcode, + & ' eval ',nfun + ieval=nfun + +#ifdef MPI + time1=MPI_WTIME() +#else + time0=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)') + & ' Time for dist min.',time1-time0, + & nfun/(time1-time0),' eval/s' + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(600+in_pdb+ico,'dist cons',etot) + endif + + enddo +c + nhpb=nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + maxfun=maxfun0 + + +c + if (minim) then +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'------------------------------------------------' + write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, + & '+ DIST eval',ieval + +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, + & nfun/(time1-time0),' eval/s' + + + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(999,'full min',etot) + endif + + return + end + + + subroutine beta_slide(i1,i2,i3,i4,i5,ieval,ij) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.FRAG' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.FFIELD' + include 'COMMON.MINIM' + include 'COMMON.CHAIN' + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision var(maxvar) + integer jdata(5),isec(maxres) +c + jdata(1)=i1 + jdata(2)=i2 + jdata(3)=i3 + jdata(4)=i4 + jdata(5)=i5 + + call secondary2(.false.) + + do i=1,nres + isec(i)=0 + enddo + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + isec(i)=1 + enddo + do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) + isec(i)=1 + enddo + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + isec(i)=2 + enddo + enddo + +c +c cut strands at the ends +c + if (jdata(2)-jdata(1).gt.3) then + jdata(1)=jdata(1)+1 + jdata(2)=jdata(2)-1 + if (jdata(3).lt.jdata(4)) then + jdata(3)=jdata(3)+1 + jdata(4)=jdata(4)-1 + else + jdata(3)=jdata(3)-1 + jdata(4)=jdata(4)+1 + endif + endif + +cv call chainbuild +cv call etotal(energy(0)) +cv etot=energy(0) +cv write(iout,*) nnt,nct,etot +cv call write_pdb(ij*100,'first structure',etot) +cv write(iout,*) 'N16 test',(jdata(i),i=1,5) + +c------------------------ +c generate constrains +c + ishift=jdata(5)-2 + if(ishift.eq.0) ishift=-2 + nhpb0=nhpb + call chainbuild + do i=jdata(1),jdata(2) + isec(i)=-1 + if(jdata(4).gt.jdata(3))then + do j=jdata(3)+i-jdata(1)-2,jdata(3)+i-jdata(1)+2 + isec(j)=-1 +cd print *,i,j,j+ishift + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=1000.0 + dhpb(nhpb)=DIST(i,j+ishift) + enddo + else + do j=jdata(3)-i+jdata(1)+2,jdata(3)-i+jdata(1)-2,-1 + isec(j)=-1 +cd print *,i,j,j+ishift + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=1000.0 + dhpb(nhpb)=DIST(i,j+ishift) + enddo + endif + enddo + + do i=nnt,nct-2 + do j=i+2,nct + if(isec(i).gt.0.or.isec(j).gt.0) then +cd print *,i,j + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=0.1 + dhpb(nhpb)=DIST(i,j) + endif + enddo + enddo + + call hpb_partition + + call geom_to_var(nvar,var) + maxfun0=maxfun + wstrain0=wstrain + maxfun=4000/5 + + do ico=1,5 + + wstrain=wstrain0/ico + +cv time0=MPI_WTIME() + call minimize(etot,var,iretcode,nfun) + write(iout,'(a10,f6.3,a14,i3,a6,i5)') + & ' SUMSL DIST',wstrain,' return code is',iretcode, + & ' eval ',nfun + ieval=ieval+nfun +cv time1=MPI_WTIME() +cv write (iout,'(a,f6.2,f8.2,a)') +cv & ' Time for dist min.',time1-time0, +cv & nfun/(time1-time0),' eval/s' +cv call var_to_geom(nvar,var) +cv call chainbuild +cv call write_pdb(ij*100+ico,'dist cons',etot) + + enddo +c + nhpb=nhpb0 + call hpb_partition + wstrain=wstrain0 + maxfun=maxfun0 +c +cd print *,etot + wscloc0=wscloc + wscloc=10.0 + call sc_move(nnt,nct,100,100d0,nft_sc,etot) + wscloc=wscloc0 +cv call chainbuild +cv call etotal(energy(0)) +cv etot=energy(0) +cv call write_pdb(ij*100+10,'sc_move',etot) +cd call intout +cd print *,nft_sc,etot + + return + end + + subroutine beta_zip(i1,i2,ieval,ij) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.FRAG' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.FFIELD' + include 'COMMON.MINIM' + include 'COMMON.CHAIN' + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision var(maxvar) + character*10 test + +cv call chainbuild +cv call etotal(energy(0)) +cv etot=energy(0) +cv write(test,'(2i5)') i1,i2 +cv call write_pdb(ij*100,test,etot) +cv write(iout,*) 'N17 test',i1,i2,etot,ij + +c +c generate constrains +c + nhpb0=nhpb + nhpb=nhpb+1 + ihpb(nhpb)=i1 + jhpb(nhpb)=i2 + forcon(nhpb)=1000.0 + dhpb(nhpb)=4.0 + + call hpb_partition + + call geom_to_var(nvar,var) + maxfun0=maxfun + wstrain0=wstrain + maxfun=1000/5 + + do ico=1,5 + wstrain=wstrain0/ico +cv time0=MPI_WTIME() + call minimize(etot,var,iretcode,nfun) + write(iout,'(a10,f6.3,a14,i3,a6,i5)') + & ' SUMSL DIST',wstrain,' return code is',iretcode, + & ' eval ',nfun + ieval=ieval+nfun +cv time1=MPI_WTIME() +cv write (iout,'(a,f6.2,f8.2,a)') +cv & ' Time for dist min.',time1-time0, +cv & nfun/(time1-time0),' eval/s' +c do not comment the next line + call var_to_geom(nvar,var) +cv call chainbuild +cv call write_pdb(ij*100+ico,'dist cons',etot) + enddo + + nhpb=nhpb0 + call hpb_partition + wstrain=wstrain0 + maxfun=maxfun0 + +cv call etotal(energy(0)) +cv etot=energy(0) +cv write(iout,*) 'N17 test end',i1,i2,etot,ij + + + return + end +c---------------------------------------------------------------------------- + + subroutine write_pdb(npdb,titelloc,ee) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + character*50 titelloc1 + character*(*) titelloc + character*3 zahl + character*5 liczba5 + double precision ee + integer npdb,ilen + external ilen + + titelloc1=titelloc + lenpre=ilen(prefix) + if (npdb.lt.1000) then + call numstr(npdb,zahl) + open(ipdb,file=prefix(:lenpre)//'@@'//zahl//'.pdb') + else + if (npdb.lt.10000) then + write(liczba5,'(i1,i4)') 0,npdb + else + write(liczba5,'(i5)') npdb + endif + open(ipdb,file=prefix(:lenpre)//'@@'//liczba5//'.pdb') + endif + call pdbout(ee,titelloc1,ipdb) + close(ipdb) + return + end + diff --git a/source/unres/src-HCD-5D/energy_p_new-sep_barrier.optrpt b/source/unres/src-HCD-5D/energy_p_new-sep_barrier.optrpt new file mode 100644 index 0000000..e69de29 diff --git a/source/unres/src-HCD-5D/energy_p_new_barrier.F.chuj b/source/unres/src-HCD-5D/energy_p_new_barrier.F.chuj new file mode 100644 index 0000000..7d2b948 --- /dev/null +++ b/source/unres/src-HCD-5D/energy_p_new_barrier.F.chuj @@ -0,0 +1,13471 @@ + subroutine etotal(energia) + implicit none + include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" + double precision weights_(n_ene) + double precision time00 + integer ierror,ierr +#endif + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision energia(0:n_ene) + include 'COMMON.LOCAL' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.CONTROL' + include 'COMMON.TIME1' + include 'COMMON.SPLITELE' + include 'COMMON.TORCNSTR' + include 'COMMON.SAXS' + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6, + & eliptran,Eafmforce,Etube, + & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet + integer n_corr,n_corr1 +#ifdef MPI +c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, +c & " nfgtasks",nfgtasks + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +C FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (fg_rank.eq.0) then + call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) +c print *,"Processor",myrank," BROADCAST iorder" +C FG master sets up the WEIGHTS_ array which will be broadcast to the +C FG slaves as WEIGHTS array. + weights_(1)=wsc + weights_(2)=wscp + weights_(3)=welec + weights_(4)=wcorr + weights_(5)=wcorr5 + weights_(6)=wcorr6 + weights_(7)=wel_loc + weights_(8)=wturn3 + weights_(9)=wturn4 + weights_(10)=wturn6 + weights_(11)=wang + weights_(12)=wscloc + weights_(13)=wtor + weights_(14)=wtor_d + weights_(15)=wstrain + weights_(16)=wvdwpp + weights_(17)=wbond + weights_(18)=scal14 + weights_(21)=wsccor + weights_(22)=wtube + weights_(26)=wsaxs + weights_(28)=wdfa_dist + weights_(29)=wdfa_tor + weights_(30)=wdfa_nei + weights_(31)=wdfa_beta +C FG Master broadcasts the WEIGHTS_ array + call MPI_Bcast(weights_(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + else +C FG slaves receive the WEIGHTS array + call MPI_Bcast(weights(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + wsc=weights(1) + wscp=weights(2) + welec=weights(3) + wcorr=weights(4) + wcorr5=weights(5) + wcorr6=weights(6) + wel_loc=weights(7) + wturn3=weights(8) + wturn4=weights(9) + wturn6=weights(10) + wang=weights(11) + wscloc=weights(12) + wtor=weights(13) + wtor_d=weights(14) + wstrain=weights(15) + wvdwpp=weights(16) + wbond=weights(17) + scal14=weights(18) + wsccor=weights(21) + wtube=weights(22) + wsaxs=weights(26) + wdfa_dist=weights_(28) + wdfa_tor=weights_(29) + wdfa_nei=weights_(30) + wdfa_beta=weights_(31) + endif + time_Bcast=time_Bcast+MPI_Wtime()-time00 + time_Bcastw=time_Bcastw+MPI_Wtime()-time00 +c call chainbuild_cart + endif +#ifndef DFA + edfadis=0.0d0 + edfator=0.0d0 + edfanei=0.0d0 + edfabet=0.0d0 +#endif +c print *,'Processor',myrank,' calling etotal ipot=',ipot +c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct +#else +c if (modecalc.eq.12.or.modecalc.eq.14) then +c call int_from_cart1(.false.) +c endif +#endif +#ifdef TIMING + time00=MPI_Wtime() +#endif +C +C Compute the side-chain and electrostatic interaction energy +C +C print *,ipot + goto (101,102,103,104,105,106) ipot +C Lennard-Jones potential. + 101 call elj(evdw) +cd print '(a)','Exit ELJ' + goto 107 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk(evdw) + goto 107 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp(evdw) + goto 107 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb(evdw) +C print *,"bylem w egb" + goto 107 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv(evdw) + goto 107 +C Soft-sphere potential + 106 call e_softsphere(evdw) +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 107 continue +#ifdef DFA +C BARTEK for dfa test! + if (wdfa_dist.gt.0) then + call edfad(edfadis) + else + edfadis=0 + endif +c print*, 'edfad is finished!', edfadis + if (wdfa_tor.gt.0) then + call edfat(edfator) + else + edfator=0 + endif +c print*, 'edfat is finished!', edfator + if (wdfa_nei.gt.0) then + call edfan(edfanei) + else + edfanei=0 + endif +c print*, 'edfan is finished!', edfanei + if (wdfa_beta.gt.0) then + call edfab(edfabet) + else + edfabet=0 + endif +#endif +cmc +cmc Sep-06: egb takes care of dynamic ss bonds too +cmc +c if (dyn_ss) call dyn_set_nss + +c print *,"Processor",myrank," computed USCSC" +#ifdef TIMING + time01=MPI_Wtime() +#endif + call vec_and_deriv +#ifdef TIMING + time_vec=time_vec+MPI_Wtime()-time01 +#endif +C Introduction of shielding effect first for each peptide group +C the shielding factor is set this factor is describing how each +C peptide group is shielded by side-chains +C the matrix - shield_fac(i) the i index describe the ith between i and i+1 +C write (iout,*) "shield_mode",shield_mode + if (shield_mode.eq.1) then + call set_shield_fac + else if (shield_mode.eq.2) then + call set_shield_fac2 + endif +c print *,"Processor",myrank," left VEC_AND_DERIV" + if (ipot.lt.6) then +#ifdef SPLITELE + if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. + & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 + & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 + & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#else + if (welec.gt.0d0.or.wel_loc.gt.0d0.or. + & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 + & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 + & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#endif + call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) + else + ees=0.0d0 + evdw1=0.0d0 + eel_loc=0.0d0 + eello_turn3=0.0d0 + eello_turn4=0.0d0 + endif + else + write (iout,*) "Soft-spheer ELEC potential" +c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, +c & eello_turn4) + endif +c#ifdef TIMING +c time_enecalc=time_enecalc+MPI_Wtime()-time00 +c#endif +c print *,"Processor",myrank," computed UELEC" +C +C Calculate excluded-volume interaction energy between peptide groups +C and side chains. +C + if (ipot.lt.6) then + if(wscp.gt.0d0) then + call escp(evdw2,evdw2_14) + else + evdw2=0 + evdw2_14=0 + endif + else +c write (iout,*) "Soft-sphere SCP potential" + call escp_soft_sphere(evdw2,evdw2_14) + endif +c +c Calculate the bond-stretching energy +c + call ebond(estr) +C +C Calculate the disulfide-bridge and other energy and the contributions +C from other distance constraints. +cd write (iout,*) 'Calling EHPB' + call edis(ehpb) +cd print *,'EHPB exitted succesfully.' +C +C Calculate the virtual-bond-angle energy. +C + 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) +c print *,"Processor",myrank," computed UB" +C +C Calculate the SC local energy. +C +C print *,"TU DOCHODZE?" + call esc(escloc) +c print *,"Processor",myrank," computed USC" +C +C Calculate the virtual-bond torsional energy. +C +cd print *,'nterm=',nterm +C print *,"tor",tor_mode + if (wtor.gt.0.0d0) then + if (tor_mode.eq.0) then + call etor(etors) + else +C etor kcc is Kubo cumulant clustered rigorous attemp to derive the +C energy function + call etor_kcc(etors) + endif + else + etors=0.0d0 + endif + edihcnstr=0.0d0 + if (ndih_constr.gt.0) call etor_constr(edihcnstr) +c print *,"Processor",myrank," computed Utor" + if (constr_homology.ge.1) then + call e_modeller(ehomology_constr) +c print *,'iset=',iset,'me=',me,ehomology_constr, +c & 'Processor',fg_rank,' CG group',kolor, +c & ' absolute rank',MyRank + else + ehomology_constr=0.0d0 + endif +C +C 6/23/01 Calculate double-torsional energy +C + if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then + call etor_d(etors_d) + else + etors_d=0 + endif +c print *,"Processor",myrank," computed Utord" +C +C 21/5/07 Calculate local sicdechain correlation energy +C + if (wsccor.gt.0.0d0) then + call eback_sc_corr(esccor) + else + esccor=0.0d0 + endif +C print *,"PRZED MULIt" +c print *,"Processor",myrank," computed Usccorr" +C +C 12/1/95 Multi-body terms +C + n_corr=0 + n_corr1=0 + if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 + & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +c write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1, +c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 +c call flush(iout) + 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 +c write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6, +c & n_corr,n_corr1 +c call flush(iout) + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr, +c & n_corr1 +c call flush(iout) + endif +c print *,"Processor",myrank," computed Ucorr" +c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode + if (nsaxs.gt.0 .and. saxs_mode.eq.0) then + call e_saxs(Esaxs_constr) +c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr + else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then + call e_saxsC(Esaxs_constr) +c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr + else + Esaxs_constr = 0.0d0 + endif +C +C If performing constraint dynamics, call the constraint energy +C after the equilibration time +c if(usampl.and.totT.gt.eq_time) then +c write (iout,*) "usampl",usampl + if(usampl) then + call EconstrQ + if (loc_qlike) then + call Econstr_back_qlike + else + call Econstr_back + endif + else + Uconst=0.0d0 + Uconst_back=0.0d0 + endif +C 01/27/2015 added by adasko +C the energy component below is energy transfer into lipid environment +C based on partition function +C print *,"przed lipidami" + if (wliptran.gt.0) then + call Eliptransfer(eliptran) + endif +C print *,"za lipidami" + if (AFMlog.gt.0) then + call AFMforce(Eafmforce) + else if (selfguide.gt.0) then + call AFMvel(Eafmforce) + endif + if (TUBElog.eq.1) then +C print *,"just before call" + call calctube(Etube) + elseif (TUBElog.eq.2) then + call calctube2(Etube) + else + Etube=0.0d0 + endif + +#ifdef TIMING + time_enecalc=time_enecalc+MPI_Wtime()-time00 +#endif +c print *,"Processor",myrank," computed Uconstr" +#ifdef TIMING + time00=MPI_Wtime() +#endif +c +C Sum the energies +C + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(18)=evdw2_14 +#else + energia(2)=evdw2 + energia(18)=0.0d0 +#endif +#ifdef SPLITELE + energia(3)=ees + energia(16)=evdw1 +#else + energia(3)=ees+evdw1 + energia(16)=0.0d0 +#endif + energia(4)=ecorr + energia(5)=ecorr5 + energia(6)=ecorr6 + energia(7)=eel_loc + energia(8)=eello_turn3 + energia(9)=eello_turn4 + energia(10)=eturn6 + energia(11)=ebe + energia(12)=escloc + energia(13)=etors + energia(14)=etors_d + energia(15)=ehpb + energia(19)=edihcnstr + energia(17)=estr + energia(20)=Uconst+Uconst_back + energia(21)=esccor + energia(22)=eliptran + energia(23)=Eafmforce + energia(24)=ethetacnstr + energia(25)=Etube + energia(26)=Esaxs_constr + energia(27)=ehomology_constr + energia(28)=edfadis + energia(29)=edfator + energia(30)=edfanei + energia(31)=edfabet +c write (iout,*) "esaxs_constr",energia(26) +c Here are the energies showed per procesor if the are more processors +c per molecule then we sum it up in sum_energy subroutine +c print *," Processor",myrank," calls SUM_ENERGY" + call sum_energy(energia,.true.) +c write (iout,*) "After sum_energy: esaxs_constr",energia(26) + if (dyn_ss) call dyn_set_nss +c print *," Processor",myrank," left SUM_ENERGY" +#ifdef TIMING + time_sumene=time_sumene+MPI_Wtime()-time00 +#endif + return + end +c------------------------------------------------------------------------------- + subroutine sum_energy(energia,reduce) + implicit none + include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" + integer ierr + double precision time00 +#endif + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision energia(0:n_ene),enebuff(0:n_ene+1) + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.TIME1' + logical reduce + integer i + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6, + & eliptran,Eafmforce,Etube, + & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet + double precision Uconst,etot +#ifdef MPI + if (nfgtasks.gt.1 .and. reduce) then +#ifdef DEBUG + write (iout,*) "energies before REDUCE" + call enerprint(energia) + call flush(iout) +#endif + do i=0,n_ene + enebuff(i)=energia(i) + enddo + time00=MPI_Wtime() + call MPI_Barrier(FG_COMM,IERR) + time_barrier_e=time_barrier_e+MPI_Wtime()-time00 + time00=MPI_Wtime() + call MPI_Reduce(enebuff(0),energia(0),n_ene+1, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) +#ifdef DEBUG + write (iout,*) "energies after REDUCE" + call enerprint(energia) + call flush(iout) +#endif + time_Reduce=time_Reduce+MPI_Wtime()-time00 + endif + if (fg_rank.eq.0) then +#endif + evdw=energia(1) +#ifdef SCP14 + evdw2=energia(2)+energia(18) + evdw2_14=energia(18) +#else + evdw2=energia(2) +#endif +#ifdef SPLITELE + ees=energia(3) + evdw1=energia(16) +#else + ees=energia(3) + evdw1=0.0d0 +#endif + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eturn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + edihcnstr=energia(19) + estr=energia(17) + Uconst=energia(20) + esccor=energia(21) + eliptran=energia(22) + Eafmforce=energia(23) + ethetacnstr=energia(24) + Etube=energia(25) + esaxs_constr=energia(26) + ehomology_constr=energia(27) + edfadis=energia(28) + edfator=energia(29) + edfanei=energia(30) + edfabet=energia(31) +#ifdef SPLITELE + etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 + & +wang*ebe+wtor*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 + & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 + & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d + & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce + & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet +#else + etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) + & +wang*ebe+wtor*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 + & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 + & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d + & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran + & +Eafmforce + & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet +#endif + energia(0)=etot +c detecting NaNQ +#ifdef ISNAN +#ifdef AIX + if (isnan(etot).ne.0) energia(0)=1.0d+99 +#else + if (isnan(etot)) energia(0)=1.0d+99 +#endif +#else + i=0 +#ifdef WINPGI + idumm=proc_proc(etot,i) +#else + call proc_proc(etot,i) +#endif + if(i.eq.1)energia(0)=1.0d+99 +#endif +#ifdef MPI + endif +#endif + return + end +c------------------------------------------------------------------------------- + subroutine sum_gradient + implicit none + include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include 'mpif.h' + integer ierror,ierr + double precision time00,time01 +#endif + double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres), + & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres) + & ,gloc_scbuf(3,-1:maxres) + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.TIME1' + include 'COMMON.MAXGRAD' + include 'COMMON.SCCOR' + include 'COMMON.MD' + include 'COMMON.QRESTR' + integer i,j,k + double precision scalar + double precision 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,gradcorr6_max,gsccorr_max,gsccorrx_max +#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 DEBUG + write (iout,*) "sum_gradient gsaxsc, gsaxsx" + do i=0,nres + write (iout,'(i3,3e15.5,5x,3e15.5)') + & i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3) + enddo + call flush(iout) +#endif +#ifdef MPI +C FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (nfgtasks.gt.1 .and. fg_rank.eq.0) + & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif +C +C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient +C in virtual-bond-vector coordinates +C +#ifdef DEBUG +c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" +c do i=1,nres-1 +c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') +c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) +c enddo +c write (iout,*) "gel_loc_tur3 gel_loc_turn4" +c do i=1,nres-1 +c write (iout,'(i5,3f10.5,2x,f10.5)') +c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) +c enddo + write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc" + do i=1,nres + write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') + & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3), + & g_corr5_loc(i) + enddo + call flush(iout) +#endif +#ifdef DEBUG + write (iout,*) "gsaxsc" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(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) + & +wsaxs*gsaxsc(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) + & +wsaxs*gsaxsc(j,i) + enddo + enddo +#endif + do i=1,nct + do j=1,3 + gradbufc(j,i)=gradbufc(j,i)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(j,i) + enddo + enddo +#ifdef DEBUG + write (iout,*) "gradc from gradbufc" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3) + enddo + call flush(iout) +#endif +#ifdef MPI + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +#ifdef DEBUG + write (iout,*) "gradbufc before allreduce" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif + do i=0,nres + do j=1,3 + gradbufc_sum(j,i)=gradbufc(j,i) + enddo + enddo +c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, +c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) +c time_reduce=time_reduce+MPI_Wtime()-time00 +#ifdef DEBUG +c write (iout,*) "gradbufc_sum after allreduce" +c do i=1,nres +c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) +c enddo +c call flush(iout) +#endif +#ifdef TIMING +c time_allreduce=time_allreduce+MPI_Wtime()-time00 +#endif + do i=nnt,nres + do k=1,3 + gradbufc(k,i)=0.0d0 + enddo + enddo +#ifdef DEBUG + write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end + write (iout,*) (i," jgrad_start",jgrad_start(i), + & " jgrad_end ",jgrad_end(i), + & i=igrad_start,igrad_end) +#endif +c +c Obsolete and inefficient code; we can make the effort O(n) and, therefore, +c do not parallelize this part. +c +c do i=igrad_start,igrad_end +c do j=jgrad_start(i),jgrad_end(i) +c do k=1,3 +c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) +c enddo +c enddo +c enddo + do j=1,3 + gradbufc(j,nres-1)=gradbufc_sum(j,nres) + enddo + do i=nres-2,-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 +#ifdef DEBUG + write (iout,*) "gradbufc" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif + do i=-1,nres + do j=1,3 + gradbufc_sum(j,i)=gradbufc(j,i) + gradbufc(j,i)=0.0d0 + enddo + enddo + do j=1,3 + gradbufc(j,nres-1)=gradbufc_sum(j,nres) + enddo + do i=nres-2,-1,-1 + do j=1,3 + gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) + enddo + enddo +c do i=nnt,nres-1 +c do k=1,3 +c gradbufc(k,i)=0.0d0 +c enddo +c do j=i+1,nres +c do k=1,3 +c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) +c enddo +c enddo +c enddo +#ifdef DEBUG + write (iout,*) "gradbufc after summing" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif +#ifdef MPI + endif +#endif + do k=1,3 + gradbufc(k,nres)=0.0d0 + enddo + do i=-1,nct + do j=1,3 +#ifdef SPLITELE +C print *,gradbufc(1,13) +C print *,welec*gelc(1,13) +C print *,wel_loc*gel_loc(1,13) +C print *,0.5d0*(wscp*gvdwc_scpp(1,13)) +C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13) +C print *,wel_loc*gel_loc_long(1,13) +C print *,gradafm(1,13),"AFM" + 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) + +#else + gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ + & wel_loc*gel_loc(j,i)+ + & 0.5d0*(wscp*gvdwc_scpp(j,i)+ + & welec*gelc_long(j,i)+ + & wel_loc*gel_loc_long(j,i)+ + & wcorr*gcorr_long(j,i)+ + & wcorr5*gradcorr5_long(j,i)+ + & wcorr6*gradcorr6_long(j,i)+ + & wturn6*gcorr6_turn_long(j,i))+ + & wbond*gradb(j,i)+ + & wcorr*gradcorr(j,i)+ + & wturn3*gcorr3_turn(j,i)+ + & wturn4*gcorr4_turn(j,i)+ + & wcorr5*gradcorr5(j,i)+ + & wcorr6*gradcorr6(j,i)+ + & wturn6*gcorr6_turn(j,i)+ + & wsccor*gsccorc(j,i) + & +wscloc*gscloc(j,i) + & +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) + + +#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) + & +wsaxs*gsaxsx(j,i) + + + + enddo + enddo + 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) + gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i) + enddo + enddo + endif +#ifdef DEBUG + write (iout,*) "gradc gradx gloc after adding" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') + & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) + enddo +#endif +#ifdef DEBUG + write (iout,*) "gloc before adding corr" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) + & +wcorr5*g_corr5_loc(i) + & +wcorr6*g_corr6_loc(i) + & +wturn4*gel_loc_turn4(i) + & +wturn3*gel_loc_turn3(i) + & +wturn6*gel_loc_turn6(i) + & +wel_loc*gel_loc_loc(i) + enddo +#ifdef DEBUG + write (iout,*) "gloc after adding corr" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif +#ifdef MPI + if (nfgtasks.gt.1) then + do j=1,3 + do i=1,nres + gradbufc(j,i)=gradc(j,i,icg) + gradbufx(j,i)=gradx(j,i,icg) + enddo + enddo + do i=1,4*nres + glocbuf(i)=gloc(i,icg) + enddo +c#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 +c#undef DEBUG + do i=1,nres + do j=1,3 + gloc_scbuf(j,i)=gloc_sc(j,i,icg) + enddo + enddo + time00=MPI_Wtime() + call MPI_Barrier(FG_COMM,IERR) + time_barrier_g=time_barrier_g+MPI_Wtime()-time00 + time00=MPI_Wtime() + call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 + call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 +#ifdef DEBUG + write (iout,*) "gradc after reduce" + do i=1,nres + do j=1,3 + write (iout,*) i,j,gradc(j,i,icg) + enddo + enddo +#endif +#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 +#ifdef DEBUG + write (iout,*) "gloc after reduce" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif + endif +#endif + if (gnorm_check) then +c +c Compute the maximum elements of the gradient +c + gvdwc_max=0.0d0 + gvdwc_scp_max=0.0d0 + gelc_max=0.0d0 + gvdwpp_max=0.0d0 + gradb_max=0.0d0 + ghpbc_max=0.0d0 + gradcorr_max=0.0d0 + gel_loc_max=0.0d0 + gcorr3_turn_max=0.0d0 + gcorr4_turn_max=0.0d0 + gradcorr5_max=0.0d0 + gradcorr6_max=0.0d0 + gcorr6_turn_max=0.0d0 + gsccorc_max=0.0d0 + gscloc_max=0.0d0 + gvdwx_max=0.0d0 + gradx_scp_max=0.0d0 + ghpbx_max=0.0d0 + gradxorr_max=0.0d0 + gsccorx_max=0.0d0 + gsclocx_max=0.0d0 + do i=1,nct + gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) + if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm + 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)gradcorr6_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 +#if (defined AIX || defined CRAY) + open(istat,file=statname,position="append") +#else + open(istat,file=statname,access="append") +#endif + write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max, + & gelc_max,gvdwpp_max,gradb_max,ghpbc_max, + & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, + & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, + & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, + & gsccorx_max,gsclocx_max + close(istat) + if (gvdwc_max.gt.1.0d4) then + write (iout,*) "gvdwc gvdwx gradb gradbx" + do i=nnt,nct + write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i), + & gradb(j,i),gradbx(j,i),j=1,3) + enddo + call pdbout(0.0d0,'cipiszcze',iout) + call flush(iout) + endif + endif + endif +#ifdef DEBUG + write (iout,*) "gradc gradx gloc" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') + & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) + enddo +#endif +#ifdef TIMING + time_sumgradient=time_sumgradient+MPI_Wtime()-time01 +#endif + return + end +c------------------------------------------------------------------------------- + subroutine rescale_weights(t_bath) + implicit none +#ifdef MPI + include 'mpif.h' + integer ierror +#endif + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + double precision t_bath + double precision kfac /2.4d0/ + double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ + double precision facT,facT2,facT3,facT4,facT5 +c facT=temp0/t_bath +c facT=2*temp0/(t_bath+temp0) + if (rescale_mode.eq.0) then + facT=1.0d0 + facT2=1.0d0 + facT3=1.0d0 + facT4=1.0d0 + facT5=1.0d0 + else if (rescale_mode.eq.1) then + facT=kfac/(kfac-1.0d0+t_bath/temp0) + facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) + facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) + facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) + facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) + else if (rescale_mode.eq.2) then + x=t_bath/temp0 + x2=x*x + x3=x2*x + x4=x3*x + x5=x4*x + facT=licznik/dlog(dexp(x)+dexp(-x)) + facT2=licznik/dlog(dexp(x2)+dexp(-x2)) + facT3=licznik/dlog(dexp(x3)+dexp(-x3)) + facT4=licznik/dlog(dexp(x4)+dexp(-x4)) + facT5=licznik/dlog(dexp(x5)+dexp(-x5)) + else + write (iout,*) "Wrong RESCALE_MODE",rescale_mode + write (*,*) "Wrong RESCALE_MODE",rescale_mode +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,IERROR) +#endif + stop 555 + endif + if (shield_mode.gt.0) then + wscp=weights(2)*fact + wsc=weights(1)*fact + wvdwpp=weights(16)*fact + endif + welec=weights(3)*fact + wcorr=weights(4)*fact3 + wcorr5=weights(5)*fact4 + wcorr6=weights(6)*fact5 + wel_loc=weights(7)*fact2 + wturn3=weights(8)*fact2 + wturn4=weights(9)*fact3 + wturn6=weights(10)*fact5 + wtor=weights(13)*fact + wtor_d=weights(14)*fact2 + wsccor=weights(21)*fact + if (scale_umb) wumb=t_bath/temp0 +c write (iout,*) "scale_umb",scale_umb +c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb + + return + end +C------------------------------------------------------------------------ + subroutine enerprint(energia) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.MD' + double precision energia(0:n_ene) + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6, + & eello_turn6, + & eliptran,Eafmforce,Etube,uconst, + & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot + etot=energia(0) + evdw=energia(1) + evdw2=energia(2) +#ifdef SCP14 + evdw2=energia(2)+energia(18) +#else + evdw2=energia(2) +#endif + ees=energia(3) +#ifdef SPLITELE + evdw1=energia(16) +#endif + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eello_turn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + edihcnstr=energia(19) + estr=energia(17) + Uconst=energia(20) + esccor=energia(21) + eliptran=energia(22) + Eafmforce=energia(23) + ethetacnstr=energia(24) + etube=energia(25) + esaxs=energia(26) + ehomology_constr=energia(27) +C Bartek + edfadis = energia(28) + edfator = energia(29) + edfanei = energia(30) + edfabet = energia(31) +#ifdef SPLITELE + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, + & estr,wbond,ebe,wang, + & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, + & ecorr,wcorr, + & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr, + & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce, + & etube,wtube,esaxs,wsaxs,ehomology_constr, + & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, + & edfabet,wdfa_beta, + & etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, + & ' (SS bridges & dist. cnstr.)'/ + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ + & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ + & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/ + & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ + & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/ + & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/ + & 'ETOT= ',1pE16.6,' (total)') + +#else + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, + & estr,wbond,ebe,wang, + & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, + & ecorr,wcorr, + & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr, + & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, + & etube,wtube,esaxs,wsaxs,ehomology_constr, + & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, + & edfabet,wdfa_beta, + & etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, + & ' (SS bridges & dist. restr.)'/ + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ + & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ + & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/ + & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ + & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/ + & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/ + & 'ETOT= ',1pE16.6,' (total)') +#endif + return + end +C----------------------------------------------------------------------- + subroutine elj(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit none + include 'DIMENSIONS' + double precision accur + parameter (accur=1.0d-10) + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.TORSION' + include 'COMMON.SBRIDGE' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.CONTACTS' + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2 +c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +C Change 12/1/95 + num_conti=0 +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi +C Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + rrij=1.0D0/rij +c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 +C have you changed here? + e1=fac*fac*aa + e2=fac*bb + evdwij=e1+e2 +cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj), +cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, +cd & (c(k,i),k=1,3),(c(k,j),k=1,3) + evdw=evdw+evdwij +C +C Calculate the components of the gradient in DC and X +C + fac=-rrij*(e1+evdwij) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + 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 +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) +cgrad enddo +cgrad enddo +C +C 12/1/95, revised on 5/20/97 +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +C +C Uncomment next line, if the correlation interactions include EVDW explicitly. +c if (j.gt.i+1 .and. evdwij.le.0.0D0) then +C Uncomment next line, if the correlation interactions are contact function only + if (j.gt.i+1.and. eps0ij.gt.0.0D0) then + rij=dsqrt(rij) + sigij=sigma(itypi,itypj) + r0ij=rs0(itypi,itypj) +C +C Check whether the SC's are not too far to make a contact. +C + rcut=1.5d0*r0ij + call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) +C Add a new contact, if the SC's are close enough, but not too close (ri' +cgrad do k=1,3 +cgrad ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) +cgrad enddo +cgrad endif +cgrad do k=1,3 +cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) +cgrad enddo +cgrad kstart=min0(i+1,j) +cgrad kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) +cgrad do k=kstart,kend +cgrad do l=1,3 +cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) +cgrad enddo +cgrad enddo + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo + enddo + + enddo ! iint + enddo ! i +C enddo !zshift +C enddo !yshift +C enddo !xshift + return + end +C----------------------------------------------------------------------------- + subroutine escp(evdw2,evdw2_14) +C +C This subroutine calculates the excluded-volume interaction energy between +C peptide-group centers and side chains and its gradient in virtual-bond and +C side-chain vectors. +C + implicit none + 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' + include 'COMMON.SPLITELE' + integer xshift,yshift,zshift + dimension ggg(3) + evdw2=0.0D0 + evdw2_14=0.0d0 +c print *,boxxsize,boxysize,boxzsize,'wymiary pudla' +cd print '(a)','Enter ESCP' +cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e +C do xshift=-1,1 +C do yshift=-1,1 +C do zshift=-1,1 + if (energy_dec) write (iout,*) "escp:",r_cut,rlamb + do i=iatscp_s,iatscp_e + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + iteli=itel(i) + xi=0.5D0*(c(1,i)+c(1,i+1)) + yi=0.5D0*(c(2,i)+c(2,i+1)) + zi=0.5D0*(c(3,i)+c(3,i+1)) + 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 +c xi=xi+xshift*boxxsize +c yi=yi+yshift*boxysize +c zi=zi+zshift*boxzsize +c print *,xi,yi,zi,'polozenie i' +C Return atom into box, boxxsize is size of box in x dimension +c 134 continue +c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize +c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize +C Condition for being inside the proper box +c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or. +c & (xi.lt.((xshift-0.5d0)*boxxsize))) then +c go to 134 +c endif +c 135 continue +c print *,xi,boxxsize,"pierwszy" + +c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize +c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize +C Condition for being inside the proper box +c if ((yi.gt.((yshift+0.5d0)*boxysize)).or. +c & (yi.lt.((yshift-0.5d0)*boxysize))) then +c go to 135 +c endif +c 136 continue +c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize +c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize +C Condition for being inside the proper box +c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or. +c & (zi.lt.((zshift-0.5d0)*boxzsize))) then +c go to 136 +c endif + do iint=1,nscp_gr(i) + + do j=iscpstart(i,iint),iscpend(i,iint) + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) 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) + 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 +c 174 continue +c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize +c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize +C Condition for being inside the proper box +c if ((xj.gt.((0.5d0)*boxxsize)).or. +c & (xj.lt.((-0.5d0)*boxxsize))) then +c go to 174 +c endif +c 175 continue +c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize +c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize +cC Condition for being inside the proper box +c if ((yj.gt.((0.5d0)*boxysize)).or. +c & (yj.lt.((-0.5d0)*boxysize))) then +c go to 175 +c endif +c 176 continue +c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize +c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize +C Condition for being inside the proper box +c if ((zj.gt.((0.5d0)*boxzsize)).or. +c & (zj.lt.((-0.5d0)*boxzsize))) then +c go to 176 +c endif +CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE + 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 print *,xj,yj,zj,'polozenie j' + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c print *,rrij + sss=sscale(1.0d0/(dsqrt(rrij))) +c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz' +c if (sss.eq.0) print *,'czasem jest OK' + if (sss.le.0.0d0) cycle + sssgrad=sscagrad(1.0d0/(dsqrt(rrij))) + fac=rrij**expon2 + e1=fac*fac*aad(itypj,iteli) + e2=fac*bad(itypj,iteli) + if (iabs(j-i) .le. 2) then + e1=scal14*e1 + e2=scal14*e2 + evdw2_14=evdw2_14+(e1+e2)*sss + endif + evdwij=e1+e2 + evdw2=evdw2+evdwij*sss + if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') + & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli), + & bad(itypj,iteli) +C +C Calculate contributions to the gradient in the virtual-bond and SC vectors. +C + fac=-(evdwij+e1)*rrij*sss + fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon + ggg(1)=xj*fac + ggg(2)=yj*fac + ggg(3)=zj*fac +cgrad if (j.lt.i) then +cd write (iout,*) 'ji' +cgrad do k=1,3 +cgrad ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) +c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) +cgrad enddo +cgrad endif +cgrad do k=1,3 +cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) +cgrad enddo +cgrad kstart=min0(i+1,j) +cgrad kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) +cgrad do k=kstart,kend +cgrad do l=1,3 +cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) +cgrad enddo +cgrad enddo + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo +c endif !endif for sscale cutoff + enddo ! j + + enddo ! iint + enddo ! i +c enddo !zshift +c enddo !yshift +c enddo !xshift + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C-------------------------------------------------------------------------- + subroutine edis(ehpb) +C +C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. +C + implicit none + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + dimension ggg(3),ggg_peak(3,1000) + ehpb=0.0D0 + do i=1,3 + ggg(i)=0.0d0 + enddo +c 8/21/18 AL: added explicit restraints on reference coords +c write (iout,*) "restr_on_coord",restr_on_coord + if (restr_on_coord) then + + do i=nnt,nct + ecoor=0.0d0 + if (itype(i).eq.ntyp1) cycle + do j=1,3 + ecoor=ecoor+(c(j,i)-cref(j,i))**2 + ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i)) + enddo + if (itype(i).ne.10) then + do j=1,3 + ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2 + ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres)) + enddo + endif + if (energy_dec) write (iout,*) + & "i",i," bfac",bfac(i)," ecoor",ecoor + ehpb=ehpb+0.5d0*bfac(i)*ecoor + enddo + + endif +C write (iout,*) ,"link_end",link_end,constr_dist +cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr +c write(iout,*)'link_start=',link_start,' link_end=',link_end, +c & " constr_dist",constr_dist," link_start_peak",link_start_peak, +c & " link_end_peak",link_end_peak + if (link_end.eq.0.and.link_end_peak.eq.0) return + do i=link_start_peak,link_end_peak + ehpb_peak=0.0d0 +c print *,"i",i," link_end_peak",link_end_peak," ipeak", +c & ipeak(1,i),ipeak(2,i) + do ip=ipeak(1,i),ipeak(2,i) + ii=ihpb_peak(ip) + jj=jhpb_peak(ip) + dd=dist(ii,jj) + iip=ip-ipeak(1,i)+1 +C iii and jjj point to the residues for which the distance is assigned. +c if (ii.gt.nres) then +c iii=ii-nres +c jjj=jj-nres +c else +c iii=ii +c jjj=jj +c endif + if (ii.gt.nres) then + iii=ii-nres + else + iii=ii + endif + if (jj.gt.nres) then + jjj=jj-nres + else + jjj=jj + endif + aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip)) + aux=dexp(-scal_peak*aux) + ehpb_peak=ehpb_peak+aux + fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip), + & forcon_peak(ip))*aux/dd + do j=1,3 + ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii)) + enddo + if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)') + & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip), + & forcon_peak(ip),fordepth_peak(ip),ehpb_peak + enddo +c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak + ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak + do ip=ipeak(1,i),ipeak(2,i) + iip=ip-ipeak(1,i)+1 + do j=1,3 + ggg(j)=ggg_peak(j,iip)/ehpb_peak + enddo + ii=ihpb_peak(ip) + jj=jhpb_peak(ip) +C iii and jjj point to the residues for which the distance is assigned. +c if (ii.gt.nres) then +c iii=ii-nres +c jjj=jj-nres +c else +c iii=ii +c jjj=jj +c endif + if (ii.gt.nres) then + iii=ii-nres + else + iii=ii + endif + if (jj.gt.nres) then + jjj=jj-nres + else + jjj=jj + endif + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + enddo + endif + if (jjj.lt.jj) then + do j=1,3 + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + enddo + enddo + do i=link_start,link_end +C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a +C CA-CA distance used in regularization of structure. + ii=ihpb(i) + jj=jhpb(i) +C iii and jjj point to the residues for which the distance is assigned. + if (ii.gt.nres) then + iii=ii-nres + else + iii=ii + endif + if (jj.gt.nres) then + jjj=jj-nres + else + jjj=jj + endif +c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, +c & dhpb(i),dhpb1(i),forcon(i) +C 24/11/03 AL: SS bridges handled separately because of introducing a specific +C distance and angle dependent SS bond potential. +C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. +C & iabs(itype(jjj)).eq.1) then +cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then +C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds + if (.not.dyn_ss .and. i.le.nss) then +C 15/02/13 CC dynamic SSbond - additional check + if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. + & iabs(itype(jjj)).eq.1) then + call ssbond_ene(iii,jjj,eij) + ehpb=ehpb+2*eij + endif +cd write (iout,*) "eij",eij +cd & ' waga=',waga,' fac=',fac +! else if (ii.gt.nres .and. jj.gt.nres) then + else +C Calculate the distance between the two points and its difference from the +C target distance. + dd=dist(ii,jj) + if (irestr_type(i).eq.11) then + ehpb=ehpb+fordepth(i)!**4.0d0 + & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + fac=fordepth(i)!**4.0d0 + & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd + if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)') + & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i), + & ehpb,irestr_type(i) + else if (irestr_type(i).eq.10) then +c AL 6//19/2018 cross-link restraints + xdis = 0.5d0*(dd/forcon(i))**2 + expdis = dexp(-xdis) +c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i) + aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i) +c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux, +c & " wboltzd",wboltzd + ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux) +c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i)) + fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i)) + & *expdis/(aux*forcon(i)**2) + if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)') + & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i), + & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i) + else if (irestr_type(i).eq.2) then +c Quartic restraints + ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)') + & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i), + & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd + else +c Quadratic restraints + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+0.5d0*waga*rdis*rdis + if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)') + & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i), + & 0.5d0*waga*rdis*rdis,irestr_type(i) +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif +c Calculate Cartesian gradient + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distance, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + enddo + endif + if (jjj.lt.jj) then + do j=1,3 + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + endif + enddo + return + end +C-------------------------------------------------------------------------- + subroutine ssbond_ene(i,j,eij) +C +C Calculate the distance and angle dependent SS-bond potential energy +C using a free-energy function derived based on RHF/6-31G** ab initio +C calculations of diethyl disulfide. +C +C A. Liwo and U. Kozlowska, 11/24/03 +C + implicit none + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + double precision erij(3),dcosom1(3),dcosom2(3),gg(3) + itypi=iabs(itype(i)) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +c dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(nres+i) + itypj=iabs(itype(j)) +c dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(nres+j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + rij=1.0d0/rij + deltad=rij-d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) + & +akct*deltad*deltat12 + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr +c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, +c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, +c & " deltat12",deltat12," eij",eij + ed=2*akcm*deltad+akct*deltat12 + pom1=akct*deltad + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + do k=1,3 + ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + ghpbx(k,i)=ghpbx(k,i)-ggk + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + ghpbx(k,j)=ghpbx(k,j)+ggk + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + ghpbc(k,i)=ghpbc(k,i)-ggk + ghpbc(k,j)=ghpbc(k,j)+ggk + enddo +C +C Calculate the components of the gradient in DC and X +C +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l) +cgrad enddo +cgrad enddo + return + end +C-------------------------------------------------------------------------- + subroutine ebond(estr) +c +c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds +c + implicit none + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + double precision u(3),ud(3) + estr=0.0d0 + estr1=0.0d0 + do i=ibondp_start,ibondp_end + if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle +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) +c else +C Checking if it involves dummy (NH3+ or COO-) group + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then +C YES vbldpDUM is the equlibrium length of spring for Dummy atom + diff = vbld(i)-vbldpDUM + if (energy_dec) write(iout,*) "dum_bond",i,diff + else +C NO vbldp0 is the equlibrium lenght of spring for peptide group + diff = vbld(i)-vbldp0 + endif + if (energy_dec) write (iout,'(a7,i5,4f7.3)') + & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff + estr=estr+diff*diff + do j=1,3 + gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) + enddo +c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) +c endif + enddo + + estr=0.5d0*AKP*estr+estr1 +c +c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included +c + do i=ibond_start,ibond_end + iti=iabs(itype(i)) + if (iti.ne.10 .and. iti.ne.ntyp1) then + nbi=nbondterm(iti) + if (nbi.eq.1) then + diff=vbld(i+nres)-vbldsc0(1,iti) + if (energy_dec) write (iout,*) + & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff, + & AKSC(1,iti),AKSC(1,iti)*diff*diff + estr=estr+0.5d0*AKSC(1,iti)*diff*diff + do j=1,3 + gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) + enddo + else + do j=1,nbi + diff=vbld(i+nres)-vbldsc0(j,iti) + ud(j)=aksc(j,iti)*diff + u(j)=abond0(j,iti)+0.5d0*ud(j)*diff + enddo + uprod=u(1) + do j=2,nbi + uprod=uprod*u(j) + enddo + usum=0.0d0 + usumsqder=0.0d0 + do j=1,nbi + uprod1=1.0d0 + uprod2=1.0d0 + do k=1,nbi + if (k.ne.j) then + uprod1=uprod1*u(k) + uprod2=uprod2*u(k)*u(k) + endif + enddo + usum=usum+uprod1 + usumsqder=usumsqder+ud(j)*uprod2 + enddo + estr=estr+uprod/usum + do j=1,3 + gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) + enddo + endif + endif + enddo + return + end +#ifdef CRYST_THETA +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.TORCNSTR' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + double precision y(2),z(2) + delta=0.02d0*pi +c time11=dexp(-2*time) +c time12=1.0d0 + etheta=0.0D0 +c write (*,'(a,i2)') 'EBEND ICG=',icg + do i=ithet_start,ithet_end + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle +C Zero the energy function and its derivative at 0 or pi. + call splinthet(theta(i),0.5d0*delta,ss,ssd) + it=itype(i-1) + ichir1=isign(1,itype(i-2)) + ichir2=isign(1,itype(i)) + if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1)) + if (itype(i).eq.10) ichir2=isign(1,itype(i-1)) + if (itype(i-1).eq.10) then + itype1=isign(10,itype(i-2)) + ichir11=isign(1,itype(i-2)) + ichir12=isign(1,itype(i-2)) + itype2=isign(10,itype(i)) + ichir21=isign(1,itype(i)) + ichir22=isign(1,itype(i)) + endif + + if (i.gt.3 .and. itype(i-3).ne.ntyp1) then +#ifdef OSF + phii=phi(i) + if (phii.ne.phii) phii=150.0 +#else + phii=phi(i) +#endif + y(1)=dcos(phii) + y(2)=dsin(phii) + else + y(1)=0.0D0 + y(2)=0.0D0 + endif + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then +#ifdef OSF + phii1=phi(i+1) + if (phii1.ne.phii1) phii1=150.0 + phii1=pinorm(phii1) + z(1)=cos(phii1) +#else + phii1=phi(i+1) +#endif + z(1)=dcos(phii1) + z(2)=dsin(phii1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif +C Calculate the "mean" value of theta from the part of the distribution +C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). +C In following comments this theta will be referred to as t_c. + thet_pred_mean=0.0d0 + do k=1,2 + athetk=athet(k,it,ichir1,ichir2) + bthetk=bthet(k,it,ichir1,ichir2) + if (it.eq.10) then + athetk=athet(k,itype1,ichir11,ichir12) + bthetk=bthet(k,itype2,ichir21,ichir22) + endif + thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) +c write(iout,*) 'chuj tu', y(k),z(k) + enddo + dthett=thet_pred_mean*ssd + thet_pred_mean=thet_pred_mean*ss+a0thet(it) +C Derivatives of the "mean" values in gamma1 and gamma2. + dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) + &+athet(2,it,ichir1,ichir2)*y(1))*ss + dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) + & +bthet(2,it,ichir1,ichir2)*z(1))*ss + if (it.eq.10) then + dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) + &+athet(2,itype1,ichir11,ichir12)*y(1))*ss + dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) + & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss + endif + if (theta(i).gt.pi-delta) then + call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, + & E_tc0) + call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) + call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, + & E_theta) + call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else if (theta(i).lt.delta) then + call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) + call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, + & E_theta) + call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) + call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else + call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, + & E_theta,E_tc) + endif + etheta=etheta+ethetai + if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)') + & 'ebend',i,ethetai,theta(i),itype(i) + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 + gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg) + enddo + +C Ufff.... We've done all this!!! + return + end +C--------------------------------------------------------------------------- + subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, + & E_tc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it +C Calculate the contributions to both Gaussian lobes. +C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) +C The "polynomial part" of the "standard deviation" of this part of +C the distributioni. +ccc write (iout,*) thetai,thet_pred_mean + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo +C Derivative of the "interior part" of the "standard deviation of the" +C gamma-dependent Gaussian lobe in t_c. + sigtc=3*polthet(3,it) + do j=2,1,-1 + sigtc=sigtc*thet_pred_mean+j*polthet(j,it) + enddo + sigtc=sig*sigtc +C Set the parameters of both Gaussian lobes of the distribution. +C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) + fac=sig*sig+sigc0(it) + sigcsq=fac+fac + sigc=1.0D0/sigcsq +C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c + sigsqtc=-4.0D0*sigcsq*sigtc +c print *,i,sig,sigtc,sigsqtc +C Following variable (sigtc) is d[sigma(t_c)]/dt_c + sigtc=-sigtc/(fac*fac) +C Following variable is sigma(t_c)**(-2) + sigcsq=sigcsq*sigcsq + sig0i=sig0(it) + sig0inv=1.0D0/sig0i**2 + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i + term1=-0.5D0*sigcsq*delthec*delthec + term2=-0.5D0*sig0inv*delthe0*delthe0 +C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0 +C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and +C NaNs in taking the logarithm. We extract the largest exponent which is added +C to the energy (this being the log of the distribution) at the end of energy +C term evaluation for this virtual-bond angle. + if (term1.gt.term2) then + termm=term1 + term2=dexp(term2-termm) + term1=1.0d0 + else + termm=term2 + term1=dexp(term1-termm) + term2=1.0d0 + endif +C The ratio between the gamma-independent and gamma-dependent lobes of +C the distribution is a Gaussian function of thet_pred_mean too. + diffak=gthet(2,it)-thet_pred_mean + ratak=diffak/gthet(3,it)**2 + ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) +C Let's differentiate it in thet_pred_mean NOW. + aktc=ak*ratak +C Now put together the distribution terms to make complete distribution. + termexp=term1+ak*term2 + termpre=sigc+ak*sig0i +C Contribution of the bending energy from this theta is just the -log of +C the sum of the contributions from the two lobes and the pre-exponential +C factor. Simple enough, isn't it? + ethetai=(-dlog(termexp)-termm+dlog(termpre)) +C write (iout,*) 'termexp',termexp,termm,termpre,i +C NOW the derivatives!!! +C 6/6/97 Take into account the deformation. + E_theta=(delthec*sigcsq*term1 + & +ak*delthe0*sig0inv*term2)/termexp + E_tc=((sigtc+aktc*sig0i)/termpre + & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ + & aktc*term2)/termexp) + return + end +c----------------------------------------------------------------------------- + subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i +C "Thank you" to MAPLE (probably spared one day of hand-differentiation). + t3 = thetai-thet_pred_mean + t6 = t3**2 + t9 = term1 + t12 = t3*sigcsq + t14 = t12+t6*sigsqtc + t16 = 1.0d0 + t21 = thetai-theta0i + t23 = t21**2 + t26 = term2 + t27 = t21*t26 + t32 = termexp + t40 = t32**2 + E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 + & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 + & *(-t12*t9-ak*sig0inv*t27) + return + end +#else +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C ab initio-derived potentials from +c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + implicit none + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.TORCNSTR' + double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), + & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), + & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), + & sinph1ph2(maxdouble,maxdouble) + logical lprn /.false./, lprn1 /.false./ + etheta=0.0D0 + do i=ithet_start,ithet_end +c print *,i,itype(i-1),itype(i),itype(i-2) + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle +C print *,i,theta(i) + if (iabs(itype(i+1)).eq.20) iblock=2 + if (iabs(itype(i+1)).ne.20) iblock=1 + dethetai=0.0d0 + dephii=0.0d0 + dephii1=0.0d0 + theti2=0.5d0*theta(i) + ityp2=ithetyp((itype(i-1))) + do k=1,nntheterm + coskt(k)=dcos(k*theti2) + sinkt(k)=dsin(k*theti2) + enddo +C print *,ethetai + if (i.gt.3 .and. itype(i-3).ne.ntyp1) then +#ifdef OSF + phii=phi(i) + if (phii.ne.phii) phii=150.0 +#else + phii=phi(i) +#endif + ityp1=ithetyp((itype(i-2))) +C propagation of chirality for glycine type + do k=1,nsingle + cosph1(k)=dcos(k*phii) + sinph1(k)=dsin(k*phii) + enddo + else + phii=0.0d0 + do k=1,nsingle + ityp1=ithetyp((itype(i-2))) + cosph1(k)=0.0d0 + sinph1(k)=0.0d0 + enddo + endif + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then +#ifdef OSF + phii1=phi(i+1) + if (phii1.ne.phii1) phii1=150.0 + phii1=pinorm(phii1) +#else + phii1=phi(i+1) +#endif + ityp3=ithetyp((itype(i))) + do k=1,nsingle + cosph2(k)=dcos(k*phii1) + sinph2(k)=dsin(k*phii1) + enddo + else + phii1=0.0d0 + ityp3=ithetyp((itype(i))) + do k=1,nsingle + cosph2(k)=0.0d0 + sinph2(k)=0.0d0 + enddo + endif + ethetai=aa0thet(ityp1,ityp2,ityp3,iblock) + do k=1,ndouble + do l=1,k-1 + ccl=cosph1(l)*cosph2(k-l) + ssl=sinph1(l)*sinph2(k-l) + scl=sinph1(l)*cosph2(k-l) + csl=cosph1(l)*sinph2(k-l) + cosph1ph2(l,k)=ccl-ssl + cosph1ph2(k,l)=ccl+ssl + sinph1ph2(l,k)=scl+csl + sinph1ph2(k,l)=scl-csl + enddo + enddo + if (lprn) then + write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, + & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 + write (iout,*) "coskt and sinkt" + do k=1,nntheterm + write (iout,*) k,coskt(k),sinkt(k) + enddo + endif + do k=1,ntheterm + ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k) + dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) + & *coskt(k) + if (lprn) + & write (iout,*) "k",k," + & aathet",aathet(k,ityp1,ityp2,ityp3,iblock), + & " ethetai",ethetai + enddo + if (lprn) then + write (iout,*) "cosph and sinph" + do k=1,nsingle + write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) + enddo + write (iout,*) "cosph1ph2 and sinph2ph2" + do k=2,ndouble + do l=1,k-1 + write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), + & sinph1ph2(l,k),sinph1ph2(k,l) + enddo + enddo + write(iout,*) "ethetai",ethetai + endif +C print *,ethetai + do m=1,ntheterm2 + do k=1,nsingle + aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) + & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) + & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) + & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k) + ethetai=ethetai+sinkt(m)*aux + dethetai=dethetai+0.5d0*m*aux*coskt(m) + dephii=dephii+k*sinkt(m)*( + & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- + & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)) + dephii1=dephii1+k*sinkt(m)*( + & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- + & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)) + if (lprn) + & write (iout,*) "m",m," k",k," bbthet", + & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", + & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", + & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", + & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai +C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k) + enddo + enddo +C print *,"cosph1", (cosph1(k), k=1,nsingle) +C print *,"cosph2", (cosph2(k), k=1,nsingle) +C print *,"sinph1", (sinph1(k), k=1,nsingle) +C print *,"sinph2", (sinph2(k), k=1,nsingle) + if (lprn) + & write(iout,*) "ethetai",ethetai +C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k) + do m=1,ntheterm3 + do k=2,ndouble + do l=1,k-1 + aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l) + ethetai=ethetai+sinkt(m)*aux + dethetai=dethetai+0.5d0*m*coskt(m)*aux + dephii=dephii+l*sinkt(m)*( + & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) + dephii1=dephii1+(k-l)*sinkt(m)*( + & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) + if (lprn) then + write (iout,*) "m",m," k",k," l",l," ffthet", + & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock), + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet", + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock), + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock), + & " ethetai",ethetai + write (iout,*) cosph1ph2(l,k)*sinkt(m), + & cosph1ph2(k,l)*sinkt(m), + & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) + endif + enddo + enddo + enddo +10 continue +c lprn1=.true. +C print *,ethetai + if (lprn1) + & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') + & i,theta(i)*rad2deg,phii*rad2deg, + & phii1*rad2deg,ethetai +c lprn1=.false. + etheta=etheta+ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai + enddo + + return + end +#endif +#ifdef CRYST_SC +c----------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), + & ddersc0(3),ddummy(3),xtemp(3),temp(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 +c write (iout,'(a)') 'ESC' + do i=loc_start,loc_end + it=itype(i) + if (it.eq.ntyp1) cycle + if (it.eq.10) goto 1 + nlobit=nlob(iabs(it)) +c print *,'i=',i,' it=',it,' nlobit=',nlobit +c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad + theti=theta(i+1)-pipol + x(1)=dtan(theti) + x(2)=alph(i) + x(3)=omeg(i) + + if (x(2).gt.pi-delta) then + xtemp(1)=x(1) + xtemp(2)=pi-delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=pi + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=pi-delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=pi + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + call splinthet(x(2),0.5d0*delta,ss,ssd) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c escloci=esclocbi +c write (iout,*) escloci + else if (x(2).lt.delta) then + xtemp(1)=x(1) + xtemp(2)=delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=0.0d0 + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=0.0d0 + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + call splinthet(x(2),0.5d0*delta,ss,ssd) + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c write (iout,*) escloci + else + call enesc(x,escloci,dersc,ddummy,.false.) + endif + + escloc=escloc+escloci + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + & 'escloc',i,escloci +c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + & wscloc*dersc(1) + gloc(ialph(i,1),icg)=wscloc*dersc(2) + gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) + 1 continue + enddo + return + end +C--------------------------------------------------------------------------- + subroutine enesc(x,escloci,dersc,ddersc,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) + double precision contr(maxlob,-1:1) + logical mixed +c write (iout,*) 'it=',it,' nlobit=',nlobit + escloc_i=0.0D0 + do j=1,3 + dersc(j)=0.0D0 + if (mixed) ddersc(j)=0.0d0 + enddo + x3=x(3) + +C Because of periodicity of the dependence of the SC energy in omega we have +C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). +C To avoid underflows, first compute & store the exponents. + + do iii=-1,1 + + x(3)=x3+iii*dwapi + + do j=1,nlobit + do k=1,3 + z(k)=x(k)-censc(k,j,it) + enddo + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j,iii)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j,iii)*z(k) + enddo + contr(j,iii)=expfac + enddo ! j + + enddo ! iii + + x(3)=x3 +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1,-1) + do iii=-1,1 + do j=1,nlobit + if (emin.gt.contr(j,iii)) emin=contr(j,iii) + enddo + enddo + emin=0.5D0*emin +cd print *,'it=',it,' emin=',emin + +C Compute the contribution to SC energy and derivatives + do iii=-1,1 + + do j=1,nlobit +#ifdef OSF + adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin + if(adexp.ne.adexp) adexp=1.0 + expfac=dexp(adexp) +#else + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) +#endif +cd print *,'j=',j,' expfac=',expfac + escloc_i=escloc_i+expfac + do k=1,3 + dersc(k)=dersc(k)+Ax(k,j,iii)*expfac + enddo + if (mixed) then + do k=1,3,2 + ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) + & +gaussc(k,2,j,it))*expfac + enddo + endif + enddo + + enddo ! iii + + dersc(1)=dersc(1)/cos(theti)**2 + ddersc(1)=ddersc(1)/cos(theti)**2 + ddersc(3)=ddersc(3) + + escloci=-(dlog(escloc_i)-emin) + do j=1,3 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) then + do j=1,3,2 + ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) + enddo + endif + return + end +C------------------------------------------------------------------------------ + subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob),dersc(3) + double precision contr(maxlob) + logical mixed + + escloc_i=0.0D0 + + do j=1,3 + dersc(j)=0.0D0 + enddo + + do j=1,nlobit + do k=1,2 + z(k)=x(k)-censc(k,j,it) + enddo + z(3)=dwapi + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j)*z(k) + enddo + contr(j)=expfac + enddo ! j + +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1) + do j=1,nlobit + if (emin.gt.contr(j)) emin=contr(j) + enddo + emin=0.5D0*emin + +C Compute the contribution to SC energy and derivatives + + dersc12=0.0d0 + do j=1,nlobit + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin) + escloc_i=escloc_i+expfac + do k=1,2 + dersc(k)=dersc(k)+Ax(k,j)*expfac + enddo + if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) + & +gaussc(1,2,j,it))*expfac + dersc(3)=0.0d0 + enddo + + dersc(1)=dersc(1)/cos(theti)**2 + dersc12=dersc12/cos(theti)**2 + escloci=-(dlog(escloc_i)-emin) + do j=1,2 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) + return + end +#else +c---------------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA derived from AM1 all-atom calculations. +C added by Urszula Kozlowska. 07/11/2007 +C + implicit none + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.SCROT' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.VECTORS' + double precision x_prime(3),y_prime(3),z_prime(3) + & , sumene,dsc_i,dp2_i,x(65), + & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, + & de_dxx,de_dyy,de_dzz,de_dt + double precision s1_t,s1_6_t,s2_t,s2_6_t + double precision + & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), + & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), + & dt_dCi(3),dt_dCi1(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 + do i=loc_start,loc_end + if (itype(i).eq.ntyp1) cycle + costtab(i+1) =dcos(theta(i+1)) + sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) + cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) + sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) + cosfac2=0.5d0/(1.0d0+costtab(i+1)) + cosfac=dsqrt(cosfac2) + sinfac2=0.5d0/(1.0d0-costtab(i+1)) + sinfac=dsqrt(sinfac2) + it=iabs(itype(i)) + if (it.eq.10) goto 1 +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)*dsign(1.0d0,dfloat(itype(i))) + enddo +c write (2,*) "i",i +c write (2,*) "x_prime",(x_prime(j),j=1,3) +c write (2,*) "y_prime",(y_prime(j),j=1,3) +c write (2,*) "z_prime",(z_prime(j),j=1,3) +c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), +c & " xy",scalar(x_prime(1),y_prime(1)), +c & " xz",scalar(x_prime(1),z_prime(1)), +c & " yy",scalar(y_prime(1),y_prime(1)), +c & " yz",scalar(y_prime(1),z_prime(1)), +c & " zz",scalar(z_prime(1),z_prime(1)) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxtab(i)=xx + yytab(i)=yy + zztab(i)=zz +C +C Compute the energy of the ith side cbain +C +c write (2,*) "xx",xx," yy",yy," zz",zz + it=iabs(itype(i)) + do j = 1,65 + x(j) = sc_parmin(j,it) + enddo +#ifdef CHECK_COORD +Cc diagnostics - remove later + xx1 = dcos(alph(2)) + yy1 = dsin(alph(2))*dcos(omeg(2)) + zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2)) + write(2,'(3f8.1,3f9.3,1x,3f9.3)') + & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, + & xx1,yy1,zz1 +C," --- ", xx_w,yy_w,zz_w +c end diagnostics +#endif + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) + & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) +c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, +c & sumene4, +c & dscp1,dscp2,sumene +c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + escloc = escloc + sumene +c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i) +c & ,zz,xx,yy +c#define DEBUG +#ifdef DEBUG +C +C This section to check the numerical derivatives of the energy of ith side +C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert +C #define DEBUG in the code to turn it on. +C + write (2,*) "sumene =",sumene + aincr=1.0d-7 + xxsave=xx + xx=xx+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dxx_num=(sumenep-sumene)/aincr + xx=xxsave + write (2,*) "xx+ sumene from enesc=",sumenep + yysave=yy + yy=yy+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dyy_num=(sumenep-sumene)/aincr + yy=yysave + write (2,*) "yy+ sumene from enesc=",sumenep + zzsave=zz + zz=zz+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dzz_num=(sumenep-sumene)/aincr + zz=zzsave + write (2,*) "zz+ sumene from enesc=",sumenep + costsave=cost2tab(i+1) + sintsave=sint2tab(i+1) + cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) + sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dt_num=(sumenep-sumene)/aincr + write (2,*) " t+ sumene from enesc=",sumenep + cost2tab(i+1)=costsave + sint2tab(i+1)=sintsave +C End of diagnostics section. +#endif +C +C Compute the gradient of esc +C +c zz=zz*dsign(1.0,dfloat(itype(i))) + pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 + pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 + pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 + pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 + pom_dx=dsc_i*dp2_i*cost2tab(i+1) + pom_dy=dsc_i*dp2_i*sint2tab(i+1) + pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) + pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) + pom1=(sumene3*sint2tab(i+1)+sumene1) + & *(pom_s1/dscp1+pom_s16*dscp1**4) + pom2=(sumene4*cost2tab(i+1)+sumene2) + & *(pom_s2/dscp2+pom_s26*dscp2**4) + sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy + sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 + & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) + & +x(40)*yy*zz + sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy + sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 + & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) + & +x(60)*yy*zz + de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) + & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) + & +(pom1+pom2)*pom_dx +#ifdef DEBUG + write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i) +#endif +C + sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz + sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 + & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) + & +x(40)*xx*zz + sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz + sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz + & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz + & +x(59)*zz**2 +x(60)*xx*zz + de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) + & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) + & +(pom1-pom2)*pom_dy +#ifdef DEBUG + write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i) +#endif +C + de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy + & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx + & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) + & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) + & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 + & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy + & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) + & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) +#ifdef DEBUG + write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i) +#endif +C + de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) + & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) + & +pom1*pom_dt1+pom2*pom_dt2 +#ifdef DEBUG + write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i) +#endif +c#undef DEBUG +c +C + cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + cosfac2xx=cosfac2*xx + sinfac2yy=sinfac2*yy + do k = 1,3 + dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* + & vbld_inv(i+1) + dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* + & vbld_inv(i) + pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) + pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) +c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, +c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) +c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), +c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) + dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx + dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx + dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy + dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy + dZZ_Ci1(k)=0.0d0 + dZZ_Ci(k)=0.0d0 + do j=1,3 + dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) + & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) + dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) + & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) + enddo + + dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) + dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) + dZZ_XYZ(k)=vbld_inv(i+nres)* + & (z_prime(k)-zz*dC_norm(k,i+nres)) +c + dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) + dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) + enddo + + do k=1,3 + dXX_Ctab(k,i)=dXX_Ci(k) + dXX_C1tab(k,i)=dXX_Ci1(k) + dYY_Ctab(k,i)=dYY_Ci(k) + dYY_C1tab(k,i)=dYY_Ci1(k) + dZZ_Ctab(k,i)=dZZ_Ci(k) + dZZ_C1tab(k,i)=dZZ_Ci1(k) + dXX_XYZtab(k,i)=dXX_XYZ(k) + dYY_XYZtab(k,i)=dYY_XYZ(k) + dZZ_XYZtab(k,i)=dZZ_XYZ(k) + enddo + + do k = 1,3 +c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", +c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) +c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", +c & dyy_ci(k)," dzz_ci",dzz_ci(k) +c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", +c & dt_dci(k) +c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", +c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) + gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) + & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) + gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) + & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) + gsclocx(k,i)= de_dxx*dxx_XYZ(k) + & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) + enddo +c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), +c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) + +C to check gradient call subroutine check_grad + + 1 continue + enddo + return + end +c------------------------------------------------------------------------------ + double precision function enesc(x,xx,yy,zz,cost2,sint2) + implicit none + double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2, + & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2+yy*sint2)) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2-yy*sint2)) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) + & + (sumene4*cost2 +sumene2)*(s2+s2_6) + enesc=sumene + return + end +#endif +c------------------------------------------------------------------------------ + subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) +C +C This procedure calculates two-body contact function g(rij) and its derivative: +C +C eps0ij ! x < -1 +C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 +C 0 ! x > 1 +C +C where x=(rij-r0ij)/delta +C +C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy +C + implicit none + double precision rij,r0ij,eps0ij,fcont,fprimcont + double precision x,x2,x4,delta +c delta=0.02D0*r0ij +c delta=0.2D0*r0ij + x=(rij-r0ij)/delta + if (x.lt.-1.0D0) then + fcont=eps0ij + fprimcont=0.0D0 + else if (x.le.1.0D0) then + x2=x*x + x4=x2*x2 + fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) + fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta + else + fcont=0.0D0 + fprimcont=0.0D0 + endif + return + end +c------------------------------------------------------------------------------ + subroutine splinthet(theti,delta,ss,ssder) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + thetup=pi-delta + thetlow=delta + if (theti.gt.pipol) then + call gcont(theti,thetup,1.0d0,delta,ss,ssder) + else + call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) + ssder=-ssder + endif + return + end +c------------------------------------------------------------------------------ + subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) + implicit none + double precision x,x0,delta,f0,f1,fprim0,f,fprim + double precision ksi,ksi2,ksi3,a1,a2,a3 + a1=fprim0*delta/(f1-f0) + a2=3.0d0-2.0d0*a1 + a3=a1-2.0d0 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) + fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) + return + end +c------------------------------------------------------------------------------ + subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) + implicit none + double precision x,x0,delta,f0x,f1x,fprim0x,fx + double precision ksi,ksi2,ksi3,a1,a2,a3 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + a1=fprim0x*delta + a2=3*(f1x-f0x)-2*fprim0x*delta + a3=fprim0x*delta-2*(f1x-f0x) + fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 + return + end +C----------------------------------------------------------------------------- +#ifdef CRYST_TOR +C----------------------------------------------------------------------------- + subroutine etor(etors) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + etors_ii=0.0D0 + if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Proline-Proline pair is a special case... + if (itori.eq.3 .and. itori1.eq.3) then + if (phii.gt.-dwapi3) then + cosphi=dcos(3*phii) + fac=1.0D0/(1.0D0-cosphi) + etorsi=v1(1,3,3)*fac + etorsi=etorsi+etorsi + etors=etors+etorsi-v1(1,3,3) + if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) + gloci=gloci-3*fac*etorsi*dsin(3*phii) + endif + do j=1,3 + v1ij=v1(j+1,itori,itori1) + v2ij=v2(j+1,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + if (energy_dec) etors_ii=etors_ii+ + & v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + else + do j=1,nterm_old + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + if (energy_dec) etors_ii=etors_ii+ + & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + endif + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + 'etor',i,etors_ii + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo + return + end +c------------------------------------------------------------------------------ + subroutine etor_d(etors_d) + etors_d=0.0d0 + return + end +c---------------------------------------------------------------------------- +c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA + subroutine e_modeller(ehomology_constr) + ehomology_constr=0.0d0 + write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!" + return + end +C !!!!!!!! NIE CZYTANE !!!!!!!!!!! + +c------------------------------------------------------------------------------ + subroutine etor_d(etors_d) + etors_d=0.0d0 + return + end +c---------------------------------------------------------------------------- +#else + subroutine etor(etors) + implicit none + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end +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).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle +C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF +C For introducing the NH3+ and COO- group please check the etor_d for reference +C and guidance + etors_ii=0.0D0 + if (iabs(itype(i)).eq.20) then + iblock=2 + else + iblock=1 + endif + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Regular cosine and sine terms + do j=1,nterm(itori,itori1,iblock) + v1ij=v1(j,itori,itori1,iblock) + v2ij=v2(j,itori,itori1,iblock) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi + if (energy_dec) etors_ii=etors_ii+ + & v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C Lorentz terms +C v1 +C E = SUM ----------------------------------- - v1 +C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 +C + cosphi=dcos(0.5d0*phii) + sinphi=dsin(0.5d0*phii) + do j=1,nlor(itori,itori1,iblock) + vl1ij=vlor1(j,itori,itori1) + vl2ij=vlor2(j,itori,itori1) + vl3ij=vlor3(j,itori,itori1) + pom=vl2ij*cosphi+vl3ij*sinphi + pom1=1.0d0/(pom*pom+1.0d0) + etors=etors+vl1ij*pom1 + if (energy_dec) etors_ii=etors_ii+ + & vl1ij*pom1 + pom=-pom*pom1*pom1 + gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom + enddo +C Subtract the constant term + etors=etors-v0(itori,itori1,iblock) + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + & 'etor',i,etors_ii-v0(itori,itori1,iblock) + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1,iblock),j=1,6), + & (v2(j,itori,itori1,iblock),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo + return + end +c---------------------------------------------------------------------------- + subroutine etor_d(etors_d) +C 6/23/01 Compute double torsional energy + implicit none + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors_d=0.0D0 +c write(iout,*) "a tu??" + do i=iphid_start,iphid_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)) .or. +C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle + if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or. + & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or. + & (itype(i+1).eq.ntyp1)) cycle +C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + itori2=itortyp(itype(i)) + phii=phi(i) + phii1=phi(i+1) + gloci1=0.0D0 + gloci2=0.0D0 + iblock=1 + if (iabs(itype(i+1)).eq.20) iblock=2 +C Iblock=2 Proline type +C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT +C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO- +C if (itype(i+1).eq.ntyp1) iblock=3 +C The problem of NH3+ group can be resolved by adding new parameters please note if there +C IS or IS NOT need for this +C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on +C is (itype(i-3).eq.ntyp1) ntblock=2 +C ntblock is N-terminal blocking group + +C Regular cosine and sine terms + do j=1,ntermd_1(itori,itori1,itori2,iblock) +C Example of changes for NH3+ blocking group +C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock) +C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock) + v1cij=v1c(1,j,itori,itori1,itori2,iblock) + v1sij=v1s(1,j,itori,itori1,itori2,iblock) + v2cij=v1c(2,j,itori,itori1,itori2,iblock) + v2sij=v1s(2,j,itori,itori1,itori2,iblock) + cosphi1=dcos(j*phii) + sinphi1=dsin(j*phii) + cosphi2=dcos(j*phii1) + sinphi2=dsin(j*phii1) + etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ + & v2cij*cosphi2+v2sij*sinphi2 + gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) + gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) + enddo + do k=2,ntermd_2(itori,itori1,itori2,iblock) + do l=1,k-1 + v1cdij = v2c(k,l,itori,itori1,itori2,iblock) + v2cdij = v2c(l,k,itori,itori1,itori2,iblock) + v1sdij = v2s(k,l,itori,itori1,itori2,iblock) + v2sdij = v2s(l,k,itori,itori1,itori2,iblock) + cosphi1p2=dcos(l*phii+(k-l)*phii1) + cosphi1m2=dcos(l*phii-(k-l)*phii1) + sinphi1p2=dsin(l*phii+(k-l)*phii1) + sinphi1m2=dsin(l*phii-(k-l)*phii1) + etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ + & v1sdij*sinphi1p2+v2sdij*sinphi1m2 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 + enddo + return + end +#endif +C---------------------------------------------------------------------------------- +C The rigorous attempt to derive energy function + subroutine etor_kcc(etors) + implicit none + 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' + double precision c1(0:maxval_kcc),c2(0:maxval_kcc) + logical lprn +c double precision thybt1(maxtermkcc),thybt2(maxtermkcc) +C Set lprn=.true. for debugging + lprn=energy_dec +c lprn=.true. +C print *,"wchodze kcc" + 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).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-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 +C derivative over gamma + 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),itype(i-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 +c--------------------------------------------------------------------------------------------- + subroutine etor_constr(edihcnstr) + implicit none + 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.BOUNDS' + include 'COMMON.CONTROL' +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 +c do i=1,ndih_constr + if (raw_psipred) then + do i=idihconstr_start,idihconstr_end + itori=idih_constr(i) + phii=phi(itori) + gaudih_i=vpsipred(1,i) + gauder_i=0.0d0 + do j=1,2 + s = sdihed(j,i) + cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2 + dexpcos_i=dexp(-cos_i*cos_i) + gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i + gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) + & *cos_i*dexpcos_i/s**2 + enddo + edihcnstr=edihcnstr-wdihc*dlog(gaudih_i) + gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i + if (energy_dec) + & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') + & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i), + & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i), + & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg, + & -wdihc*dlog(gaudih_i) + enddo + else + + do i=idihconstr_start,idihconstr_end + itori=idih_constr(i) + phii=phi(itori) + difi=pinorm(phii-phi0(i)) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + else + difi=0.0 + endif + enddo + + endif + + return + end +c---------------------------------------------------------------------------- +c MODELLER restraint function + subroutine e_modeller(ehomology_constr) + implicit none + include 'DIMENSIONS' + + integer nnn, i, j, k, ki, irec, l + integer katy, odleglosci, test7 + real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template) + real*8 Eval,Erot + real*8 distance(max_template),distancek(max_template), + & min_odl,godl(max_template),dih_diff(max_template) + +c +c FP - 30/10/2014 Temporary specifications for homology restraints +c + double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta, + & sgtheta + double precision, dimension (maxres) :: guscdiff,usc_diff + double precision, dimension (max_template) :: + & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3, + & theta_diff +c + + 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' +c +c From subroutine Econstr_back +c + include 'COMMON.NAMES' + include 'COMMON.TIME1' +c + + + do i=1,max_template + distancek(i)=9999999.9 + enddo + + + odleg=0.0d0 + +c Pseudo-energy and gradient from homology restraints (MODELLER-like +c function) +C AL 5/2/14 - Introduce list of restraints +c 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) +c write (iout,*) "dij(",i,j,") =",dij + nexl=0 + do k=1,constr_homology +c 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 +c write (iout,*) "distance(",k,") =",distance(k) +c +c For Gaussian-type Urestr +c + distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument +c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii) +c write (iout,*) "distancek(",k,") =",distancek(k) +c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii) +c +c For Lorentzian-type Urestr +c + 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 + +c min_odl=minval(distancek) + 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 + +c 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 +c Nie wiem po co to liczycie jeszcze raz! +c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/ +c & (2*(sigma_odl(i,j,k))**2)) + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + godl(k)=dexp(-distancek(k)+min_odl) + odleg2=odleg2+godl(k) +c +c For Lorentzian-type Urestr +c + else + odleg2=odleg2+distancek(k) + endif + +ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3, +ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=", +ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1), +ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k) + + enddo +c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents +c 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 +c +c For Gaussian-type Urestr +c + odleg=odleg-dLOG(odleg2/constr_homology)+min_odl +c +c For Lorentzian-type Urestr +c + else + odleg=odleg+odleg2/constr_homology + endif +c +c write (iout,*) "odleg",odleg ! sum of -ln-s +c Gradient +c +c For Gaussian-type Urestr +c + if (waga_dist.ge.0.0d0) sum_godl=odleg2 + sum_sgodl=0.0d0 + do k=1,constr_homology +c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) +c & *waga_dist)+min_odl +c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist +c + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c For Gaussian-type Urestr +c + sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd +c +c For Lorentzian-type Urestr +c + else + sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ + & sigma_odlir(k,ii)**2)**2) + endif + sum_sgodl=sum_sgodl+sgodl + +c sgodl2=sgodl2+sgodl +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1" +c write(iout,*) "constr_homology=",constr_homology +c write(iout,*) i, j, k, "TEST K" + enddo + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + grad_odl3=waga_homology(iset)*waga_dist + & *sum_sgodl/(sum_godl*dij) +c +c For Lorentzian-type Urestr +c + else +c Original grad expr modified by analogy w Gaussian-type Urestr grad +c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl + grad_odl3=-waga_homology(iset)*waga_dist* + & sum_sgodl/(constr_homology*dij) + endif +c +c grad_odl3=sum_sgodl/(sum_godl*dij) + + +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2" +c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2), +c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) + +ccc write(iout,*) godl, sgodl, grad_odl3 + +c grad_odl=grad_odl+grad_odl3 + + do jik=1,3 + ggodl=grad_odl3*(c(jik,i)-c(jik,j)) +ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1)) +ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) + ghpbc(jik,i)=ghpbc(jik,i)+ggodl + ghpbc(jik,j)=ghpbc(jik,j)-ggodl +ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) +c if (i.eq.25.and.j.eq.27) then +c write(iout,*) "jik",jik,"i",i,"j",j +c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl +c write(iout,*) "grad_odl3",grad_odl3 +c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j) +c write(iout,*) "ggodl",ggodl +c write(iout,*) "ghpbc(",jik,i,")", +c & ghpbc(jik,i),"ghpbc(",jik,j,")", +c & ghpbc(jik,j) +c endif + enddo +ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=", +ccc & dLOG(odleg2),"-odleg=", -odleg + + enddo ! ii-loop for dist +#ifdef DEBUG + write(iout,*) "------- dist restrs end -------" +c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or. +c & waga_d.eq.1.0d0) call sum_gradient +#endif +c Pseudo-energy and gradient from dihedral-angle restraints from +c homology templates +c write (iout,*) "End of distance loop" +c call flush(iout) + kat=0.0d0 +c 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 +#endif + do i=idihconstr_start_homo,idihconstr_end_homo + kat2=0.0d0 +c betai=beta(i,i+1,i+2,i+3) + betai = phi(i) +c write (iout,*) "betai =",betai + do k=1,constr_homology + dih_diff(k)=pinorm(dih(k,i)-betai) +cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k) +cd & ,sigma_dih(k,i) +c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)= +c & -(6.28318-dih_diff(i,k)) +c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)= +c & 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 +c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i) + gdih(k)=dexp(kat3) + kat2=kat2+gdih(k) +c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3) +c write(*,*)"" + enddo +c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps +c 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) +c write (iout,*) "kat",kat ! sum of -ln-s + +ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=", +ccc & dLOG(kat2), "-kat=", -kat + +c ---------------------------------------------------------------------- +c Gradient +c ---------------------------------------------------------------------- + + 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 +c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle + sum_sgdih=sum_sgdih+sgdih + enddo +c grad_dih3=sum_sgdih/sum_gdih + grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih + +c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3 +ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3 +c if (i.eq.25) then +c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg) +c endif +ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + + enddo ! i-loop for dih +#ifdef DEBUG + write(iout,*) "------- dih restrs end -------" +#endif + +c Pseudo-energy and gradient for theta angle restraints from +c homology templates +c FP 01/15 - inserted from econstr_local_test.F, loop structure +c adapted + +c +c For constr_homology reference structures (FP) +c +c Uconst_back_tot=0.0d0 + Eval=0.0d0 + Erot=0.0d0 +c Econstr_back legacy + do i=1,nres +c do i=ithet_start,ithet_end + dutheta(i)=0.0d0 +c enddo +c do i=loc_start,loc_end + do j=1,3 + duscdiff(j,i)=0.0d0 + duscdiffx(j,i)=0.0d0 + enddo + enddo +c +c do iref=1,nref +c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +c write (iout,*) "waga_theta",waga_theta + if (waga_theta.gt.0.0d0) then +#ifdef DEBUG + write (iout,*) "usampl",usampl + write(iout,*) "------- theta restrs start -------" +c do i=ithet_start,ithet_end +c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg) +c enddo +#endif +c write (iout,*) "maxres",maxres,"nres",nres + + do i=ithet_start,ithet_end +c +c do i=1,nfrag_back +c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) +c +c Deviation of theta angles wrt constr_homology ref structures +c + utheta_i=0.0d0 ! argument of Gaussian for single k + gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop +c over residues in a fragment +c write (iout,*) "theta(",i,")=",theta(i) + do k=1,constr_homology +c +c dtheta_i=theta(j)-thetaref(j,iref) +c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing + theta_diff(k)=thetatpl(k,i)-theta(i) +cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k) +cd & ,sigma_theta(k,i) + +c + utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument +c 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) +c Gradient for single Gaussian restraint in subr Econstr_back +c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) +c + enddo +c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps + +c +c Gradient for multiple Gaussian restraint + sum_gtheta=gutheta_i + sum_sgtheta=0.0d0 + do k=1,constr_homology +c New generalized expr for multiple Gaussian from Econstr_back + sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd +c +c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form? + sum_sgtheta=sum_sgtheta+sgtheta ! cum variable + enddo +c 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) +c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta +c & *waga_homology(iset) +c dutheta(i)=sum_sgtheta/sum_gtheta +c +c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight + Eval=Eval-dLOG(gutheta_i/constr_homology) +c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s +c Uconst_back=Uconst_back+utheta(i) + enddo ! (i-loop for theta) +#ifdef DEBUG + write(iout,*) "------- theta restrs end -------" +#endif + endif +c +c Deviation of local SC geometry +c +c Separation of two i-loops (instructed by AL - 11/3/2014) +c +c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +c 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 +#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 +c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy +c write(iout,*) "xxtab, yytab, zztab" +c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i) + do k=1,constr_homology +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c 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 +c write(iout,*) "dxx, dyy, dzz" +cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i) +c + usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument +c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d? +c uscdiffk(k)=usc_diff(i) + guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff +c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i), +c & " guscdiff2",guscdiff2(k) + guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk) +c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), +c & xxref(j),yyref(j),zzref(j) + enddo +c +c Gradient +c +c Generalized expression for multiple Gaussian acc to that for a single +c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014) +c +c Original implementation +c sum_guscdiff=guscdiff(i) +c +c sum_sguscdiff=0.0d0 +c do k=1,constr_homology +c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d? +c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff +c sum_sguscdiff=sum_sguscdiff+sguscdiff +c enddo +c +c Implementation of new expressions for gradient (Jan. 2015) +c +c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !? + do k=1,constr_homology +c +c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong +c before. Now the drivatives should be correct +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c 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 +c +c New implementation +c + sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong! + & sigma_d(k,i) ! for the grad wrt r' +c sum_sguscdiff=sum_sguscdiff+sum_guscdiff +c +c +c 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) +c +#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) +c write(iout,*) "sum_sguscdiff",sum_sguscdiff +cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i) +c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i) +c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i) +c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i) +c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i) +c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i) +c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i) +c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i) +c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i) +c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1) +c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i) +c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i) +c endif +#endif + enddo + enddo +c +c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required? +c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ? +c +c write (iout,*) i," uscdiff",uscdiff(i) +c +c Put together deviations from local geometry + +c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ +c & wfrag_back(3,i,iset)*uscdiff(i) + Erot=Erot-dLOG(guscdiff(i)/constr_homology) +c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s +c Uconst_back=Uconst_back+usc_diff(i) +c +c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?) +c +c New implment: multiplied by sum_sguscdiff +c + + enddo ! (i-loop for dscdiff) + +c 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 + endif + 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 + endif +#endif + +c Total energy from homology restraints +#ifdef DEBUG + write (iout,*) "odleg",odleg," kat",kat +#endif +c +c Addition of energy of theta angle and SC local geom over constr_homologs ref strs +c +c ehomology_constr=odleg+kat +c +c For Lorentzian-type Urestr +c + + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + ehomology_constr=(waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) +c write (iout,*) "ehomology_constr=",ehomology_constr + else +c +c For Lorentzian-type Urestr +c + ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) +c write (iout,*) "ehomology_constr=",ehomology_constr + endif +#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 +c +c FP 01/15 end +c + 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 +c---------------------------------------------------------------------------- +C The rigorous attempt to derive energy function + subroutine ebend_kcc(etheta) + + implicit none + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn + double precision thybt1(maxang_kcc) +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).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle + iti=iabs(itortyp(itype(i-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),iti,theta(i)*rad2deg, + & sumth1thyb + ihelp=nbend_kcc_Tb(iti)-1 + gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet) + etheta=etheta+sumth1thyb +C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0) + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet + enddo + return + end +c------------------------------------------------------------------------------------- + subroutine etheta_constr(ethetacnstr) + + implicit none + 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' + 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 +c------------------------------------------------------------------------------ + subroutine eback_sc_corr(esccor) +c 7/21/2007 Correlations between the backbone-local and side-chain-local +c conformational states; temporarily implemented as differences +c between UNRES torsional potentials (dependent on three types of +c residues) and the torsional potentials dependent on all 20 types +c of residues computed from AM1 energy surfaces of terminally-blocked +c amino-acid residues. + implicit 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' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. +c write (iout,*) "EBACK_SC_COR",itau_start,itau_end + esccor=0.0D0 + do i=itau_start,itau_end + if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle + esccor_ii=0.0D0 + isccori=isccortyp(itype(i-2)) + isccori1=isccortyp(itype(i-1)) +c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1) + phii=phi(i) + do intertyp=1,3 !intertyp +cc Added 09 May 2012 (Adasko) +cc Intertyp means interaction type of backbone mainchain correlation: +c 1 = SC...Ca...Ca...Ca +c 2 = Ca...Ca...Ca...SC +c 3 = SC...Ca...Ca...SCi + gloci=0.0D0 + if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. + & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. + & (itype(i-1).eq.ntyp1))) + & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) + & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) + & .or.(itype(i).eq.ntyp1))) + & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. + & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. + & (itype(i-3).eq.ntyp1)))) cycle + if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle + if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) + & cycle + do j=1,nterm_sccor(isccori,isccori1) + v1ij=v1sccor(j,intertyp,isccori,isccori1) + v2ij=v2sccor(j,intertyp,isccori,isccori1) + cosphi=dcos(j*tauangle(intertyp,i)) + sinphi=dsin(j*tauangle(intertyp,i)) + esccor=esccor+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp + gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1, + & (v1sccor(j,intertyp,isccori,isccori1),j=1,6) + & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6) + gsccor_loc(i-3)=gsccor_loc(i-3)+gloci + enddo !intertyp + enddo + + return + end +c---------------------------------------------------------------------------- + subroutine multibody(ecorr) +C This subroutine calculates multi-body contributions to energy following +C the idea of Skolnick et al. If side chains I and J make a contact and +C at the same time side chains I+1 and J+1 make a contact, an extra +C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + double precision gx(3),gx1(3) + logical lprn + +C Set lprn=.true. for debugging + lprn=.false. + + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(i2,20(1x,i2,f10.5))') + & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) + enddo + endif + ecorr=0.0D0 + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo + do i=nnt,nct-2 + + DO ISHIFT = 3,4 + + i1=i+ishift + num_conti=num_cont(i) + num_conti1=num_cont(i1) + do jj=1,num_conti + j=jcont(jj,i) + do kk=1,num_conti1 + j1=jcont(kk,i1) + if (j1.eq.j+ishift .or. j1.eq.j-ishift) then +cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, +cd & ' ishift=',ishift +C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) + endif ! j1==j+-ishift + enddo ! kk + enddo ! jj + + ENDDO ! ISHIFT + + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function esccorr(i,j,k,l,jj,kk) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.SHIELD' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont(jj,i) + ekl=facont(kk,k) +cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl +C Calculate the multi-body contribution to energy. +C Calculate multi-body contributions to the gradient. +cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), +cd & k,l,(gacont(m,kk,k),m=1,3) + do m=1,3 + gx(m) =ekl*gacont(m,jj,i) + gx1(m)=eij*gacont(m,kk,k) + gradxorr(m,i)=gradxorr(m,i)-gx(m) + gradxorr(m,j)=gradxorr(m,j)+gx(m) + gradxorr(m,k)=gradxorr(m,k)-gx1(m) + gradxorr(m,l)=gradxorr(m,l)+gx1(m) + enddo + do m=i,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) + enddo + enddo + do m=k,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) + enddo + enddo + esccorr=-eij*ekl + return + end +c------------------------------------------------------------------------------ + subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +#ifdef MPI + include "mpif.h" + parameter (max_cont=maxconts) + parameter (max_dim=26) + integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer status(MPI_STATUS_SIZE),req(maxconts*2), + & status_array(MPI_STATUS_SIZE,maxconts*2) +#endif + include 'COMMON.SETUP' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTROL' + include 'COMMON.LOCAL' + double precision gx(3),gx1(3),time00 + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. +#ifdef MPI + n_corr=0 + n_corr1=0 + if (nfgtasks.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values before RECEIVE:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + call flush(iout) + endif + do i=1,ntask_cont_from + ncont_recv(i)=0 + enddo + do i=1,ntask_cont_to + ncont_sent(i)=0 + enddo +c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", +c & ntask_cont_to +C Make the list of contacts to send to send to other procesors +c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end +c call flush(iout) + do i=iturn3_start,iturn3_end +c write (iout,*) "make contact list turn3",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) + enddo + do i=iturn4_start,iturn4_end +c write (iout,*) "make contact list turn4",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) + enddo + do ii=1,nat_sent + i=iat_sent(ii) +c write (iout,*) "make contact list longrange",i,ii," num_cont", +c & num_cont_hb(i) + do j=1,num_cont_hb(i) + do k=1,4 + jjc=jcont_hb(j,i) + iproc=iint_sent_local(k,jjc,ii) +c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc + if (iproc.gt.0) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=i + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=facont_hb(j,i) + zapas(4,nn,iproc)=ees0p(j,i) + zapas(5,nn,iproc)=ees0m(j,i) + zapas(6,nn,iproc)=gacont_hbr(1,j,i) + zapas(7,nn,iproc)=gacont_hbr(2,j,i) + zapas(8,nn,iproc)=gacont_hbr(3,j,i) + zapas(9,nn,iproc)=gacontm_hb1(1,j,i) + zapas(10,nn,iproc)=gacontm_hb1(2,j,i) + zapas(11,nn,iproc)=gacontm_hb1(3,j,i) + zapas(12,nn,iproc)=gacontp_hb1(1,j,i) + zapas(13,nn,iproc)=gacontp_hb1(2,j,i) + zapas(14,nn,iproc)=gacontp_hb1(3,j,i) + zapas(15,nn,iproc)=gacontm_hb2(1,j,i) + zapas(16,nn,iproc)=gacontm_hb2(2,j,i) + zapas(17,nn,iproc)=gacontm_hb2(3,j,i) + zapas(18,nn,iproc)=gacontp_hb2(1,j,i) + zapas(19,nn,iproc)=gacontp_hb2(2,j,i) + zapas(20,nn,iproc)=gacontp_hb2(3,j,i) + zapas(21,nn,iproc)=gacontm_hb3(1,j,i) + zapas(22,nn,iproc)=gacontm_hb3(2,j,i) + zapas(23,nn,iproc)=gacontm_hb3(3,j,i) + zapas(24,nn,iproc)=gacontp_hb3(1,j,i) + zapas(25,nn,iproc)=gacontp_hb3(2,j,i) + zapas(26,nn,iproc)=gacontp_hb3(3,j,i) + endif + enddo + enddo + enddo + if (lprn) then + write (iout,*) + & "Numbers of contacts to be sent to other processors", + & (ncont_sent(i),i=1,ntask_cont_to) + write (iout,*) "Contacts sent" + do ii=1,ntask_cont_to + nn=ncont_sent(ii) + iproc=itask_cont_to(ii) + write (iout,*) nn," contacts to processor",iproc, + & " of CONT_TO_COMM group" + do i=1,nn + write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) + enddo + enddo + call flush(iout) + endif + CorrelType=477 + CorrelID=fg_rank+1 + CorrelType1=478 + CorrelID1=nfgtasks+fg_rank+1 + ireq=0 +C Receive the numbers of needed contacts from other processors + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + ireq=ireq+1 + call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "IRECV ended" +c call flush(iout) +C Send the number of contacts needed by other processors + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + ireq=ireq+1 + call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "ISEND ended" +c write (iout,*) "number of requests (nn)",ireq +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) +c write (iout,*) +c & "Numbers of contacts to be received from other processors", +c & (ncont_recv(i),i=1,ntask_cont_from) +c call flush(iout) +C Receive contacts + ireq=0 + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + nn=ncont_recv(ii) +c write (iout,*) "Receiving",nn," contacts from processor",iproc, +c & " of CONT_TO_COMM group" +c call flush(iout) + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, + & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) + endif + enddo +C Send the contacts to processors that need them + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + nn=ncont_sent(ii) +c write (iout,*) nn," contacts to processor",iproc, +c & " of CONT_TO_COMM group" + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, + & iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) +c do i=1,nn +c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) +c enddo + endif + enddo +c write (iout,*) "number of requests (contacts)",ireq +c write (iout,*) "req",(req(i),i=1,4) +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) + do iii=1,ntask_cont_from + iproc=itask_cont_from(iii) + nn=ncont_recv(iii) + if (lprn) then + write (iout,*) "Received",nn," contacts from processor",iproc, + & " of CONT_FROM_COMM group" + call flush(iout) + do i=1,nn + write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) + enddo + call flush(iout) + endif + do i=1,nn + ii=zapas_recv(1,i,iii) +c Flag the received contacts to prevent double-counting + jj=-zapas_recv(2,i,iii) +c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj +c call flush(iout) + nnn=num_cont_hb(ii)+1 + num_cont_hb(ii)=nnn + jcont_hb(nnn,ii)=jj + facont_hb(nnn,ii)=zapas_recv(3,i,iii) + ees0p(nnn,ii)=zapas_recv(4,i,iii) + ees0m(nnn,ii)=zapas_recv(5,i,iii) + gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii) + gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii) + gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii) + gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii) + gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii) + gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii) + gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii) + gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii) + gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii) + gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii) + gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii) + gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii) + gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii) + gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii) + gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii) + gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii) + gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii) + gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii) + gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii) + gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii) + gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii) + enddo + enddo + 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 + call flush(iout) + endif + ecorr=0.0D0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the local-electrostatic correlation terms + do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end) + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk +c call flush(iout) + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 + & .or. j.lt.0 .and. j1.gt.0) .and. + & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) + n_corr=n_corr+1 + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + subroutine add_hb_contact(ii,jj,itask) + implicit none + include "DIMENSIONS" + include "COMMON.IOUNITS" + integer max_cont + integer max_dim + parameter (max_cont=maxconts) + parameter (max_dim=26) + include "COMMON.CONTACTS" + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer i,j,ii,jj,iproc,itask(4),nn +c write (iout,*) "itask",itask + do i=1,2 + iproc=itask(i) + if (iproc.gt.0) then + do j=1,num_cont_hb(ii) + jjc=jcont_hb(j,ii) +c write (iout,*) "i",ii," j",jj," jjc",jjc + if (jjc.eq.jj) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=ii + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=facont_hb(j,ii) + zapas(4,nn,iproc)=ees0p(j,ii) + zapas(5,nn,iproc)=ees0m(j,ii) + zapas(6,nn,iproc)=gacont_hbr(1,j,ii) + zapas(7,nn,iproc)=gacont_hbr(2,j,ii) + zapas(8,nn,iproc)=gacont_hbr(3,j,ii) + zapas(9,nn,iproc)=gacontm_hb1(1,j,ii) + zapas(10,nn,iproc)=gacontm_hb1(2,j,ii) + zapas(11,nn,iproc)=gacontm_hb1(3,j,ii) + zapas(12,nn,iproc)=gacontp_hb1(1,j,ii) + zapas(13,nn,iproc)=gacontp_hb1(2,j,ii) + zapas(14,nn,iproc)=gacontp_hb1(3,j,ii) + zapas(15,nn,iproc)=gacontm_hb2(1,j,ii) + zapas(16,nn,iproc)=gacontm_hb2(2,j,ii) + zapas(17,nn,iproc)=gacontm_hb2(3,j,ii) + zapas(18,nn,iproc)=gacontp_hb2(1,j,ii) + zapas(19,nn,iproc)=gacontp_hb2(2,j,ii) + zapas(20,nn,iproc)=gacontp_hb2(3,j,ii) + zapas(21,nn,iproc)=gacontm_hb3(1,j,ii) + zapas(22,nn,iproc)=gacontm_hb3(2,j,ii) + zapas(23,nn,iproc)=gacontm_hb3(3,j,ii) + zapas(24,nn,iproc)=gacontp_hb3(1,j,ii) + zapas(25,nn,iproc)=gacontp_hb3(2,j,ii) + zapas(26,nn,iproc)=gacontp_hb3(3,j,ii) + exit + endif + enddo + endif + enddo + return + end +c------------------------------------------------------------------------------ + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, + & n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +#ifdef MPI + include "mpif.h" + parameter (max_cont=maxconts) + parameter (max_dim=70) + integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer status(MPI_STATUS_SIZE),req(maxconts*2), + & status_array(MPI_STATUS_SIZE,maxconts*2) +#endif + include 'COMMON.SETUP' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CHAIN' + include 'COMMON.CONTROL' + include 'COMMON.SHIELD' + double precision gx(3),gx1(3) + integer num_cont_hb_old(maxres) + logical lprn,ldone + double precision eello4,eello5,eelo6,eello_turn6 + external eello4,eello5,eello6,eello_turn6 +C Set lprn=.true. for debugging + lprn=.false. + eturn6=0.0d0 +#ifdef MPI + do i=1,nres + num_cont_hb_old(i)=num_cont_hb(i) + enddo + n_corr=0 + n_corr1=0 + if (nfgtasks.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values before RECEIVE:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + do i=1,ntask_cont_from + ncont_recv(i)=0 + enddo + do i=1,ntask_cont_to + ncont_sent(i)=0 + enddo +c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", +c & ntask_cont_to +C Make the list of contacts to send to send to other procesors + do i=iturn3_start,iturn3_end +c write (iout,*) "make contact list turn3",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) + enddo + do i=iturn4_start,iturn4_end +c write (iout,*) "make contact list turn4",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i)) + enddo + do ii=1,nat_sent + i=iat_sent(ii) +c write (iout,*) "make contact list longrange",i,ii," num_cont", +c & num_cont_hb(i) + do j=1,num_cont_hb(i) + do k=1,4 + jjc=jcont_hb(j,i) + iproc=iint_sent_local(k,jjc,ii) +c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc + if (iproc.ne.0) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=i + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=d_cont(j,i) + ind=3 + do kk=1,3 + ind=ind+1 + zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i) + enddo + enddo + enddo + enddo + endif + enddo + enddo + enddo + if (lprn) then + write (iout,*) + & "Numbers of contacts to be sent to other processors", + & (ncont_sent(i),i=1,ntask_cont_to) + write (iout,*) "Contacts sent" + do ii=1,ntask_cont_to + nn=ncont_sent(ii) + iproc=itask_cont_to(ii) + write (iout,*) nn," contacts to processor",iproc, + & " of CONT_TO_COMM group" + do i=1,nn + write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10) + enddo + enddo + call flush(iout) + endif + CorrelType=477 + CorrelID=fg_rank+1 + CorrelType1=478 + CorrelID1=nfgtasks+fg_rank+1 + ireq=0 +C Receive the numbers of needed contacts from other processors + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + ireq=ireq+1 + call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "IRECV ended" +c call flush(iout) +C Send the number of contacts needed by other processors + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + ireq=ireq+1 + call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "ISEND ended" +c write (iout,*) "number of requests (nn)",ireq +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) +c write (iout,*) +c & "Numbers of contacts to be received from other processors", +c & (ncont_recv(i),i=1,ntask_cont_from) +c call flush(iout) +C Receive contacts + ireq=0 + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + nn=ncont_recv(ii) +c write (iout,*) "Receiving",nn," contacts from processor",iproc, +c & " of CONT_TO_COMM group" +c call flush(iout) + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, + & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) + endif + enddo +C Send the contacts to processors that need them + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + nn=ncont_sent(ii) +c write (iout,*) nn," contacts to processor",iproc, +c & " of CONT_TO_COMM group" + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, + & iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) +c do i=1,nn +c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) +c enddo + endif + enddo +c write (iout,*) "number of requests (contacts)",ireq +c write (iout,*) "req",(req(i),i=1,4) +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) + do iii=1,ntask_cont_from + iproc=itask_cont_from(iii) + nn=ncont_recv(iii) + if (lprn) then + write (iout,*) "Received",nn," contacts from processor",iproc, + & " of CONT_FROM_COMM group" + call flush(iout) + do i=1,nn + write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10) + enddo + call flush(iout) + endif + do i=1,nn + ii=zapas_recv(1,i,iii) +c Flag the received contacts to prevent double-counting + jj=-zapas_recv(2,i,iii) +c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj +c call flush(iout) + nnn=num_cont_hb(ii)+1 + num_cont_hb(ii)=nnn + jcont_hb(nnn,ii)=jj + d_cont(nnn,ii)=zapas_recv(3,i,iii) + ind=3 + do kk=1,3 + ind=ind+1 + grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii) + enddo + enddo + enddo + enddo + enddo + enddo + if (lprn) then + write (iout,'(a)') 'Contact function values after receive:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i3,5f6.3))') + & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), + & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + call flush(iout) + endif + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,5f6.3))') + & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), + & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 + ecorr5=0.0d0 + ecorr6=0.0d0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the dipole-dipole interaction energies + if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then + do i=iatel_s,iatel_e+1 + num_conti=num_cont_hb(i) + do jj=1,num_conti + j=jcont_hb(jj,i) +#ifdef MOMENT + call dipole(i,j,jj) +#endif + enddo + enddo + endif +C Calculate the local-electrostatic correlation terms +c write (iout,*) "gradcorr5 in eello5 before loop" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) +c write (iout,*) "corr loop i",i + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk +c if (j1.eq.j+1 .or. j1.eq.j-1) then + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 + & .or. j.lt.0 .and. j1.gt.0) .and. + & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + n_corr=n_corr+1 + sqd1=dsqrt(d_cont(jj,i)) + sqd2=dsqrt(d_cont(kk,i1)) + sred_geom = sqd1*sqd2 + IF (sred_geom.lt.cutoff_corr) THEN + call gcont(sred_geom,r0_corr,1.0D0,delt_corr, + & ekont,fprimcont) +cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, +cd & ' jj=',jj,' kk=',kk + fac_prim1=0.5d0*sqd2/sqd1*fprimcont + fac_prim2=0.5d0*sqd1/sqd2*fprimcont + do l=1,3 + g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) + g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) + enddo + n_corr1=n_corr1+1 +cd write (iout,*) 'sred_geom=',sred_geom, +cd & ' ekont=',ekont,' fprim=',fprimcont, +cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 +cd write (iout,*) "g_contij",g_contij +cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) +cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) + call calc_eello(i,jp,i+1,jp1,jj,kk) + if (wcorr4.gt.0.0d0) + & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) +CC & *fac_shield(i)**2*fac_shield(j)**2 + if (energy_dec.and.wcorr4.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 before eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (wcorr5.gt.0.0d0) + & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 after eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (energy_dec.and.wcorr5.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) +cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 +cd write(2,*)'ijkl',i,jp,i+1,jp1 + if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 + & .or. wturn6.eq.0.0d0))then +cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 + ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) +cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, +cd & 'ecorr6=',ecorr6 +cd write (iout,'(4e15.5)') sred_geom, +cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) + else if (wturn6.gt.0.0d0 + & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then +cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 + eturn6=eturn6+eello_turn6(i,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) +cd write (2,*) 'multibody_eello:eturn6',eturn6 + endif + ENDIF +1111 continue + endif + enddo ! kk + enddo ! jj + enddo ! i + do i=1,nres + num_cont_hb(i)=num_cont_hb_old(i) + enddo +c write (iout,*) "gradcorr5 in eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + return + end +c------------------------------------------------------------------------------ + subroutine add_hb_contact_eello(ii,jj,itask) + implicit none + include "DIMENSIONS" + include "COMMON.IOUNITS" + integer max_cont + integer max_dim + parameter (max_cont=maxconts) + parameter (max_dim=70) + include "COMMON.CONTACTS" + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer i,j,ii,jj,iproc,itask(4),nn +c write (iout,*) "itask",itask + do i=1,2 + iproc=itask(i) + if (iproc.gt.0) then + do j=1,num_cont_hb(ii) + jjc=jcont_hb(j,ii) +c write (iout,*) "send turns i",ii," j",jj," jjc",jjc + if (jjc.eq.jj) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=ii + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=d_cont(j,ii) + ind=3 + do kk=1,3 + ind=ind+1 + zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii) + enddo + enddo + enddo + enddo + exit + endif + enddo + endif + enddo + return + end +c------------------------------------------------------------------------------ + double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. +C print *,"wchodze",fac_shield(i),shield_mode + 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) +C* +C & fac_shield(i)**2*fac_shield(j)**2 +cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) +C Following 4 lines for diagnostics. +cd ees0pkl=0.0D0 +cd ees0pij=1.0D0 +cd ees0mkl=0.0D0 +cd ees0mij=1.0D0 +c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') +c & 'Contacts ',i,j, +c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l +c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, +c & 'gradcorr_long' +C Calculate the multi-body contribution to energy. +C ecorr=ecorr+ekont*ees +C Calculate multi-body contributions to the gradient. + coeffpees0pij=coeffp*ees0pij + coeffmees0mij=coeffm*ees0mij + coeffpees0pkl=coeffp*ees0pkl + coeffmees0mkl=coeffm*ees0mkl + do ll=1,3 +cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb1(ll,jj,i)) + gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb2(ll,jj,i)) +cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ + & coeffmees0mij*gacontm_hb1(ll,kk,k)) + gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ + & coeffmees0mij*gacontm_hb2(ll,kk,k)) + gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- + & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb3(ll,jj,i)) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij + gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- + & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ + & coeffmees0mij*gacontm_hb3(ll,kk,k)) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl +c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl + enddo +c write (iout,*) +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*ekl*gacont_hbr(ll,jj,i)- +cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ +cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*eij*gacont_hbr(ll,kk,k)- +cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ +cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) +cgrad enddo +cgrad enddo +c write (iout,*) "ehbcorr",ekont*ees +C print *,ekont,ees,i,k + ehbcorr=ekont*ees +C now gradient over shielding +C return + 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) +C & *2.0 + 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) +C & *2.0 + 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) +C & *2.0 + 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) +C & *2.0 + 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 +C print *,gshieldx(m,iresshield) + 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 +#ifdef MOMENT +C--------------------------------------------------------------------------- + subroutine dipole(i,j,jj) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), + & auxmat(2,2) + iti1 = itortyp(itype(i+1)) + if (j.lt.nres-1) then + itj1 = itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + do iii=1,2 + dipi(iii,1)=Ub2(iii,i) + dipderi(iii)=Ub2der(iii,i) + dipi(iii,2)=b1(iii,i+1) + dipj(iii,1)=Ub2(iii,j) + dipderj(iii)=Ub2der(iii,j) + dipj(iii,2)=b1(iii,j+1) + enddo + kkk=0 + do iii=1,2 + call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) + do jjj=1,2 + kkk=kkk+1 + dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + do kkk=1,5 + do lll=1,3 + mmm=0 + do iii=1,2 + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), + & auxvec(1)) + do jjj=1,2 + mmm=mmm+1 + dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + enddo + enddo + call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) + call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) + do iii=1,2 + dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) + enddo + call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) + do iii=1,2 + dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) + enddo + return + end +#endif +C--------------------------------------------------------------------------- + subroutine calc_eello(i,j,k,l,jj,kk) +C +C This subroutine computes matrices and vectors needed to calculate +C the fourth-, fifth-, and sixth-order local-electrostatic terms. +C + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), + & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) + logical lprn + common /kutas/ lprn +cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, +cd & ' jj=',jj,' kk=',kk +cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return +cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) +cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) + do iii=1,2 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) + enddo + enddo + call transpose2(aa1(1,1),aa1t(1,1)) + call transpose2(aa2(1,1),aa2t(1,1)) + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), + & aa1tder(1,1,lll,kkk)) + call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), + & aa2tder(1,1,lll,kkk)) + enddo + enddo + if (l.eq.j+1) then +C parallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itype2loc(itype(i)) + else + iti=nloctyp + endif + itk1=itype2loc(itype(k+1)) + itj=itype2loc(itype(j)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +C A1 kernel(j+1) A2T +cd do iii=1,2 +cd write (iout,'(3f10.5,5x,3f10.5)') +cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) +cd enddo + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), + & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + lprn=.false. + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), + & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants +cd lprn=.false. +cd if (lprn) then +cd write (2,*) 'In calc_eello6' +cd do iii=1,2 +cd write (2,*) 'iii=',iii +cd do kkk=1,5 +cd write (2,*) 'kkk=',kkk +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) +cd enddo +cd enddo +cd enddo +cd endif + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) +C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E +c in theta; to be sriten later. +c#ifdef NEWCORR +c call transpose2(gtEE(1,1,k),auxmat(1,1)) +c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1)) +c call transpose2(EUg(1,1,k),auxmat(1,1)) +c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1)) +c#endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A1T kernel(i+1) A2 + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i),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,i),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,k+1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j),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,j),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,l+1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i), + & 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,k+1), + & 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,j), + & 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,l+1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + else +C Antiparallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itype2loc(itype(i)) + else + iti=nloctyp + endif + itk1=itype2loc(itype(k+1)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif +C A2 kernel(j-1)T A1T + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), + & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), + & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A2T kernel(i+1)T A1 + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. + & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i),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,i),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,k+1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j+1),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,l),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,j+1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i), + & 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,k+1), + & 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,l), + & 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,j+1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + endif + return + end +C--------------------------------------------------------------------------- + subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, + & KK,KKderg,AKA,AKAderg,AKAderx) + implicit none + integer nderg + logical transp + double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), + & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), + & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) + integer iii,kkk,lll + integer jjj,mmm + logical lprn + common /kutas/ lprn + call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) + do iii=1,nderg + call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, + & AKAderg(1,1,iii)) + enddo +cd if (lprn) write (2,*) 'In kernel' + do kkk=1,5 +cd if (lprn) write (2,*) 'kkk=',kkk + do lll=1,3 + call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=1' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) +cd enddo +cd endif + call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=2' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) +cd enddo +cd endif + enddo + enddo + return + end +C--------------------------------------------------------------------------- + double precision function eello4(i,j,k,l,jj,kk) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then +cd eello4=0.0d0 +cd return +cd endif +cd print *,'eello4:',i,j,k,l,jj,kk +cd write (2,*) 'i',i,' j',j,' k',k,' l',l +cd call checkint4(i,j,k,l,jj,kk,eel4_num) +cold eij=facont_hb(jj,i) +cold ekl=facont_hb(kk,k) +cold ekont=eij*ekl + eel4=-EAEA(1,1,1)-EAEA(2,2,1) +cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) + gcorr_loc(k-1)=gcorr_loc(k-1) + & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) + if (l.eq.j+1) then + gcorr_loc(l-1)=gcorr_loc(l-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) +C Al 4/16/16: Derivatives in theta, to be added later. +c#ifdef NEWCORR +c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1) +c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1)) +c#endif + else + gcorr_loc(j-1)=gcorr_loc(j-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) +c#ifdef NEWCORR +c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1) +c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1)) +c#endif + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) + & -EAEAderx(2,2,lll,kkk,iii,1) +cd derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd gcorr_loc(l-1)=0.0d0 +cd gcorr_loc(j-1)=0.0d0 +cd gcorr_loc(k-1)=0.0d0 +cd eel4=1.0d0 +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l, +cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel4*g_contij(ll,1) +cgrad ggg2(ll)=eel4*g_contij(ll,2) + glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) + glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) +cgrad ghalf=0.5d0*ggg1(ll) + gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) + gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) + gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) + gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij +cgrad ghalf=0.5d0*ggg2(ll) + gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) + gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) + gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) + gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl + enddo +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,gcorr_loc(iii) +cd enddo + eello4=ekont*eel4 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello4',ekont*eel4 + return + end +C--------------------------------------------------------------------------- + double precision function eello5(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) + double precision ggg1(3),ggg2(3) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel chains C +C C +C o o o o C +C /l\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j| o |l1 | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C Antiparallel chains C +C C +C o o o o C +C /j\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j1| o |l | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C o denotes a local interaction, vertical lines an electrostatic interaction. C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then +cd eello5=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + itk=itype2loc(itype(k)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) + eello5_1=0.0d0 + eello5_2=0.0d0 + eello5_3=0.0d0 + eello5_4=0.0d0 +cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, +cd & eel5_3_num,eel5_4_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l +cd goto 1111 +C Contribution from the graph I. +cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) +cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) +C Explicit gradient in virtual-dihedral angles. + if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + if (l.eq.j+1) then + if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + else + if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + enddo + enddo + enddo +c goto 1112 +c1111 continue +C Contribution from graph II + call transpose2(EE(1,1,k),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,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + if (l.eq.j+1) then + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k)) + & -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,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + enddo + enddo + enddo +cd goto 1112 +cd1111 continue + if (l.eq.j+1) then +cd goto 1110 +C Parallel orientation +C Contribution from graph III + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) + call transpose2(EUgder(1,1,l),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + enddo + enddo + enddo +cd goto 1112 +C Contribution from graph IV +cd1110 continue + call transpose2(EE(1,1,l),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,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + enddo + enddo + enddo + else +C Antiparallel orientation +C Contribution from graph III +c goto 1110 + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) + call transpose2(EUgder(1,1,j),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + enddo + enddo + enddo +cd goto 1112 +C Contribution from graph IV +1110 continue + call transpose2(EE(1,1,j),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,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + enddo + enddo + enddo + endif +1112 continue + eel5=eello5_1+eello5_2+eello5_3+eello5_4 +cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then +cd write (2,*) 'ijkl',i,j,k,l +cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, +cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 +cd endif +cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num +cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num +cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num +cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 +cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont +C 2/11/08 AL Gradients over DC's connecting interacting sites will be +C summed up outside the subrouine as for the other subroutines +C handling long-range interactions. The old code is commented out +C with "cgrad" to keep track of changes. + do ll=1,3 +cgrad ggg1(ll)=eel5*g_contij(ll,1) +cgrad ggg2(ll)=eel5*g_contij(ll,2) + gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) +c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') +c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), +c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), +c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont +c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') +c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), +c & gradcorr5ij, +c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl +cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) + gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) + gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) + gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) + gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij + gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij +cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2) + gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) + gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2) + gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) + gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl + gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +c1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr5_loc(iii) +cd enddo + eello5=ekont*eel5 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello5',ekont*eel5 + return + end +c-------------------------------------------------------------------------- + double precision function eello6(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + eello6_1=0.0d0 + eello6_2=0.0d0 + eello6_3=0.0d0 + eello6_4=0.0d0 + eello6_5=0.0d0 + eello6_6=0.0d0 +cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, +cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + if (l.eq.j+1) then + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(j,i,l,k,2,.false.) + eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) + eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) + else + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(l,k,j,i,2,.true.) + eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + if (wturn6.eq.0.0d0 .or. j.ne.i+4) then + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) + else + eello6_5=0.0d0 + endif + eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) + endif +C If turn contributions are considered, they will be handled separately. + eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 +cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num +cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num +cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num +cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num +cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num +cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel6*g_contij(ll,1) +cgrad ggg2(ll)=eel6*g_contij(ll,2) +cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) + gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) + gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) + gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) + gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) + gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij + gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij +cgrad ghalf=0.5d0*ggg2(ll) +cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) +cd ghalf=0.0d0 + gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) + gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) + gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) + gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) + gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl + gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + eello6=ekont*eel6 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello6',ekont*eel6 + return + end +c-------------------------------------------------------------------------- + double precision function eello6_graph1(i,j,k,l,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) + logical swap + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ /j\ C +C / \ / \ C +C /| o | | o |\ C +C \ j|/k\| / \ |/k\|l / C +C \ / \ / \ / \ / C +C o o o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itype2loc(itype(k)) + s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k) + vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k) + s5=scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) + & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) + & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) + & +scalar2(vv(1),Dtobr2der(1,i))) + call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k) + vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k) + 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,k) + & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k) + vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k) + & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k) + s5=scalar2(vv(1),Dtobr2(1,i)) + derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph2(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + logical swap + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxvec2(2),auxmat1(2,2) + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C \ /l\ /j\ / C +C \ / \ / \ / C +C o| o | | o |o C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l +C AL 7/4/01 s1 would occur in the sixth-order moment, +C but not in a cluster cumulant +#ifdef MOMENT + s1=dip(1,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph2=-(s1+s2+s3+s4) +#else + eello6_graph2=-(s2+s3+s4) +#endif +c eello6_graph2=-s3 +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + s1=dipderg(1,jj,i)*dip(1,kk,k) +#endif + s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 +C Derivatives in gamma(j-1) or gamma(l-1) + if (j.gt.1) then +#ifdef MOMENT + s1=dipderg(3,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) + call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + endif +#endif + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) +c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 + endif +C Derivatives in gamma(l-1) or gamma(j-1) + if (l.gt.1) then +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(3,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + else + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + endif +#endif + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) +c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 + endif +C Cartesian derivatives. + if (lprn) then + write (2,*) 'In eello6_graph2' + do iii=1,2 + write (2,*) 'iii=',iii + do kkk=1,5 + write (2,*) 'kkk=',kkk + do jjj=1,2 + write (2,'(3(2f10.5),5x)') + & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) + enddo + enddo + enddo + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) + else + s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) + endif +#endif + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), + & auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph3(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C j|/k\| / |/k\|l / C +C / \ / / \ / C +C / o / o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + itk=itype2loc(itype(k)) + itk1=itype2loc(itype(k+1)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,k),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) + call transpose2(EE(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, +cd & "sum",-(s2+s3+s4) +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else + eello6_graph3=-(s2+s3+s4) +#endif + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), + & auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph3(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C j|/k\| / |/k\|l / C +C / \ / / \ / C +C / o / o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + itk=itype2loc(itype(k)) + itk1=itype2loc(itype(k+1)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,k),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) + call transpose2(EE(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, +cd & "sum",-(s2+s3+s4) +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else +cd write (2,*) 'eello_graph4: wturn6',wturn6 + iti=itype2loc(itype(i)) + itj=itype2loc(itype(j)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + itk=itype2loc(itype(k)) + if (k.lt.nres-1) then + itk1=itype2loc(itype(k+1)) + else + itk1=nloctyp + endif + itl=itype2loc(itype(l)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l +cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, +cd & ' itl',itl,' itl1',itl1 +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dip(3,kk,k) + else + s1=dip(2,jj,j)*dip(2,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph4=-(s1+s2+s3+s4) +#else + eello6_graph4=-(s2+s3+s4) +#endif +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + if (imat.eq.1) then + s1=dipderg(2,jj,i)*dip(3,kk,k) + else + s1=dipderg(4,jj,j)*dip(2,kk,l) + endif +#endif + s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +cd write (2,*) 'turn6 derivatives' +#ifdef MOMENT + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif + endif + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderg(2,kk,k) + else + s1=dip(2,jj,j)*dipderg(4,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif + endif +C Derivatives in gamma(j-1) or gamma(l-1) + if (l.eq.j+1 .and. l.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) + else if (j.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then + gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) + endif + endif +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + if (imat.eq.1) then + s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) + else + s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) + endif + else + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) + else + s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) + endif + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), + & auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,j+1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec(1)) + else + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,l+1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec(1)) + endif + call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (swap) then + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s1+s2+s4) +#else + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s2+s4) +#endif + derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 + else +#ifdef MOMENT + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) +#else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) +#endif + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + else +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (l.eq.j+1) then + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + endif + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello_turn6(i,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), + & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), + & ggg1(3),ggg2(3) + double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), + & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) +C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to +C the respective energy moment and not to the cluster cumulant. + s1=0.0d0 + s8=0.0d0 + s13=0.0d0 +c + eello_turn6=0.0d0 + j=i+4 + k=i+1 + l=i+3 + iti=itype2loc(itype(i)) + itk=itype2loc(itype(k)) + itk1=itype2loc(itype(k+1)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) +cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj +cd write (2,*) 'i',i,' k',k,' j',j,' l',l +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l +cd call checkint_turn6(i,jj,kk,eel_turn6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx_turn(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) +cd eello6_5=0.0d0 +cd write (2,*) 'eello6_5',eello6_5 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) + ss1=scalar2(Ub2(1,i+2),b1(1,l)) + s1 = (auxmat(1,1)+auxmat(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1)) + call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) + s2 = scalar2(b1(1,k),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,k+1),vtemp2(1)) + s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),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,k),vtemp4(1)) + s13 = (gtemp(1,1)+gtemp(2,2))*ss13 +#endif +c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 +c s1=0.0d0 +c s2=0.0d0 +c s8=0.0d0 +c s12=0.0d0 +c s13=0.0d0 + eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) +C Derivatives in gamma(i+2) + s1d =0.0d0 + s8d =0.0d0 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 + call transpose2(AEAderg(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 + gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) +C Derivatives in gamma(i+3) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + ss1d=scalar2(Ub2der(1,i+2),b1(1,l)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d +#endif + call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1)) + call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,k),vtemp1d(1)) +#ifdef MOMENT + call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1)) + s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1)) +#endif + s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Derivatives in gamma(i+4) + call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +C s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) +#else + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) +#endif +C Derivatives in gamma(i+5) +#ifdef MOMENT + call transpose2(AEAderg(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1)) + call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,k),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,l),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,k),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Cartesian derivatives + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), + & vtemp1d(1)) + s2d = scalar2(b1(1,k),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,l),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), + & auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*(s1d+s2d) +#else + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*s2d +#endif +#ifdef MOMENT + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*(s8d+s12d) +#else + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*s12d +#endif + enddo + enddo + enddo +#ifdef MOMENT + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), + & achuj_tempd(1,1)) + call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d=(gtempd(1,1)+gtempd(2,2))*ss13 + derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), + & vtemp4d(1)) + ss13d = scalar2(b1(1,k),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d + derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d + enddo + enddo +#endif +cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', +cd & 16*eel_turn6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel_turn6*g_contij(ll,1) +cgrad ggg2(ll)=eel_turn6*g_contij(ll,2) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) + gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) + gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf + & +ekont*derx_turn(ll,2,1) + gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) + gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf + & +ekont*derx_turn(ll,4,1) + gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) + gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij + gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf + & +ekont*derx_turn(ll,2,2) + gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) + gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf + & +ekont*derx_turn(ll,4,2) + gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) + gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl + gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + eello_turn6=ekont*eel_turn6 +cd write (2,*) 'ekont',ekont +cd write (2,*) 'eel_turn6',ekont*eel_turn6 + return + end + +C----------------------------------------------------------------------------- + double precision function scalar(u,v) +!DIR$ INLINEALWAYS scalar +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::scalar +#endif + implicit none + double precision u(3),v(3) +cd double precision sc +cd integer i +cd sc=0.0d0 +cd do i=1,3 +cd sc=sc+u(i)*v(i) +cd enddo +cd scalar=sc + + scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) + return + end +crc------------------------------------------------- + SUBROUTINE MATVEC2(A1,V1,V2) +!DIR$ INLINEALWAYS MATVEC2 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2 +#endif + implicit none + include 'DIMENSIONS' + double precision A1(2,2),V1(2),V2(2) + double precision vaux1,vaux2 +c DO 1 I=1,2 +c VI=0.0 +c DO 3 K=1,2 +c 3 VI=VI+A1(I,K)*V1(K) +c Vaux(I)=VI +c 1 CONTINUE + + vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) + vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) + + v2(1)=vaux1 + v2(2)=vaux2 + END +C--------------------------------------- + SUBROUTINE MATMAT2(A1,A2,A3) +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2 +#endif + implicit none + include 'DIMENSIONS' + double precision A1(2,2),A2(2,2),A3(2,2) + double precision ai3_11,ai3_12,ai3_21,ai3_22 +c DIMENSION AI3(2,2) +c DO J=1,2 +c A3IJ=0.0 +c DO K=1,2 +c A3IJ=A3IJ+A1(I,K)*A2(K,J) +c enddo +c A3(I,J)=A3IJ +c enddo +c enddo + + ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) + ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) + ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) + ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) + + A3(1,1)=AI3_11 + A3(2,1)=AI3_21 + A3(1,2)=AI3_12 + A3(2,2)=AI3_22 + END + +c------------------------------------------------------------------------- + double precision function scalar2(u,v) +!DIR$ INLINEALWAYS scalar2 + implicit none + double precision u(2),v(2) + double precision sc + integer i + scalar2=u(1)*v(1)+u(2)*v(2) + return + end + +C----------------------------------------------------------------------------- + + subroutine transpose2(a,at) +!DIR$ INLINEALWAYS transpose2 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::transpose2 +#endif + implicit none + double precision a(2,2),at(2,2) + at(1,1)=a(1,1) + at(1,2)=a(2,1) + at(2,1)=a(1,2) + at(2,2)=a(2,2) + return + end +c-------------------------------------------------------------------------- + subroutine transpose(n,a,at) + implicit none + integer n,i,j + double precision a(n,n),at(n,n) + do i=1,n + do j=1,n + at(j,i)=a(i,j) + enddo + enddo + return + end +C--------------------------------------------------------------------------- + subroutine prodmat3(a1,a2,kk,transp,prod) +!DIR$ INLINEALWAYS prodmat3 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::prodmat3 +#endif + implicit none + integer i,j + double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) + logical transp +crc double precision auxmat(2,2),prod_(2,2) + + if (transp) then +crc call transpose2(kk(1,1),auxmat(1,1)) +crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) + + else +crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) + + endif +c call transpose2(a2(1,1),a2t(1,1)) + +crc print *,transp +crc print *,((prod_(i,j),i=1,2),j=1,2) +crc print *,((prod(i,j),i=1,2),j=1,2) + + return + end +CCC---------------------------------------------- + subroutine Eliptransfer(eliptran) + implicit none + 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.SPLITELE' + include 'COMMON.SBRIDGE' +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 + eliptran=0.0 + do i=ilip_start,ilip_end +C do i=1,1 + if (itype(i).eq.ntyp1) 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 + enddo +C print *, "nic nie bylo w lipidzie?" +C now multiply all by the peptide group transfer factor +C eliptran=eliptran*pepliptran +C now the same for side chains +CV do i=1,1 + do i=ilip_start,ilip_end + if (itype(i).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)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +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)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +C print *, "doing sscalefor top part",sslip,fracinbuf + else + eliptran=eliptran+liptranene(itype(i)) +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 + enddo + return + end +C--------------------------------------------------------- +C AFM soubroutine for constant force + subroutine AFMforce(Eafmforce) + implicit none + 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.SPLITELE' + include 'COMMON.SBRIDGE' + real*8 diffafm(3) + dist=0.0d0 + Eafmforce=0.0d0 + do i=1,3 + diffafm(i)=c(i,afmend)-c(i,afmbeg) + dist=dist+diffafm(i)**2 + enddo + dist=dsqrt(dist) + Eafmforce=-forceAFMconst*(dist-distafminit) + do i=1,3 + gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist + gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist + enddo +C print *,'AFM',Eafmforce + return + end +C--------------------------------------------------------- +C AFM subroutine with pseudoconstant velocity + subroutine AFMvel(Eafmforce) + implicit none + 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.SPLITELE' + include 'COMMON.SBRIDGE' + real*8 diffafm(3) +C Only for check grad COMMENT if not used for checkgrad +C totT=3.0d0 +C-------------------------------------------------------- +C print *,"wchodze" + dist=0.0d0 + Eafmforce=0.0d0 + do i=1,3 + diffafm(i)=c(i,afmend)-c(i,afmbeg) + dist=dist+diffafm(i)**2 + enddo + dist=dsqrt(dist) + Eafmforce=0.5d0*forceAFMconst + & *(distafminit+totTafm*velAFMconst-dist)**2 +C Eafmforce=-forceAFMconst*(dist-distafminit) + do i=1,3 + gradafm(i,afmend-1)=-forceAFMconst* + &(distafminit+totTafm*velAFMconst-dist) + &*diffafm(i)/dist + gradafm(i,afmbeg-1)=forceAFMconst* + &(distafminit+totTafm*velAFMconst-dist) + &*diffafm(i)/dist + enddo +C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist + return + end +C----------------------------------------------------------- +C first for shielding is setting of function of side-chains + subroutine set_shield_fac + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +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).eq.ntyp1).or.(itype(k).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=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(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 +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +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.0*sh_frac_dist-3.0d0) + fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2) + & /dist_pep_side/buff_shield*0.5 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + do j=1,3 + sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) +C print *,"jestem",scale_fac_dist,fac_help_scale, +C & sh_frac_dist_grad(j) + enddo + endif +C if ((i.eq.3).and.(k.eq.2)) then +C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist +C & ,"TU" +C endif + +C this is what is now we have the distance scaling now volume... + short=short_r_sidechain(itype(k)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2) +C now costhet_grad +C costhet=0.0d0 + costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4 +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.0 + 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.0-cosalfa**2 + fac_alfa_sin=dsqrt(fac_alfa_sin) + rkprim=fac_alfa_sin*(long-short)+short +C now costhet_grad + cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2) + cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4 + + do j=1,3 + cosphi_grad_long(j)=cosphi_fac*pep_side(j) + &+cosphi**3*0.5/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)) + + cosphi_grad_loc(j)=cosphi**3*0.5/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) + enddo + + VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi) + & /VSolvSphere_div + & *wshield +C now the gradient... +C grad_shield is gradient of Calfa for peptide groups +C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist, +C & costhet,cosphi +C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group, +C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k) + do j=1,3 + grad_shield(j,i)=grad_shield(j,i) +C gradient po skalowaniu + & +(sh_frac_dist_grad(j) +C gradient po costhet + &-scale_fac_dist*costhet_grad(j)/(1.0-costhet) + &-scale_fac_dist*(cosphi_grad_long(j)) + &/(1.0-cosphi) )*div77_81 + &*VofOverlap +C grad_shield_side is Cbeta sidechain gradient + grad_shield_side(j,ishield_list(i),i)= + & (sh_frac_dist_grad(j)*(-2.0d0) + & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet) + & +scale_fac_dist*(cosphi_grad_long(j)) + & *2.0d0/(1.0-cosphi)) + & *div77_81*VofOverlap + + grad_shield_loc(j,ishield_list(i),i)= + & scale_fac_dist*cosphi_grad_loc(j) + & *2.0d0/(1.0-cosphi) + & *div77_81*VofOverlap + enddo + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*div77_81+div4_81 +c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) + enddo + return + end +C-------------------------------------------------------------------------- + double precision function tschebyshev(m,n,x,y) + implicit none + include "DIMENSIONS" + 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 +C-------------------------------------------------------------------------- + double precision function gradtschebyshev(m,n,x,y) + implicit none + include "DIMENSIONS" + 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 +C------------------------------------------------------------------------ +C first for shielding is setting of function of side-chains + subroutine set_shield_fac2 + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +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).eq.ntyp1).or.(itype(k).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=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(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 +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +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 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + 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)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2) + sinthet=short/dist_pep_side*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 +c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div", +c & VSolvSphere_div," sinphi",sinphi," sinthet",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 + + 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 + enddo +c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist", +c & scale_fac_dist + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield) +c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i), +c & " wshield",wshield +c write(2,*) "TU",rpp(1,1),short,long,buff_shield + enddo + return + end +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) + implicit none + 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.SPLITELE' + include 'COMMON.SBRIDGE' + double precision tub_r,vectube(3),enetube(maxres*2) + Etube=0.0d0 + do i=1,2*nres + enetube(i)=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=1,nres +C lets ommit dummy atoms for now + if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle +C now calculate distance from center of tube and direction vectors + vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize) + if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize + vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize) + if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize + 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) + do i=1,nres +C Lets not jump over memory as we use many times iti + iti=itype(i) +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 + 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),boxxsize) + if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize + + 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 +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 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=1,2*nres + Etube=Etube+enetube(i) + enddo +C print *,"ETUBE", etube + return + end +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----------------------------------------------------------------------- +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) + implicit none + 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.SPLITELE' + include 'COMMON.SBRIDGE' + double precision tub_r,vectube(3),enetube(maxres*2) + Etube=0.0d0 + do i=1,2*nres + enetube(i)=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=1,nres +C lets ommit dummy atoms for now + if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle +C now calculate distance from center of tube and direction vectors + vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize) + if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize + vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize) + if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize + 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) + do i=1,nres +C Lets not jump over memory as we use many times iti + iti=itype(i) +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),boxxsize) + if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize + + 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) + 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 + print *,ssgradtube, sstube,tubetranene(itype(i)) + enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i)) + gg_tube_SC(3,i)=gg_tube_SC(3,i) + &+ssgradtube*tubetranene(itype(i)) + gg_tube(3,i-1)= gg_tube(3,i-1) + &+ssgradtube*tubetranene(itype(i)) +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)) +C gg_tube_SC(3,i)=gg_tube_SC(3,i) +C &+ssgradtube*tubetranene(itype(i)) +C gg_tube(3,i-1)= gg_tube(3,i-1) +C &+ssgradtube*tubetranene(itype(i)) +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)) +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=1,2*nres + Etube=Etube+enetube(i) + enddo +C print *,"ETUBE", etube + return + end +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---------------------------------------------------------------------------- + subroutine e_saxs(Esaxs_constr) + implicit none + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + include "COMMON.SETUP" + integer IERR +#endif + 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' +#ifdef LANG0 + include 'COMMON.LANGEVIN.lang0' +#else + include 'COMMON.LANGEVIN' +#endif + include 'COMMON.CONTROL' + include 'COMMON.SAXS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + include 'COMMON.FFIELD' +c + double precision Esaxs_constr + integer i,iint,j,k,l + double precision PgradC(maxSAXS,3,maxres), + & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS) +#ifdef MPI + double precision PgradC_(maxSAXS,3,maxres), + & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS) +#endif + double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC, + & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC, + & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1, + & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig + double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2 + double precision dist,mygauss,mygaussder + external dist + integer llicz,lllicz + double precision time01 +c SAXS restraint penalty function +#ifdef DEBUG + write(iout,*) "------- SAXS penalty function start -------" + write (iout,*) "nsaxs",nsaxs + write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e + write (iout,*) "Psaxs" + do i=1,nsaxs + write (iout,'(i5,e15.5)') i, Psaxs(i) + enddo +#endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + Esaxs_constr = 0.0d0 + do k=1,nsaxs + Pcalc(k)=0.0d0 + do j=1,nres + do l=1,3 + PgradC(k,l,j)=0.0d0 + PgradX(k,l,j)=0.0d0 + enddo + enddo + enddo +c lllicz=0 + do i=iatsc_s,iatsc_e + if (itype(i).eq.ntyp1) cycle + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + if (itype(j).eq.ntyp1) cycle +#ifdef ALLSAXS + dijCACA=dist(i,j) + dijCASC=dist(i,j+nres) + dijSCCA=dist(i+nres,j) + dijSCSC=dist(i+nres,j+nres) + sigma2CACA=2.0d0/(pstok**2) + sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2) + sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2) + sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2) + do k=1,nsaxs + dk = distsaxs(k) + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2) + if (itype(j).ne.10) then + expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2) + else + endif + expCASC = 0.0d0 + if (itype(i).ne.10) then + expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2) + else + expSCCA = 0.0d0 + endif + if (itype(i).ne.10 .and. itype(j).ne.10) then + expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2) + else + expSCSC = 0.0d0 + endif + Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC +#ifdef DEBUG + write(iout,*) "i j k Pcalc",i,j,Pcalc(k) +#endif + CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA + CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC + SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA + SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC + do l=1,3 +c CA CA + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux +c CA SC + if (itype(j).ne.10) then + aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + PgradX(k,l,j) = PgradX(k,l,j)+aux + endif +c SC CA + if (itype(i).ne.10) then + aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA + PgradX(k,l,i) = PgradX(k,l,i)-aux + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + endif +c SC SC + if (itype(i).ne.10 .and. itype(j).ne.10) then + aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + PgradX(k,l,i) = PgradX(k,l,i)-aux + PgradX(k,l,j) = PgradX(k,l,j)+aux + endif + enddo ! l + enddo ! k +#else + dijCACA=dist(i,j) + sigma2CACA=scal_rad**2*0.25d0/ + & (restok(itype(j))**2+restok(itype(i))**2) +c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j)) +c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA) +#ifdef MYGAUSS + sigmaCACA=dsqrt(sigma2CACA) + threesig=3.0d0/sigmaCACA +c llicz=0 + do k=1,nsaxs + dk = distsaxs(k) + if (dabs(dijCACA-dk).ge.threesig) cycle +c llicz=llicz+1 +c lllicz=lllicz+1 + aux = sigmaCACA*(dijCACA-dk) + expCACA = mygauss(aux) +c if (expcaca.eq.0.0d0) cycle + Pcalc(k) = Pcalc(k)+expCACA + CACAgrad = -sigmaCACA*mygaussder(aux) +c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad + do l=1,3 + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + enddo ! l + enddo ! k +c write (iout,*) "i",i," j",j," llicz",llicz +#else + IF (saxs_cutoff.eq.0) THEN + do k=1,nsaxs + dk = distsaxs(k) + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2) + Pcalc(k) = Pcalc(k)+expCACA + CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA + do l=1,3 + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + enddo ! l + enddo ! k + ELSE + rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA) + do k=1,nsaxs + dk = distsaxs(k) +c write (2,*) "ijk",i,j,k + sss2 = sscale2(dijCACA,rrr,dk,0.3d0) + if (sss2.eq.0.0d0) cycle + ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0) + if (energy_dec) write(iout,'(a4,3i5,8f10.4)') + & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)), + & 1.0d0/dsqrt(sigma2CACA),rrr,dk, + & sss2,ssgrad2 + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2 + Pcalc(k) = Pcalc(k)+expCACA +#ifdef DEBUG + write(iout,*) "i j k Pcalc",i,j,Pcalc(k) +#endif + CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+ + & ssgrad2*expCACA/sss2 + do l=1,3 +c CA CA + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)+aux + PgradC(k,l,j) = PgradC(k,l,j)-aux + enddo ! l + enddo ! k + ENDIF +#endif +#endif + enddo ! j + enddo ! iint + enddo ! i +c#ifdef TIMING +c time_SAXS=time_SAXS+MPI_Wtime()-time01 +c#endif +c write (iout,*) "lllicz",lllicz +c#ifdef TIMING +c time01=MPI_Wtime() +c#endif +#ifdef MPI + if (nfgtasks.gt.1) then + call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION, + & MPI_SUM,FG_COMM,IERR) +c if (fg_rank.eq.king) then + do k=1,nsaxs + Pcalc(k) = Pcalc_(k) + enddo +c endif +c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres, +c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) +c if (fg_rank.eq.king) then +c do i=1,nres +c do l=1,3 +c do k=1,nsaxs +c PgradC(k,l,i) = PgradC_(k,l,i) +c enddo +c enddo +c enddo +c endif +#ifdef ALLSAXS +c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres, +c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) +c if (fg_rank.eq.king) then +c do i=1,nres +c do l=1,3 +c do k=1,nsaxs +c PgradX(k,l,i) = PgradX_(k,l,i) +c enddo +c enddo +c enddo +c endif +#endif + endif +#endif + Cnorm = 0.0d0 + do k=1,nsaxs + Cnorm = Cnorm + Pcalc(k) + enddo +#ifdef MPI + if (fg_rank.eq.king) then +#endif + Esaxs_constr = dlog(Cnorm)-wsaxs0 + do k=1,nsaxs + if (Pcalc(k).gt.0.0d0) + & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k)) +#ifdef DEBUG + write (iout,*) "k",k," Esaxs_constr",Esaxs_constr +#endif + enddo +#ifdef DEBUG + write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr +#endif +#ifdef MPI + endif +#endif + gsaxsC=0.0d0 + gsaxsX=0.0d0 + do i=nnt,nct + do l=1,3 + auxC=0.0d0 + auxC1=0.0d0 + auxX=0.0d0 + auxX1=0.d0 + do k=1,nsaxs + if (Pcalc(k).gt.0) + & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k) + auxC1 = auxC1+PgradC(k,l,i) +#ifdef ALLSAXS + auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k) + auxX1 = auxX1+PgradX(k,l,i) +#endif + enddo + gsaxsC(l,i) = auxC - auxC1/Cnorm +#ifdef ALLSAXS + gsaxsX(l,i) = auxX - auxX1/Cnorm +#endif +c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm), +c * " gradX",wsaxs*(auxX - auxX1/Cnorm) +c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i), +c * " gradX",wsaxs*gsaxsX(l,i) + enddo + enddo +#ifdef TIMING + time_SAXS=time_SAXS+MPI_Wtime()-time01 +#endif +#ifdef DEBUG + write (iout,*) "gsaxsc" + do i=nnt,nct + write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3) + enddo +#endif +#ifdef MPI +c endif +#endif + return + end +c---------------------------------------------------------------------------- + subroutine e_saxsC(Esaxs_constr) + implicit none + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + include "COMMON.SETUP" + integer IERR +#endif + 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' +#ifdef LANG0 + include 'COMMON.LANGEVIN.lang0' +#else + include 'COMMON.LANGEVIN' +#endif + include 'COMMON.CONTROL' + include 'COMMON.SAXS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + include 'COMMON.FFIELD' +c + double precision Esaxs_constr + integer i,iint,j,k,l + double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot +#ifdef MPI + double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_ +#endif + double precision dk,dijCASPH,dijSCSPH, + & sigma2CA,sigma2SC,expCASPH,expSCSPH, + & CASPHgrad,SCSPHgrad,aux,auxC,auxC1, + & auxX,auxX1,Cnorm +c SAXS restraint penalty function +#ifdef DEBUG + write(iout,*) "------- SAXS penalty function start -------" + write (iout,*) "nsaxs",nsaxs + + do i=nnt,nct + print *,MyRank,"C",i,(C(j,i),j=1,3) + enddo + do i=nnt,nct + print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3) + enddo +#endif + Esaxs_constr = 0.0d0 + logPtot=0.0d0 + do j=isaxs_start,isaxs_end + Pcalc=0.0d0 + do i=1,nres + do l=1,3 + PgradC(l,i)=0.0d0 + PgradX(l,i)=0.0d0 + enddo + enddo + do i=nnt,nct + if (itype(i).eq.ntyp1) cycle + dijCASPH=0.0d0 + dijSCSPH=0.0d0 + do l=1,3 + dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2 + enddo + if (itype(i).ne.10) then + do l=1,3 + dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2 + enddo + endif + sigma2CA=2.0d0/pstok**2 + sigma2SC=4.0d0/restok(itype(i))**2 + expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH) + expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH) + Pcalc = Pcalc+expCASPH+expSCSPH +#ifdef DEBUG + write(*,*) "processor i j Pcalc", + & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc +#endif + CASPHgrad = sigma2CA*expCASPH + SCSPHgrad = sigma2SC*expSCSPH + do l=1,3 + aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad + PgradX(l,i) = PgradX(l,i) + aux + PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux + enddo ! l + enddo ! i + do i=nnt,nct + do l=1,3 + gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc + gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc + enddo + enddo + logPtot = logPtot - dlog(Pcalc) +c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc), +c & " logPtot",logPtot + enddo ! j +#ifdef MPI + if (nfgtasks.gt.1) then +c write (iout,*) "logPtot before reduction",logPtot + call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION, + & MPI_SUM,king,FG_COMM,IERR) + logPtot = logPtot_ +c write (iout,*) "logPtot after reduction",logPtot + call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + gsaxsC(l,i) = gsaxsC_(l,i) + enddo + enddo + endif + call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + gsaxsX(l,i) = gsaxsX_(l,i) + enddo + enddo + endif + endif +#endif + Esaxs_constr = logPtot + return + end +c---------------------------------------------------------------------------- + double precision function sscale2(r,r_cut,r0,rlamb) + implicit none + double precision r,gamm,r_cut,r0,rlamb,rr + rr = dabs(r-r0) +c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb +c write (2,*) "rr",rr + if(rr.lt.r_cut-rlamb) then + sscale2=1.0d0 + else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then + gamm=(rr-(r_cut-rlamb))/rlamb + sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale2=0d0 + endif + return + end +C----------------------------------------------------------------------- + double precision function sscalgrad2(r,r_cut,r0,rlamb) + implicit none + double precision r,gamm,r_cut,r0,rlamb,rr + rr = dabs(r-r0) + if(rr.lt.r_cut-rlamb) then + sscalgrad2=0.0d0 + else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then + gamm=(rr-(r_cut-rlamb))/rlamb + if (r.ge.r0) then + sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb + else + sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb + endif + else + sscalgrad2=0.0d0 + endif + return + end diff --git a/source/unres/src-HCD-5D/energy_p_new_barrier.F.safe b/source/unres/src-HCD-5D/energy_p_new_barrier.F.safe new file mode 100644 index 0000000..ae8e449 --- /dev/null +++ b/source/unres/src-HCD-5D/energy_p_new_barrier.F.safe @@ -0,0 +1,13539 @@ + subroutine etotal(energia) + implicit none + include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" + double precision weights_(n_ene) + double precision time00 + integer ierror,ierr +#endif + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision energia(0:n_ene) + include 'COMMON.LOCAL' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' +c include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.CONTROL' + include 'COMMON.TIME1' + include 'COMMON.SPLITELE' + include 'COMMON.TORCNSTR' + include 'COMMON.SAXS' + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6, + & eliptran,Eafmforce,Etube, + & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet + integer n_corr,n_corr1 +#ifdef MPI +c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, +c & " nfgtasks",nfgtasks + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +C FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (fg_rank.eq.0) then + call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) +c print *,"Processor",myrank," BROADCAST iorder" +C FG master sets up the WEIGHTS_ array which will be broadcast to the +C FG slaves as WEIGHTS array. + weights_(1)=wsc + weights_(2)=wscp + weights_(3)=welec + weights_(4)=wcorr + weights_(5)=wcorr5 + weights_(6)=wcorr6 + weights_(7)=wel_loc + weights_(8)=wturn3 + weights_(9)=wturn4 + weights_(10)=wturn6 + weights_(11)=wang + weights_(12)=wscloc + weights_(13)=wtor + weights_(14)=wtor_d + weights_(15)=wstrain + weights_(16)=wvdwpp + weights_(17)=wbond + weights_(18)=scal14 + weights_(21)=wsccor + weights_(22)=wtube + weights_(26)=wsaxs + weights_(28)=wdfa_dist + weights_(29)=wdfa_tor + weights_(30)=wdfa_nei + weights_(31)=wdfa_beta +C FG Master broadcasts the WEIGHTS_ array + call MPI_Bcast(weights_(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + else +C FG slaves receive the WEIGHTS array + call MPI_Bcast(weights(1),n_ene, + & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) + wsc=weights(1) + wscp=weights(2) + welec=weights(3) + wcorr=weights(4) + wcorr5=weights(5) + wcorr6=weights(6) + wel_loc=weights(7) + wturn3=weights(8) + wturn4=weights(9) + wturn6=weights(10) + wang=weights(11) + wscloc=weights(12) + wtor=weights(13) + wtor_d=weights(14) + wstrain=weights(15) + wvdwpp=weights(16) + wbond=weights(17) + scal14=weights(18) + wsccor=weights(21) + wtube=weights(22) + wsaxs=weights(26) + wdfa_dist=weights_(28) + wdfa_tor=weights_(29) + wdfa_nei=weights_(30) + wdfa_beta=weights_(31) + endif + time_Bcast=time_Bcast+MPI_Wtime()-time00 + time_Bcastw=time_Bcastw+MPI_Wtime()-time00 +c call chainbuild_cart + endif +#ifndef DFA + edfadis=0.0d0 + edfator=0.0d0 + edfanei=0.0d0 + edfabet=0.0d0 +#endif +c print *,'Processor',myrank,' calling etotal ipot=',ipot +c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct +#else +c if (modecalc.eq.12.or.modecalc.eq.14) then +c call int_from_cart1(.false.) +c endif +#endif +#ifdef TIMING + time00=MPI_Wtime() +#endif +C +C Compute the side-chain and electrostatic interaction energy +C +C print *,ipot + goto (101,102,103,104,105,106) ipot +C Lennard-Jones potential. + 101 call elj(evdw) +cd print '(a)','Exit ELJ' + goto 107 +C Lennard-Jones-Kihara potential (shifted). + 102 call eljk(evdw) + goto 107 +C Berne-Pechukas potential (dilated LJ, angular dependence). + 103 call ebp(evdw) + goto 107 +C Gay-Berne potential (shifted LJ, angular dependence). + 104 call egb(evdw) +C print *,"bylem w egb" + goto 107 +C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). + 105 call egbv(evdw) + goto 107 +C Soft-sphere potential + 106 call e_softsphere(evdw) +C +C Calculate electrostatic (H-bonding) energy of the main chain. +C + 107 continue +#ifdef DFA +C BARTEK for dfa test! + if (wdfa_dist.gt.0) then + call edfad(edfadis) + else + edfadis=0 + endif +c print*, 'edfad is finished!', edfadis + if (wdfa_tor.gt.0) then + call edfat(edfator) + else + edfator=0 + endif +c print*, 'edfat is finished!', edfator + if (wdfa_nei.gt.0) then + call edfan(edfanei) + else + edfanei=0 + endif +c print*, 'edfan is finished!', edfanei + if (wdfa_beta.gt.0) then + call edfab(edfabet) + else + edfabet=0 + endif +#endif +cmc +cmc Sep-06: egb takes care of dynamic ss bonds too +cmc +c if (dyn_ss) call dyn_set_nss + +c print *,"Processor",myrank," computed USCSC" +#ifdef TIMING + time01=MPI_Wtime() +#endif + call vec_and_deriv +#ifdef TIMING + time_vec=time_vec+MPI_Wtime()-time01 +#endif +C Introduction of shielding effect first for each peptide group +C the shielding factor is set this factor is describing how each +C peptide group is shielded by side-chains +C the matrix - shield_fac(i) the i index describe the ith between i and i+1 +C write (iout,*) "shield_mode",shield_mode + if (shield_mode.eq.1) then + call set_shield_fac + else if (shield_mode.eq.2) then + call set_shield_fac2 + endif +c print *,"Processor",myrank," left VEC_AND_DERIV" + if (ipot.lt.6) then +#ifdef SPLITELE + if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. + & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 + & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 + & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#else + if (welec.gt.0d0.or.wel_loc.gt.0d0.or. + & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 + & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 + & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then +#endif + call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) + else + ees=0.0d0 + evdw1=0.0d0 + eel_loc=0.0d0 + eello_turn3=0.0d0 + eello_turn4=0.0d0 + endif + else + write (iout,*) "Soft-spheer ELEC potential" +c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, +c & eello_turn4) + endif +c#ifdef TIMING +c time_enecalc=time_enecalc+MPI_Wtime()-time00 +c#endif +c print *,"Processor",myrank," computed UELEC" +C +C Calculate excluded-volume interaction energy between peptide groups +C and side chains. +C + if (ipot.lt.6) then + if(wscp.gt.0d0) then + call escp(evdw2,evdw2_14) + else + evdw2=0 + evdw2_14=0 + endif + else +c write (iout,*) "Soft-sphere SCP potential" + call escp_soft_sphere(evdw2,evdw2_14) + endif +c +c Calculate the bond-stretching energy +c + call ebond(estr) +C +C Calculate the disulfide-bridge and other energy and the contributions +C from other distance constraints. +cd write (iout,*) 'Calling EHPB' + call edis(ehpb) +cd print *,'EHPB exitted succesfully.' +C +C Calculate the virtual-bond-angle energy. +C + 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) +c print *,"Processor",myrank," computed UB" +C +C Calculate the SC local energy. +C +C print *,"TU DOCHODZE?" + call esc(escloc) +c print *,"Processor",myrank," computed USC" +C +C Calculate the virtual-bond torsional energy. +C +cd print *,'nterm=',nterm +C print *,"tor",tor_mode + if (wtor.gt.0.0d0) then + if (tor_mode.eq.0) then + call etor(etors) + else +C etor kcc is Kubo cumulant clustered rigorous attemp to derive the +C energy function + call etor_kcc(etors) + endif + else + etors=0.0d0 + endif + edihcnstr=0.0d0 + if (ndih_constr.gt.0) call etor_constr(edihcnstr) +c print *,"Processor",myrank," computed Utor" + if (constr_homology.ge.1) then + call e_modeller(ehomology_constr) +c print *,'iset=',iset,'me=',me,ehomology_constr, +c & 'Processor',fg_rank,' CG group',kolor, +c & ' absolute rank',MyRank + else + ehomology_constr=0.0d0 + endif +C +C 6/23/01 Calculate double-torsional energy +C + if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then + call etor_d(etors_d) + else + etors_d=0 + endif +c print *,"Processor",myrank," computed Utord" +C +C 21/5/07 Calculate local sicdechain correlation energy +C + if (wsccor.gt.0.0d0) then + call eback_sc_corr(esccor) + else + esccor=0.0d0 + endif +#ifdef FOURBODY +C print *,"PRZED MULIt" +c print *,"Processor",myrank," computed Usccorr" +C +C 12/1/95 Multi-body terms +C + n_corr=0 + n_corr1=0 + if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 + & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then + call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) +c write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1, +c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 +c call flush(iout) + 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 +c write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6, +c & n_corr,n_corr1 +c call flush(iout) + call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr, +c & n_corr1 +c call flush(iout) + endif +#endif +c print *,"Processor",myrank," computed Ucorr" +c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode + if (nsaxs.gt.0 .and. saxs_mode.eq.0) then + call e_saxs(Esaxs_constr) +c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr + else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then + call e_saxsC(Esaxs_constr) +c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr + else + Esaxs_constr = 0.0d0 + endif +C +C If performing constraint dynamics, call the constraint energy +C after the equilibration time +c if(usampl.and.totT.gt.eq_time) then +c write (iout,*) "usampl",usampl + if(usampl) then + call EconstrQ + if (loc_qlike) then + call Econstr_back_qlike + else + call Econstr_back + endif + else + Uconst=0.0d0 + Uconst_back=0.0d0 + endif +C 01/27/2015 added by adasko +C the energy component below is energy transfer into lipid environment +C based on partition function +C print *,"przed lipidami" + if (wliptran.gt.0) then + call Eliptransfer(eliptran) + endif +C print *,"za lipidami" + if (AFMlog.gt.0) then + call AFMforce(Eafmforce) + else if (selfguide.gt.0) then + call AFMvel(Eafmforce) + endif + if (TUBElog.eq.1) then +C print *,"just before call" + call calctube(Etube) + elseif (TUBElog.eq.2) then + call calctube2(Etube) + else + Etube=0.0d0 + endif + +#ifdef TIMING + time_enecalc=time_enecalc+MPI_Wtime()-time00 +#endif +c print *,"Processor",myrank," computed Uconstr" +#ifdef TIMING + time00=MPI_Wtime() +#endif +c +C Sum the energies +C + energia(1)=evdw +#ifdef SCP14 + energia(2)=evdw2-evdw2_14 + energia(18)=evdw2_14 +#else + energia(2)=evdw2 + energia(18)=0.0d0 +#endif +#ifdef SPLITELE + energia(3)=ees + energia(16)=evdw1 +#else + energia(3)=ees+evdw1 + energia(16)=0.0d0 +#endif + energia(4)=ecorr + energia(5)=ecorr5 + energia(6)=ecorr6 + energia(7)=eel_loc + energia(8)=eello_turn3 + energia(9)=eello_turn4 + energia(10)=eturn6 + energia(11)=ebe + energia(12)=escloc + energia(13)=etors + energia(14)=etors_d + energia(15)=ehpb + energia(19)=edihcnstr + energia(17)=estr + energia(20)=Uconst+Uconst_back + energia(21)=esccor + energia(22)=eliptran + energia(23)=Eafmforce + energia(24)=ethetacnstr + energia(25)=Etube + energia(26)=Esaxs_constr + energia(27)=ehomology_constr + energia(28)=edfadis + energia(29)=edfator + energia(30)=edfanei + energia(31)=edfabet +c write (iout,*) "esaxs_constr",energia(26) +c Here are the energies showed per procesor if the are more processors +c per molecule then we sum it up in sum_energy subroutine +c print *," Processor",myrank," calls SUM_ENERGY" + call sum_energy(energia,.true.) +c write (iout,*) "After sum_energy: esaxs_constr",energia(26) + if (dyn_ss) call dyn_set_nss +c print *," Processor",myrank," left SUM_ENERGY" +#ifdef TIMING + time_sumene=time_sumene+MPI_Wtime()-time00 +#endif + return + end +c------------------------------------------------------------------------------- + subroutine sum_energy(energia,reduce) + implicit none + include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include "mpif.h" + integer ierr + double precision time00 +#endif + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision energia(0:n_ene),enebuff(0:n_ene+1) + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.TIME1' + logical reduce + integer i + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6, + & eliptran,Eafmforce,Etube, + & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet + double precision Uconst,etot +#ifdef MPI + if (nfgtasks.gt.1 .and. reduce) then +#ifdef DEBUG + write (iout,*) "energies before REDUCE" + call enerprint(energia) + call flush(iout) +#endif + do i=0,n_ene + enebuff(i)=energia(i) + enddo + time00=MPI_Wtime() + call MPI_Barrier(FG_COMM,IERR) + time_barrier_e=time_barrier_e+MPI_Wtime()-time00 + time00=MPI_Wtime() + call MPI_Reduce(enebuff(0),energia(0),n_ene+1, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) +#ifdef DEBUG + write (iout,*) "energies after REDUCE" + call enerprint(energia) + call flush(iout) +#endif + time_Reduce=time_Reduce+MPI_Wtime()-time00 + endif + if (fg_rank.eq.0) then +#endif + evdw=energia(1) +#ifdef SCP14 + evdw2=energia(2)+energia(18) + evdw2_14=energia(18) +#else + evdw2=energia(2) +#endif +#ifdef SPLITELE + ees=energia(3) + evdw1=energia(16) +#else + ees=energia(3) + evdw1=0.0d0 +#endif + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eturn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + edihcnstr=energia(19) + estr=energia(17) + Uconst=energia(20) + esccor=energia(21) + eliptran=energia(22) + Eafmforce=energia(23) + ethetacnstr=energia(24) + Etube=energia(25) + esaxs_constr=energia(26) + ehomology_constr=energia(27) + edfadis=energia(28) + edfator=energia(29) + edfanei=energia(30) + edfabet=energia(31) +#ifdef SPLITELE + etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 + & +wang*ebe+wtor*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 + & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 + & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d + & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce + & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet +#else + etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) + & +wang*ebe+wtor*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 + & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 + & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d + & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran + & +Eafmforce + & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr + & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei + & +wdfa_beta*edfabet +#endif + energia(0)=etot +c detecting NaNQ +#ifdef ISNAN +#ifdef AIX + if (isnan(etot).ne.0) energia(0)=1.0d+99 +#else + if (isnan(etot)) energia(0)=1.0d+99 +#endif +#else + i=0 +#ifdef WINPGI + idumm=proc_proc(etot,i) +#else + call proc_proc(etot,i) +#endif + if(i.eq.1)energia(0)=1.0d+99 +#endif +#ifdef MPI + endif +#endif + return + end +c------------------------------------------------------------------------------- + subroutine sum_gradient + implicit none + include 'DIMENSIONS' +#ifndef ISNAN + external proc_proc +#ifdef WINPGI +cMS$ATTRIBUTES C :: proc_proc +#endif +#endif +#ifdef MPI + include 'mpif.h' + integer ierror,ierr + double precision time00,time01 +#endif + double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres), + & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres) + & ,gloc_scbuf(3,-1:maxres) + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.TIME1' + include 'COMMON.MAXGRAD' + include 'COMMON.SCCOR' +c include 'COMMON.MD' + include 'COMMON.QRESTR' + integer i,j,k + double precision scalar + double precision 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,gsccorrc_norm,gscloc_norm,gvdwx_norm, + &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm, + &gsclocx_norm +#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 DEBUG + write (iout,*) "sum_gradient gsaxsc, gsaxsx" + do i=0,nres + write (iout,'(i3,3e15.5,5x,3e15.5)') + & i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3) + enddo + call flush(iout) +#endif +#ifdef MPI +C FG slaves call the following matching MPI_Bcast in ERGASTULUM + if (nfgtasks.gt.1 .and. fg_rank.eq.0) + & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) +#endif +C +C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient +C in virtual-bond-vector coordinates +C +#ifdef DEBUG +c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" +c do i=1,nres-1 +c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') +c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) +c enddo +c write (iout,*) "gel_loc_tur3 gel_loc_turn4" +c do i=1,nres-1 +c write (iout,'(i5,3f10.5,2x,f10.5)') +c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) +c enddo + write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc" + do i=1,nres + write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') + & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3), + & g_corr5_loc(i) + enddo + call flush(iout) +#endif +#ifdef DEBUG + write (iout,*) "gsaxsc" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(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) + & +wsaxs*gsaxsc(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) + & +wsaxs*gsaxsc(j,i) + enddo + enddo +#endif + do i=1,nct + do j=1,3 + gradbufc(j,i)=gradbufc(j,i)+ + & wdfa_dist*gdfad(j,i)+ + & wdfa_tor*gdfat(j,i)+ + & wdfa_nei*gdfan(j,i)+ + & wdfa_beta*gdfab(j,i) + enddo + enddo +#ifdef DEBUG + write (iout,*) "gradc from gradbufc" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3) + enddo + call flush(iout) +#endif +#ifdef MPI + if (nfgtasks.gt.1) then + time00=MPI_Wtime() +#ifdef DEBUG + write (iout,*) "gradbufc before allreduce" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif + do i=0,nres + do j=1,3 + gradbufc_sum(j,i)=gradbufc(j,i) + enddo + enddo +c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, +c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) +c time_reduce=time_reduce+MPI_Wtime()-time00 +#ifdef DEBUG +c write (iout,*) "gradbufc_sum after allreduce" +c do i=1,nres +c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) +c enddo +c call flush(iout) +#endif +#ifdef TIMING +c time_allreduce=time_allreduce+MPI_Wtime()-time00 +#endif + do i=nnt,nres + do k=1,3 + gradbufc(k,i)=0.0d0 + enddo + enddo +#ifdef DEBUG + write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end + write (iout,*) (i," jgrad_start",jgrad_start(i), + & " jgrad_end ",jgrad_end(i), + & i=igrad_start,igrad_end) +#endif +c +c Obsolete and inefficient code; we can make the effort O(n) and, therefore, +c do not parallelize this part. +c +c do i=igrad_start,igrad_end +c do j=jgrad_start(i),jgrad_end(i) +c do k=1,3 +c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) +c enddo +c enddo +c enddo + do j=1,3 + gradbufc(j,nres-1)=gradbufc_sum(j,nres) + enddo + do i=nres-2,-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 +#ifdef DEBUG + write (iout,*) "gradbufc" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif + do i=-1,nres + do j=1,3 + gradbufc_sum(j,i)=gradbufc(j,i) + gradbufc(j,i)=0.0d0 + enddo + enddo + do j=1,3 + gradbufc(j,nres-1)=gradbufc_sum(j,nres) + enddo + do i=nres-2,-1,-1 + do j=1,3 + gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) + enddo + enddo +c do i=nnt,nres-1 +c do k=1,3 +c gradbufc(k,i)=0.0d0 +c enddo +c do j=i+1,nres +c do k=1,3 +c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) +c enddo +c enddo +c enddo +#ifdef DEBUG + write (iout,*) "gradbufc after summing" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) + enddo + call flush(iout) +#endif +#ifdef MPI + endif +#endif + do k=1,3 + gradbufc(k,nres)=0.0d0 + enddo + do i=-1,nct + do j=1,3 +#ifdef SPLITELE +C print *,gradbufc(1,13) +C print *,welec*gelc(1,13) +C print *,wel_loc*gel_loc(1,13) +C print *,0.5d0*(wscp*gvdwc_scpp(1,13)) +C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13) +C print *,wel_loc*gel_loc_long(1,13) +C print *,gradafm(1,13),"AFM" + 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) + +#else + gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ + & wel_loc*gel_loc(j,i)+ + & 0.5d0*(wscp*gvdwc_scpp(j,i)+ + & welec*gelc_long(j,i)+ + & wel_loc*gel_loc_long(j,i)+ + & wcorr*gcorr_long(j,i)+ + & wcorr5*gradcorr5_long(j,i)+ + & wcorr6*gradcorr6_long(j,i)+ + & wturn6*gcorr6_turn_long(j,i))+ + & wbond*gradb(j,i)+ + & wcorr*gradcorr(j,i)+ + & wturn3*gcorr3_turn(j,i)+ + & wturn4*gcorr4_turn(j,i)+ + & wcorr5*gradcorr5(j,i)+ + & wcorr6*gradcorr6(j,i)+ + & wturn6*gcorr6_turn(j,i)+ + & wsccor*gsccorc(j,i) + & +wscloc*gscloc(j,i) + & +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) + + +#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) + & +wsaxs*gsaxsx(j,i) + + + + enddo + enddo + 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) + gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i) + enddo + enddo + endif +#ifdef DEBUG + write (iout,*) "gradc gradx gloc after adding" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') + & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) + enddo +#endif +#ifdef DEBUG + write (iout,*) "gloc before adding corr" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) + & +wcorr5*g_corr5_loc(i) + & +wcorr6*g_corr6_loc(i) + & +wturn4*gel_loc_turn4(i) + & +wturn3*gel_loc_turn3(i) + & +wturn6*gel_loc_turn6(i) + & +wel_loc*gel_loc_loc(i) + enddo +#ifdef DEBUG + write (iout,*) "gloc after adding corr" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif +#ifdef MPI + if (nfgtasks.gt.1) then + do j=1,3 + do i=1,nres + gradbufc(j,i)=gradc(j,i,icg) + gradbufx(j,i)=gradx(j,i,icg) + enddo + enddo + do i=1,4*nres + glocbuf(i)=gloc(i,icg) + enddo +c#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 +c#undef DEBUG + do i=1,nres + do j=1,3 + gloc_scbuf(j,i)=gloc_sc(j,i,icg) + enddo + enddo + time00=MPI_Wtime() + call MPI_Barrier(FG_COMM,IERR) + time_barrier_g=time_barrier_g+MPI_Wtime()-time00 + time00=MPI_Wtime() + call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 + call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + time_reduce=time_reduce+MPI_Wtime()-time00 +#ifdef DEBUG + write (iout,*) "gradc after reduce" + do i=1,nres + do j=1,3 + write (iout,*) i,j,gradc(j,i,icg) + enddo + enddo +#endif +#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 +#ifdef DEBUG + write (iout,*) "gloc after reduce" + do i=1,4*nres + write (iout,*) i,gloc(i,icg) + enddo +#endif + endif +#endif + if (gnorm_check) then +c +c Compute the maximum elements of the gradient +c + gvdwc_max=0.0d0 + gvdwc_scp_max=0.0d0 + gelc_max=0.0d0 + gvdwpp_max=0.0d0 + gradb_max=0.0d0 + ghpbc_max=0.0d0 + gradcorr_max=0.0d0 + gel_loc_max=0.0d0 + gcorr3_turn_max=0.0d0 + gcorr4_turn_max=0.0d0 + gradcorr5_max=0.0d0 + gradcorr6_max=0.0d0 + gcorr6_turn_max=0.0d0 + gsccorrc_max=0.0d0 + gscloc_max=0.0d0 + gvdwx_max=0.0d0 + gradx_scp_max=0.0d0 + ghpbx_max=0.0d0 + gradxorr_max=0.0d0 + gsccorrx_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)gradcorr6_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 + gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) + if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_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 +#if (defined AIX || defined CRAY) + 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,gsccorrc_max, + & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, + & gsccorrx_max,gsclocx_max + close(istat) + if (gvdwc_max.gt.1.0d4) then + write (iout,*) "gvdwc gvdwx gradb gradbx" + do i=nnt,nct + write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i), + & gradb(j,i),gradbx(j,i),j=1,3) + enddo + call pdbout(0.0d0,'cipiszcze',iout) + call flush(iout) + endif + endif + endif +#ifdef DEBUG + write (iout,*) "gradc gradx gloc" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') + & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) + enddo +#endif +#ifdef TIMING + time_sumgradient=time_sumgradient+MPI_Wtime()-time01 +#endif + return + end +c------------------------------------------------------------------------------- + subroutine rescale_weights(t_bath) + implicit none +#ifdef MPI + include 'mpif.h' + integer ierror +#endif + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + double precision t_bath + double precision facT,facT2,facT3,facT4,facT5 + double precision kfac /2.4d0/ + double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ +c facT=temp0/t_bath +c facT=2*temp0/(t_bath+temp0) + if (rescale_mode.eq.0) then + facT=1.0d0 + facT2=1.0d0 + facT3=1.0d0 + facT4=1.0d0 + facT5=1.0d0 + else if (rescale_mode.eq.1) then + facT=kfac/(kfac-1.0d0+t_bath/temp0) + facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) + facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) + facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) + facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) + else if (rescale_mode.eq.2) then + x=t_bath/temp0 + x2=x*x + x3=x2*x + x4=x3*x + x5=x4*x + facT=licznik/dlog(dexp(x)+dexp(-x)) + facT2=licznik/dlog(dexp(x2)+dexp(-x2)) + facT3=licznik/dlog(dexp(x3)+dexp(-x3)) + facT4=licznik/dlog(dexp(x4)+dexp(-x4)) + facT5=licznik/dlog(dexp(x5)+dexp(-x5)) + else + write (iout,*) "Wrong RESCALE_MODE",rescale_mode + write (*,*) "Wrong RESCALE_MODE",rescale_mode +#ifdef MPI + call MPI_Finalize(MPI_COMM_WORLD,IERROR) +#endif + stop 555 + endif + if (shield_mode.gt.0) then + wscp=weights(2)*fact + wsc=weights(1)*fact + wvdwpp=weights(16)*fact + endif + welec=weights(3)*fact + wcorr=weights(4)*fact3 + wcorr5=weights(5)*fact4 + wcorr6=weights(6)*fact5 + wel_loc=weights(7)*fact2 + wturn3=weights(8)*fact2 + wturn4=weights(9)*fact3 + wturn6=weights(10)*fact5 + wtor=weights(13)*fact + wtor_d=weights(14)*fact2 + wsccor=weights(21)*fact + if (scale_umb) wumb=t_bath/temp0 +c write (iout,*) "scale_umb",scale_umb +c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb + + return + end +C------------------------------------------------------------------------ + subroutine enerprint(energia) + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.SBRIDGE' + include 'COMMON.QRESTR' + double precision energia(0:n_ene) + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6, + & eello_turn6, + & eliptran,Eafmforce,Etube, + & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot + etot=energia(0) + evdw=energia(1) + evdw2=energia(2) +#ifdef SCP14 + evdw2=energia(2)+energia(18) +#else + evdw2=energia(2) +#endif + ees=energia(3) +#ifdef SPLITELE + evdw1=energia(16) +#endif + ecorr=energia(4) + ecorr5=energia(5) + ecorr6=energia(6) + eel_loc=energia(7) + eello_turn3=energia(8) + eello_turn4=energia(9) + eello_turn6=energia(10) + ebe=energia(11) + escloc=energia(12) + etors=energia(13) + etors_d=energia(14) + ehpb=energia(15) + edihcnstr=energia(19) + estr=energia(17) + Uconst=energia(20) + esccor=energia(21) + eliptran=energia(22) + Eafmforce=energia(23) + ethetacnstr=energia(24) + etube=energia(25) + esaxs=energia(26) + ehomology_constr=energia(27) +C Bartek + edfadis = energia(28) + edfator = energia(29) + edfanei = energia(30) + edfabet = energia(31) +#ifdef SPLITELE + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, + & estr,wbond,ebe,wang, + & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, +#ifdef FOURBODY + & ecorr,wcorr, + & ecorr5,wcorr5,ecorr6,wcorr6, +#endif + & eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4, +#ifdef FOURBODY + & eello_turn6,wturn6, +#endif + & esccor,wsccor,edihcnstr, + & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce, + & etube,wtube,esaxs,wsaxs,ehomology_constr, + & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, + & edfabet,wdfa_beta, + & etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, + & ' (SS bridges & dist. cnstr.)'/ +#ifdef FOURBODY + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ + & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ + & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/ + & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ + & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/ + & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/ + & 'ETOT= ',1pE16.6,' (total)') + +#else + write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, + & estr,wbond,ebe,wang, + & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, +#ifdef FOURBODY + & ecorr,wcorr, + & ecorr5,wcorr5,ecorr6,wcorr6, +#endif + & eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4, +#ifdef FOURBODY + & eello_turn6,wturn6, +#endif + & esccor,wsccor,edihcnstr, + & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, + & etube,wtube,esaxs,wsaxs,ehomology_constr, + & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, + & edfabet,wdfa_beta, + & etot + 10 format (/'Virtual-chain energies:'// + & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/ + & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/ + & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/ + & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/ + & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/ + & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/ + & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/ + & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ + & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, + & ' (SS bridges & dist. restr.)'/ +#ifdef FOURBODY + & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ + & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif + & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ + & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ + & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY + & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif + & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ + & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ + & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ + & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ + & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ + & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/ + & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/ + & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/ + & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ + & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/ + & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/ + & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/ + & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/ + & 'ETOT= ',1pE16.6,' (total)') +#endif + return + end +C----------------------------------------------------------------------- + subroutine elj(evdw) +C +C This subroutine calculates the interaction energy of nonbonded side chains +C assuming the LJ potential of interaction. +C + implicit none + double precision accur + include 'DIMENSIONS' + parameter (accur=1.0d-10) + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.TORSION' + include 'COMMON.SBRIDGE' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' +#ifdef FOURBODY + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,num_conti,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & sigij,r0ij,rcut + double precision fcont,fprimcont +c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon + evdw=0.0D0 + do i=iatsc_s,iatsc_e + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) +C Change 12/1/95 + num_conti=0 +C +C Calculate SC interaction energy. +C + do iint=1,nint_gr(i) +cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), +cd & 'iend=',iend(i,iint) + do j=istart(i,iint),iend(i,iint) + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi +C Change 12/1/95 to calculate four-body interactions + rij=xj*xj+yj*yj+zj*zj + rrij=1.0D0/rij +c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj + eps0ij=eps(itypi,itypj) + fac=rrij**expon2 +C have you changed here? + e1=fac*fac*aa + e2=fac*bb + evdwij=e1+e2 +cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') +cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj), +cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, +cd & (c(k,i),k=1,3),(c(k,j),k=1,3) + evdw=evdw+evdwij +C +C Calculate the components of the gradient in DC and X +C + fac=-rrij*(e1+evdwij) + gg(1)=xj*fac + gg(2)=yj*fac + gg(3)=zj*fac + 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 +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) +cgrad enddo +cgrad enddo +C +#ifdef FOURBODY +C 12/1/95, revised on 5/20/97 +C +C Calculate the contact function. The ith column of the array JCONT will +C contain the numbers of atoms that make contacts with the atom I (of numbers +C greater than I). The arrays FACONT and GACONT will contain the values of +C the contact function and its derivative. +C +C Uncomment next line, if the correlation interactions include EVDW explicitly. +c if (j.gt.i+1 .and. evdwij.le.0.0D0) then +C Uncomment next line, if the correlation interactions are contact function only + if (j.gt.i+1.and. eps0ij.gt.0.0D0) then + rij=dsqrt(rij) + sigij=sigma(itypi,itypj) + r0ij=rs0(itypi,itypj) +C +C Check whether the SC's are not too far to make a contact. +C + rcut=1.5d0*r0ij + call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) +C Add a new contact, if the SC's are close enough, but not too close (ri' +cgrad do k=1,3 +cgrad ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) +cgrad enddo +cgrad endif +cgrad do k=1,3 +cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) +cgrad enddo +cgrad kstart=min0(i+1,j) +cgrad kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) +cgrad do k=kstart,kend +cgrad do l=1,3 +cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) +cgrad enddo +cgrad enddo + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo + enddo + + enddo ! iint + enddo ! i +C enddo !zshift +C enddo !yshift +C enddo !xshift + return + end +C----------------------------------------------------------------------------- + subroutine escp(evdw2,evdw2_14) +C +C This subroutine calculates the excluded-volume interaction energy between +C peptide-group centers and side chains and its gradient in virtual-bond and +C side-chain vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.SPLITELE' + integer xshift,yshift,zshift + dimension ggg(3) + evdw2=0.0D0 + evdw2_14=0.0d0 +c print *,boxxsize,boxysize,boxzsize,'wymiary pudla' +cd print '(a)','Enter ESCP' +cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e +C do xshift=-1,1 +C do yshift=-1,1 +C do zshift=-1,1 + if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb + do i=iatscp_s,iatscp_e + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + iteli=itel(i) + xi=0.5D0*(c(1,i)+c(1,i+1)) + yi=0.5D0*(c(2,i)+c(2,i+1)) + zi=0.5D0*(c(3,i)+c(3,i+1)) + 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 +c xi=xi+xshift*boxxsize +c yi=yi+yshift*boxysize +c zi=zi+zshift*boxzsize +c print *,xi,yi,zi,'polozenie i' +C Return atom into box, boxxsize is size of box in x dimension +c 134 continue +c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize +c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize +C Condition for being inside the proper box +c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or. +c & (xi.lt.((xshift-0.5d0)*boxxsize))) then +c go to 134 +c endif +c 135 continue +c print *,xi,boxxsize,"pierwszy" + +c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize +c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize +C Condition for being inside the proper box +c if ((yi.gt.((yshift+0.5d0)*boxysize)).or. +c & (yi.lt.((yshift-0.5d0)*boxysize))) then +c go to 135 +c endif +c 136 continue +c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize +c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize +C Condition for being inside the proper box +c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or. +c & (zi.lt.((zshift-0.5d0)*boxzsize))) then +c go to 136 +c endif + do iint=1,nscp_gr(i) + + do j=iscpstart(i,iint),iscpend(i,iint) + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) 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) + 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 +c 174 continue +c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize +c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize +C Condition for being inside the proper box +c if ((xj.gt.((0.5d0)*boxxsize)).or. +c & (xj.lt.((-0.5d0)*boxxsize))) then +c go to 174 +c endif +c 175 continue +c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize +c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize +cC Condition for being inside the proper box +c if ((yj.gt.((0.5d0)*boxysize)).or. +c & (yj.lt.((-0.5d0)*boxysize))) then +c go to 175 +c endif +c 176 continue +c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize +c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize +C Condition for being inside the proper box +c if ((zj.gt.((0.5d0)*boxzsize)).or. +c & (zj.lt.((-0.5d0)*boxzsize))) then +c go to 176 +c endif +CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE + 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 print *,xj,yj,zj,'polozenie j' + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c print *,rrij + sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int) +c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz' +c if (sss.eq.0) print *,'czasem jest OK' + if (sss.le.0.0d0) cycle + sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int) + fac=rrij**expon2 + e1=fac*fac*aad(itypj,iteli) + e2=fac*bad(itypj,iteli) + if (iabs(j-i) .le. 2) then + e1=scal14*e1 + e2=scal14*e2 + evdw2_14=evdw2_14+(e1+e2)*sss + endif + evdwij=e1+e2 + evdw2=evdw2+evdwij*sss + if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') + & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli), + & bad(itypj,iteli) +C +C Calculate contributions to the gradient in the virtual-bond and SC vectors. +C + fac=-(evdwij+e1)*rrij*sss + fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon + ggg(1)=xj*fac + ggg(2)=yj*fac + ggg(3)=zj*fac +cgrad if (j.lt.i) then +cd write (iout,*) 'ji' +cgrad do k=1,3 +cgrad ggg(k)=-ggg(k) +C Uncomment following line for SC-p interactions +ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) +c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) +cgrad enddo +cgrad endif +cgrad do k=1,3 +cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) +cgrad enddo +cgrad kstart=min0(i+1,j) +cgrad kend=max0(i-1,j-1) +cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend +cd write (iout,*) ggg(1),ggg(2),ggg(3) +cgrad do k=kstart,kend +cgrad do l=1,3 +cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) +cgrad enddo +cgrad enddo + do k=1,3 + gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) + gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) + enddo +c endif !endif for sscale cutoff + enddo ! j + + enddo ! iint + enddo ! i +c enddo !zshift +c enddo !yshift +c enddo !xshift + do i=1,nct + do j=1,3 + gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) + gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) + gradx_scp(j,i)=expon*gradx_scp(j,i) + enddo + enddo +C****************************************************************************** +C +C N O T E !!! +C +C To save time the factor EXPON has been extracted from ALL components +C of GVDWC and GRADX. Remember to multiply them by this factor before further +C use! +C +C****************************************************************************** + return + end +C-------------------------------------------------------------------------- + subroutine edis(ehpb) +C +C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + dimension ggg(3),ggg_peak(3,1000) + ehpb=0.0D0 + do i=1,3 + ggg(i)=0.0d0 + enddo +c 8/21/18 AL: added explicit restraints on reference coords +c write (iout,*) "restr_on_coord",restr_on_coord + if (restr_on_coord) then + + do i=nnt,nct + ecoor=0.0d0 + if (itype(i).eq.ntyp1) cycle + do j=1,3 + ecoor=ecoor+(c(j,i)-cref(j,i))**2 + ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i)) + enddo + if (itype(i).ne.10) then + do j=1,3 + ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2 + ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres)) + enddo + endif + if (energy_dec) write (iout,*) + & "i",i," bfac",bfac(i)," ecoor",ecoor + ehpb=ehpb+0.5d0*bfac(i)*ecoor + enddo + + endif +C write (iout,*) ,"link_end",link_end,constr_dist +cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr +c write(iout,*)'link_start=',link_start,' link_end=',link_end, +c & " constr_dist",constr_dist," link_start_peak",link_start_peak, +c & " link_end_peak",link_end_peak + if (link_end.eq.0.and.link_end_peak.eq.0) return + do i=link_start_peak,link_end_peak + ehpb_peak=0.0d0 +c print *,"i",i," link_end_peak",link_end_peak," ipeak", +c & ipeak(1,i),ipeak(2,i) + do ip=ipeak(1,i),ipeak(2,i) + ii=ihpb_peak(ip) + jj=jhpb_peak(ip) + dd=dist(ii,jj) + iip=ip-ipeak(1,i)+1 +C iii and jjj point to the residues for which the distance is assigned. +c if (ii.gt.nres) then +c iii=ii-nres +c jjj=jj-nres +c else +c iii=ii +c jjj=jj +c endif + if (ii.gt.nres) then + iii=ii-nres + else + iii=ii + endif + if (jj.gt.nres) then + jjj=jj-nres + else + jjj=jj + endif + aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip)) + aux=dexp(-scal_peak*aux) + ehpb_peak=ehpb_peak+aux + fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip), + & forcon_peak(ip))*aux/dd + do j=1,3 + ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii)) + enddo + if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)') + & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip), + & forcon_peak(ip),fordepth_peak(ip),ehpb_peak + enddo +c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak + ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak + do ip=ipeak(1,i),ipeak(2,i) + iip=ip-ipeak(1,i)+1 + do j=1,3 + ggg(j)=ggg_peak(j,iip)/ehpb_peak + enddo + ii=ihpb_peak(ip) + jj=jhpb_peak(ip) +C iii and jjj point to the residues for which the distance is assigned. +c if (ii.gt.nres) then +c iii=ii-nres +c jjj=jj-nres +c else +c iii=ii +c jjj=jj +c endif + if (ii.gt.nres) then + iii=ii-nres + else + iii=ii + endif + if (jj.gt.nres) then + jjj=jj-nres + else + jjj=jj + endif + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + enddo + endif + if (jjj.lt.jj) then + do j=1,3 + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + enddo + enddo + do i=link_start,link_end +C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a +C CA-CA distance used in regularization of structure. + ii=ihpb(i) + jj=jhpb(i) +C iii and jjj point to the residues for which the distance is assigned. + if (ii.gt.nres) then + iii=ii-nres + else + iii=ii + endif + if (jj.gt.nres) then + jjj=jj-nres + else + jjj=jj + endif +c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj, +c & dhpb(i),dhpb1(i),forcon(i) +C 24/11/03 AL: SS bridges handled separately because of introducing a specific +C distance and angle dependent SS bond potential. +C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. +C & iabs(itype(jjj)).eq.1) then +cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then +C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds + if (.not.dyn_ss .and. i.le.nss) then +C 15/02/13 CC dynamic SSbond - additional check + if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. + & iabs(itype(jjj)).eq.1) then + call ssbond_ene(iii,jjj,eij) + ehpb=ehpb+2*eij + endif +cd write (iout,*) "eij",eij +cd & ' waga=',waga,' fac=',fac +! else if (ii.gt.nres .and. jj.gt.nres) then + else +C Calculate the distance between the two points and its difference from the +C target distance. + dd=dist(ii,jj) + if (irestr_type(i).eq.11) then + ehpb=ehpb+fordepth(i)!**4.0d0 + & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + fac=fordepth(i)!**4.0d0 + & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd + if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)') + & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i), + & ehpb,irestr_type(i) + else if (irestr_type(i).eq.10) then +c AL 6//19/2018 cross-link restraints + xdis = 0.5d0*(dd/forcon(i))**2 + expdis = dexp(-xdis) +c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i) + aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i) +c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux, +c & " wboltzd",wboltzd + ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux) +c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i)) + fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i)) + & *expdis/(aux*forcon(i)**2) + if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)') + & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i), + & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i) + else if (irestr_type(i).eq.2) then +c Quartic restraints + ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)') + & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i), + & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd + else +c Quadratic restraints + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+0.5d0*waga*rdis*rdis + if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)') + & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i), + & 0.5d0*waga*rdis*rdis,irestr_type(i) +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif +c Calculate Cartesian gradient + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distance, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + enddo + endif + if (jjj.lt.jj) then + do j=1,3 + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + endif + enddo + return + end +C-------------------------------------------------------------------------- + subroutine ssbond_ene(i,j,eij) +C +C Calculate the distance and angle dependent SS-bond potential energy +C using a free-energy function derived based on RHF/6-31G** ab initio +C calculations of diethyl disulfide. +C +C A. Liwo and U. Kozlowska, 11/24/03 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + double precision erij(3),dcosom1(3),dcosom2(3),gg(3) + itypi=iabs(itype(i)) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) +c dsci_inv=dsc_inv(itypi) + dsci_inv=vbld_inv(nres+i) + itypj=iabs(itype(j)) +c dscj_inv=dsc_inv(itypj) + dscj_inv=vbld_inv(nres+j) + xj=c(1,nres+j)-xi + yj=c(2,nres+j)-yi + zj=c(3,nres+j)-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + erij(1)=xj*rij + erij(2)=yj*rij + erij(3)=zj*rij + om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) + om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) + om12=dxi*dxj+dyi*dyj+dzi*dzj + do k=1,3 + dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) + dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) + enddo + rij=1.0d0/rij + deltad=rij-d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) + & +akct*deltad*deltat12 + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr +c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, +c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, +c & " deltat12",deltat12," eij",eij + ed=2*akcm*deltad+akct*deltat12 + pom1=akct*deltad + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + do k=1,3 + ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + ghpbx(k,i)=ghpbx(k,i)-ggk + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + ghpbx(k,j)=ghpbx(k,j)+ggk + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + ghpbc(k,i)=ghpbc(k,i)-ggk + ghpbc(k,j)=ghpbc(k,j)+ggk + enddo +C +C Calculate the components of the gradient in DC and X +C +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l) +cgrad enddo +cgrad enddo + return + end +C-------------------------------------------------------------------------- + subroutine ebond(estr) +c +c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + double precision u(3),ud(3) + estr=0.0d0 + estr1=0.0d0 + do i=ibondp_start,ibondp_end +c 3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are +c used +#ifdef FIVEDIAG + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle + diff = vbld(i)-vbldp0 +#else + if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle +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) +c else +C Checking if it involves dummy (NH3+ or COO-) group + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then +C YES vbldpDUM is the equlibrium length of spring for Dummy atom + diff = vbld(i)-vbldpDUM + if (energy_dec) write(iout,*) "dum_bond",i,diff + else +C NO vbldp0 is the equlibrium length of spring for peptide group + 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 + do j=1,3 + gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) + enddo +c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) +c endif + enddo + + estr=0.5d0*AKP*estr+estr1 +c +c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included +c + do i=ibond_start,ibond_end + iti=iabs(itype(i)) + if (iti.ne.10 .and. iti.ne.ntyp1) then + nbi=nbondterm(iti) + if (nbi.eq.1) then + diff=vbld(i+nres)-vbldsc0(1,iti) + if (energy_dec) write (iout,*) + & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff, + & AKSC(1,iti),AKSC(1,iti)*diff*diff + estr=estr+0.5d0*AKSC(1,iti)*diff*diff + do j=1,3 + gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) + enddo + else + do j=1,nbi + diff=vbld(i+nres)-vbldsc0(j,iti) + ud(j)=aksc(j,iti)*diff + u(j)=abond0(j,iti)+0.5d0*ud(j)*diff + enddo + uprod=u(1) + do j=2,nbi + uprod=uprod*u(j) + enddo + usum=0.0d0 + usumsqder=0.0d0 + do j=1,nbi + uprod1=1.0d0 + uprod2=1.0d0 + do k=1,nbi + if (k.ne.j) then + uprod1=uprod1*u(k) + uprod2=uprod2*u(k)*u(k) + endif + enddo + usum=usum+uprod1 + usumsqder=usumsqder+ud(j)*uprod2 + enddo + estr=estr+uprod/usum + do j=1,3 + gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) + enddo + endif + endif + enddo + return + end +#ifdef CRYST_THETA +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.TORCNSTR' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + double precision y(2),z(2) + delta=0.02d0*pi +c time11=dexp(-2*time) +c time12=1.0d0 + etheta=0.0D0 +c write (*,'(a,i2)') 'EBEND ICG=',icg + do i=ithet_start,ithet_end + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle +C Zero the energy function and its derivative at 0 or pi. + call splinthet(theta(i),0.5d0*delta,ss,ssd) + it=itype(i-1) + ichir1=isign(1,itype(i-2)) + ichir2=isign(1,itype(i)) + if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1)) + if (itype(i).eq.10) ichir2=isign(1,itype(i-1)) + if (itype(i-1).eq.10) then + itype1=isign(10,itype(i-2)) + ichir11=isign(1,itype(i-2)) + ichir12=isign(1,itype(i-2)) + itype2=isign(10,itype(i)) + ichir21=isign(1,itype(i)) + ichir22=isign(1,itype(i)) + endif + + if (i.gt.3 .and. itype(i-3).ne.ntyp1) then +#ifdef OSF + phii=phi(i) + if (phii.ne.phii) phii=150.0 +#else + phii=phi(i) +#endif + y(1)=dcos(phii) + y(2)=dsin(phii) + else + y(1)=0.0D0 + y(2)=0.0D0 + endif + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then +#ifdef OSF + phii1=phi(i+1) + if (phii1.ne.phii1) phii1=150.0 + phii1=pinorm(phii1) + z(1)=cos(phii1) +#else + phii1=phi(i+1) +#endif + z(1)=dcos(phii1) + z(2)=dsin(phii1) + else + z(1)=0.0D0 + z(2)=0.0D0 + endif +C Calculate the "mean" value of theta from the part of the distribution +C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). +C In following comments this theta will be referred to as t_c. + thet_pred_mean=0.0d0 + do k=1,2 + athetk=athet(k,it,ichir1,ichir2) + bthetk=bthet(k,it,ichir1,ichir2) + if (it.eq.10) then + athetk=athet(k,itype1,ichir11,ichir12) + bthetk=bthet(k,itype2,ichir21,ichir22) + endif + thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) +c write(iout,*) 'chuj tu', y(k),z(k) + enddo + dthett=thet_pred_mean*ssd + thet_pred_mean=thet_pred_mean*ss+a0thet(it) +C Derivatives of the "mean" values in gamma1 and gamma2. + dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) + &+athet(2,it,ichir1,ichir2)*y(1))*ss + dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) + & +bthet(2,it,ichir1,ichir2)*z(1))*ss + if (it.eq.10) then + dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) + &+athet(2,itype1,ichir11,ichir12)*y(1))*ss + dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) + & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss + endif + if (theta(i).gt.pi-delta) then + call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, + & E_tc0) + call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) + call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, + & E_theta) + call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else if (theta(i).lt.delta) then + call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) + call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) + call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, + & E_theta) + call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) + call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, + & E_tc) + else + call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, + & E_theta,E_tc) + endif + etheta=etheta+ethetai + if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)') + & 'ebend',i,ethetai,theta(i),itype(i) + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 + gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg) + enddo + +C Ufff.... We've done all this!!! + return + end +C--------------------------------------------------------------------------- + subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, + & E_tc) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it +C Calculate the contributions to both Gaussian lobes. +C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) +C The "polynomial part" of the "standard deviation" of this part of +C the distributioni. +ccc write (iout,*) thetai,thet_pred_mean + sig=polthet(3,it) + do j=2,0,-1 + sig=sig*thet_pred_mean+polthet(j,it) + enddo +C Derivative of the "interior part" of the "standard deviation of the" +C gamma-dependent Gaussian lobe in t_c. + sigtc=3*polthet(3,it) + do j=2,1,-1 + sigtc=sigtc*thet_pred_mean+j*polthet(j,it) + enddo + sigtc=sig*sigtc +C Set the parameters of both Gaussian lobes of the distribution. +C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) + fac=sig*sig+sigc0(it) + sigcsq=fac+fac + sigc=1.0D0/sigcsq +C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c + sigsqtc=-4.0D0*sigcsq*sigtc +c print *,i,sig,sigtc,sigsqtc +C Following variable (sigtc) is d[sigma(t_c)]/dt_c + sigtc=-sigtc/(fac*fac) +C Following variable is sigma(t_c)**(-2) + sigcsq=sigcsq*sigcsq + sig0i=sig0(it) + sig0inv=1.0D0/sig0i**2 + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i + term1=-0.5D0*sigcsq*delthec*delthec + term2=-0.5D0*sig0inv*delthe0*delthe0 +C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0 +C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and +C NaNs in taking the logarithm. We extract the largest exponent which is added +C to the energy (this being the log of the distribution) at the end of energy +C term evaluation for this virtual-bond angle. + if (term1.gt.term2) then + termm=term1 + term2=dexp(term2-termm) + term1=1.0d0 + else + termm=term2 + term1=dexp(term1-termm) + term2=1.0d0 + endif +C The ratio between the gamma-independent and gamma-dependent lobes of +C the distribution is a Gaussian function of thet_pred_mean too. + diffak=gthet(2,it)-thet_pred_mean + ratak=diffak/gthet(3,it)**2 + ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) +C Let's differentiate it in thet_pred_mean NOW. + aktc=ak*ratak +C Now put together the distribution terms to make complete distribution. + termexp=term1+ak*term2 + termpre=sigc+ak*sig0i +C Contribution of the bending energy from this theta is just the -log of +C the sum of the contributions from the two lobes and the pre-exponential +C factor. Simple enough, isn't it? + ethetai=(-dlog(termexp)-termm+dlog(termpre)) +C write (iout,*) 'termexp',termexp,termm,termpre,i +C NOW the derivatives!!! +C 6/6/97 Take into account the deformation. + E_theta=(delthec*sigcsq*term1 + & +ak*delthe0*sig0inv*term2)/termexp + E_tc=((sigtc+aktc*sig0i)/termpre + & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ + & aktc*term2)/termexp) + return + end +c----------------------------------------------------------------------------- + subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /calcthet/ term1,term2,termm,diffak,ratak, + & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, + & delthe0,sig0inv,sigtc,sigsqtc,delthec,it + delthec=thetai-thet_pred_mean + delthe0=thetai-theta0i +C "Thank you" to MAPLE (probably spared one day of hand-differentiation). + t3 = thetai-thet_pred_mean + t6 = t3**2 + t9 = term1 + t12 = t3*sigcsq + t14 = t12+t6*sigsqtc + t16 = 1.0d0 + t21 = thetai-theta0i + t23 = t21**2 + t26 = term2 + t27 = t21*t26 + t32 = termexp + t40 = t32**2 + E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 + & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 + & *(-t12*t9-ak*sig0inv*t27) + return + end +#else +C-------------------------------------------------------------------------- + subroutine ebend(etheta) +C +C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral +C angles gamma and its derivatives in consecutive thetas and gammas. +C ab initio-derived potentials from +c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.TORCNSTR' + double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), + & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), + & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), + & sinph1ph2(maxdouble,maxdouble) + logical lprn /.false./, lprn1 /.false./ + etheta=0.0D0 + do i=ithet_start,ithet_end +c print *,i,itype(i-1),itype(i),itype(i-2) + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle +C print *,i,theta(i) + if (iabs(itype(i+1)).eq.20) iblock=2 + if (iabs(itype(i+1)).ne.20) iblock=1 + dethetai=0.0d0 + dephii=0.0d0 + dephii1=0.0d0 + theti2=0.5d0*theta(i) + ityp2=ithetyp((itype(i-1))) + do k=1,nntheterm + coskt(k)=dcos(k*theti2) + sinkt(k)=dsin(k*theti2) + enddo +C print *,ethetai + if (i.gt.3 .and. itype(i-3).ne.ntyp1) then +#ifdef OSF + phii=phi(i) + if (phii.ne.phii) phii=150.0 +#else + phii=phi(i) +#endif + ityp1=ithetyp((itype(i-2))) +C propagation of chirality for glycine type + do k=1,nsingle + cosph1(k)=dcos(k*phii) + sinph1(k)=dsin(k*phii) + enddo + else + phii=0.0d0 + do k=1,nsingle + ityp1=ithetyp((itype(i-2))) + cosph1(k)=0.0d0 + sinph1(k)=0.0d0 + enddo + endif + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then +#ifdef OSF + phii1=phi(i+1) + if (phii1.ne.phii1) phii1=150.0 + phii1=pinorm(phii1) +#else + phii1=phi(i+1) +#endif + ityp3=ithetyp((itype(i))) + do k=1,nsingle + cosph2(k)=dcos(k*phii1) + sinph2(k)=dsin(k*phii1) + enddo + else + phii1=0.0d0 + ityp3=ithetyp((itype(i))) + do k=1,nsingle + cosph2(k)=0.0d0 + sinph2(k)=0.0d0 + enddo + endif + ethetai=aa0thet(ityp1,ityp2,ityp3,iblock) + do k=1,ndouble + do l=1,k-1 + ccl=cosph1(l)*cosph2(k-l) + ssl=sinph1(l)*sinph2(k-l) + scl=sinph1(l)*cosph2(k-l) + csl=cosph1(l)*sinph2(k-l) + cosph1ph2(l,k)=ccl-ssl + cosph1ph2(k,l)=ccl+ssl + sinph1ph2(l,k)=scl+csl + sinph1ph2(k,l)=scl-csl + enddo + enddo + if (lprn) then + write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, + & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 + write (iout,*) "coskt and sinkt" + do k=1,nntheterm + write (iout,*) k,coskt(k),sinkt(k) + enddo + endif + do k=1,ntheterm + ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k) + dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) + & *coskt(k) + if (lprn) + & write (iout,*) "k",k," + & aathet",aathet(k,ityp1,ityp2,ityp3,iblock), + & " ethetai",ethetai + enddo + if (lprn) then + write (iout,*) "cosph and sinph" + do k=1,nsingle + write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) + enddo + write (iout,*) "cosph1ph2 and sinph2ph2" + do k=2,ndouble + do l=1,k-1 + write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), + & sinph1ph2(l,k),sinph1ph2(k,l) + enddo + enddo + write(iout,*) "ethetai",ethetai + endif +C print *,ethetai + do m=1,ntheterm2 + do k=1,nsingle + aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) + & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) + & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) + & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k) + ethetai=ethetai+sinkt(m)*aux + dethetai=dethetai+0.5d0*m*aux*coskt(m) + dephii=dephii+k*sinkt(m)*( + & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- + & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)) + dephii1=dephii1+k*sinkt(m)*( + & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- + & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)) + if (lprn) + & write (iout,*) "m",m," k",k," bbthet", + & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", + & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", + & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", + & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai +C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k) + enddo + enddo +C print *,"cosph1", (cosph1(k), k=1,nsingle) +C print *,"cosph2", (cosph2(k), k=1,nsingle) +C print *,"sinph1", (sinph1(k), k=1,nsingle) +C print *,"sinph2", (sinph2(k), k=1,nsingle) + if (lprn) + & write(iout,*) "ethetai",ethetai +C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k) + do m=1,ntheterm3 + do k=2,ndouble + do l=1,k-1 + aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l) + ethetai=ethetai+sinkt(m)*aux + dethetai=dethetai+0.5d0*m*coskt(m)*aux + dephii=dephii+l*sinkt(m)*( + & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) + dephii1=dephii1+(k-l)*sinkt(m)*( + & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) + if (lprn) then + write (iout,*) "m",m," k",k," l",l," ffthet", + & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock), + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet", + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock), + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock), + & " ethetai",ethetai + write (iout,*) cosph1ph2(l,k)*sinkt(m), + & cosph1ph2(k,l)*sinkt(m), + & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) + endif + enddo + enddo + enddo +10 continue +c lprn1=.true. +C print *,ethetai + if (lprn1) + & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') + & i,theta(i)*rad2deg,phii*rad2deg, + & phii1*rad2deg,ethetai +c lprn1=.false. + etheta=etheta+ethetai + if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii + if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai + enddo + + return + end +#endif +#ifdef CRYST_SC +c----------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), + & ddersc0(3),ddummy(3),xtemp(3),temp(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 +c write (iout,'(a)') 'ESC' + do i=loc_start,loc_end + it=itype(i) + if (it.eq.ntyp1) cycle + if (it.eq.10) goto 1 + nlobit=nlob(iabs(it)) +c print *,'i=',i,' it=',it,' nlobit=',nlobit +c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad + theti=theta(i+1)-pipol + x(1)=dtan(theti) + x(2)=alph(i) + x(3)=omeg(i) + + if (x(2).gt.pi-delta) then + xtemp(1)=x(1) + xtemp(2)=pi-delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=pi + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=pi-delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=pi + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + call splinthet(x(2),0.5d0*delta,ss,ssd) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c escloci=esclocbi +c write (iout,*) escloci + else if (x(2).lt.delta) then + xtemp(1)=x(1) + xtemp(2)=delta + xtemp(3)=x(3) + call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) + xtemp(2)=0.0d0 + call enesc(xtemp,escloci1,dersc1,ddummy,.false.) + call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), + & escloci,dersc(2)) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & ddersc0(1),dersc(1)) + call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), + & ddersc0(3),dersc(3)) + xtemp(2)=delta + call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) + xtemp(2)=0.0d0 + call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) + call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, + & dersc0(2),esclocbi,dersc02) + call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), + & dersc12,dersc01) + dersc0(1)=dersc01 + dersc0(2)=dersc02 + dersc0(3)=0.0d0 + call splinthet(x(2),0.5d0*delta,ss,ssd) + do k=1,3 + dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) + enddo + dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c & esclocbi,ss,ssd + escloci=ss*escloci+(1.0d0-ss)*esclocbi +c write (iout,*) escloci + else + call enesc(x,escloci,dersc,ddummy,.false.) + endif + + escloc=escloc+escloci + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + & 'escloc',i,escloci +c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + & wscloc*dersc(1) + gloc(ialph(i,1),icg)=wscloc*dersc(2) + gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) + 1 continue + enddo + return + end +C--------------------------------------------------------------------------- + subroutine enesc(x,escloci,dersc,ddersc,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) + double precision contr(maxlob,-1:1) + logical mixed +c write (iout,*) 'it=',it,' nlobit=',nlobit + escloc_i=0.0D0 + do j=1,3 + dersc(j)=0.0D0 + if (mixed) ddersc(j)=0.0d0 + enddo + x3=x(3) + +C Because of periodicity of the dependence of the SC energy in omega we have +C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). +C To avoid underflows, first compute & store the exponents. + + do iii=-1,1 + + x(3)=x3+iii*dwapi + + do j=1,nlobit + do k=1,3 + z(k)=x(k)-censc(k,j,it) + enddo + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j,iii)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j,iii)*z(k) + enddo + contr(j,iii)=expfac + enddo ! j + + enddo ! iii + + x(3)=x3 +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1,-1) + do iii=-1,1 + do j=1,nlobit + if (emin.gt.contr(j,iii)) emin=contr(j,iii) + enddo + enddo + emin=0.5D0*emin +cd print *,'it=',it,' emin=',emin + +C Compute the contribution to SC energy and derivatives + do iii=-1,1 + + do j=1,nlobit +#ifdef OSF + adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin + if(adexp.ne.adexp) adexp=1.0 + expfac=dexp(adexp) +#else + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) +#endif +cd print *,'j=',j,' expfac=',expfac + escloc_i=escloc_i+expfac + do k=1,3 + dersc(k)=dersc(k)+Ax(k,j,iii)*expfac + enddo + if (mixed) then + do k=1,3,2 + ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) + & +gaussc(k,2,j,it))*expfac + enddo + endif + enddo + + enddo ! iii + + dersc(1)=dersc(1)/cos(theti)**2 + ddersc(1)=ddersc(1)/cos(theti)**2 + ddersc(3)=ddersc(3) + + escloci=-(dlog(escloc_i)-emin) + do j=1,3 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) then + do j=1,3,2 + ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) + enddo + endif + return + end +C------------------------------------------------------------------------------ + subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.IOUNITS' + common /sccalc/ time11,time12,time112,theti,it,nlobit + double precision x(3),z(3),Ax(3,maxlob),dersc(3) + double precision contr(maxlob) + logical mixed + + escloc_i=0.0D0 + + do j=1,3 + dersc(j)=0.0D0 + enddo + + do j=1,nlobit + do k=1,2 + z(k)=x(k)-censc(k,j,it) + enddo + z(3)=dwapi + do k=1,3 + Axk=0.0D0 + do l=1,3 + Axk=Axk+gaussc(l,k,j,it)*z(l) + enddo + Ax(k,j)=Axk + enddo + expfac=0.0D0 + do k=1,3 + expfac=expfac+Ax(k,j)*z(k) + enddo + contr(j)=expfac + enddo ! j + +C As in the case of ebend, we want to avoid underflows in exponentiation and +C subsequent NaNs and INFs in energy calculation. +C Find the largest exponent + emin=contr(1) + do j=1,nlobit + if (emin.gt.contr(j)) emin=contr(j) + enddo + emin=0.5D0*emin + +C Compute the contribution to SC energy and derivatives + + dersc12=0.0d0 + do j=1,nlobit + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin) + escloc_i=escloc_i+expfac + do k=1,2 + dersc(k)=dersc(k)+Ax(k,j)*expfac + enddo + if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) + & +gaussc(1,2,j,it))*expfac + dersc(3)=0.0d0 + enddo + + dersc(1)=dersc(1)/cos(theti)**2 + dersc12=dersc12/cos(theti)**2 + escloci=-(dlog(escloc_i)-emin) + do j=1,2 + dersc(j)=dersc(j)/escloc_i + enddo + if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) + return + end +#else +c---------------------------------------------------------------------------------- + subroutine esc(escloc) +C Calculate the local energy of a side chain and its derivatives in the +C corresponding virtual-bond valence angles THETA and the spherical angles +C ALPHA and OMEGA derived from AM1 all-atom calculations. +C added by Urszula Kozlowska. 07/11/2007 +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.SCROT' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + include 'COMMON.VECTORS' + double precision x_prime(3),y_prime(3),z_prime(3) + & , sumene,dsc_i,dp2_i,x(65), + & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, + & de_dxx,de_dyy,de_dzz,de_dt + double precision s1_t,s1_6_t,s2_t,s2_6_t + double precision + & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), + & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), + & dt_dCi(3),dt_dCi1(3) + common /sccalc/ time11,time12,time112,theti,it,nlobit + delta=0.02d0*pi + escloc=0.0D0 + do i=loc_start,loc_end + if (itype(i).eq.ntyp1) cycle + costtab(i+1) =dcos(theta(i+1)) + sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) + cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) + sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) + cosfac2=0.5d0/(1.0d0+costtab(i+1)) + cosfac=dsqrt(cosfac2) + sinfac2=0.5d0/(1.0d0-costtab(i+1)) + sinfac=dsqrt(sinfac2) + it=iabs(itype(i)) + if (it.eq.10) goto 1 +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)*dsign(1.0d0,dfloat(itype(i))) + enddo +c write (2,*) "i",i +c write (2,*) "x_prime",(x_prime(j),j=1,3) +c write (2,*) "y_prime",(y_prime(j),j=1,3) +c write (2,*) "z_prime",(z_prime(j),j=1,3) +c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), +c & " xy",scalar(x_prime(1),y_prime(1)), +c & " xz",scalar(x_prime(1),z_prime(1)), +c & " yy",scalar(y_prime(1),y_prime(1)), +c & " yz",scalar(y_prime(1),z_prime(1)), +c & " zz",scalar(z_prime(1),z_prime(1)) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxtab(i)=xx + yytab(i)=yy + zztab(i)=zz +C +C Compute the energy of the ith side cbain +C +c write (2,*) "xx",xx," yy",yy," zz",zz + it=iabs(itype(i)) + do j = 1,65 + x(j) = sc_parmin(j,it) + enddo +#ifdef CHECK_COORD +Cc diagnostics - remove later + xx1 = dcos(alph(2)) + yy1 = dsin(alph(2))*dcos(omeg(2)) + zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2)) + write(2,'(3f8.1,3f9.3,1x,3f9.3)') + & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, + & xx1,yy1,zz1 +C," --- ", xx_w,yy_w,zz_w +c end diagnostics +#endif + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) + & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) +c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, +c & sumene4, +c & dscp1,dscp2,sumene +c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + escloc = escloc + sumene + if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it, + & " escloc",sumene,escloc,it,itype(i) +c & ,zz,xx,yy +c#define DEBUG +#ifdef DEBUG +C +C This section to check the numerical derivatives of the energy of ith side +C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert +C #define DEBUG in the code to turn it on. +C + write (2,*) "sumene =",sumene + aincr=1.0d-7 + xxsave=xx + xx=xx+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dxx_num=(sumenep-sumene)/aincr + xx=xxsave + write (2,*) "xx+ sumene from enesc=",sumenep + yysave=yy + yy=yy+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dyy_num=(sumenep-sumene)/aincr + yy=yysave + write (2,*) "yy+ sumene from enesc=",sumenep + zzsave=zz + zz=zz+aincr + write (2,*) xx,yy,zz + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dzz_num=(sumenep-sumene)/aincr + zz=zzsave + write (2,*) "zz+ sumene from enesc=",sumenep + costsave=cost2tab(i+1) + sintsave=sint2tab(i+1) + cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) + sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) + sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) + de_dt_num=(sumenep-sumene)/aincr + write (2,*) " t+ sumene from enesc=",sumenep + cost2tab(i+1)=costsave + sint2tab(i+1)=sintsave +C End of diagnostics section. +#endif +C +C Compute the gradient of esc +C +c zz=zz*dsign(1.0,dfloat(itype(i))) + pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 + pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 + pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 + pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 + pom_dx=dsc_i*dp2_i*cost2tab(i+1) + pom_dy=dsc_i*dp2_i*sint2tab(i+1) + pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) + pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) + pom1=(sumene3*sint2tab(i+1)+sumene1) + & *(pom_s1/dscp1+pom_s16*dscp1**4) + pom2=(sumene4*cost2tab(i+1)+sumene2) + & *(pom_s2/dscp2+pom_s26*dscp2**4) + sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy + sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 + & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) + & +x(40)*yy*zz + sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy + sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 + & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) + & +x(60)*yy*zz + de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) + & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) + & +(pom1+pom2)*pom_dx +#ifdef DEBUG + write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i) +#endif +C + sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz + sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 + & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) + & +x(40)*xx*zz + sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz + sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz + & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz + & +x(59)*zz**2 +x(60)*xx*zz + de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) + & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) + & +(pom1-pom2)*pom_dy +#ifdef DEBUG + write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i) +#endif +C + de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy + & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx + & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) + & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) + & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 + & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy + & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) + & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) +#ifdef DEBUG + write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i) +#endif +C + de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) + & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) + & +pom1*pom_dt1+pom2*pom_dt2 +#ifdef DEBUG + write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i) +#endif +c#undef DEBUG +c +C + cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) + cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) + cosfac2xx=cosfac2*xx + sinfac2yy=sinfac2*yy + do k = 1,3 + dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* + & vbld_inv(i+1) + dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* + & vbld_inv(i) + pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) + pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) +c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, +c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) +c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), +c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) + dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx + dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx + dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy + dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy + dZZ_Ci1(k)=0.0d0 + dZZ_Ci(k)=0.0d0 + do j=1,3 + dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) + & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) + dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) + & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) + enddo + + dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) + dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) + dZZ_XYZ(k)=vbld_inv(i+nres)* + & (z_prime(k)-zz*dC_norm(k,i+nres)) +c + dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) + dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) + enddo + + do k=1,3 + dXX_Ctab(k,i)=dXX_Ci(k) + dXX_C1tab(k,i)=dXX_Ci1(k) + dYY_Ctab(k,i)=dYY_Ci(k) + dYY_C1tab(k,i)=dYY_Ci1(k) + dZZ_Ctab(k,i)=dZZ_Ci(k) + dZZ_C1tab(k,i)=dZZ_Ci1(k) + dXX_XYZtab(k,i)=dXX_XYZ(k) + dYY_XYZtab(k,i)=dYY_XYZ(k) + dZZ_XYZtab(k,i)=dZZ_XYZ(k) + enddo + + do k = 1,3 +c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", +c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) +c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", +c & dyy_ci(k)," dzz_ci",dzz_ci(k) +c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", +c & dt_dci(k) +c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", +c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) + gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) + & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) + gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) + & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) + gsclocx(k,i)= de_dxx*dxx_XYZ(k) + & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) + enddo +c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), +c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) + +C to check gradient call subroutine check_grad + + 1 continue + enddo + return + end +c------------------------------------------------------------------------------ + double precision function enesc(x,xx,yy,zz,cost2,sint2) + implicit none + double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2, + & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 + sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 + & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy + & + x(10)*yy*zz + sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 + & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy + & + x(20)*yy*zz + sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 + & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy + & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 + & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx + & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy + & +x(40)*xx*yy*zz + sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 + & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy + & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 + & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx + & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy + & +x(60)*xx*yy*zz + dsc_i = 0.743d0+x(61) + dp2_i = 1.9d0+x(62) + dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2+yy*sint2)) + dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i + & *(xx*cost2-yy*sint2)) + s1=(1+x(63))/(0.1d0 + dscp1) + s1_6=(1+x(64))/(0.1d0 + dscp1**6) + s2=(1+x(65))/(0.1d0 + dscp2) + s2_6=(1+x(65))/(0.1d0 + dscp2**6) + sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) + & + (sumene4*cost2 +sumene2)*(s2+s2_6) + enesc=sumene + return + end +#endif +c------------------------------------------------------------------------------ + subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) +C +C This procedure calculates two-body contact function g(rij) and its derivative: +C +C eps0ij ! x < -1 +C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 +C 0 ! x > 1 +C +C where x=(rij-r0ij)/delta +C +C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy +C + implicit none + double precision rij,r0ij,eps0ij,fcont,fprimcont + double precision x,x2,x4,delta +c delta=0.02D0*r0ij +c delta=0.2D0*r0ij + x=(rij-r0ij)/delta + if (x.lt.-1.0D0) then + fcont=eps0ij + fprimcont=0.0D0 + else if (x.le.1.0D0) then + x2=x*x + x4=x2*x2 + fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) + fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta + else + fcont=0.0D0 + fprimcont=0.0D0 + endif + return + end +c------------------------------------------------------------------------------ + subroutine splinthet(theti,delta,ss,ssder) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + thetup=pi-delta + thetlow=delta + if (theti.gt.pipol) then + call gcont(theti,thetup,1.0d0,delta,ss,ssder) + else + call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) + ssder=-ssder + endif + return + end +c------------------------------------------------------------------------------ + subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) + implicit none + double precision x,x0,delta,f0,f1,fprim0,f,fprim + double precision ksi,ksi2,ksi3,a1,a2,a3 + a1=fprim0*delta/(f1-f0) + a2=3.0d0-2.0d0*a1 + a3=a1-2.0d0 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) + fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) + return + end +c------------------------------------------------------------------------------ + subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) + implicit none + double precision x,x0,delta,f0x,f1x,fprim0x,fx + double precision ksi,ksi2,ksi3,a1,a2,a3 + ksi=(x-x0)/delta + ksi2=ksi*ksi + ksi3=ksi2*ksi + a1=fprim0x*delta + a2=3*(f1x-f0x)-2*fprim0x*delta + a3=fprim0x*delta-2*(f1x-f0x) + fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 + return + end +C----------------------------------------------------------------------------- +#ifdef CRYST_TOR +C----------------------------------------------------------------------------- + subroutine etor(etors) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors=0.0D0 + do i=iphi_start,iphi_end + etors_ii=0.0D0 + if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Proline-Proline pair is a special case... + if (itori.eq.3 .and. itori1.eq.3) then + if (phii.gt.-dwapi3) then + cosphi=dcos(3*phii) + fac=1.0D0/(1.0D0-cosphi) + etorsi=v1(1,3,3)*fac + etorsi=etorsi+etorsi + etors=etors+etorsi-v1(1,3,3) + if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) + gloci=gloci-3*fac*etorsi*dsin(3*phii) + endif + do j=1,3 + v1ij=v1(j+1,itori,itori1) + v2ij=v2(j+1,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + if (energy_dec) etors_ii=etors_ii+ + & v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + else + do j=1,nterm_old + v1ij=v1(j,itori,itori1) + v2ij=v2(j,itori,itori1) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + if (energy_dec) etors_ii=etors_ii+ + & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo + endif + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + 'etor',i,etors_ii + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo + return + end +c------------------------------------------------------------------------------ + subroutine etor_d(etors_d) + etors_d=0.0d0 + return + end +c---------------------------------------------------------------------------- +c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA + subroutine e_modeller(ehomology_constr) + ehomology_constr=0.0d0 + write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!" + return + end +C !!!!!!!! NIE CZYTANE !!!!!!!!!!! + +c------------------------------------------------------------------------------ + subroutine etor_d(etors_d) + etors_d=0.0d0 + return + end +c---------------------------------------------------------------------------- +#else + subroutine etor(etors) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + 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).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle +C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF +C For introducing the NH3+ and COO- group please check the etor_d for reference +C and guidance + etors_ii=0.0D0 + if (iabs(itype(i)).eq.20) then + iblock=2 + else + iblock=1 + endif + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + phii=phi(i) + gloci=0.0D0 +C Regular cosine and sine terms + do j=1,nterm(itori,itori1,iblock) + v1ij=v1(j,itori,itori1,iblock) + v2ij=v2(j,itori,itori1,iblock) + cosphi=dcos(j*phii) + sinphi=dsin(j*phii) + etors=etors+v1ij*cosphi+v2ij*sinphi + if (energy_dec) etors_ii=etors_ii+ + & v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +C Lorentz terms +C v1 +C E = SUM ----------------------------------- - v1 +C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 +C + cosphi=dcos(0.5d0*phii) + sinphi=dsin(0.5d0*phii) + do j=1,nlor(itori,itori1,iblock) + vl1ij=vlor1(j,itori,itori1) + vl2ij=vlor2(j,itori,itori1) + vl3ij=vlor3(j,itori,itori1) + pom=vl2ij*cosphi+vl3ij*sinphi + pom1=1.0d0/(pom*pom+1.0d0) + etors=etors+vl1ij*pom1 + if (energy_dec) etors_ii=etors_ii+ + & vl1ij*pom1 + pom=-pom*pom1*pom1 + gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom + enddo +C Subtract the constant term + etors=etors-v0(itori,itori1,iblock) + if (energy_dec) write (iout,'(a6,i5,0pf7.3)') + & 'etor',i,etors_ii-v0(itori,itori1,iblock) + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, + & (v1(j,itori,itori1,iblock),j=1,6), + & (v2(j,itori,itori1,iblock),j=1,6) + gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci +c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) + enddo + return + end +c---------------------------------------------------------------------------- + subroutine etor_d(etors_d) +C 6/23/01 Compute double torsional energy + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. + etors_d=0.0D0 +c write(iout,*) "a tu??" + do i=iphid_start,iphid_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)) .or. +C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle + if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or. + & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or. + & (itype(i+1).eq.ntyp1)) cycle +C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-1)) + itori2=itortyp(itype(i)) + phii=phi(i) + phii1=phi(i+1) + gloci1=0.0D0 + gloci2=0.0D0 + iblock=1 + if (iabs(itype(i+1)).eq.20) iblock=2 +C Iblock=2 Proline type +C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT +C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO- +C if (itype(i+1).eq.ntyp1) iblock=3 +C The problem of NH3+ group can be resolved by adding new parameters please note if there +C IS or IS NOT need for this +C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on +C is (itype(i-3).eq.ntyp1) ntblock=2 +C ntblock is N-terminal blocking group + +C Regular cosine and sine terms + do j=1,ntermd_1(itori,itori1,itori2,iblock) +C Example of changes for NH3+ blocking group +C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock) +C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock) + v1cij=v1c(1,j,itori,itori1,itori2,iblock) + v1sij=v1s(1,j,itori,itori1,itori2,iblock) + v2cij=v1c(2,j,itori,itori1,itori2,iblock) + v2sij=v1s(2,j,itori,itori1,itori2,iblock) + cosphi1=dcos(j*phii) + sinphi1=dsin(j*phii) + cosphi2=dcos(j*phii1) + sinphi2=dsin(j*phii1) + etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ + & v2cij*cosphi2+v2sij*sinphi2 + gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) + gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) + enddo + do k=2,ntermd_2(itori,itori1,itori2,iblock) + do l=1,k-1 + v1cdij = v2c(k,l,itori,itori1,itori2,iblock) + v2cdij = v2c(l,k,itori,itori1,itori2,iblock) + v1sdij = v2s(k,l,itori,itori1,itori2,iblock) + v2sdij = v2s(l,k,itori,itori1,itori2,iblock) + cosphi1p2=dcos(l*phii+(k-l)*phii1) + cosphi1m2=dcos(l*phii-(k-l)*phii1) + sinphi1p2=dsin(l*phii+(k-l)*phii1) + sinphi1m2=dsin(l*phii-(k-l)*phii1) + etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ + & v1sdij*sinphi1p2+v2sdij*sinphi1m2 + gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) + gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + enddo + enddo + gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 + gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 + enddo + return + end +#endif +C---------------------------------------------------------------------------------- +C The rigorous attempt to derive energy function + subroutine etor_kcc(etors) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + double precision c1(0:maxval_kcc),c2(0:maxval_kcc) + logical lprn +c double precision thybt1(maxtermkcc),thybt2(maxtermkcc) +C Set lprn=.true. for debugging + lprn=energy_dec +c lprn=.true. +C print *,"wchodze kcc" + 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).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle + itori=itortyp(itype(i-2)) + itori1=itortyp(itype(i-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 +C derivative over gamma + 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),itype(i-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 +c--------------------------------------------------------------------------------------------- + subroutine etor_constr(edihcnstr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.BOUNDS' + include 'COMMON.CONTROL' +! 6/20/98 - dihedral angle constraints + edihcnstr=0.0d0 +c do i=1,ndih_constr + if (raw_psipred) then + do i=idihconstr_start,idihconstr_end + itori=idih_constr(i) + phii=phi(itori) + gaudih_i=vpsipred(1,i) + gauder_i=0.0d0 + do j=1,2 + s = sdihed(j,i) + cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2 + dexpcos_i=dexp(-cos_i*cos_i) + gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i + gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) + & *cos_i*dexpcos_i/s**2 + enddo + edihcnstr=edihcnstr-wdihc*dlog(gaudih_i) + gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i + if (energy_dec) + & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') + & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i), + & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i), + & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg, + & -wdihc*dlog(gaudih_i) + enddo + else + + do i=idihconstr_start,idihconstr_end + itori=idih_constr(i) + phii=phi(itori) + difi=pinorm(phii-phi0(i)) + if (difi.gt.drange(i)) then + difi=difi-drange(i) + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + else + difi=0.0 + endif + enddo + + endif + + return + end +c---------------------------------------------------------------------------- +c MODELLER restraint function + subroutine e_modeller(ehomology_constr) + implicit none + include 'DIMENSIONS' + + double precision ehomology_constr + integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l + integer katy, odleglosci, test7 + real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template) + real*8 Eval,Erot + real*8 distance(max_template),distancek(max_template), + & min_odl,godl(max_template),dih_diff(max_template) + +c +c FP - 30/10/2014 Temporary specifications for homology restraints +c + double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta, + & sgtheta + double precision, dimension (maxres) :: guscdiff,usc_diff + double precision, dimension (max_template) :: + & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3, + & theta_diff + double precision 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 + double precision dist,pinorm +c + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' +c include 'COMMON.MD' + include 'COMMON.CONTROL' + include 'COMMON.HOMOLOGY' + include 'COMMON.QRESTR' +c +c From subroutine Econstr_back +c + include 'COMMON.NAMES' + include 'COMMON.TIME1' +c + + + do i=1,max_template + distancek(i)=9999999.9 + enddo + + + odleg=0.0d0 + +c Pseudo-energy and gradient from homology restraints (MODELLER-like +c function) +C AL 5/2/14 - Introduce list of restraints +c 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) +c write (iout,*) "dij(",i,j,") =",dij + nexl=0 + do k=1,constr_homology +c 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 +c write (iout,*) "distance(",k,") =",distance(k) +c +c For Gaussian-type Urestr +c + distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument +c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii) +c write (iout,*) "distancek(",k,") =",distancek(k) +c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii) +c +c For Lorentzian-type Urestr +c + 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 + +c min_odl=minval(distancek) + 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 + +c 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 +c Nie wiem po co to liczycie jeszcze raz! +c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/ +c & (2*(sigma_odl(i,j,k))**2)) + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + godl(k)=dexp(-distancek(k)+min_odl) + odleg2=odleg2+godl(k) +c +c For Lorentzian-type Urestr +c + else + odleg2=odleg2+distancek(k) + endif + +ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3, +ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=", +ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1), +ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k) + + enddo +c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents +c 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 +c +c For Gaussian-type Urestr +c + odleg=odleg-dLOG(odleg2/constr_homology)+min_odl +c +c For Lorentzian-type Urestr +c + else + odleg=odleg+odleg2/constr_homology + endif +c +c write (iout,*) "odleg",odleg ! sum of -ln-s +c Gradient +c +c For Gaussian-type Urestr +c + if (waga_dist.ge.0.0d0) sum_godl=odleg2 + sum_sgodl=0.0d0 + do k=1,constr_homology +c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) +c & *waga_dist)+min_odl +c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist +c + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c For Gaussian-type Urestr +c + sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd +c +c For Lorentzian-type Urestr +c + else + sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ + & sigma_odlir(k,ii)**2)**2) + endif + sum_sgodl=sum_sgodl+sgodl + +c sgodl2=sgodl2+sgodl +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1" +c write(iout,*) "constr_homology=",constr_homology +c write(iout,*) i, j, k, "TEST K" + enddo + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + grad_odl3=waga_homology(iset)*waga_dist + & *sum_sgodl/(sum_godl*dij) +c +c For Lorentzian-type Urestr +c + else +c Original grad expr modified by analogy w Gaussian-type Urestr grad +c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl + grad_odl3=-waga_homology(iset)*waga_dist* + & sum_sgodl/(constr_homology*dij) + endif +c +c grad_odl3=sum_sgodl/(sum_godl*dij) + + +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2" +c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2), +c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) + +ccc write(iout,*) godl, sgodl, grad_odl3 + +c grad_odl=grad_odl+grad_odl3 + + do jik=1,3 + ggodl=grad_odl3*(c(jik,i)-c(jik,j)) +ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1)) +ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) + ghpbc(jik,i)=ghpbc(jik,i)+ggodl + ghpbc(jik,j)=ghpbc(jik,j)-ggodl +ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) +c if (i.eq.25.and.j.eq.27) then +c write(iout,*) "jik",jik,"i",i,"j",j +c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl +c write(iout,*) "grad_odl3",grad_odl3 +c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j) +c write(iout,*) "ggodl",ggodl +c write(iout,*) "ghpbc(",jik,i,")", +c & ghpbc(jik,i),"ghpbc(",jik,j,")", +c & ghpbc(jik,j) +c endif + enddo +ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=", +ccc & dLOG(odleg2),"-odleg=", -odleg + + enddo ! ii-loop for dist +#ifdef DEBUG + write(iout,*) "------- dist restrs end -------" +c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or. +c & waga_d.eq.1.0d0) call sum_gradient +#endif +c Pseudo-energy and gradient from dihedral-angle restraints from +c homology templates +c write (iout,*) "End of distance loop" +c call flush(iout) + kat=0.0d0 +c 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 +#endif + do i=idihconstr_start_homo,idihconstr_end_homo + kat2=0.0d0 +c betai=beta(i,i+1,i+2,i+3) + betai = phi(i) +c write (iout,*) "betai =",betai + do k=1,constr_homology + dih_diff(k)=pinorm(dih(k,i)-betai) +cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k) +cd & ,sigma_dih(k,i) +c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)= +c & -(6.28318-dih_diff(i,k)) +c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)= +c & 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 +c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i) + gdih(k)=dexp(kat3) + kat2=kat2+gdih(k) +c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3) +c write(*,*)"" + enddo +c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps +c 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) +c write (iout,*) "kat",kat ! sum of -ln-s + +ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=", +ccc & dLOG(kat2), "-kat=", -kat + +c ---------------------------------------------------------------------- +c Gradient +c ---------------------------------------------------------------------- + + 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 +c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle + sum_sgdih=sum_sgdih+sgdih + enddo +c grad_dih3=sum_sgdih/sum_gdih + grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih + +c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3 +ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3 +c if (i.eq.25) then +c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg) +c endif +ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + + enddo ! i-loop for dih +#ifdef DEBUG + write(iout,*) "------- dih restrs end -------" +#endif + +c Pseudo-energy and gradient for theta angle restraints from +c homology templates +c FP 01/15 - inserted from econstr_local_test.F, loop structure +c adapted + +c +c For constr_homology reference structures (FP) +c +c Uconst_back_tot=0.0d0 + Eval=0.0d0 + Erot=0.0d0 +c Econstr_back legacy + do i=1,nres +c do i=ithet_start,ithet_end + dutheta(i)=0.0d0 +c enddo +c do i=loc_start,loc_end + do j=1,3 + duscdiff(j,i)=0.0d0 + duscdiffx(j,i)=0.0d0 + enddo + enddo +c +c do iref=1,nref +c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +c write (iout,*) "waga_theta",waga_theta + if (waga_theta.gt.0.0d0) then +#ifdef DEBUG + write (iout,*) "usampl",usampl + write(iout,*) "------- theta restrs start -------" +c do i=ithet_start,ithet_end +c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg) +c enddo +#endif +c write (iout,*) "maxres",maxres,"nres",nres + + do i=ithet_start,ithet_end +c +c do i=1,nfrag_back +c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) +c +c Deviation of theta angles wrt constr_homology ref structures +c + utheta_i=0.0d0 ! argument of Gaussian for single k + gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop +c over residues in a fragment +c write (iout,*) "theta(",i,")=",theta(i) + do k=1,constr_homology +c +c dtheta_i=theta(j)-thetaref(j,iref) +c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing + theta_diff(k)=thetatpl(k,i)-theta(i) +cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k) +cd & ,sigma_theta(k,i) + +c + utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument +c 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) +c Gradient for single Gaussian restraint in subr Econstr_back +c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) +c + enddo +c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps + +c +c Gradient for multiple Gaussian restraint + sum_gtheta=gutheta_i + sum_sgtheta=0.0d0 + do k=1,constr_homology +c New generalized expr for multiple Gaussian from Econstr_back + sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd +c +c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form? + sum_sgtheta=sum_sgtheta+sgtheta ! cum variable + enddo +c 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) +c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta +c & *waga_homology(iset) +c dutheta(i)=sum_sgtheta/sum_gtheta +c +c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight + Eval=Eval-dLOG(gutheta_i/constr_homology) +c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s +c Uconst_back=Uconst_back+utheta(i) + enddo ! (i-loop for theta) +#ifdef DEBUG + write(iout,*) "------- theta restrs end -------" +#endif + endif +c +c Deviation of local SC geometry +c +c Separation of two i-loops (instructed by AL - 11/3/2014) +c +c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +c 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 +#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 +c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy +c write(iout,*) "xxtab, yytab, zztab" +c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i) + do k=1,constr_homology +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c 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 +c write(iout,*) "dxx, dyy, dzz" +cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i) +c + usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument +c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d? +c uscdiffk(k)=usc_diff(i) + guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff +c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i), +c & " guscdiff2",guscdiff2(k) + guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk) +c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), +c & xxref(j),yyref(j),zzref(j) + enddo +c +c Gradient +c +c Generalized expression for multiple Gaussian acc to that for a single +c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014) +c +c Original implementation +c sum_guscdiff=guscdiff(i) +c +c sum_sguscdiff=0.0d0 +c do k=1,constr_homology +c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d? +c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff +c sum_sguscdiff=sum_sguscdiff+sguscdiff +c enddo +c +c Implementation of new expressions for gradient (Jan. 2015) +c +c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !? + do k=1,constr_homology +c +c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong +c before. Now the drivatives should be correct +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c 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 +c +c New implementation +c + sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong! + & sigma_d(k,i) ! for the grad wrt r' +c sum_sguscdiff=sum_sguscdiff+sum_guscdiff +c +c +c 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) +c +#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) +c write(iout,*) "sum_sguscdiff",sum_sguscdiff +cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i) +c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i) +c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i) +c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i) +c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i) +c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i) +c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i) +c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i) +c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i) +c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1) +c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i) +c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i) +c endif +#endif + enddo + enddo +c +c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required? +c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ? +c +c write (iout,*) i," uscdiff",uscdiff(i) +c +c Put together deviations from local geometry + +c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ +c & wfrag_back(3,i,iset)*uscdiff(i) + Erot=Erot-dLOG(guscdiff(i)/constr_homology) +c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s +c Uconst_back=Uconst_back+usc_diff(i) +c +c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?) +c +c New implment: multiplied by sum_sguscdiff +c + + enddo ! (i-loop for dscdiff) + +c 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 + endif + 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 + endif +#endif + +c Total energy from homology restraints +#ifdef DEBUG + write (iout,*) "odleg",odleg," kat",kat +#endif +c +c Addition of energy of theta angle and SC local geom over constr_homologs ref strs +c +c ehomology_constr=odleg+kat +c +c For Lorentzian-type Urestr +c + + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + ehomology_constr=(waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) +c write (iout,*) "ehomology_constr=",ehomology_constr + else +c +c For Lorentzian-type Urestr +c + ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) +c write (iout,*) "ehomology_constr=",ehomology_constr + endif +#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 +c +c FP 01/15 end +c + 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 +c---------------------------------------------------------------------------- +C The rigorous attempt to derive energy function + subroutine ebend_kcc(etheta) + + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' + include 'COMMON.CONTROL' + logical lprn + double precision thybt1(maxang_kcc) +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).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle + iti=iabs(itortyp(itype(i-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),iti,theta(i)*rad2deg, + & sumth1thyb + ihelp=nbend_kcc_Tb(iti)-1 + gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet) + etheta=etheta+sumth1thyb +C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0) + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet + enddo + return + end +c------------------------------------------------------------------------------------- + subroutine etheta_constr(ethetacnstr) + + 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' + 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 +c------------------------------------------------------------------------------ + subroutine eback_sc_corr(esccor) +c 7/21/2007 Correlations between the backbone-local and side-chain-local +c conformational states; temporarily implemented as differences +c between UNRES torsional potentials (dependent on three types of +c residues) and the torsional potentials dependent on all 20 types +c of residues computed from AM1 energy surfaces of terminally-blocked +c amino-acid residues. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.TORSION' + include 'COMMON.SCCOR' + include 'COMMON.INTERACT' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.NAMES' + include 'COMMON.IOUNITS' + include 'COMMON.FFIELD' + include 'COMMON.CONTROL' + logical lprn +C Set lprn=.true. for debugging + lprn=.false. +c lprn=.true. +c write (iout,*) "EBACK_SC_COR",itau_start,itau_end + esccor=0.0D0 + do i=itau_start,itau_end + if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle + esccor_ii=0.0D0 + isccori=isccortyp(itype(i-2)) + isccori1=isccortyp(itype(i-1)) +c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1) + phii=phi(i) + do intertyp=1,3 !intertyp +cc Added 09 May 2012 (Adasko) +cc Intertyp means interaction type of backbone mainchain correlation: +c 1 = SC...Ca...Ca...Ca +c 2 = Ca...Ca...Ca...SC +c 3 = SC...Ca...Ca...SCi + gloci=0.0D0 + if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. + & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. + & (itype(i-1).eq.ntyp1))) + & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) + & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) + & .or.(itype(i).eq.ntyp1))) + & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. + & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. + & (itype(i-3).eq.ntyp1)))) cycle + if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle + if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) + & cycle + do j=1,nterm_sccor(isccori,isccori1) + v1ij=v1sccor(j,intertyp,isccori,isccori1) + v2ij=v2sccor(j,intertyp,isccori,isccori1) + cosphi=dcos(j*tauangle(intertyp,i)) + sinphi=dsin(j*tauangle(intertyp,i)) + esccor=esccor+v1ij*cosphi+v2ij*sinphi + gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) + enddo +c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp + gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci + if (lprn) + & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') + & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1, + & (v1sccor(j,intertyp,isccori,isccori1),j=1,6) + & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6) + gsccor_loc(i-3)=gsccor_loc(i-3)+gloci + enddo !intertyp + enddo + + return + end +#ifdef FOURBODY +c---------------------------------------------------------------------------- + subroutine multibody(ecorr) +C This subroutine calculates multi-body contributions to energy following +C the idea of Skolnick et al. If side chains I and J make a contact and +C at the same time side chains I+1 and J+1 make a contact, an extra +C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + double precision gx(3),gx1(3) + logical lprn + +C Set lprn=.true. for debugging + lprn=.false. + + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(i2,20(1x,i2,f10.5))') + & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) + enddo + endif + ecorr=0.0D0 + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo + do i=nnt,nct-2 + + DO ISHIFT = 3,4 + + i1=i+ishift + num_conti=num_cont(i) + num_conti1=num_cont(i1) + do jj=1,num_conti + j=jcont(jj,i) + do kk=1,num_conti1 + j1=jcont(kk,i1) + if (j1.eq.j+ishift .or. j1.eq.j-ishift) then +cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, +cd & ' ishift=',ishift +C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) + endif ! j1==j+-ishift + enddo ! kk + enddo ! jj + + ENDDO ! ISHIFT + + enddo ! i + return + end +c------------------------------------------------------------------------------ + double precision function esccorr(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.SHIELD' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. + eij=facont(jj,i) + ekl=facont(kk,k) +cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl +C Calculate the multi-body contribution to energy. +C Calculate multi-body contributions to the gradient. +cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), +cd & k,l,(gacont(m,kk,k),m=1,3) + do m=1,3 + gx(m) =ekl*gacont(m,jj,i) + gx1(m)=eij*gacont(m,kk,k) + gradxorr(m,i)=gradxorr(m,i)-gx(m) + gradxorr(m,j)=gradxorr(m,j)+gx(m) + gradxorr(m,k)=gradxorr(m,k)-gx1(m) + gradxorr(m,l)=gradxorr(m,l)+gx1(m) + enddo + do m=i,j-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) + enddo + enddo + do m=k,l-1 + do ll=1,3 + gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) + enddo + enddo + esccorr=-eij*ekl + return + end +c------------------------------------------------------------------------------ + subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +#ifdef MPI + include "mpif.h" + parameter (max_cont=maxconts) + parameter (max_dim=26) + integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer status(MPI_STATUS_SIZE),req(maxconts*2), + & status_array(MPI_STATUS_SIZE,maxconts*2) +#endif + include 'COMMON.SETUP' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.CONTROL' + include 'COMMON.LOCAL' + double precision gx(3),gx1(3),time00 + logical lprn,ldone + +C Set lprn=.true. for debugging + lprn=.false. +#ifdef MPI + n_corr=0 + n_corr1=0 + if (nfgtasks.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values before RECEIVE:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + call flush(iout) + endif + do i=1,ntask_cont_from + ncont_recv(i)=0 + enddo + do i=1,ntask_cont_to + ncont_sent(i)=0 + enddo +c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", +c & ntask_cont_to +C Make the list of contacts to send to send to other procesors +c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end +c call flush(iout) + do i=iturn3_start,iturn3_end +c write (iout,*) "make contact list turn3",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) + enddo + do i=iturn4_start,iturn4_end +c write (iout,*) "make contact list turn4",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) + enddo + do ii=1,nat_sent + i=iat_sent(ii) +c write (iout,*) "make contact list longrange",i,ii," num_cont", +c & num_cont_hb(i) + do j=1,num_cont_hb(i) + do k=1,4 + jjc=jcont_hb(j,i) + iproc=iint_sent_local(k,jjc,ii) +c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc + if (iproc.gt.0) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=i + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=facont_hb(j,i) + zapas(4,nn,iproc)=ees0p(j,i) + zapas(5,nn,iproc)=ees0m(j,i) + zapas(6,nn,iproc)=gacont_hbr(1,j,i) + zapas(7,nn,iproc)=gacont_hbr(2,j,i) + zapas(8,nn,iproc)=gacont_hbr(3,j,i) + zapas(9,nn,iproc)=gacontm_hb1(1,j,i) + zapas(10,nn,iproc)=gacontm_hb1(2,j,i) + zapas(11,nn,iproc)=gacontm_hb1(3,j,i) + zapas(12,nn,iproc)=gacontp_hb1(1,j,i) + zapas(13,nn,iproc)=gacontp_hb1(2,j,i) + zapas(14,nn,iproc)=gacontp_hb1(3,j,i) + zapas(15,nn,iproc)=gacontm_hb2(1,j,i) + zapas(16,nn,iproc)=gacontm_hb2(2,j,i) + zapas(17,nn,iproc)=gacontm_hb2(3,j,i) + zapas(18,nn,iproc)=gacontp_hb2(1,j,i) + zapas(19,nn,iproc)=gacontp_hb2(2,j,i) + zapas(20,nn,iproc)=gacontp_hb2(3,j,i) + zapas(21,nn,iproc)=gacontm_hb3(1,j,i) + zapas(22,nn,iproc)=gacontm_hb3(2,j,i) + zapas(23,nn,iproc)=gacontm_hb3(3,j,i) + zapas(24,nn,iproc)=gacontp_hb3(1,j,i) + zapas(25,nn,iproc)=gacontp_hb3(2,j,i) + zapas(26,nn,iproc)=gacontp_hb3(3,j,i) + endif + enddo + enddo + enddo + if (lprn) then + write (iout,*) + & "Numbers of contacts to be sent to other processors", + & (ncont_sent(i),i=1,ntask_cont_to) + write (iout,*) "Contacts sent" + do ii=1,ntask_cont_to + nn=ncont_sent(ii) + iproc=itask_cont_to(ii) + write (iout,*) nn," contacts to processor",iproc, + & " of CONT_TO_COMM group" + do i=1,nn + write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) + enddo + enddo + call flush(iout) + endif + CorrelType=477 + CorrelID=fg_rank+1 + CorrelType1=478 + CorrelID1=nfgtasks+fg_rank+1 + ireq=0 +C Receive the numbers of needed contacts from other processors + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + ireq=ireq+1 + call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "IRECV ended" +c call flush(iout) +C Send the number of contacts needed by other processors + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + ireq=ireq+1 + call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "ISEND ended" +c write (iout,*) "number of requests (nn)",ireq +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) +c write (iout,*) +c & "Numbers of contacts to be received from other processors", +c & (ncont_recv(i),i=1,ntask_cont_from) +c call flush(iout) +C Receive contacts + ireq=0 + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + nn=ncont_recv(ii) +c write (iout,*) "Receiving",nn," contacts from processor",iproc, +c & " of CONT_TO_COMM group" +c call flush(iout) + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, + & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) + endif + enddo +C Send the contacts to processors that need them + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + nn=ncont_sent(ii) +c write (iout,*) nn," contacts to processor",iproc, +c & " of CONT_TO_COMM group" + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, + & iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) +c do i=1,nn +c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) +c enddo + endif + enddo +c write (iout,*) "number of requests (contacts)",ireq +c write (iout,*) "req",(req(i),i=1,4) +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) + do iii=1,ntask_cont_from + iproc=itask_cont_from(iii) + nn=ncont_recv(iii) + if (lprn) then + write (iout,*) "Received",nn," contacts from processor",iproc, + & " of CONT_FROM_COMM group" + call flush(iout) + do i=1,nn + write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) + enddo + call flush(iout) + endif + do i=1,nn + ii=zapas_recv(1,i,iii) +c Flag the received contacts to prevent double-counting + jj=-zapas_recv(2,i,iii) +c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj +c call flush(iout) + nnn=num_cont_hb(ii)+1 + num_cont_hb(ii)=nnn + jcont_hb(nnn,ii)=jj + facont_hb(nnn,ii)=zapas_recv(3,i,iii) + ees0p(nnn,ii)=zapas_recv(4,i,iii) + ees0m(nnn,ii)=zapas_recv(5,i,iii) + gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii) + gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii) + gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii) + gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii) + gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii) + gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii) + gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii) + gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii) + gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii) + gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii) + gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii) + gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii) + gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii) + gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii) + gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii) + gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii) + gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii) + gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii) + gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii) + gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii) + gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii) + enddo + enddo + 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 + call flush(iout) + endif + ecorr=0.0D0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the local-electrostatic correlation terms + do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end) + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk +c call flush(iout) + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 + & .or. j.lt.0 .and. j1.gt.0) .and. + & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) + n_corr=n_corr+1 + else if (j1.eq.j) then +C Contacts I-J and I-(J+1) occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) + endif + enddo ! kk + do kk=1,num_conti + j1=jcont_hb(kk,i) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk + if (j1.eq.j+1) then +C Contacts I-J and (I+1)-J occur simultaneously. +C The system loses extra energy. +c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) + endif ! j1==j+1 + enddo ! kk + enddo ! jj + enddo ! i + return + end +c------------------------------------------------------------------------------ + subroutine add_hb_contact(ii,jj,itask) + implicit real*8 (a-h,o-z) + include "DIMENSIONS" + include "COMMON.IOUNITS" + integer max_cont + integer max_dim + parameter (max_cont=maxconts) + parameter (max_dim=26) + include "COMMON.CONTACTS" + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer i,j,ii,jj,iproc,itask(4),nn +c write (iout,*) "itask",itask + do i=1,2 + iproc=itask(i) + if (iproc.gt.0) then + do j=1,num_cont_hb(ii) + jjc=jcont_hb(j,ii) +c write (iout,*) "i",ii," j",jj," jjc",jjc + if (jjc.eq.jj) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=ii + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=facont_hb(j,ii) + zapas(4,nn,iproc)=ees0p(j,ii) + zapas(5,nn,iproc)=ees0m(j,ii) + zapas(6,nn,iproc)=gacont_hbr(1,j,ii) + zapas(7,nn,iproc)=gacont_hbr(2,j,ii) + zapas(8,nn,iproc)=gacont_hbr(3,j,ii) + zapas(9,nn,iproc)=gacontm_hb1(1,j,ii) + zapas(10,nn,iproc)=gacontm_hb1(2,j,ii) + zapas(11,nn,iproc)=gacontm_hb1(3,j,ii) + zapas(12,nn,iproc)=gacontp_hb1(1,j,ii) + zapas(13,nn,iproc)=gacontp_hb1(2,j,ii) + zapas(14,nn,iproc)=gacontp_hb1(3,j,ii) + zapas(15,nn,iproc)=gacontm_hb2(1,j,ii) + zapas(16,nn,iproc)=gacontm_hb2(2,j,ii) + zapas(17,nn,iproc)=gacontm_hb2(3,j,ii) + zapas(18,nn,iproc)=gacontp_hb2(1,j,ii) + zapas(19,nn,iproc)=gacontp_hb2(2,j,ii) + zapas(20,nn,iproc)=gacontp_hb2(3,j,ii) + zapas(21,nn,iproc)=gacontm_hb3(1,j,ii) + zapas(22,nn,iproc)=gacontm_hb3(2,j,ii) + zapas(23,nn,iproc)=gacontm_hb3(3,j,ii) + zapas(24,nn,iproc)=gacontp_hb3(1,j,ii) + zapas(25,nn,iproc)=gacontp_hb3(2,j,ii) + zapas(26,nn,iproc)=gacontp_hb3(3,j,ii) + exit + endif + enddo + endif + enddo + return + end +c------------------------------------------------------------------------------ + subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, + & n_corr1) +C This subroutine calculates multi-body contributions to hydrogen-bonding + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' +#ifdef MPI + include "mpif.h" + parameter (max_cont=maxconts) + parameter (max_dim=70) + integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer status(MPI_STATUS_SIZE),req(maxconts*2), + & status_array(MPI_STATUS_SIZE,maxconts*2) +#endif + include 'COMMON.SETUP' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.CHAIN' + include 'COMMON.CONTROL' + include 'COMMON.SHIELD' + double precision gx(3),gx1(3) + integer num_cont_hb_old(maxres) + logical lprn,ldone + double precision eello4,eello5,eelo6,eello_turn6 + external eello4,eello5,eello6,eello_turn6 +C Set lprn=.true. for debugging + lprn=.false. + eturn6=0.0d0 +#ifdef MPI + do i=1,nres + num_cont_hb_old(i)=num_cont_hb(i) + enddo + n_corr=0 + n_corr1=0 + if (nfgtasks.le.1) goto 30 + if (lprn) then + write (iout,'(a)') 'Contact function values before RECEIVE:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,f5.2))') + & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), + & j=1,num_cont_hb(i)) + enddo + endif + do i=1,ntask_cont_from + ncont_recv(i)=0 + enddo + do i=1,ntask_cont_to + ncont_sent(i)=0 + enddo +c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", +c & ntask_cont_to +C Make the list of contacts to send to send to other procesors + do i=iturn3_start,iturn3_end +c write (iout,*) "make contact list turn3",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) + enddo + do i=iturn4_start,iturn4_end +c write (iout,*) "make contact list turn4",i," num_cont", +c & num_cont_hb(i) + call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i)) + enddo + do ii=1,nat_sent + i=iat_sent(ii) +c write (iout,*) "make contact list longrange",i,ii," num_cont", +c & num_cont_hb(i) + do j=1,num_cont_hb(i) + do k=1,4 + jjc=jcont_hb(j,i) + iproc=iint_sent_local(k,jjc,ii) +c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc + if (iproc.ne.0) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=i + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=d_cont(j,i) + ind=3 + do kk=1,3 + ind=ind+1 + zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i) + enddo + enddo + enddo + enddo + endif + enddo + enddo + enddo + if (lprn) then + write (iout,*) + & "Numbers of contacts to be sent to other processors", + & (ncont_sent(i),i=1,ntask_cont_to) + write (iout,*) "Contacts sent" + do ii=1,ntask_cont_to + nn=ncont_sent(ii) + iproc=itask_cont_to(ii) + write (iout,*) nn," contacts to processor",iproc, + & " of CONT_TO_COMM group" + do i=1,nn + write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10) + enddo + enddo + call flush(iout) + endif + CorrelType=477 + CorrelID=fg_rank+1 + CorrelType1=478 + CorrelID1=nfgtasks+fg_rank+1 + ireq=0 +C Receive the numbers of needed contacts from other processors + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + ireq=ireq+1 + call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "IRECV ended" +c call flush(iout) +C Send the number of contacts needed by other processors + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + ireq=ireq+1 + call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, + & FG_COMM,req(ireq),IERR) + enddo +c write (iout,*) "ISEND ended" +c write (iout,*) "number of requests (nn)",ireq +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) +c write (iout,*) +c & "Numbers of contacts to be received from other processors", +c & (ncont_recv(i),i=1,ntask_cont_from) +c call flush(iout) +C Receive contacts + ireq=0 + do ii=1,ntask_cont_from + iproc=itask_cont_from(ii) + nn=ncont_recv(ii) +c write (iout,*) "Receiving",nn," contacts from processor",iproc, +c & " of CONT_TO_COMM group" +c call flush(iout) + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, + & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) + endif + enddo +C Send the contacts to processors that need them + do ii=1,ntask_cont_to + iproc=itask_cont_to(ii) + nn=ncont_sent(ii) +c write (iout,*) nn," contacts to processor",iproc, +c & " of CONT_TO_COMM group" + if (nn.gt.0) then + ireq=ireq+1 + call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, + & iproc,CorrelType1,FG_COMM,req(ireq),IERR) +c write (iout,*) "ireq,req",ireq,req(ireq) +c do i=1,nn +c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) +c enddo + endif + enddo +c write (iout,*) "number of requests (contacts)",ireq +c write (iout,*) "req",(req(i),i=1,4) +c call flush(iout) + if (ireq.gt.0) + & call MPI_Waitall(ireq,req,status_array,ierr) + do iii=1,ntask_cont_from + iproc=itask_cont_from(iii) + nn=ncont_recv(iii) + if (lprn) then + write (iout,*) "Received",nn," contacts from processor",iproc, + & " of CONT_FROM_COMM group" + call flush(iout) + do i=1,nn + write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10) + enddo + call flush(iout) + endif + do i=1,nn + ii=zapas_recv(1,i,iii) +c Flag the received contacts to prevent double-counting + jj=-zapas_recv(2,i,iii) +c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj +c call flush(iout) + nnn=num_cont_hb(ii)+1 + num_cont_hb(ii)=nnn + jcont_hb(nnn,ii)=jj + d_cont(nnn,ii)=zapas_recv(3,i,iii) + ind=3 + do kk=1,3 + ind=ind+1 + grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii) + enddo + enddo + enddo + enddo + enddo + enddo + if (lprn) then + write (iout,'(a)') 'Contact function values after receive:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i3,5f6.3))') + & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), + & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + call flush(iout) + endif + 30 continue +#endif + if (lprn) then + write (iout,'(a)') 'Contact function values:' + do i=nnt,nct-2 + write (iout,'(2i3,50(1x,i2,5f6.3))') + & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), + & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) + enddo + endif + ecorr=0.0D0 + ecorr5=0.0d0 + ecorr6=0.0d0 +C Remove the loop below after debugging !!! + do i=nnt,nct + do j=1,3 + gradcorr(j,i)=0.0D0 + gradxorr(j,i)=0.0D0 + enddo + enddo +C Calculate the dipole-dipole interaction energies + if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then + do i=iatel_s,iatel_e+1 + num_conti=num_cont_hb(i) + do jj=1,num_conti + j=jcont_hb(jj,i) +#ifdef MOMENT + call dipole(i,j,jj) +#endif + enddo + enddo + endif +C Calculate the local-electrostatic correlation terms +c write (iout,*) "gradcorr5 in eello5 before loop" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) +c write (iout,*) "corr loop i",i + i1=i+1 + num_conti=num_cont_hb(i) + num_conti1=num_cont_hb(i+1) + do jj=1,num_conti + j=jcont_hb(jj,i) + jp=iabs(j) + do kk=1,num_conti1 + j1=jcont_hb(kk,i1) + jp1=iabs(j1) +c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, +c & ' jj=',jj,' kk=',kk +c if (j1.eq.j+1 .or. j1.eq.j-1) then + if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 + & .or. j.lt.0 .and. j1.gt.0) .and. + & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then +C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. +C The system gains extra energy. + n_corr=n_corr+1 + sqd1=dsqrt(d_cont(jj,i)) + sqd2=dsqrt(d_cont(kk,i1)) + sred_geom = sqd1*sqd2 + IF (sred_geom.lt.cutoff_corr) THEN + call gcont(sred_geom,r0_corr,1.0D0,delt_corr, + & ekont,fprimcont) +cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, +cd & ' jj=',jj,' kk=',kk + fac_prim1=0.5d0*sqd2/sqd1*fprimcont + fac_prim2=0.5d0*sqd1/sqd2*fprimcont + do l=1,3 + g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) + g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) + enddo + n_corr1=n_corr1+1 +cd write (iout,*) 'sred_geom=',sred_geom, +cd & ' ekont=',ekont,' fprim=',fprimcont, +cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 +cd write (iout,*) "g_contij",g_contij +cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) +cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) + call calc_eello(i,jp,i+1,jp1,jj,kk) + if (wcorr4.gt.0.0d0) + & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) +CC & *fac_shield(i)**2*fac_shield(j)**2 + if (energy_dec.and.wcorr4.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 before eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (wcorr5.gt.0.0d0) + & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) +c write (iout,*) "gradcorr5 after eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + if (energy_dec.and.wcorr5.gt.0.0d0) + 1 write (iout,'(a6,4i5,0pf7.3)') + 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) +cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 +cd write(2,*)'ijkl',i,jp,i+1,jp1 + if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 + & .or. wturn6.eq.0.0d0))then +cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 + ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) +cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, +cd & 'ecorr6=',ecorr6 +cd write (iout,'(4e15.5)') sred_geom, +cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), +cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) + else if (wturn6.gt.0.0d0 + & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then +cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 + eturn6=eturn6+eello_turn6(i,jj,kk) + if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') + 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) +cd write (2,*) 'multibody_eello:eturn6',eturn6 + endif + ENDIF +1111 continue + endif + enddo ! kk + enddo ! jj + enddo ! i + do i=1,nres + num_cont_hb(i)=num_cont_hb_old(i) + enddo +c write (iout,*) "gradcorr5 in eello5" +c do iii=1,nres +c write (iout,'(i5,3f10.5)') +c & iii,(gradcorr5(jjj,iii),jjj=1,3) +c enddo + return + end +c------------------------------------------------------------------------------ + subroutine add_hb_contact_eello(ii,jj,itask) + implicit real*8 (a-h,o-z) + include "DIMENSIONS" + include "COMMON.IOUNITS" + integer max_cont + integer max_dim + parameter (max_cont=maxconts) + parameter (max_dim=70) + include "COMMON.CONTACTS" + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + double precision zapas(max_dim,maxconts,max_fg_procs), + & zapas_recv(max_dim,maxconts,max_fg_procs) + common /przechowalnia/ zapas + integer i,j,ii,jj,iproc,itask(4),nn +c write (iout,*) "itask",itask + do i=1,2 + iproc=itask(i) + if (iproc.gt.0) then + do j=1,num_cont_hb(ii) + jjc=jcont_hb(j,ii) +c write (iout,*) "send turns i",ii," j",jj," jjc",jjc + if (jjc.eq.jj) then + ncont_sent(iproc)=ncont_sent(iproc)+1 + nn=ncont_sent(iproc) + zapas(1,nn,iproc)=ii + zapas(2,nn,iproc)=jjc + zapas(3,nn,iproc)=d_cont(j,ii) + ind=3 + do kk=1,3 + ind=ind+1 + zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii) + enddo + do kk=1,2 + do ll=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii) + enddo + enddo + do jj=1,5 + do kk=1,3 + do ll=1,2 + do mm=1,2 + ind=ind+1 + zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii) + enddo + enddo + enddo + enddo + exit + endif + enddo + endif + enddo + return + end +c------------------------------------------------------------------------------ + double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' + double precision gx(3),gx1(3) + logical lprn + lprn=.false. +C print *,"wchodze",fac_shield(i),shield_mode + 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) +C* +C & fac_shield(i)**2*fac_shield(j)**2 +cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) +C Following 4 lines for diagnostics. +cd ees0pkl=0.0D0 +cd ees0pij=1.0D0 +cd ees0mkl=0.0D0 +cd ees0mij=1.0D0 +c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') +c & 'Contacts ',i,j, +c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l +c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, +c & 'gradcorr_long' +C Calculate the multi-body contribution to energy. +C ecorr=ecorr+ekont*ees +C Calculate multi-body contributions to the gradient. + coeffpees0pij=coeffp*ees0pij + coeffmees0mij=coeffm*ees0mij + coeffpees0pkl=coeffp*ees0pkl + coeffmees0mkl=coeffm*ees0mkl + do ll=1,3 +cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) + gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb1(ll,jj,i)) + gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi + & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb2(ll,jj,i)) +cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) + gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ + & coeffmees0mij*gacontm_hb1(ll,kk,k)) + gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk + & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ + & coeffmees0mij*gacontm_hb2(ll,kk,k)) + gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- + & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ + & coeffmees0mkl*gacontm_hb3(ll,jj,i)) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij + gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- + & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ + & coeffmees0mij*gacontm_hb3(ll,kk,k)) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl +c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl + enddo +c write (iout,*) +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*ekl*gacont_hbr(ll,jj,i)- +cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ +cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ +cgrad & ees*eij*gacont_hbr(ll,kk,k)- +cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ +cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) +cgrad enddo +cgrad enddo +c write (iout,*) "ehbcorr",ekont*ees +C print *,ekont,ees,i,k + ehbcorr=ekont*ees +C now gradient over shielding +C return + 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) +C & *2.0 + 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) +C & *2.0 + 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) +C & *2.0 + 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) +C & *2.0 + 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 +C print *,gshieldx(m,iresshield) + 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 +#ifdef MOMENT +C--------------------------------------------------------------------------- + subroutine dipole(i,j,jj) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), + & auxmat(2,2) + iti1 = itortyp(itype(i+1)) + if (j.lt.nres-1) then + itj1 = itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + do iii=1,2 + dipi(iii,1)=Ub2(iii,i) + dipderi(iii)=Ub2der(iii,i) + dipi(iii,2)=b1(iii,i+1) + dipj(iii,1)=Ub2(iii,j) + dipderj(iii)=Ub2der(iii,j) + dipj(iii,2)=b1(iii,j+1) + enddo + kkk=0 + do iii=1,2 + call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) + do jjj=1,2 + kkk=kkk+1 + dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + do kkk=1,5 + do lll=1,3 + mmm=0 + do iii=1,2 + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), + & auxvec(1)) + do jjj=1,2 + mmm=mmm+1 + dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) + enddo + enddo + enddo + enddo + call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) + call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) + do iii=1,2 + dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) + enddo + call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) + do iii=1,2 + dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) + enddo + return + end +#endif +C--------------------------------------------------------------------------- + subroutine calc_eello(i,j,k,l,jj,kk) +C +C This subroutine computes matrices and vectors needed to calculate +C the fourth-, fifth-, and sixth-order local-electrostatic terms. +C + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), + & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) + logical lprn + common /kutas/ lprn +cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, +cd & ' jj=',jj,' kk=',kk +cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return +cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) +cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) + do iii=1,2 + do jjj=1,2 + aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) + aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) + enddo + enddo + call transpose2(aa1(1,1),aa1t(1,1)) + call transpose2(aa2(1,1),aa2t(1,1)) + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), + & aa1tder(1,1,lll,kkk)) + call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), + & aa2tder(1,1,lll,kkk)) + enddo + enddo + if (l.eq.j+1) then +C parallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itype2loc(itype(i)) + else + iti=nloctyp + endif + itk1=itype2loc(itype(k+1)) + itj=itype2loc(itype(j)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +C A1 kernel(j+1) A2T +cd do iii=1,2 +cd write (iout,'(3f10.5,5x,3f10.5)') +cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) +cd enddo + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), + & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + lprn=.false. + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), + & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants +cd lprn=.false. +cd if (lprn) then +cd write (2,*) 'In calc_eello6' +cd do iii=1,2 +cd write (2,*) 'iii=',iii +cd do kkk=1,5 +cd write (2,*) 'kkk=',kkk +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) +cd enddo +cd enddo +cd enddo +cd endif + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) +C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E +c in theta; to be sriten later. +c#ifdef NEWCORR +c call transpose2(gtEE(1,1,k),auxmat(1,1)) +c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1)) +c call transpose2(EUg(1,1,k),auxmat(1,1)) +c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1)) +c#endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A1T kernel(i+1) A2 + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0) THEN + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), + & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i),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,i),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,k+1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j),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,j),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,l+1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i), + & 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,k+1), + & 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,j), + & 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,l+1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + else +C Antiparallel orientation of the two CA-CA-CA frames. + if (i.gt.1) then + iti=itype2loc(itype(i)) + else + iti=nloctyp + endif + itk1=itype2loc(itype(k+1)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif +C A2 kernel(j-1)T A1T + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), + & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), + & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) + call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), + & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), + & ADtEAderx(1,1,1,1,1,1)) + call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), + & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), + & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), + & ADtEA1derx(1,1,1,1,1,1)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & EAEAderx(1,1,lll,kkk,iii,1)) + enddo + enddo + enddo +C A2T kernel(i+1)T A1 + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), + & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) +C Following matrices are needed only for 6-th order cumulants + IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. + & j.eq.i+4 .and. l.eq.i+3)) THEN + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), + & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), + & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), + & ADtEAderx(1,1,1,1,1,2)) + call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), + & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), + & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), + & ADtEA1derx(1,1,1,1,1,2)) + ENDIF +C End 6-th order cumulants + call transpose2(EUgder(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & EAEAderx(1,1,lll,kkk,iii,2)) + enddo + enddo + enddo +C AEAb1 and AEAb2 +C Calculate the vectors and their derivatives in virtual-bond dihedral angles. +C They are needed only when the fifth- or the sixth-order cumulants are +C indluded. + IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. + & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i),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,i),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,k+1),AEAb1(1,2,1)) + call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j+1),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,l),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,j+1),AEAb1(1,2,2)) + call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2)) + call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) + call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) + call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) +C Calculate the Cartesian derivatives of the vectors. + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) + call matvec2(auxmat(1,1),b1(1,i), + & 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,k+1), + & 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,l), + & 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,j+1), + & AEAb1derx(1,lll,kkk,iii,2,2)) + call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), + & AEAb2derx(1,lll,kkk,iii,2,2)) + enddo + enddo + enddo + ENDIF +C End vectors + endif + return + end +C--------------------------------------------------------------------------- + subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, + & KK,KKderg,AKA,AKAderg,AKAderx) + implicit none + integer nderg + logical transp + double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), + & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), + & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) + integer iii,kkk,lll + integer jjj,mmm + logical lprn + common /kutas/ lprn + call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) + do iii=1,nderg + call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, + & AKAderg(1,1,iii)) + enddo +cd if (lprn) write (2,*) 'In kernel' + do kkk=1,5 +cd if (lprn) write (2,*) 'kkk=',kkk + do lll=1,3 + call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=1' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) +cd enddo +cd endif + call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), + & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) +cd if (lprn) then +cd write (2,*) 'lll=',lll +cd write (2,*) 'iii=2' +cd do jjj=1,2 +cd write (2,'(3(2f10.5),5x)') +cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) +cd enddo +cd endif + enddo + enddo + return + end +C--------------------------------------------------------------------------- + double precision function eello4(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then +cd eello4=0.0d0 +cd return +cd endif +cd print *,'eello4:',i,j,k,l,jj,kk +cd write (2,*) 'i',i,' j',j,' k',k,' l',l +cd call checkint4(i,j,k,l,jj,kk,eel4_num) +cold eij=facont_hb(jj,i) +cold ekl=facont_hb(kk,k) +cold ekont=eij*ekl + eel4=-EAEA(1,1,1)-EAEA(2,2,1) +cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) + gcorr_loc(k-1)=gcorr_loc(k-1) + & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) + if (l.eq.j+1) then + gcorr_loc(l-1)=gcorr_loc(l-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) +C Al 4/16/16: Derivatives in theta, to be added later. +c#ifdef NEWCORR +c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1) +c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1)) +c#endif + else + gcorr_loc(j-1)=gcorr_loc(j-1) + & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) +c#ifdef NEWCORR +c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1) +c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1)) +c#endif + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) + & -EAEAderx(2,2,lll,kkk,iii,1) +cd derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd gcorr_loc(l-1)=0.0d0 +cd gcorr_loc(j-1)=0.0d0 +cd gcorr_loc(k-1)=0.0d0 +cd eel4=1.0d0 +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l, +cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel4*g_contij(ll,1) +cgrad ggg2(ll)=eel4*g_contij(ll,2) + glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) + glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) +cgrad ghalf=0.5d0*ggg1(ll) + gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) + gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) + gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) + gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) + gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij + gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij +cgrad ghalf=0.5d0*ggg2(ll) + gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) + gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) + gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) + gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) + gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl + gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl + enddo +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,gcorr_loc(iii) +cd enddo + eello4=ekont*eel4 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello4',ekont*eel4 + return + end +C--------------------------------------------------------------------------- + double precision function eello5(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) + double precision ggg1(3),ggg2(3) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel chains C +C C +C o o o o C +C /l\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j| o |l1 | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C Antiparallel chains C +C C +C o o o o C +C /j\ / \ \ / \ / \ / C +C / \ / \ \ / \ / \ / C +C j1| o |l | o | o| o | | o |o C +C \ |/k\| |/ \| / |/ \| |/ \| C +C \i/ \ / \ / / \ / \ C +C o k1 o C +C (I) (II) (III) (IV) C +C C +C eello5_1 eello5_2 eello5_3 eello5_4 C +C C +C o denotes a local interaction, vertical lines an electrostatic interaction. C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then +cd eello5=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + itk=itype2loc(itype(k)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) + eello5_1=0.0d0 + eello5_2=0.0d0 + eello5_3=0.0d0 + eello5_4=0.0d0 +cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, +cd & eel5_3_num,eel5_4_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd write (iout,*)'Contacts have occurred for peptide groups', +cd & i,j,' fcont:',eij,' eij',' and ',k,l +cd goto 1111 +C Contribution from the graph I. +cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) +cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) +C Explicit gradient in virtual-dihedral angles. + if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + if (l.eq.j+1) then + if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + else + if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) + enddo + enddo + enddo +c goto 1112 +c1111 continue +C Contribution from graph II + call transpose2(EE(1,1,k),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,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) + call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + if (l.eq.j+1) then + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k)) + & -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,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k))) + endif +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k)) + & -0.5d0*scalar2(vv(1),Ctobr(1,k)) + enddo + enddo + enddo +cd goto 1112 +cd1111 continue + if (l.eq.j+1) then +cd goto 1110 +C Parallel orientation +C Contribution from graph III + call transpose2(EUg(1,1,l),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) + call transpose2(EUgder(1,1,l),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) + enddo + enddo + enddo +cd goto 1112 +C Contribution from graph IV +cd1110 continue + call transpose2(EE(1,1,l),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,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,iii)=derx(lll,kkk,iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l)) + & -0.5d0*scalar2(vv(1),Ctobr(1,l)) + enddo + enddo + enddo + else +C Antiparallel orientation +C Contribution from graph III +c goto 1110 + call transpose2(EUg(1,1,j),auxmat(1,1)) + call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(l-1)=g_corr5_loc(l-1) + & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) + call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) + call transpose2(EUgder(1,1,j),auxmat1(1,1)) + call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) + & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) + enddo + enddo + enddo +cd goto 1112 +C Contribution from graph IV +1110 continue + call transpose2(EE(1,1,j),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,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) +C Explicit gradient in virtual-dihedral angles. + g_corr5_loc(j-1)=g_corr5_loc(j-1) + & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) + call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + g_corr5_loc(k-1)=g_corr5_loc(k-1) + & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j))) +C Cartesian gradient + do iii=1,2 + do kkk=1,5 + do lll=1,3 + call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) + & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j)) + & -0.5d0*scalar2(vv(1),Ctobr(1,j)) + enddo + enddo + enddo + endif +1112 continue + eel5=eello5_1+eello5_2+eello5_3+eello5_4 +cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then +cd write (2,*) 'ijkl',i,j,k,l +cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, +cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 +cd endif +cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num +cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num +cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num +cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 +cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont +C 2/11/08 AL Gradients over DC's connecting interacting sites will be +C summed up outside the subrouine as for the other subroutines +C handling long-range interactions. The old code is commented out +C with "cgrad" to keep track of changes. + do ll=1,3 +cgrad ggg1(ll)=eel5*g_contij(ll,1) +cgrad ggg2(ll)=eel5*g_contij(ll,2) + gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) +c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') +c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), +c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), +c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont +c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') +c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), +c & gradcorr5ij, +c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl +cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) + gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) + gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) + gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) + gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij + gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij +cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2) + gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) + gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2) + gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) + gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl + gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +c1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr5_loc(iii) +cd enddo + eello5=ekont*eel5 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello5',ekont*eel5 + return + end +c-------------------------------------------------------------------------- + double precision function eello6(i,j,k,l,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision ggg1(3),ggg2(3) +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l + eello6_1=0.0d0 + eello6_2=0.0d0 + eello6_3=0.0d0 + eello6_4=0.0d0 + eello6_5=0.0d0 + eello6_6=0.0d0 +cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, +cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=facont_hb(jj,i) +cd ekl=facont_hb(kk,k) +cd ekont=eij*ekl +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + if (l.eq.j+1) then + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(j,i,l,k,2,.false.) + eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) + eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) + else + eello6_1=eello6_graph1(i,j,k,l,1,.false.) + eello6_2=eello6_graph1(l,k,j,i,2,.true.) + eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) + eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) + if (wturn6.eq.0.0d0 .or. j.ne.i+4) then + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) + else + eello6_5=0.0d0 + endif + eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) + endif +C If turn contributions are considered, they will be handled separately. + eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 +cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num +cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num +cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num +cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num +cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num +cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel6*g_contij(ll,1) +cgrad ggg2(ll)=eel6*g_contij(ll,2) +cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) + gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) + gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) + gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) + gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) + gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) + gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij + gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij +cgrad ghalf=0.5d0*ggg2(ll) +cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) +cd ghalf=0.0d0 + gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) + gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) + gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) + gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) + gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl + gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + eello6=ekont*eel6 +cd write (2,*) 'ekont',ekont +cd write (iout,*) 'eello6',ekont*eel6 + return + end +c-------------------------------------------------------------------------- + double precision function eello6_graph1(i,j,k,l,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) + logical swap + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ /j\ C +C / \ / \ C +C /| o | | o |\ C +C \ j|/k\| / \ |/k\|l / C +C \ / \ / \ / \ / C +C o o o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + itk=itype2loc(itype(k)) + s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) + s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) + s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) + call transpose2(EUgC(1,1,k),auxmat(1,1)) + call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) + vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k) + vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k) + s5=scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 + eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) + if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) + & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) + & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) + & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) + & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) + & +scalar2(vv(1),Dtobr2der(1,i))) + call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) + vv1(1)=pizda1(1,1)-pizda1(2,2) + vv1(2)=pizda1(1,2)+pizda1(2,1) + vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k) + vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k) + 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,k) + & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k) + vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k) + & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k) + s5=scalar2(vv(1),Dtobr2(1,i)) + derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph2(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + logical swap + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxvec2(2),auxmat1(2,2) + logical lprn + common /kutas/ lprn +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C \ /l\ /j\ / C +C \ / \ / \ / C +C o| o | | o |o C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l +C AL 7/4/01 s1 would occur in the sixth-order moment, +C but not in a cluster cumulant +#ifdef MOMENT + s1=dip(1,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph2=-(s1+s2+s3+s4) +#else + eello6_graph2=-(s2+s3+s4) +#endif +c eello6_graph2=-s3 +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + s1=dipderg(1,jj,i)*dip(1,kk,k) +#endif + s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(1,kk,k) +#endif + call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif +c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 +C Derivatives in gamma(j-1) or gamma(l-1) + if (j.gt.1) then +#ifdef MOMENT + s1=dipderg(3,jj,i)*dip(1,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) + call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + endif +#endif + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) +c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 + endif +C Derivatives in gamma(l-1) or gamma(j-1) + if (l.gt.1) then +#ifdef MOMENT + s1=dip(1,jj,i)*dipderg(3,kk,k) +#endif + call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) + call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) + call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +#ifdef MOMENT + if (swap) then + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 + else + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 + endif +#endif + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) +c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 + endif +C Cartesian derivatives. + if (lprn) then + write (2,*) 'In eello6_graph2' + do iii=1,2 + write (2,*) 'iii=',iii + do kkk=1,5 + write (2,*) 'kkk=',kkk + do jjj=1,2 + write (2,'(3(2f10.5),5x)') + & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) + enddo + enddo + enddo + endif + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) + else + s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) + endif +#endif + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), + & auxvec(1)) + s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), + & auxvec(1)) + s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(1,2)+pizda(2,1) + s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph3(i,j,k,l,jj,kk,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C j|/k\| / |/k\|l / C +C / \ / / \ / C +C / o / o C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. + iti=itortyp(itype(i)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + itk=itype2loc(itype(k)) + itk1=itype2loc(itype(k+1)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +#ifdef MOMENT + s1=dip(4,jj,i)*dip(4,kk,k) +#endif + call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,k),auxvec(1)) + call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) + call transpose2(EE(1,1,k),auxmat(1,1)) + call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, +cd & "sum",-(s2+s3+s4) +#ifdef MOMENT + eello6_graph3=-(s1+s2+s3+s4) +#else + eello6_graph3=-(s2+s3+s4) +#endif +c eello6_graph3=-s4 +C Derivatives in gamma(k-1) + call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1)) + s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) + s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) +C Derivatives in gamma(l-1) + call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1)) + s2=0.5d0*scalar2(b1(1,k),auxvec(1)) + call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) + else + s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1), + & auxvec(1)) + s2=0.5d0*scalar2(b1(1,k),auxvec(1)) + call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1), + & auxvec(1)) + s3=0.5d0*scalar2(b1(1,j+1),auxvec(1)) + call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), + & pizda(1,1)) + vv(1)=pizda(1,1)+pizda(2,2) + vv(2)=pizda(2,1)-pizda(1,2) + s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (swap) then + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif +c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), + & auxvec1(2),auxmat1(2,2) + logical swap +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Parallel Antiparallel C +C C +C o o C +C /l\ / \ /j\ C +C / \ / \ / \ C +C /| o |o o| o |\ C +C \ j|/k\| \ |/k\|l C +C \ / \ \ / \ C +C o \ o \ C +C i i C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C 4/7/01 AL Component s1 was removed, because it pertains to the respective +C energy moment and not to the cluster cumulant. +cd write (2,*) 'eello_graph4: wturn6',wturn6 + iti=itype2loc(itype(i)) + itj=itype2loc(itype(j)) + if (j.lt.nres-1) then + itj1=itype2loc(itype(j+1)) + else + itj1=nloctyp + endif + itk=itype2loc(itype(k)) + if (k.lt.nres-1) then + itk1=itype2loc(itype(k+1)) + else + itk1=nloctyp + endif + itl=itype2loc(itype(l)) + if (l.lt.nres-1) then + itl1=itype2loc(itype(l+1)) + else + itl1=nloctyp + endif +cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l +cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, +cd & ' itl',itl,' itl1',itl1 +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dip(3,kk,k) + else + s1=dip(2,jj,j)*dip(2,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + call transpose2(EUg(1,1,k),auxmat(1,1)) + call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) +cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 +#ifdef MOMENT + eello6_graph4=-(s1+s2+s3+s4) +#else + eello6_graph4=-(s2+s3+s4) +#endif +C Derivatives in gamma(i-1) + if (i.gt.1) then +#ifdef MOMENT + if (imat.eq.1) then + s1=dipderg(2,jj,i)*dip(3,kk,k) + else + s1=dipderg(4,jj,j)*dip(2,kk,l) + endif +#endif + s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +cd write (2,*) 'turn6 derivatives' +#ifdef MOMENT + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) +#endif + endif + endif +C Derivatives in gamma(k-1) +#ifdef MOMENT + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderg(2,kk,k) + else + s1=dip(2,jj,j)*dipderg(4,kk,l) + endif +#endif + call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec1(1)) + else + call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec1(1)) + endif + call transpose2(EUgder(1,1,k),auxmat1(1,1)) + call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) +#else + gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) +#endif + else +#ifdef MOMENT + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) +#else + g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) +#endif + endif +C Derivatives in gamma(j-1) or gamma(l-1) + if (l.eq.j+1 .and. l.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) + else if (j.gt.1) then + call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then + gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) + else + g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) + endif + endif +C Cartesian derivatives. + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + if (iii.eq.1) then + if (imat.eq.1) then + s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) + else + s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) + endif + else + if (imat.eq.1) then + s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) + else + s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) + endif + endif +#endif + call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), + & auxvec(1)) + s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) + if (j.eq.l+1) then + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,j+1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,j),auxvec(1)) + else + call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), + & b1(1,l+1),auxvec(1)) + s3=-0.5d0*scalar2(b1(1,l),auxvec(1)) + endif + call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), + & pizda(1,1)) + vv(1)=pizda(1,1)-pizda(2,2) + vv(2)=pizda(2,1)+pizda(1,2) + s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) + if (swap) then + if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then +#ifdef MOMENT + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s1+s2+s4) +#else + derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) + & -(s2+s4) +#endif + derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 + else +#ifdef MOMENT + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) +#else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) +#endif + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + endif + else +#ifdef MOMENT + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) +#else + derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) +#endif + if (l.eq.j+1) then + derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 + else + derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 + endif + endif + enddo + enddo + enddo + return + end +c---------------------------------------------------------------------------- + double precision function eello_turn6(i,jj,kk) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' + include 'COMMON.TORSION' + include 'COMMON.VAR' + include 'COMMON.GEO' + double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), + & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), + & ggg1(3),ggg2(3) + double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), + & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) +C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to +C the respective energy moment and not to the cluster cumulant. + s1=0.0d0 + s8=0.0d0 + s13=0.0d0 +c + eello_turn6=0.0d0 + j=i+4 + k=i+1 + l=i+3 + iti=itype2loc(itype(i)) + itk=itype2loc(itype(k)) + itk1=itype2loc(itype(k+1)) + itl=itype2loc(itype(l)) + itj=itype2loc(itype(j)) +cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj +cd write (2,*) 'i',i,' k',k,' j',j,' l',l +cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then +cd eello6=0.0d0 +cd return +cd endif +cd write (iout,*) +cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, +cd & ' and',k,l +cd call checkint_turn6(i,jj,kk,eel_turn6_num) + do iii=1,2 + do kkk=1,5 + do lll=1,3 + derx_turn(lll,kkk,iii)=0.0d0 + enddo + enddo + enddo +cd eij=1.0d0 +cd ekl=1.0d0 +cd ekont=1.0d0 + eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) +cd eello6_5=0.0d0 +cd write (2,*) 'eello6_5',eello6_5 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmat(1,1)) + call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) + ss1=scalar2(Ub2(1,i+2),b1(1,l)) + s1 = (auxmat(1,1)+auxmat(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1)) + call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) + s2 = scalar2(b1(1,k),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,k+1),vtemp2(1)) + s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),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,k),vtemp4(1)) + s13 = (gtemp(1,1)+gtemp(2,2))*ss13 +#endif +c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 +c s1=0.0d0 +c s2=0.0d0 +c s8=0.0d0 +c s12=0.0d0 +c s13=0.0d0 + eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) +C Derivatives in gamma(i+2) + s1d =0.0d0 + s8d =0.0d0 +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 + call transpose2(AEAderg(1,1,2),atempd(1,1)) + call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) + s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 + gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) +C Derivatives in gamma(i+3) +#ifdef MOMENT + call transpose2(AEA(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + ss1d=scalar2(Ub2der(1,i+2),b1(1,l)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d +#endif + call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1)) + call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,k),vtemp1d(1)) +#ifdef MOMENT + call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1)) + s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1)) +#endif + s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+1)=gel_loc_turn6(i+1) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Derivatives in gamma(i+4) + call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +#ifdef MOMENT + call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) + s13d = (gtempd(1,1)+gtempd(2,2))*ss13 +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +C s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) +#else + gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) +#endif +C Derivatives in gamma(i+5) +#ifdef MOMENT + call transpose2(AEAderg(1,1,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1)) + call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) + s2d = scalar2(b1(1,k),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,l),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,k),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d +#endif +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) +#else + gel_loc_turn6(i+3)=gel_loc_turn6(i+3) + & -0.5d0*ekont*(s2d+s12d) +#endif +C Cartesian derivatives + do iii=1,2 + do kkk=1,5 + do lll=1,3 +#ifdef MOMENT + call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) + call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) + s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 +#endif + call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1)) + call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), + & vtemp1d(1)) + s2d = scalar2(b1(1,k),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,l),vtemp2(1)) +#endif + call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), + & auxmatd(1,1)) + call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) + s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) +c s1d=0.0d0 +c s2d=0.0d0 +c s8d=0.0d0 +c s12d=0.0d0 +c s13d=0.0d0 +#ifdef MOMENT + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*(s1d+s2d) +#else + derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) + & - 0.5d0*s2d +#endif +#ifdef MOMENT + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*(s8d+s12d) +#else + derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) + & - 0.5d0*s12d +#endif + enddo + enddo + enddo +#ifdef MOMENT + do kkk=1,5 + do lll=1,3 + call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), + & achuj_tempd(1,1)) + call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) + call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) + s13d=(gtempd(1,1)+gtempd(2,2))*ss13 + derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d + call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), + & vtemp4d(1)) + ss13d = scalar2(b1(1,k),vtemp4d(1)) + s13d = (gtemp(1,1)+gtemp(2,2))*ss13d + derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d + enddo + enddo +#endif +cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', +cd & 16*eel_turn6_num +cd goto 1112 + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + if (l.lt.nres-1) then + l1=l+1 + l2=l-1 + else + l1=l-1 + l2=l-2 + endif + do ll=1,3 +cgrad ggg1(ll)=eel_turn6*g_contij(ll,1) +cgrad ggg2(ll)=eel_turn6*g_contij(ll,2) +cgrad ghalf=0.5d0*ggg1(ll) +cd ghalf=0.0d0 + gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) + gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) + gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf + & +ekont*derx_turn(ll,2,1) + gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) + gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf + & +ekont*derx_turn(ll,4,1) + gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) + gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij + gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij +cgrad ghalf=0.5d0*ggg2(ll) +cd ghalf=0.0d0 + gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf + & +ekont*derx_turn(ll,2,2) + gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) + gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf + & +ekont*derx_turn(ll,4,2) + gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) + gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl + gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl + enddo +cd goto 1112 +cgrad do m=i+1,j-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) +cgrad enddo +cgrad enddo +cgrad do m=k+1,l-1 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) +cgrad enddo +cgrad enddo +cgrad1112 continue +cgrad do m=i+2,j2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) +cgrad enddo +cgrad enddo +cgrad do m=k+2,l2 +cgrad do ll=1,3 +cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) +cgrad enddo +cgrad enddo +cd do iii=1,nres-3 +cd write (2,*) iii,g_corr6_loc(iii) +cd enddo + eello_turn6=ekont*eel_turn6 +cd write (2,*) 'ekont',ekont +cd write (2,*) 'eel_turn6',ekont*eel_turn6 + return + end +C----------------------------------------------------------------------------- +#endif + double precision function scalar(u,v) +!DIR$ INLINEALWAYS scalar +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::scalar +#endif + implicit none + double precision u(3),v(3) +cd double precision sc +cd integer i +cd sc=0.0d0 +cd do i=1,3 +cd sc=sc+u(i)*v(i) +cd enddo +cd scalar=sc + + scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) + return + end +crc------------------------------------------------- + SUBROUTINE MATVEC2(A1,V1,V2) +!DIR$ INLINEALWAYS MATVEC2 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2 +#endif + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),V1(2),V2(2) +c DO 1 I=1,2 +c VI=0.0 +c DO 3 K=1,2 +c 3 VI=VI+A1(I,K)*V1(K) +c Vaux(I)=VI +c 1 CONTINUE + + vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) + vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) + + v2(1)=vaux1 + v2(2)=vaux2 + END +C--------------------------------------- + SUBROUTINE MATMAT2(A1,A2,A3) +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2 +#endif + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + DIMENSION A1(2,2),A2(2,2),A3(2,2) +c DIMENSION AI3(2,2) +c DO J=1,2 +c A3IJ=0.0 +c DO K=1,2 +c A3IJ=A3IJ+A1(I,K)*A2(K,J) +c enddo +c A3(I,J)=A3IJ +c enddo +c enddo + + ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) + ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) + ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) + ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) + + A3(1,1)=AI3_11 + A3(2,1)=AI3_21 + A3(1,2)=AI3_12 + A3(2,2)=AI3_22 + END + +c------------------------------------------------------------------------- + double precision function scalar2(u,v) +!DIR$ INLINEALWAYS scalar2 + implicit none + double precision u(2),v(2) + double precision sc + integer i + scalar2=u(1)*v(1)+u(2)*v(2) + return + end + +C----------------------------------------------------------------------------- + + subroutine transpose2(a,at) +!DIR$ INLINEALWAYS transpose2 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::transpose2 +#endif + implicit none + double precision a(2,2),at(2,2) + at(1,1)=a(1,1) + at(1,2)=a(2,1) + at(2,1)=a(1,2) + at(2,2)=a(2,2) + return + end +c-------------------------------------------------------------------------- + subroutine transpose(n,a,at) + implicit none + integer n,i,j + double precision a(n,n),at(n,n) + do i=1,n + do j=1,n + at(j,i)=a(i,j) + enddo + enddo + return + end +C--------------------------------------------------------------------------- + subroutine prodmat3(a1,a2,kk,transp,prod) +!DIR$ INLINEALWAYS prodmat3 +#ifndef OSF +cDEC$ ATTRIBUTES FORCEINLINE::prodmat3 +#endif + implicit none + integer i,j + double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) + logical transp +crc double precision auxmat(2,2),prod_(2,2) + + if (transp) then +crc call transpose2(kk(1,1),auxmat(1,1)) +crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) + & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) + & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) + + else +crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) +crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) + + prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) + prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) + & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) + prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) + prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) + & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) + + endif +c call transpose2(a2(1,1),a2t(1,1)) + +crc print *,transp +crc print *,((prod_(i,j),i=1,2),j=1,2) +crc print *,((prod(i,j),i=1,2),j=1,2) + + return + end +CCC---------------------------------------------- + subroutine Eliptransfer(eliptran) + 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.SPLITELE' + include 'COMMON.SBRIDGE' +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 + eliptran=0.0 + do i=ilip_start,ilip_end +C do i=1,1 + if (itype(i).eq.ntyp1) 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 + enddo +C print *, "nic nie bylo w lipidzie?" +C now multiply all by the peptide group transfer factor +C eliptran=eliptran*pepliptran +C now the same for side chains +CV do i=1,1 + do i=ilip_start,ilip_end + if (itype(i).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)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +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)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +C print *, "doing sscalefor top part",sslip,fracinbuf + else + eliptran=eliptran+liptranene(itype(i)) +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 + enddo + return + end +C--------------------------------------------------------- +C AFM soubroutine for constant force + subroutine AFMforce(Eafmforce) + 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.SPLITELE' + include 'COMMON.SBRIDGE' + real*8 diffafm(3) + dist=0.0d0 + Eafmforce=0.0d0 + do i=1,3 + diffafm(i)=c(i,afmend)-c(i,afmbeg) + dist=dist+diffafm(i)**2 + enddo + dist=dsqrt(dist) + Eafmforce=-forceAFMconst*(dist-distafminit) + do i=1,3 + gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist + gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist + enddo +C print *,'AFM',Eafmforce + return + end +C--------------------------------------------------------- +C AFM subroutine with pseudoconstant velocity + subroutine AFMvel(Eafmforce) + 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.SPLITELE' + include 'COMMON.SBRIDGE' + real*8 diffafm(3) +C Only for check grad COMMENT if not used for checkgrad +C totT=3.0d0 +C-------------------------------------------------------- +C print *,"wchodze" + dist=0.0d0 + Eafmforce=0.0d0 + do i=1,3 + diffafm(i)=c(i,afmend)-c(i,afmbeg) + dist=dist+diffafm(i)**2 + enddo + dist=dsqrt(dist) + Eafmforce=0.5d0*forceAFMconst + & *(distafminit+totTafm*velAFMconst-dist)**2 +C Eafmforce=-forceAFMconst*(dist-distafminit) + do i=1,3 + gradafm(i,afmend-1)=-forceAFMconst* + &(distafminit+totTafm*velAFMconst-dist) + &*diffafm(i)/dist + gradafm(i,afmbeg-1)=forceAFMconst* + &(distafminit+totTafm*velAFMconst-dist) + &*diffafm(i)/dist + enddo +C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist + return + end +C----------------------------------------------------------- +C first for shielding is setting of function of side-chains + subroutine set_shield_fac + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +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).eq.ntyp1).or.(itype(k).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=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(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 +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +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.0*sh_frac_dist-3.0d0) + fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2) + & /dist_pep_side/buff_shield*0.5 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + do j=1,3 + sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) +C print *,"jestem",scale_fac_dist,fac_help_scale, +C & sh_frac_dist_grad(j) + enddo + endif +C if ((i.eq.3).and.(k.eq.2)) then +C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist +C & ,"TU" +C endif + +C this is what is now we have the distance scaling now volume... + short=short_r_sidechain(itype(k)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2) +C now costhet_grad +C costhet=0.0d0 + costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4 +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.0 + 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.0-cosalfa**2 + fac_alfa_sin=dsqrt(fac_alfa_sin) + rkprim=fac_alfa_sin*(long-short)+short +C now costhet_grad + cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2) + cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4 + + do j=1,3 + cosphi_grad_long(j)=cosphi_fac*pep_side(j) + &+cosphi**3*0.5/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)) + + cosphi_grad_loc(j)=cosphi**3*0.5/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) + enddo + + VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi) + & /VSolvSphere_div + & *wshield +C now the gradient... +C grad_shield is gradient of Calfa for peptide groups +C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist, +C & costhet,cosphi +C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group, +C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k) + do j=1,3 + grad_shield(j,i)=grad_shield(j,i) +C gradient po skalowaniu + & +(sh_frac_dist_grad(j) +C gradient po costhet + &-scale_fac_dist*costhet_grad(j)/(1.0-costhet) + &-scale_fac_dist*(cosphi_grad_long(j)) + &/(1.0-cosphi) )*div77_81 + &*VofOverlap +C grad_shield_side is Cbeta sidechain gradient + grad_shield_side(j,ishield_list(i),i)= + & (sh_frac_dist_grad(j)*(-2.0d0) + & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet) + & +scale_fac_dist*(cosphi_grad_long(j)) + & *2.0d0/(1.0-cosphi)) + & *div77_81*VofOverlap + + grad_shield_loc(j,ishield_list(i),i)= + & scale_fac_dist*cosphi_grad_loc(j) + & *2.0d0/(1.0-cosphi) + & *div77_81*VofOverlap + enddo + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*div77_81+div4_81 +c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) + enddo + return + end +C-------------------------------------------------------------------------- + double precision function tschebyshev(m,n,x,y) + implicit none + include "DIMENSIONS" + 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 +C-------------------------------------------------------------------------- + double precision function gradtschebyshev(m,n,x,y) + implicit none + include "DIMENSIONS" + 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 +C------------------------------------------------------------------------ +C first for shielding is setting of function of side-chains + subroutine set_shield_fac2 + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +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).eq.ntyp1).or.(itype(k).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=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(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 +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +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 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + 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)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2) + sinthet=short/dist_pep_side*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 +c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div", +c & VSolvSphere_div," sinphi",sinphi," sinthet",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 + + 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 + enddo +c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist", +c & scale_fac_dist + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield) +c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i), +c & " wshield",wshield +c write(2,*) "TU",rpp(1,1),short,long,buff_shield + enddo + return + end +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) + 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.SPLITELE' + include 'COMMON.SBRIDGE' + double precision tub_r,vectube(3),enetube(maxres*2) + Etube=0.0d0 + do i=1,2*nres + enetube(i)=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=1,nres +C lets ommit dummy atoms for now + if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle +C now calculate distance from center of tube and direction vectors + vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize) + if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize + vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize) + if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize + 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) + do i=1,nres +C Lets not jump over memory as we use many times iti + iti=itype(i) +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 + 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),boxxsize) + if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize + + 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 +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 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=1,2*nres + Etube=Etube+enetube(i) + enddo +C print *,"ETUBE", etube + return + end +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----------------------------------------------------------------------- +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) + 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.SPLITELE' + include 'COMMON.SBRIDGE' + double precision tub_r,vectube(3),enetube(maxres*2) + Etube=0.0d0 + do i=1,2*nres + enetube(i)=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=1,nres +C lets ommit dummy atoms for now + if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle +C now calculate distance from center of tube and direction vectors + vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize) + if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize + vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize) + if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize + 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) + do i=1,nres +C Lets not jump over memory as we use many times iti + iti=itype(i) +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),boxxsize) + if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize + + 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) + 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 + print *,ssgradtube, sstube,tubetranene(itype(i)) + enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i)) + gg_tube_SC(3,i)=gg_tube_SC(3,i) + &+ssgradtube*tubetranene(itype(i)) + gg_tube(3,i-1)= gg_tube(3,i-1) + &+ssgradtube*tubetranene(itype(i)) +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)) +C gg_tube_SC(3,i)=gg_tube_SC(3,i) +C &+ssgradtube*tubetranene(itype(i)) +C gg_tube(3,i-1)= gg_tube(3,i-1) +C &+ssgradtube*tubetranene(itype(i)) +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)) +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=1,2*nres + Etube=Etube+enetube(i) + enddo +C print *,"ETUBE", etube + return + end +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---------------------------------------------------------------------------- + subroutine e_saxs(Esaxs_constr) + implicit none + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + include "COMMON.SETUP" + integer IERR +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' +c include 'COMMON.MD' +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif + include 'COMMON.CONTROL' + include 'COMMON.SAXS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + include 'COMMON.FFIELD' +c + double precision Esaxs_constr + integer i,iint,j,k,l + double precision PgradC(maxSAXS,3,maxres), + & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS) +#ifdef MPI + double precision PgradC_(maxSAXS,3,maxres), + & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS) +#endif + double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC, + & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC, + & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1, + & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig + double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2 + double precision dist,mygauss,mygaussder + external dist + integer llicz,lllicz + double precision time01 +c SAXS restraint penalty function +#ifdef DEBUG + write(iout,*) "------- SAXS penalty function start -------" + write (iout,*) "nsaxs",nsaxs + write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e + write (iout,*) "Psaxs" + do i=1,nsaxs + write (iout,'(i5,e15.5)') i, Psaxs(i) + enddo +#endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + Esaxs_constr = 0.0d0 + do k=1,nsaxs + Pcalc(k)=0.0d0 + do j=1,nres + do l=1,3 + PgradC(k,l,j)=0.0d0 + PgradX(k,l,j)=0.0d0 + enddo + enddo + enddo +c lllicz=0 + do i=iatsc_s,iatsc_e + if (itype(i).eq.ntyp1) cycle + do iint=1,nint_gr(i) + do j=istart(i,iint),iend(i,iint) + if (itype(j).eq.ntyp1) cycle +#ifdef ALLSAXS + dijCACA=dist(i,j) + dijCASC=dist(i,j+nres) + dijSCCA=dist(i+nres,j) + dijSCSC=dist(i+nres,j+nres) + sigma2CACA=2.0d0/(pstok**2) + sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2) + sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2) + sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2) + do k=1,nsaxs + dk = distsaxs(k) + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2) + if (itype(j).ne.10) then + expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2) + else + endif + expCASC = 0.0d0 + if (itype(i).ne.10) then + expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2) + else + expSCCA = 0.0d0 + endif + if (itype(i).ne.10 .and. itype(j).ne.10) then + expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2) + else + expSCSC = 0.0d0 + endif + Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC +#ifdef DEBUG + write(iout,*) "i j k Pcalc",i,j,Pcalc(k) +#endif + CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA + CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC + SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA + SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC + do l=1,3 +c CA CA + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux +c CA SC + if (itype(j).ne.10) then + aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + PgradX(k,l,j) = PgradX(k,l,j)+aux + endif +c SC CA + if (itype(i).ne.10) then + aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA + PgradX(k,l,i) = PgradX(k,l,i)-aux + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + endif +c SC SC + if (itype(i).ne.10 .and. itype(j).ne.10) then + aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + PgradX(k,l,i) = PgradX(k,l,i)-aux + PgradX(k,l,j) = PgradX(k,l,j)+aux + endif + enddo ! l + enddo ! k +#else + dijCACA=dist(i,j) + sigma2CACA=scal_rad**2*0.25d0/ + & (restok(itype(j))**2+restok(itype(i))**2) +c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j)) +c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA) +#ifdef MYGAUSS + sigmaCACA=dsqrt(sigma2CACA) + threesig=3.0d0/sigmaCACA +c llicz=0 + do k=1,nsaxs + dk = distsaxs(k) + if (dabs(dijCACA-dk).ge.threesig) cycle +c llicz=llicz+1 +c lllicz=lllicz+1 + aux = sigmaCACA*(dijCACA-dk) + expCACA = mygauss(aux) +c if (expcaca.eq.0.0d0) cycle + Pcalc(k) = Pcalc(k)+expCACA + CACAgrad = -sigmaCACA*mygaussder(aux) +c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad + do l=1,3 + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + enddo ! l + enddo ! k +c write (iout,*) "i",i," j",j," llicz",llicz +#else + IF (saxs_cutoff.eq.0) THEN + do k=1,nsaxs + dk = distsaxs(k) + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2) + Pcalc(k) = Pcalc(k)+expCACA + CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA + do l=1,3 + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)-aux + PgradC(k,l,j) = PgradC(k,l,j)+aux + enddo ! l + enddo ! k + ELSE + rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA) + do k=1,nsaxs + dk = distsaxs(k) +c write (2,*) "ijk",i,j,k + sss2 = sscale2(dijCACA,rrr,dk,0.3d0) + if (sss2.eq.0.0d0) cycle + ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0) + if (energy_dec) write(iout,'(a4,3i5,8f10.4)') + & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)), + & 1.0d0/dsqrt(sigma2CACA),rrr,dk, + & sss2,ssgrad2 + expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2 + Pcalc(k) = Pcalc(k)+expCACA +#ifdef DEBUG + write(iout,*) "i j k Pcalc",i,j,Pcalc(k) +#endif + CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+ + & ssgrad2*expCACA/sss2 + do l=1,3 +c CA CA + aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA + PgradC(k,l,i) = PgradC(k,l,i)+aux + PgradC(k,l,j) = PgradC(k,l,j)-aux + enddo ! l + enddo ! k + ENDIF +#endif +#endif + enddo ! j + enddo ! iint + enddo ! i +c#ifdef TIMING +c time_SAXS=time_SAXS+MPI_Wtime()-time01 +c#endif +c write (iout,*) "lllicz",lllicz +c#ifdef TIMING +c time01=MPI_Wtime() +c#endif +#ifdef MPI + if (nfgtasks.gt.1) then + call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION, + & MPI_SUM,FG_COMM,IERR) +c if (fg_rank.eq.king) then + do k=1,nsaxs + Pcalc(k) = Pcalc_(k) + enddo +c endif +c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres, +c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) +c if (fg_rank.eq.king) then +c do i=1,nres +c do l=1,3 +c do k=1,nsaxs +c PgradC(k,l,i) = PgradC_(k,l,i) +c enddo +c enddo +c enddo +c endif +#ifdef ALLSAXS +c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres, +c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) +c if (fg_rank.eq.king) then +c do i=1,nres +c do l=1,3 +c do k=1,nsaxs +c PgradX(k,l,i) = PgradX_(k,l,i) +c enddo +c enddo +c enddo +c endif +#endif + endif +#endif + Cnorm = 0.0d0 + do k=1,nsaxs + Cnorm = Cnorm + Pcalc(k) + enddo +#ifdef MPI + if (fg_rank.eq.king) then +#endif + Esaxs_constr = dlog(Cnorm)-wsaxs0 + do k=1,nsaxs + if (Pcalc(k).gt.0.0d0) + & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k)) +#ifdef DEBUG + write (iout,*) "k",k," Esaxs_constr",Esaxs_constr +#endif + enddo +#ifdef DEBUG + write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr +#endif +#ifdef MPI + endif +#endif + gsaxsC=0.0d0 + gsaxsX=0.0d0 + do i=nnt,nct + do l=1,3 + auxC=0.0d0 + auxC1=0.0d0 + auxX=0.0d0 + auxX1=0.d0 + do k=1,nsaxs + if (Pcalc(k).gt.0) + & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k) + auxC1 = auxC1+PgradC(k,l,i) +#ifdef ALLSAXS + auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k) + auxX1 = auxX1+PgradX(k,l,i) +#endif + enddo + gsaxsC(l,i) = auxC - auxC1/Cnorm +#ifdef ALLSAXS + gsaxsX(l,i) = auxX - auxX1/Cnorm +#endif +c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm), +c * " gradX",wsaxs*(auxX - auxX1/Cnorm) +c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i), +c * " gradX",wsaxs*gsaxsX(l,i) + enddo + enddo +#ifdef TIMING + time_SAXS=time_SAXS+MPI_Wtime()-time01 +#endif +#ifdef DEBUG + write (iout,*) "gsaxsc" + do i=nnt,nct + write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3) + enddo +#endif +#ifdef MPI +c endif +#endif + return + end +c---------------------------------------------------------------------------- + subroutine e_saxsC(Esaxs_constr) + implicit none + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" + include "COMMON.SETUP" + integer IERR +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' +c include 'COMMON.MD' +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif + include 'COMMON.CONTROL' + include 'COMMON.SAXS' + include 'COMMON.NAMES' + include 'COMMON.TIME1' + include 'COMMON.FFIELD' +c + double precision Esaxs_constr + integer i,iint,j,k,l + double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot +#ifdef MPI + double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_ +#endif + double precision dk,dijCASPH,dijSCSPH, + & sigma2CA,sigma2SC,expCASPH,expSCSPH, + & CASPHgrad,SCSPHgrad,aux,auxC,auxC1, + & auxX,auxX1,Cnorm +c SAXS restraint penalty function +#ifdef DEBUG + write(iout,*) "------- SAXS penalty function start -------" + write (iout,*) "nsaxs",nsaxs + + do i=nnt,nct + print *,MyRank,"C",i,(C(j,i),j=1,3) + enddo + do i=nnt,nct + print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3) + enddo +#endif + Esaxs_constr = 0.0d0 + logPtot=0.0d0 + do j=isaxs_start,isaxs_end + Pcalc=0.0d0 + do i=1,nres + do l=1,3 + PgradC(l,i)=0.0d0 + PgradX(l,i)=0.0d0 + enddo + enddo + do i=nnt,nct + if (itype(i).eq.ntyp1) cycle + dijCASPH=0.0d0 + dijSCSPH=0.0d0 + do l=1,3 + dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2 + enddo + if (itype(i).ne.10) then + do l=1,3 + dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2 + enddo + endif + sigma2CA=2.0d0/pstok**2 + sigma2SC=4.0d0/restok(itype(i))**2 + expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH) + expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH) + Pcalc = Pcalc+expCASPH+expSCSPH +#ifdef DEBUG + write(*,*) "processor i j Pcalc", + & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc +#endif + CASPHgrad = sigma2CA*expCASPH + SCSPHgrad = sigma2SC*expSCSPH + do l=1,3 + aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad + PgradX(l,i) = PgradX(l,i) + aux + PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux + enddo ! l + enddo ! i + do i=nnt,nct + do l=1,3 + gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc + gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc + enddo + enddo + logPtot = logPtot - dlog(Pcalc) +c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc), +c & " logPtot",logPtot + enddo ! j +#ifdef MPI + if (nfgtasks.gt.1) then +c write (iout,*) "logPtot before reduction",logPtot + call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION, + & MPI_SUM,king,FG_COMM,IERR) + logPtot = logPtot_ +c write (iout,*) "logPtot after reduction",logPtot + call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + gsaxsC(l,i) = gsaxsC_(l,i) + enddo + enddo + endif + call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres, + & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) + if (fg_rank.eq.king) then + do i=1,nres + do l=1,3 + gsaxsX(l,i) = gsaxsX_(l,i) + enddo + enddo + endif + endif +#endif + Esaxs_constr = logPtot + return + end +c---------------------------------------------------------------------------- + double precision function sscale2(r,r_cut,r0,rlamb) + implicit none + double precision r,gamm,r_cut,r0,rlamb,rr + rr = dabs(r-r0) +c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb +c write (2,*) "rr",rr + if(rr.lt.r_cut-rlamb) then + sscale2=1.0d0 + else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then + gamm=(rr-(r_cut-rlamb))/rlamb + sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0) + else + sscale2=0d0 + endif + return + end +C----------------------------------------------------------------------- + double precision function sscalgrad2(r,r_cut,r0,rlamb) + implicit none + double precision r,gamm,r_cut,r0,rlamb,rr + rr = dabs(r-r0) + if(rr.lt.r_cut-rlamb) then + sscalgrad2=0.0d0 + else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then + gamm=(rr-(r_cut-rlamb))/rlamb + if (r.ge.r0) then + sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb + else + sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb + endif + else + sscalgrad2=0.0d0 + endif + return + end diff --git a/source/unres/src-HCD-5D/energy_p_new_barrier.optrpt b/source/unres/src-HCD-5D/energy_p_new_barrier.optrpt new file mode 100644 index 0000000..e69de29 diff --git a/source/unres/src-HCD-5D/fdiag.f b/source/unres/src-HCD-5D/fdiag.f new file mode 100644 index 0000000..dfcdd1d --- /dev/null +++ b/source/unres/src-HCD-5D/fdiag.f @@ -0,0 +1,316 @@ +C[BA*) +C[LE*) +C[LE*) +C[LE*) +C[FE{F 4.12.1}{Systems with Five-Diagonal Matrices} +C[ {Systems with Five-Diagonal Matrices}*) +C[LE*) + SUBROUTINE FDIAG (N,DL2,DL1,DM,DU1,DU2,RS,X,MARK) +C[IX{FDIAG}*) +C +C***************************************************************** +C * +C Solving a system of linear equations * +C A * X = RS * +C with a five-diagonal, strongly nonsingular matrix A via * +C Gauss algorithm without pivoting. * +C[BE*) +C The matrix A is given as five N-vectors DL2, DL1, DM, DU1 * +C and DU2. The linear system has the form: * +C * +C DM(1)*X(1)+DU1(1)*X(2)+DU2(1)*X(3) = RS(1) * +C DL1(2)*X(1)+DM(2)*X(2)+DU1(2)*X(3)+DU2(2)*X(4) = RS(2) * +C * +C DL2(I)*X(I-2)+DL1(I)*X(I-1)+ * +C +DM(I)*X(I)+DU1(I)*X(I+1)+DU2(I)*X(I+2) = RS(I) * +C for I = 3, ..., N - 2, and * +C * +C DL2(N-1)*X(N-3)+DL1(N-1)*X(N-2)+ * +C +DM(N-1)*X(N-1)+DU1(N-1)+X(N) = RS(N-1) * +C DL2(N)*X(N-2)+DL1(N)*X(N-1)+DM(N)*X(N) = RS(N) * +C * +C * +C * +C INPUT PARAMETERS: * +C ================= * +C N : number of equations; N > 3 * +C DL2 : N-vector DL2(1:N); second lower co-diagonal * +C DL2(3), DL2(4), ... , DL2(N) * +C DL1 : N-vector DL1(1:N); lower co-diagonal * +C DL1(2), DL1(3), ... , DL1(N) * +C DM : N-vector DM(1:N); main diagonal * +C DM(1), DM(2), ... , DM(N) * +C DU1 : N-vector DU1(1:N); upper co-diagonal * +C DU1(1), DU1(2), ... , DU1(N-1) * +C DU2 : N-vector DU2(1:N); second upper co-diagonal * +C DU2(1), DU2(2), ... , DU2(N-2) * +C RS : N-vector RS(1:N); the right hand side of the * +C linear system * +C * +C * +C OUTPUT PARAMETERS: * +C ================== * +C DL2 :) overwritten with auxiliary vectors defining the * +C DL1 :) factorization of the cyclically tridiagonal * +C DM :) matrix A * +C DU1 :) * +C DU2 :) * +C X : N-vector X(1:N); containing the solution of the * +C the system of equations * +C MARK : error parameter * +C MARK=-1 : condition N > 3 is not satisfied * +C MARK= 0 : numerically the matrix A is not strongly * +C nonsingular * +C MARK= 1 : everything is o.k. * +C * +C NOTE: if MARK = 1, the determinant of A is given by: * +C DET A = DM(1) * DM(2) * ... * DM(N) * +C * +C----------------------------------------------------------------* +C * +C subroutines required: FDIAGP, FDIAGS, MACHPD * +C * +C***************************************************************** +C * +C author : Gisela Engeln-Muellges * +C date : 05.06.1988 * +C source : FORTRAN 77 * +C * +C[BA*) +C***************************************************************** +C[BE*) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DOUBLE PRECISION DL1(1:N),DL2(1:N),DM(1:N) + DOUBLE PRECISION DU1(1:N),DU2(1:N),RS(1:N),X(1:N) + MARK = -1 + IF (N .LT. 4) RETURN +C +C Factor the matrix A +C + CALL FDIAGP(N,DL2,DL1,DM,DU1,DU2,MARK) +C +C if MARK = 1, update and bachsubstitute +C + IF (MARK .EQ. 1) THEN + CALL FDIAGS(N,DL2,DL1,DM,DU1,DU2,RS,X) + END IF + RETURN + END +C +C +C[BA*) +C[LE*) + SUBROUTINE FDIAGP (N,DL2,DL1,DM,DU1,DU2,MARK) +C[IX{FDIAGP}*) +C +C***************************************************************** +C * +C Factor a five-diagonal, strongly nonsingular matrix A * +C that is defined by the five N-vectors DL2, DL1, DM, DU1 * +C and DU2, into its triangular factors L * R by applying * +C Gaussian elimination specialized for five-diagonal matrices* +C (without pivoting). * +C[BE*) +C * +C * +C INPUT PARAMETERS: * +C ================= * +C N : number of equations; N > 3 * +C DL2 : N-vector DL2(1:N); second lower co-diagonal * +C DL2(3), DL2(4), ... , DL2(N) * +C DL1 : N-vector DL1(1:N); lower co-diagonal * +C DL1(2), DL1(3), ... , DL1(N) * +C DM : N-vector DM(1:N); main diagonal * +C DM(1), DM(2), ... , DM(N) * +C DU1 : N-vector DU1(1:N); upper co-diagonal * +C DU1(1), DU1(2), ... , DU1(N-1) * +C DU2 : N-vector DU2(1:N); second upper co-diagonal * +C DU2(1), DU2(2), ... , DU2(N-2) * +C * +C * +C OUTPUT PARAMETERS: * +C ================== * +C DL2 :) overwritten with auxiliary vectors that define * +C DL1 :) the factors of the five-diagonal matrix A; * +C DM :) the three co-diagonals of the lower triangular * +C DU1 :) matrix L are stored in the vectors DL2, DL1 and * +C DU2 :) DM. The two co-diagonals of the unit upper * +C triangular matrix R are stored in the vectors DU1 * +C and DU2, its diagonal elements each have the * +C value 1. * +C MARK : error parameter * +C MARK=-1 : condition N > 3 is violated * +C MARK= 0 : numerically the matrix is not strongly * +C nonsingular * +C MARK= 1 : everything is o.k. * +C * +C----------------------------------------------------------------* +C * +C subroutines required: MACHPD * +C * +C***************************************************************** +C * +C author : Gisela Engeln-Muellges * +C date : 05.06.1988 * +C source : FORTRAN 77 * +C * +C[BA*) +C***************************************************************** +C[BE*) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DOUBLE PRECISION DL2(1:N),DL1(1:N),DM(1:N),DU1(1:N),DU2(1:N) +C +C testing whether N > 3 +C + MARK = -1 + IF (N .LT. 4) RETURN +C +C calculating the machine constant +C + FMACHP = 1.0D0 + 10 FMACHP = 0.5D0 * FMACHP + IF (MACHPD(1.0D0+FMACHP) .EQ. 1) GOTO 10 + FMACHP = FMACHP * 2.0D0 +C +C determining relative error bounds +C + EPS = 4.0D0 * FMACHP +C +C initializing the undefined vector components +C + DL2(1) = 0.0D0 + DL2(2) = 0.0D0 + DL1(1) = 0.0D0 + DU1(N) = 0.0D0 + DU2(N-1) = 0.0D0 + DU2(N) = 0.0D0 +C +C factoring the matrix A while checking for strong nonsingularity +C for N=1, 2 +C + ROW = DABS(DM(1)) + DABS(DU1(1)) + DABS(DU2(1)) + IF (ROW .EQ. 0.0D0) THEN + MARK = 0 + RETURN + ENDIF + D = 1.0D0/ROW + IF (DABS(DM(1))*D .LE. EPS) THEN + MARK = 0 + RETURN + ENDIF + DU1(1) = DU1(1)/DM(1) + DU2(1) = DU2(1)/DM(1) + ROW = DABS(DL1(2)) + DABS(DM(2)) + DABS(DU1(2)) + DABS(DU2(2)) + IF (ROW .EQ. 0.0D0) THEN + MARK = 0 + RETURN + ENDIF + D = 1.0D0/ROW + DM(2) = DM(2)-DL1(2)*DU1(1) + IF (DABS(DM(2))*D .LE. EPS) THEN + MARK = 0 + RETURN + ENDIF + DU1(2) = (DU1(2)-DL1(2)*DU2(1))/DM(2) + DU2(2) = DU2(2)/DM(2) +C +C factoring A while checking for strong nonsingularity of A +C + DO 20 I=3,N,1 + ROW = DABS(DL2(I))+DABS(DL1(I))+DABS(DM(I))+ + + DABS(DU1(I))+DABS(DU2(I)) + IF (ROW .EQ. 0.0D0) THEN + MARK = 0 + RETURN + ENDIF + D = 1.0D0/ROW + DL1(I) = DL1(I)-DL2(I)*DU1(I-2) + DM(I) = DM(I)-DL2(I)*DU2(I-2)-DL1(I)*DU1(I-1) + IF (DABS(DM(I))*D .LE. EPS) THEN + MARK = 0 + RETURN + ENDIF + IF (I .LT. N) THEN + DU1(I) = (DU1(I)-DL1(I)*DU2(I-1))/DM(I) + ENDIF + IF (I .LT. (N-1)) THEN + DU2(I) = DU2(I)/DM(I) + ENDIF + 20 CONTINUE + MARK = 1 + RETURN + END +C +C +C[BA*) +C[LE*) + SUBROUTINE FDIAGS (N,DL2,DL1,DM,DU1,DU2,RS,X) +C[IX{FDIAGS}*) +C +C***************************************************************** +C * +C Solving a linear system of equations * +C A * X = RS * +C for a five-diagonal, strongly nonsingular matrix A, once * +C the factor matrices L * R have been calculated by * +C SUBROUTINE FDIAGP. * +C[BE*) +C Here they are used as input arrays and * +C they are stored in the five N-vectors DL2, DL1, DM, DU1 * +C and DU2. * +C * +C * +C INPUT PARAMETERS: * +C ================= * +C N : number of equations; N > 3 * +C DL2 : N-vector DL2(1:N); ) lower triangular matrix L * +C DL1 : N-vector DL1(1:N); ) including the diagonal * +C DM : N-vector DM(1:N); ) elements * +C * +C DU1 : N-vector DU1(1:N); ) unit upper triangular matrix * +C DU2 : N-vector DU2(1:N); ) R without its unit diagonal * +C elements * +C RS : N-vector RS1(1:N); right side of the linear system * +C * +C * +C OUTPUT PARAMETERS: * +C ================== * +C X : N-vector X(1:N); the solution of the linear system * +C * +C----------------------------------------------------------------* +C * +C subroutines required: none * +C * +C***************************************************************** +C * +C author : Gisela Engeln-Muellges * +C date : 05.06.1988 * +C source : FORTRAN 77 * +C * +C[BA*) +C***************************************************************** +C[BE*) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DOUBLE PRECISION DL2(1:N),DL1(1:N),DM(1:N) + DOUBLE PRECISION DU1(1:N),DU2(1:N),RS(1:N),X(1:N) +C +C updating +C + RS(1)=RS(1)/DM(1) + RS(2)=(RS(2)-DL1(2)*RS(1))/DM(2) + DO 10 I=3,N + RS(I)=(RS(I)-DL2(I)*RS(I-2)-DL1(I)*RS(I-1))/DM(I) + 10 CONTINUE +C +C backsubstitution +C + X(N)=RS(N) + X(N-1)=RS(N-1)-DU1(N-1)*X(N) + DO 20 I=N-2,1,-1 + X(I)=RS(I)-DU1(I)*X(I+1)-DU2(I)*X(I+2) + 20 CONTINUE + RETURN + END diff --git a/source/unres/src-HCD-5D/fdisy.f b/source/unres/src-HCD-5D/fdisy.f new file mode 100644 index 0000000..8e2b2ac --- /dev/null +++ b/source/unres/src-HCD-5D/fdisy.f @@ -0,0 +1,321 @@ +C[BA*) +C[LE*) +C[LE*) +C[LE*) +C[FE{F 4.12.2} +C[ {Systems with Five-Diagonal Symmetric Matrices} +C[ {Systems with Five-Diagonal Symmetric Matrices}*) +C[LE*) + SUBROUTINE FDISY (N,DM,DU1,DU2,RS,X,MARK) +C[IX{FDISY}*) +C +C***************************************************************** +C * +C Solving a system of linear equations * +C A * X = RS * +C for a five-diagonal, symmetric and strongly nonsingular * +C matrix A. * +C[BE*) +C The matrix A is given by the three N-vectors DM, * +C DU1 and DU2. The system of equations has the form : * +C * +C DM(1)*X(1) + DU1(1)*X(2) + DU2(1)*X(3) = RS(1) * +C DU1(1)*X(1) + DM(2)*X(2) + DU1(2)*X(3) + DU2(2)*X(4) = RS(2) * +C * +C DU2(I-2)*X(I-2) + DU1(I-1)*X(I-1) + DM(I)*X(I) + * +C + DU1(I)*X(I+1) + DU2(I)*X(I+2) = RS(I) * +C for I = 3, ..., N - 2, and * +C * +C DU2(N-3)*X(N-2) + DU1(N-2)*X(N-1) + DM(N-1)*X(N-1) + * +C + DU1(N-1)*X(N) = RS(N-1)* +C DU2(N-2)*X(N-2) + OD(N-1)*X(N-1) + DM(N)*X(N) = RS(N) * +C * +C * +C * +C INPUT PARAMETERS: * +C ================= * +C N : number of equations, N > 3 * +C DM : N-vector DM(1:N); main diagonal of A * +C DM(1), DM(2), ... , DM(N) * +C DU1 : N-vector DU1(1:N); co-diagonal of A * +C DU1(1), DU1(2), ... , DU1(N-1) * +C DU2 : N-vector DU2(1:N); second co-diagonal of A * +C DU2(1), DU2(2), ... , DU2(N-2) * +C RS : N-vector RS(1:N); the right hand side * +C * +C * +C OUTPUT PARAMETERS: * +C ================== * +C DM :) * +C DU1 :) overwritten with intermediate quantities * +C DU2 :) * +C RS :) * +C X : N-vector X(1:N) containing the solution vector * +C MARK : error parameter * +C MARK=-2 : condition N > 3 is not satisfied * +C MARK=-1 : A is strongly nonsingular, but not positive * +C definite * +C MARK= 0 : numerically the matrix A is not strongly * +C nonsingular * +C MARK= 1 : A is positive definite * +C * +C NOTE: If MARK = +/- 1, then the determinant of A is: * +C DET A = DM(1) * DM(2) * ... * DM(N) * +C * +C----------------------------------------------------------------* +C * +C subroutines required: FDISYP, FDISYS, MACHPD * +C * +C***************************************************************** +C * +C authors : Gisela Engeln-Muellges * +C date : 01.07.1992 * +C source : FORTRAN 77 * +C * +C[BA*) +C***************************************************************** +C[BE*) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DOUBLE PRECISION DM(1:N),DU1(1:N),DU2(1:N),RS(1:N),X(1:N) + MARK = -2 + IF (N .LT. 4) RETURN +C +C Factorization of the matrix A +C + CALL FDISYP (N,DM,DU1,DU2,MARK) +C +C if MARK = +/- 1 , update and backsubstitute +C + IF (MARK .EQ. 1) THEN + CALL FDISYS (N,DM,DU1,DU2,RS,X) + ENDIF + RETURN + END +C +C +C[BA*) +C[LE*) + SUBROUTINE FDISYP (N,DM,DU1,DU2,MARK) +C[IX{FDISYP}*) +C +C***************************************************************** +C * +C Factor a five-diagonal, symmetric and strongly nonsingular * +C matrix A, that is given by the three N-vectors DM, DU1 and * +C DU2, into its Cholesky factors A = R(TRANSP) * D * R by * +C applying the root-free Cholesky method for five-diagonal * +C matrices. The form of the linear system is identical with * +C the one in SUBROUTINE FDISY. * +C[BE*) +C * +C * +C INPUT PARAMETERS: * +C ================= * +C N : number of equations, N > 3 * +C DM : N-vector DM(1:N); main diagonal of A * +C DM(1), DM(2), ... , DM(N) * +C DU1 : N-vector DU1(1:N); upper co-diagonal of A * +C DU1(1), DU1(2), ... , DU1(N-1) * +C DU2 : N-vector DU2(1:N); second upper co-diagonal of A * +C DU2(1), DU2(2), ... , DU2(N-2); * +C due to symmetry the lower co-diagonals do not need to * +C be stored separately. * +C * +C * +C OUTPUT PARAMETERS: * +C ================== * +C DM :) overwritten with auxiliary vectors containing the * +C DU1 :) Cholesky factors of A. The co-diagonals of the unit * +C DU2 :) upper tridiagonal matrix R are stored in DU1 and DU2, * +C the diagonal matrix D in DM. * +C MARK : error parameter * +C MARK=-2 : condition N > 3 is not satisfied * +C MARK=-1 : A is strongly nonsingular, but not positive * +C definite * +C MARK= 0 : numerically the matrix is not strongly * +C nonsingular * +C MARK= 1 : A is positive definite * +C * +C NOTE : If MARK = +/-1, then the inertia of A, i. e., the * +C number of positive and negative eigenvalues of A, * +C is the same as the number of positive and negative * +C numbers among the components of DM. * +C * +C----------------------------------------------------------------* +C * +C subroutines required: MACHPD * +C * +C***************************************************************** +C * +C authors : Gisela Engeln-Muellges * +C date : 01.07.1988 * +C source : FORTRAN 77 * +C * +C***************************************************************** +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DOUBLE PRECISION DM(1:N),DU1(1:N),DU2(1:N) +C +C calculating the machine constant +C + FMACHP = 1.0D0 + 10 FMACHP = 0.5D0 * FMACHP + IF (MACHPD(1.0D0+FMACHP) .EQ. 1) GOTO 10 + FMACHP = FMACHP * 2.0D0 +C +C determining the relative error bound +C + EPS = 4.0D0 * FMACHP +C +C checking for N > 3 +C + MARK = -2 + IF (N .LT. 4) RETURN + DU1(N) = 0.0D0 + DU2(N) = 0.0D0 + DU2(N-1) = 0.0D0 +C +C checking for strong nonsingularity of the matrix A for N=1 +C + ROW = DABS(DM(1)) + DABS(DU1(1)) + DABS(DU2(1)) + IF (ROW .EQ. 0.0D0) THEN + MARK = 0 + RETURN + ENDIF + D = 1.0D0/ROW + IF (DM(1) .LT. 0.0D0) THEN + MARK =-1 + RETURN + ELSEIF (DABS(DM(1))*D .LE. EPS) THEN + MARK = 0 + RETURN + ENDIF +C +C factoring A while checking for strong nonsingularity +C + DUMMY = DU1(1) + DU1(1) = DU1(1)/DM(1) + DUMMY1 = DU2(1) + DU2(1) = DU2(1)/DM(1) + ROW = DABS(DUMMY) + DABS(DM(2)) + DABS(DU1(2)) + DABS(DU2(2)) + IF (ROW .EQ. 0.0D0) THEN + MARK = 0 + RETURN + ENDIF + D = 1.0D0/ROW + DM(2) = DM(2) - DUMMY*DU1(1) + IF (DM(2) .LT. 0.0D0) THEN + MARK =-1 + RETURN + ELSEIF (DABS(DM(2)) .LE. EPS) THEN + MARK = 0 + RETURN + ENDIF + DUMMY = DU1(2) + DU1(2) = (DU1(2)-DUMMY1*DU1(1))/DM(2) + DUMMY2 = DU2(2) + DU2(2) = DU2(2)/DM(2) + DO 20 I=3,N,1 + ROW = DABS(DUMMY1)+DABS(DUMMY)+DABS(DM(I))+DABS(DU1(I))+ + + DABS(DU2(I)) + IF (ROW .EQ. 0.0D0) THEN + MARK = 0 + RETURN + ENDIF + D = 1.0D0/ROW + DM(I) = DM(I) - DM(I-1) * DU1(I-1) * DU1(I-1) + + -DUMMY1*DU2(I-2) + IF (DM(I) .LT. 0.0D0) THEN + MARK = -1 + RETURN + ELSEIF (DABS(DM(I))*D .LE. EPS) THEN + MARK = 0 + RETURN + ENDIF + IF (I .LT. N) THEN + DUMMY = DU1(I) + DU1(I) = (DU1(I)-DUMMY2*DU1(I-1))/DM(I) + DUMMY1 = DUMMY2 + ENDIF + IF (I .LT. N-1) THEN + DUMMY2 = DU2(I) + DU2(I) = DU2(I)/DM(I) + ENDIF + 20 CONTINUE + MARK = 1 + RETURN + END +C +C +C[BA*) +C[LE*) + SUBROUTINE FDISYS (N,DM,DU1,DU2,RS,X) +C[IX{FDISYS}*) +C +C***************************************************************** +C * +C Solving a linear system of equations * +C A * X = RS * +C for a five-diagonal, symmetric and strongly nonsingular * +C matrix A. * +C[BE*) +C Before this its Cholesky must factors have been calculated by * +C SUBROUTINE FDISYP. Here the factors of A are used as input * +C arrays and they are stored in the three N-vectors DM, DU1 * +C and DU2. * +C * +C * +C INPUT PARAMETER: * +C ================ * +C N : number of equations, N > 3 * +C DM : N-vector DM(1:N); diagonal matrix D * +C DU1 : N-vector DM(1:N); ) co-diagonals of the upper * +C DU2 : N-vector DM(1:N); ) triangular matrix R * +C RS : N-vector DM(1:N); the right hand side * +C * +C * +C OUTPUT PARAMETER: * +C ================= * +C X : N-vector X(1:N) containing the solution vector * +C * +C----------------------------------------------------------------* +C * +C subroutines required: none * +C * +C***************************************************************** +C * +C author : Gisela Engeln-Muellges * +C date : 29.04.1988 * +C source : FORTRAN 77 * +C * +C[BA*) +C***************************************************************** +C[BE*) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DOUBLE PRECISION DM(1:N),DU1(1:N),DU2(1:N),RS(1:N),X(1:N) +C +C updating +C + DUMMY1 = RS(1) + RS(1) = DUMMY1/DM(1) + DUMMY2 = RS(2)-DU1(1)*DUMMY1 + RS(2) = DUMMY2/DM(2) + DO 10 I=3,N,1 + DUMMY1 = RS(I)-DU1(I-1)*DUMMY2-DU2(I-2)*DUMMY1 + RS(I) = DUMMY1/DM(I) + DUMMY3 = DUMMY2 + DUMMY2 = DUMMY1 + DUMMY1 = DUMMY3 + 10 CONTINUE +C +C backsubstitution +C + X(N) = RS(N) + X(N-1) = RS(N-1)-DU1(N-1)*X(N) + DO 20 I=N-2,1,-1 + X(I) = RS(I)-DU1(I)*X(I+1)-DU2(I)*X(I+2) + 20 CONTINUE + RETURN + END diff --git a/source/unres/src-HCD-5D/gradient_p.F.new b/source/unres/src-HCD-5D/gradient_p.F.new new file mode 100644 index 0000000..ee8b01a --- /dev/null +++ b/source/unres/src-HCD-5D/gradient_p.F.new @@ -0,0 +1,523 @@ + subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(n),g(n) + integer i,j,k,ind,ind1 + double precision f,gthetai,gphii,galphai,gomegai +c +c This subroutine calculates total internal coordinate gradient. +c Depending on the number of function evaluations, either whole energy +c is evaluated beforehand, Cartesian coordinates and their derivatives in +c internal coordinates are reevaluated or only the cartesian-in-internal +c coordinate derivatives are evaluated. The subroutine was designed to work +c with SUMSL. +c +c + icg=mod(nf,2)+1 + +cd print *,'grad',nf,icg + if (nf-nfl+1) 20,30,40 + 20 call func(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 call var_to_geom(n,x) + call chainbuild +c write (iout,*) 'grad 30' +C +C Transform the gradient to the gradient in angles. +C + 40 call cart2intgrad(n,g) +C +C Add the components corresponding to local energy terms. +C + 10 continue +c Add the usampl contributions + 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 +cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) + g(i)=g(i)+gloc(i,icg) + enddo +C Uncomment following three lines for diagnostics. +cd call intout +cd call briefout(0,0.0d0) +cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) + return + end +C------------------------------------------------------------------------- + subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(maxvar),g(maxvar) + integer i,j,k,ig,ind,ij,igall + double precision f,gthetai,gphii,galphai,gomegai + + icg=mod(nf,2)+1 + if (nf-nfl+1) 20,30,40 + 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 continue +#ifdef OSF +c Intercept NaNs in the coordinates +c write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,n + x_sum=x_sum+x(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** grad_restr : Found NaN in coordinates" + call flush(iout) + print *," *** grad_restr : Found NaN in coordinates" + return + endif +#endif + call var_to_geom_restr(n,x) + call chainbuild +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + + ig=0 + ind=nres-2 + do i=2,nres-2 + IF (mask_phi(i+2).eq.1) THEN + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) + enddo + enddo + ig=ig+1 + g(ig)=gphii + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + + ind=0 + do i=1,nres-2 + IF (mask_theta(i+2).eq.1) THEN + ig=ig+1 + gthetai=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) + enddo + enddo + g(ig)=gthetai + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + galphai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + g(ig)=galphai + ENDIF + endif + enddo + + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + gomegai=0.0D0 + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ig)=gomegai + ENDIF + endif + enddo + +C +C Add the components corresponding to local energy terms. +C + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + endif + enddo + enddo + +cd do i=1,ig +cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +cd enddo + return + end +C------------------------------------------------------------------------- + subroutine cartgrad + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +c +c This subrouting calculates total Cartesian coordinate gradient. +c The subroutine chainbuild_cart and energy MUST be called beforehand. +c +#ifdef TIMING + time00=MPI_Wtime() +#endif + icg=1 +#ifdef DEBUG + write (iout,*) "Before 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 + write (iout,*) "gsaxsc, gsaxcx" + do i=1,nres-1 + write (iout,*) i," gsaxsc ",(gsaxsc(j,i),j=1,3) + write (iout,*) i," gsaxsx ",(gsaxsx(j,i),j=1,3) + enddo +#endif + call sum_gradient +#ifdef TIMING +#endif +#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 +c If performing constraint dynamics, add the gradients of the constraint energy + if(usampl.and.totT.gt.eq_time) then +#ifdef DEBUG + write (iout,*) "dudconst, duscdiff, dugamma,dutheta" + write (iout,*) "wumb",wumb + do i=1,nct + write (iout,'(i5,3f10.5,5x,3f10.5,5x,2f10.5)') + & i,(dudconst(j,i),j=1,3),(duscdiff(j,i),j=1,3), + & dugamma(i),dutheta(i) + enddo +#endif + do i=1,nct + do j=1,3 + gradc(j,i,icg)=gradc(j,i,icg)+ + & wumb*(dudconst(j,i)+duscdiff(j,i)) + gradx(j,i,icg)=gradx(j,i,icg)+ + & wumb*(dudxconst(j,i)+duscdiffx(j,i)) + enddo + enddo + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wumb*dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+wumb*dutheta(i) + enddo + endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + call intcartderiv +#ifdef TIMING + time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 +#endif +cd call checkintcartgrad +cd write(iout,*) 'calling int_to_cart' +#ifdef DEBUG + write (iout,*) "gcart, gxcart, gloc before int_to_cart" +#endif + do i=1,nct + do j=1,3 + gcart(j,i)=gradc(j,i,icg) + gxcart(j,i)=gradx(j,i,icg) + enddo +#ifdef DEBUG + if((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then + 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(i+nphi,icg), + & gloc(ialph(i,1),icg),gloc(ialph(i,1)+nside,icg) + else + 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(i+nphi,icg) + endif + call flush(iout) +#endif + enddo +#ifdef TIMING + time01=MPI_Wtime() +#endif + call int_to_cart +#ifdef TIMING + time_inttocart=time_inttocart+MPI_Wtime()-time01 +#endif +#ifdef DEBUG + write (iout,*) "gcart and gxcart after int_to_cart" + do i=0,nres-1 + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif +#ifdef TIMING + time_cartgrad=time_cartgrad+MPI_Wtime()-time00 +#endif + return + end +c--------------------------------------------------------------------------- +#ifdef FIVEDIAG + subroutine grad_transform + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +#ifdef DEBUG + write (iout,*)"Converting virtual-bond gradient to CA/SC gradient" +#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 + 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 +#endif +C------------------------------------------------------------------------- + subroutine zerograd + implicit none + include 'DIMENSIONS' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.SCCOR' + include 'COMMON.SHIELD' + integer i,j,kk,intertyp,maxshieldlist + maxshieldlist=0 +C +C Initialize Cartesian-coordinate gradient +C + 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 +C below is zero grad for shielding in order: ees (p-p) +C ecorr4, eturn3, eturn4, eel_loc, c denotes calfa,x is side-chain + 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 +C end of zero grad for shielding + 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 + gsaxsc(j,i)=0.0D0 + gsaxsx(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 + gliptranc(j,i)=0.0d0 + gliptranx(j,i)=0.0d0 + gradafm(j,i)=0.0d0 + grad_shield(j,i)=0.0d0 + gg_tube(j,i)=0.0d0 + gg_tube_sc(j,i)=0.0d0 +C grad_shield_side is Cbeta sidechain gradient + do kk=1,maxshieldlist + grad_shield_side(j,kk,i)=0.0d0 + grad_shield_loc(j,kk,i)=0.0d0 + +C grad_shield_side_ca is Calfa sidechain gradient + + +C grad_shield_side_ca(j,kk,i)=0.0d0 + enddo + do intertyp=1,3 + gloc_sc(intertyp,i,icg)=0.0d0 + enddo + enddo + enddo +#ifndef DFA + do i=1,nres + do j=1,3 + gdfad(j,i)=0.0d0 + gdfat(j,i)=0.0d0 + gdfan(j,i)=0.0d0 + gdfab(j,i)=0.0d0 + enddo + enddo +#endif +C +C Initialize the gradient of local energy terms. +C + 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 +c initialize gcart and gxcart + do i=0,nres + do j=1,3 + gcart(j,i)=0.0d0 + gxcart(j,i)=0.0d0 + enddo + enddo + return + end +c------------------------------------------------------------------------- + double precision function fdum() + fdum=0.0D0 + return + end diff --git a/source/unres/src-HCD-5D/gradient_p.F.org b/source/unres/src-HCD-5D/gradient_p.F.org new file mode 100644 index 0000000..1d89e0f --- /dev/null +++ b/source/unres/src-HCD-5D/gradient_p.F.org @@ -0,0 +1,571 @@ + subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(n),g(n) + integer i,j,k,ind,ind1 + double precision f,gthetai,gphii,galphai,gomegai +c +c This subroutine calculates total internal coordinate gradient. +c Depending on the number of function evaluations, either whole energy +c is evaluated beforehand, Cartesian coordinates and their derivatives in +c internal coordinates are reevaluated or only the cartesian-in-internal +c coordinate derivatives are evaluated. The subroutine was designed to work +c with SUMSL. +c +c + icg=mod(nf,2)+1 + +cd print *,'grad',nf,icg + if (nf-nfl+1) 20,30,40 + 20 call func(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 call var_to_geom(n,x) + call chainbuild +c write (iout,*) 'grad 30' +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +c write (iout,*) 'grad 40' +c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + ind=0 + ind1=0 + do i=1,nres-2 + gthetai=0.0D0 + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 +c ind=indmat(i,j) +c 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 +c ind1=indmat(i,j) +c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 + do k=1,3 + gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) + gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) + enddo + enddo + if (i.gt.1) g(i-1)=gphii + if (n.gt.nphi) g(nphi+i)=gthetai + enddo + if (n.le.nphi+ntheta) goto 10 + do i=2,nres-1 + if (itype(i).ne.10) then + galphai=0.0D0 + gomegai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ialph(i,1))=galphai + g(ialph(i,1)+nside)=gomegai + endif + enddo +C +C Add the components corresponding to local energy terms. +C + 10 continue +c Add the usampl contributions + 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 +cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) + g(i)=g(i)+gloc(i,icg) + enddo +C Uncomment following three lines for diagnostics. +cd call intout +cd call briefout(0,0.0d0) +cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) + return + end +C------------------------------------------------------------------------- + subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(maxvar),g(maxvar) + integer i,j,k,ig,ind,ij,igall + double precision f,gthetai,gphii,galphai,gomegai + + icg=mod(nf,2)+1 + if (nf-nfl+1) 20,30,40 + 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 continue +#ifdef OSF +c Intercept NaNs in the coordinates +c write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,n + x_sum=x_sum+x(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** grad_restr : Found NaN in coordinates" + call flush(iout) + print *," *** grad_restr : Found NaN in coordinates" + return + endif +#endif + call var_to_geom_restr(n,x) + call chainbuild +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + + ig=0 + ind=nres-2 + do i=2,nres-2 + IF (mask_phi(i+2).eq.1) THEN + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) + enddo + enddo + ig=ig+1 + g(ig)=gphii + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + + ind=0 + do i=1,nres-2 + IF (mask_theta(i+2).eq.1) THEN + ig=ig+1 + gthetai=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) + enddo + enddo + g(ig)=gthetai + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + galphai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + g(ig)=galphai + ENDIF + endif + enddo + + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + gomegai=0.0D0 + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ig)=gomegai + ENDIF + endif + enddo + +C +C Add the components corresponding to local energy terms. +C + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + endif + enddo + enddo + +cd do i=1,ig +cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +cd enddo + return + end +C------------------------------------------------------------------------- + subroutine cartgrad + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +c +c This subrouting calculates total Cartesian coordinate gradient. +c The subroutine chainbuild_cart and energy MUST be called beforehand. +c +#ifdef TIMING + time00=MPI_Wtime() +#endif + icg=1 +#ifdef DEBUG + write (iout,*) "Before 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 + write (iout,*) "gsaxsc, gsaxcx" + do i=1,nres-1 + write (iout,*) i," gsaxsc ",(gsaxsc(j,i),j=1,3) + write (iout,*) i," gsaxsx ",(gsaxsx(j,i),j=1,3) + enddo +#endif + call sum_gradient +#ifdef TIMING +#endif +#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 +c If performing constraint dynamics, add the gradients of the constraint energy + if(usampl.and.totT.gt.eq_time) then +#ifdef DEBUG + write (iout,*) "dudconst, duscdiff, dugamma,dutheta" + write (iout,*) "wumb",wumb + do i=1,nct + write (iout,'(i5,3f10.5,5x,3f10.5,5x,2f10.5)') + & i,(dudconst(j,i),j=1,3),(duscdiff(j,i),j=1,3), + & dugamma(i),dutheta(i) + enddo +#endif + do i=1,nct + do j=1,3 + gradc(j,i,icg)=gradc(j,i,icg)+ + & wumb*(dudconst(j,i)+duscdiff(j,i)) + gradx(j,i,icg)=gradx(j,i,icg)+ + & wumb*(dudxconst(j,i)+duscdiffx(j,i)) + enddo + enddo + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wumb*dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+wumb*dutheta(i) + enddo + endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + call intcartderiv +#ifdef TIMING + time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 +#endif +cd call checkintcartgrad +cd write(iout,*) 'calling int_to_cart' +#ifdef DEBUG + write (iout,*) "gcart, gxcart, gloc before int_to_cart" +#endif + do i=1,nct + do j=1,3 + gcart(j,i)=gradc(j,i,icg) + gxcart(j,i)=gradx(j,i,icg) + enddo +#ifdef DEBUG + if((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then + 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(i+nphi,icg), + & gloc(ialph(i,1),icg),gloc(ialph(i,1)+nside,icg) + else + 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(i+nphi,icg) + endif + call flush(iout) +#endif + enddo +#ifdef TIMING + time01=MPI_Wtime() +#endif + call int_to_cart +#ifdef TIMING + time_inttocart=time_inttocart+MPI_Wtime()-time01 +#endif +#ifdef DEBUG + write (iout,*) "gcart and gxcart after int_to_cart" + do i=0,nres-1 + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif +#ifdef TIMING + time_cartgrad=time_cartgrad+MPI_Wtime()-time00 +#endif + return + end +c--------------------------------------------------------------------------- +#ifdef FIVEDIAG + subroutine grad_transform + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +#ifdef DEBUG + write (iout,*)"Converting virtual-bond gradient to CA/SC gradient" +#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 + 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 +#endif +C------------------------------------------------------------------------- + subroutine zerograd + implicit none + include 'DIMENSIONS' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.SCCOR' + include 'COMMON.SHIELD' + integer i,j,kk,intertyp,maxshieldlist + maxshieldlist=0 +C +C Initialize Cartesian-coordinate gradient +C + 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 +C below is zero grad for shielding in order: ees (p-p) +C ecorr4, eturn3, eturn4, eel_loc, c denotes calfa,x is side-chain + 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 +C end of zero grad for shielding + 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 + gsaxsc(j,i)=0.0D0 + gsaxsx(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 + gliptranc(j,i)=0.0d0 + gliptranx(j,i)=0.0d0 + gradafm(j,i)=0.0d0 + grad_shield(j,i)=0.0d0 + gg_tube(j,i)=0.0d0 + gg_tube_sc(j,i)=0.0d0 +C grad_shield_side is Cbeta sidechain gradient + do kk=1,maxshieldlist + grad_shield_side(j,kk,i)=0.0d0 + grad_shield_loc(j,kk,i)=0.0d0 + +C grad_shield_side_ca is Calfa sidechain gradient + + +C grad_shield_side_ca(j,kk,i)=0.0d0 + enddo + do intertyp=1,3 + gloc_sc(intertyp,i,icg)=0.0d0 + enddo + enddo + enddo +#ifndef DFA + do i=1,nres + do j=1,3 + gdfad(j,i)=0.0d0 + gdfat(j,i)=0.0d0 + gdfan(j,i)=0.0d0 + gdfab(j,i)=0.0d0 + enddo + enddo +#endif +C +C Initialize the gradient of local energy terms. +C + 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 +c initialize gcart and gxcart + do i=0,nres + do j=1,3 + gcart(j,i)=0.0d0 + gxcart(j,i)=0.0d0 + enddo + enddo + return + end +c------------------------------------------------------------------------- + double precision function fdum() + fdum=0.0D0 + return + end diff --git a/source/unres/src-HCD-5D/gradient_p.F.org.debug b/source/unres/src-HCD-5D/gradient_p.F.org.debug new file mode 100644 index 0000000..e2ac689 --- /dev/null +++ b/source/unres/src-HCD-5D/gradient_p.F.org.debug @@ -0,0 +1,574 @@ + subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(n),g(n) + integer i,j,k,ind,ind1 + double precision f,gthetai,gphii,galphai,gomegai +c +c This subroutine calculates total internal coordinate gradient. +c Depending on the number of function evaluations, either whole energy +c is evaluated beforehand, Cartesian coordinates and their derivatives in +c internal coordinates are reevaluated or only the cartesian-in-internal +c coordinate derivatives are evaluated. The subroutine was designed to work +c with SUMSL. +c +c + icg=mod(nf,2)+1 + +cd print *,'grad',nf,icg + if (nf-nfl+1) 20,30,40 + 20 call func(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 call var_to_geom(n,x) + call chainbuild +c write (iout,*) 'grad 30' +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +c write (iout,*) 'grad 40' +c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + ind=0 + ind1=0 + do i=1,nres-2 + gthetai=0.0D0 + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 +c ind=indmat(i,j) +c 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 +c ind1=indmat(i,j) +c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 + write (iout,*) "i",i," j",j," ind1",ind1 + write (iout,*) "dxdv",(dxdv(k,ind1),k=1,6) + write (iout,*) "gradx",(gradx(k,j,icg),k=1,3) + do k=1,3 + gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) + gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) + enddo + enddo + if (i.gt.1) g(i-1)=gphii + if (n.gt.nphi) g(nphi+i)=gthetai + enddo + if (n.le.nphi+ntheta) goto 10 + do i=2,nres-1 + if (itype(i).ne.10) then + galphai=0.0D0 + gomegai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ialph(i,1))=galphai + g(ialph(i,1)+nside)=gomegai + endif + enddo +C +C Add the components corresponding to local energy terms. +C + 10 continue +c Add the usampl contributions + 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 +cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) + g(i)=g(i)+gloc(i,icg) + enddo +C Uncomment following three lines for diagnostics. +cd call intout +cd call briefout(0,0.0d0) +cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) + return + end +C------------------------------------------------------------------------- + subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(maxvar),g(maxvar) + integer i,j,k,ig,ind,ij,igall + double precision f,gthetai,gphii,galphai,gomegai + + icg=mod(nf,2)+1 + if (nf-nfl+1) 20,30,40 + 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 continue +#ifdef OSF +c Intercept NaNs in the coordinates +c write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,n + x_sum=x_sum+x(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** grad_restr : Found NaN in coordinates" + call flush(iout) + print *," *** grad_restr : Found NaN in coordinates" + return + endif +#endif + call var_to_geom_restr(n,x) + call chainbuild +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + + ig=0 + ind=nres-2 + do i=2,nres-2 + IF (mask_phi(i+2).eq.1) THEN + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) + enddo + enddo + ig=ig+1 + g(ig)=gphii + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + + ind=0 + do i=1,nres-2 + IF (mask_theta(i+2).eq.1) THEN + ig=ig+1 + gthetai=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) + enddo + enddo + g(ig)=gthetai + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + galphai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + g(ig)=galphai + ENDIF + endif + enddo + + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + gomegai=0.0D0 + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ig)=gomegai + ENDIF + endif + enddo + +C +C Add the components corresponding to local energy terms. +C + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + endif + enddo + enddo + +cd do i=1,ig +cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +cd enddo + return + end +C------------------------------------------------------------------------- + subroutine cartgrad + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +c +c This subrouting calculates total Cartesian coordinate gradient. +c The subroutine chainbuild_cart and energy MUST be called beforehand. +c +#ifdef TIMING + time00=MPI_Wtime() +#endif + icg=1 +#ifdef DEBUG + write (iout,*) "Before 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 + write (iout,*) "gsaxsc, gsaxcx" + do i=1,nres-1 + write (iout,*) i," gsaxsc ",(gsaxsc(j,i),j=1,3) + write (iout,*) i," gsaxsx ",(gsaxsx(j,i),j=1,3) + enddo +#endif + call sum_gradient +#ifdef TIMING +#endif +#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 +c If performing constraint dynamics, add the gradients of the constraint energy + if(usampl.and.totT.gt.eq_time) then +#ifdef DEBUG + write (iout,*) "dudconst, duscdiff, dugamma,dutheta" + write (iout,*) "wumb",wumb + do i=1,nct + write (iout,'(i5,3f10.5,5x,3f10.5,5x,2f10.5)') + & i,(dudconst(j,i),j=1,3),(duscdiff(j,i),j=1,3), + & dugamma(i),dutheta(i) + enddo +#endif + do i=1,nct + do j=1,3 + gradc(j,i,icg)=gradc(j,i,icg)+ + & wumb*(dudconst(j,i)+duscdiff(j,i)) + gradx(j,i,icg)=gradx(j,i,icg)+ + & wumb*(dudxconst(j,i)+duscdiffx(j,i)) + enddo + enddo + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wumb*dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+wumb*dutheta(i) + enddo + endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + call intcartderiv +#ifdef TIMING + time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 +#endif +cd call checkintcartgrad +cd write(iout,*) 'calling int_to_cart' +#ifdef DEBUG + write (iout,*) "gcart, gxcart, gloc before int_to_cart" +#endif + do i=1,nct + do j=1,3 + gcart(j,i)=gradc(j,i,icg) + gxcart(j,i)=gradx(j,i,icg) + enddo +#ifdef DEBUG + if((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then + 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(i+nphi,icg), + & gloc(ialph(i,1),icg),gloc(ialph(i,1)+nside,icg) + else + 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(i+nphi,icg) + endif + call flush(iout) +#endif + enddo +#ifdef TIMING + time01=MPI_Wtime() +#endif + call int_to_cart +#ifdef TIMING + time_inttocart=time_inttocart+MPI_Wtime()-time01 +#endif +#ifdef DEBUG + write (iout,*) "gcart and gxcart after int_to_cart" + do i=0,nres-1 + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif +#ifdef TIMING + time_cartgrad=time_cartgrad+MPI_Wtime()-time00 +#endif + return + end +c--------------------------------------------------------------------------- +#ifdef FIVEDIAG + subroutine grad_transform + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +#ifdef DEBUG + write (iout,*)"Converting virtual-bond gradient to CA/SC gradient" +#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 + 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 +#endif +C------------------------------------------------------------------------- + subroutine zerograd + implicit none + include 'DIMENSIONS' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.SCCOR' + include 'COMMON.SHIELD' + integer i,j,kk,intertyp,maxshieldlist + maxshieldlist=0 +C +C Initialize Cartesian-coordinate gradient +C + 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 +C below is zero grad for shielding in order: ees (p-p) +C ecorr4, eturn3, eturn4, eel_loc, c denotes calfa,x is side-chain + 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 +C end of zero grad for shielding + 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 + gsaxsc(j,i)=0.0D0 + gsaxsx(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 + gliptranc(j,i)=0.0d0 + gliptranx(j,i)=0.0d0 + gradafm(j,i)=0.0d0 + grad_shield(j,i)=0.0d0 + gg_tube(j,i)=0.0d0 + gg_tube_sc(j,i)=0.0d0 +C grad_shield_side is Cbeta sidechain gradient + do kk=1,maxshieldlist + grad_shield_side(j,kk,i)=0.0d0 + grad_shield_loc(j,kk,i)=0.0d0 + +C grad_shield_side_ca is Calfa sidechain gradient + + +C grad_shield_side_ca(j,kk,i)=0.0d0 + enddo + do intertyp=1,3 + gloc_sc(intertyp,i,icg)=0.0d0 + enddo + enddo + enddo +#ifndef DFA + do i=1,nres + do j=1,3 + gdfad(j,i)=0.0d0 + gdfat(j,i)=0.0d0 + gdfan(j,i)=0.0d0 + gdfab(j,i)=0.0d0 + enddo + enddo +#endif +C +C Initialize the gradient of local energy terms. +C + 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 +c initialize gcart and gxcart + do i=0,nres + do j=1,3 + gcart(j,i)=0.0d0 + gxcart(j,i)=0.0d0 + enddo + enddo + return + end +c------------------------------------------------------------------------- + double precision function fdum() + fdum=0.0D0 + return + end diff --git a/source/unres/src-HCD-5D/gradient_p.optrpt b/source/unres/src-HCD-5D/gradient_p.optrpt new file mode 100644 index 0000000..e69de29 diff --git a/source/unres/src-HCD-5D/inform.f b/source/unres/src-HCD-5D/inform.f new file mode 100644 index 0000000..5905b04 --- /dev/null +++ b/source/unres/src-HCD-5D/inform.f @@ -0,0 +1,38 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1992 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ############################################################## +c ## ## +c ## module inform -- program I/O and flow control values ## +c ## ## +c ############################################################## +c +c +c maxask maximum number of queries for interactive input +c +c digits decimal places output for energy and coordinates +c iprint steps between status printing (0=no printing) +c iwrite steps between coordinate saves (0=no saves) +c isend steps between socket communication (0=no sockets) +c silent logical flag to turn off all information printing +c verbose logical flag to turn on extra information printing +c debug logical flag to turn on full debug printing +c holdup logical flag to wait for carriage return on exit +c abort logical flag to stop execution at next chance +c +c + module inform + implicit none + integer maxask + parameter (maxask=5) + integer digits,jprint + integer iwrite,isend + logical silent,verbose + logical debug,holdup + logical abort + save + end diff --git a/source/unres/src-HCD-5D/iounit.f b/source/unres/src-HCD-5D/iounit.f new file mode 100644 index 0000000..dfb5ecc --- /dev/null +++ b/source/unres/src-HCD-5D/iounit.f @@ -0,0 +1,24 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1992 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ############################################################ +c ## ## +c ## module iounit -- Fortran input/output unit numbers ## +c ## ## +c ############################################################ +c +c +c input Fortran I/O unit for main input (default=5) +c iout Fortran I/O unit for main output (default=6) +c +c + module iounit + implicit none + integer input + integer jout + save + end diff --git a/source/unres/src-HCD-5D/keys.f b/source/unres/src-HCD-5D/keys.f new file mode 100644 index 0000000..fcdb08c --- /dev/null +++ b/source/unres/src-HCD-5D/keys.f @@ -0,0 +1,28 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1992 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ############################################################# +c ## ## +c ## module keys -- contents of the keyword control file ## +c ## ## +c ############################################################# +c +c +c maxkey maximum number of lines in the keyword file +c +c nkey number of nonblank lines in the keyword file +c keyline contents of each individual keyword file line +c +c + module keys + implicit none + integer maxkey + parameter (maxkey=25000) + integer nkey + character*240 keyline(maxkey) + save + end diff --git a/source/unres/src-HCD-5D/kinetic_CASC.F b/source/unres/src-HCD-5D/kinetic_CASC.F new file mode 100644 index 0000000..21c2844 --- /dev/null +++ b/source/unres/src-HCD-5D/kinetic_CASC.F @@ -0,0 +1,108 @@ + subroutine kinetic_CASC(KE_total) +c---------------------------------------------------------------- +c Compute the kinetic energy of the system using the Calpha-SC +c coordinate system +c----------------------------------------------------------------- + implicit none + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif + include 'COMMON.IOUNITS' + double precision KE_total + + integer i,j,k,iti,ichain,innt,inct + double precision KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3), + & mag1,mag2,v(3) +#ifdef FIVEDIAG + KEt_p=0.0d0 + KEt_sc=0.0d0 + KEr_p=0.0D0 + KEr_sc=0.0D0 +c write (iout,*) "ISC",(isc(itype(i)),i=1,nres) +c The translational part for peptide virtual bonds + do ichain=1,nchain + + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) +c write (iout,*) "Kinetic_CASC chain",ichain," innt",innt, +c & " inct",inct + + do i=innt,inct-1 +c write (iout,*) i,(d_t(j,i),j=1,3),(d_t(j,i+1),j=1,3) + do j=1,3 + v(j)=0.5d0*(d_t(j,i)+d_t(j,i+1)) + enddo +c write (iout,*) "Kinetic trp i",i," v",(v(j),j=1,3) + KEt_p=KEt_p+(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + enddo +c write(iout,*) 'KEt_p', KEt_p +c The translational part for the side chain virtual bond +c Only now we can initialize incr with zeros. It must be equal +c to the velocities of the first Calpha. + do i=innt,inct + iti=iabs(itype(i)) + if (iti.eq.10) then +c write (iout,*) i,iti,(d_t(j,i),j=1,3) + do j=1,3 + v(j)=d_t(j,i) + enddo + else +c write (iout,*) i,iti,(d_t(j,nres+i),j=1,3) + do j=1,3 + v(j)=d_t(j,nres+i) + enddo + endif +c write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3) +c write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3) + KEt_sc=KEt_sc+msc(iti)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + enddo +c goto 111 +c write(iout,*) 'KEt_sc', KEt_sc +c The part due to stretching and rotation of the peptide groups + do i=innt,inct-1 + do j=1,3 + incr(j)=d_t(j,i+1)-d_t(j,i) + enddo +c write (iout,*) i,(incr(j),j=1,3) +c write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3) + KEr_p=KEr_p+(incr(1)*incr(1)+incr(2)*incr(2) + & +incr(3)*incr(3)) + enddo +c goto 111 +c write(iout,*) 'KEr_p', KEr_p +c The rotational part of the side chain virtual bond + do i=innt,inct + iti=iabs(itype(i)) + if (iti.ne.10) then + do j=1,3 + incr(j)=d_t(j,nres+i)-d_t(j,i) + enddo +c write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3) + KEr_sc=KEr_sc+Isc(iti)*(incr(1)*incr(1)+incr(2)*incr(2)+ + & incr(3)*incr(3)) + endif + enddo + + enddo ! ichain +c The total kinetic energy + 111 continue +c write(iout,*) ' KEt_p',KEt_p,' KEt_sc',KEt_sc,' KEr_p',KEr_p, +c & ' KEr_sc', KEr_sc + KE_total=0.5d0*(mp*KEt_p+KEt_sc+0.25d0*Ip*KEr_p+KEr_sc) +c write (iout,*) "KE_total",KE_tota +#else + write (iout,*) "Need to compile with -DFIVEDIAG to use this sub!" + stop +#endif + return + end diff --git a/source/unres/src-HCD-5D/kinetic_lesyng.F b/source/unres/src-HCD-5D/kinetic_lesyng.F new file mode 100644 index 0000000..84b1e26 --- /dev/null +++ b/source/unres/src-HCD-5D/kinetic_lesyng.F @@ -0,0 +1,212 @@ +#ifdef FIVEDIAG + subroutine kinetic(KE_total) +c---------------------------------------------------------------- +c This subroutine calculates the total kinetic energy of the chain +c----------------------------------------------------------------- +c 3/5/2020 AL Corrected for multichain systems, no fake peptide groups +c inside, implemented with five-diagonal inertia matrix + implicit none + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.MD' + include 'COMMON.LAGRANGE.5diag' + include 'COMMON.IOUNITS' + double precision KE_total + integer i,j,k,iti + double precision KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3), + & mag1,mag2,v(3) + + KEt_p=0.0d0 + KEt_sc=0.0d0 + KEr_p=0.0D0 + KEr_sc=0.0D0 +c write (iout,*) "ISC",(isc(itype(i)),i=1,nres) +c The translational part for peptide virtual bonds + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct-1 +c write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3 +c Skip dummy peptide groups + if (itype(i).ne.ntyp1 .and. itype(i+1).ne.ntyp1) then + do j=1,3 + v(j)=incr(j)+0.5d0*d_t(j,i) + enddo +c write (iout,*) "Kinetic trp:",i,(v(j),j=1,3) + vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) + KEt_p=KEt_p+(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + endif + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo +c write(iout,*) 'KEt_p', KEt_p +c The translational part for the side chain virtual bond +c Only now we can initialize incr with zeros. It must be equal +c to the velocities of the first Calpha. + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct + iti=iabs(itype(i)) + if (itype(i).eq.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + v(j)=incr(j) + enddo + else + do j=1,3 + v(j)=incr(j)+d_t(j,nres+i) + enddo + endif +c write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3) +c write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3) + KEt_sc=KEt_sc+msc(iti)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo +c goto 111 +c write(iout,*) 'KEt_sc', KEt_sc +c The part due to stretching and rotation of the peptide groups + do i=nnt,nct-1 + if (itype(i).ne.ntyp1.and.itype(i+1).ne.ntyp1) then +c write (iout,*) "i",i +c write (iout,*) "i",i," mag1",mag1," mag2",mag2 + do j=1,3 + incr(j)=d_t(j,i) + enddo +c write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3) + KEr_p=KEr_p+(incr(1)*incr(1)+incr(2)*incr(2) + & +incr(3)*incr(3)) + endif + enddo +c goto 111 +c write(iout,*) 'KEr_p', KEr_p +c The rotational part of the side chain virtual bond + do i=nnt,nct + iti=iabs(itype(i)) + if (itype(i).ne.10.and.itype(i).ne.ntyp1) then + do j=1,3 + incr(j)=d_t(j,nres+i) + enddo +c write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3) + KEr_sc=KEr_sc+Isc(iti)*(incr(1)*incr(1)+incr(2)*incr(2)+ + & incr(3)*incr(3)) + endif + enddo +c The total kinetic energy + 111 continue +c write(iout,*) ' KEt_p',KEt_p,' KEt_sc',KEt_sc,' KEr_p',KEr_p, +c & ' KEr_sc', KEr_sc + KE_total=0.5d0*(mp*KEt_p+KEt_sc+0.25d0*Ip*KEr_p+KEr_sc) +c write (iout,*) "KE_total",KE_total + return + end +#else + subroutine kinetic(KE_total) +c---------------------------------------------------------------- +c This subroutine calculates the total kinetic energy of the chain +c----------------------------------------------------------------- + implicit none + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.MD' + include 'COMMON.LAGRANGE' + include 'COMMON.IOUNITS' + double precision KE_total + integer i,j,k,iti + double precision KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3), + & mag1,mag2,v(3) + + KEt_p=0.0d0 + KEt_sc=0.0d0 +c write (iout,*) "ISC",(isc(itype(i)),i=1,nres) +c The translational part for peptide virtual bonds + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct-1 +c write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3) + do j=1,3 + v(j)=incr(j)+0.5d0*d_t(j,i) + enddo + vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) + KEt_p=KEt_p+(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo +c write(iout,*) 'KEt_p', KEt_p +c The translational part for the side chain virtual bond +c Only now we can initialize incr with zeros. It must be equal +c to the velocities of the first Calpha. + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct + iti=iabs(itype(i)) + if (itype(i).eq.10) then + do j=1,3 + v(j)=incr(j) + enddo + else + do j=1,3 + v(j)=incr(j)+d_t(j,nres+i) + enddo + endif +c write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3) +c write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3) + KEt_sc=KEt_sc+msc(iti)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo +c goto 111 +c write(iout,*) 'KEt_sc', KEt_sc +c The part due to stretching and rotation of the peptide groups + KEr_p=0.0D0 + do i=nnt,nct-1 +c write (iout,*) "i",i +c write (iout,*) "i",i," mag1",mag1," mag2",mag2 + do j=1,3 + incr(j)=d_t(j,i) + enddo +c write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3) + KEr_p=KEr_p+(incr(1)*incr(1)+incr(2)*incr(2) + & +incr(3)*incr(3)) + enddo +c goto 111 +c write(iout,*) 'KEr_p', KEr_p +c The rotational part of the side chain virtual bond + KEr_sc=0.0D0 + do i=nnt,nct + iti=iabs(itype(i)) + if (itype(i).ne.10) then + do j=1,3 + incr(j)=d_t(j,nres+i) + enddo +c write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3) + KEr_sc=KEr_sc+Isc(iti)*(incr(1)*incr(1)+incr(2)*incr(2)+ + & incr(3)*incr(3)) + endif + enddo +c The total kinetic energy + 111 continue +c write(iout,*) 'KEr_sc', KEr_sc + KE_total=0.5d0*(mp*KEt_p+KEt_sc+0.25d0*Ip*KEr_p+KEr_sc) +c write (iout,*) "KE_total",KE_total + return + end +#endif diff --git a/source/unres/src-HCD-5D/kinetic_lesyng.F.safe b/source/unres/src-HCD-5D/kinetic_lesyng.F.safe new file mode 100644 index 0000000..ad17edf --- /dev/null +++ b/source/unres/src-HCD-5D/kinetic_lesyng.F.safe @@ -0,0 +1,109 @@ + subroutine kinetic(KE_total) +c---------------------------------------------------------------- +c This subroutine calculates the total kinetic energy of the chain +c----------------------------------------------------------------- + implicit none + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif + include 'COMMON.IOUNITS' + double precision KE_total + + integer i,j,k,iti + double precision KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3), + & mag1,mag2,v(3) + + KEt_p=0.0d0 + KEt_sc=0.0d0 +c write (iout,*) "ISC",(isc(itype(i)),i=1,nres) +c The translational part for peptide virtual bonds + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct-1 +c write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3) + do j=1,3 + v(j)=incr(j)+0.5d0*d_t(j,i) + enddo + vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) + KEt_p=KEt_p+(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo +c write(iout,*) 'KEt_p', KEt_p +c The translational part for the side chain virtual bond +c Only now we can initialize incr with zeros. It must be equal +c to the velocities of the first Calpha. + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct + iti=iabs(itype(i)) + if (itype(i).eq.10) then + do j=1,3 + v(j)=incr(j) + enddo + else + do j=1,3 + v(j)=incr(j)+d_t(j,nres+i) + enddo + endif +c write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3) +c write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3) + KEt_sc=KEt_sc+msc(iti)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) + vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo +c goto 111 +c write(iout,*) 'KEt_sc', KEt_sc +c The part due to stretching and rotation of the peptide groups + KEr_p=0.0D0 + do i=nnt,nct-1 +c write (iout,*) "i",i +c write (iout,*) "i",i," mag1",mag1," mag2",mag2 + do j=1,3 + incr(j)=d_t(j,i) + enddo +c write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3) + KEr_p=KEr_p+(incr(1)*incr(1)+incr(2)*incr(2) + & +incr(3)*incr(3)) + enddo +c goto 111 +c write(iout,*) 'KEr_p', KEr_p +c The rotational part of the side chain virtual bond + KEr_sc=0.0D0 + do i=nnt,nct + iti=iabs(itype(i)) + if (itype(i).ne.10) then + do j=1,3 + incr(j)=d_t(j,nres+i) + enddo +c write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3) + KEr_sc=KEr_sc+Isc(iti)*(incr(1)*incr(1)+incr(2)*incr(2)+ + & incr(3)*incr(3)) + endif + enddo +c The total kinetic energy + 111 continue +c write(iout,*) 'KEr_sc', KEr_sc + KE_total=0.5d0*(mp*KEt_p+KEt_sc+0.25d0*Ip*KEr_p+KEr_sc) +c write (iout,*) "KE_total",KE_total + return + end + + + + diff --git a/source/unres/src-HCD-5D/lagrangian_lesyng.optrpt b/source/unres/src-HCD-5D/lagrangian_lesyng.optrpt new file mode 100644 index 0000000..e69de29 diff --git a/source/unres/src-HCD-5D/lbfgs.F b/source/unres/src-HCD-5D/lbfgs.F new file mode 100644 index 0000000..dabcbb3 --- /dev/null +++ b/source/unres/src-HCD-5D/lbfgs.F @@ -0,0 +1,434 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1999 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ############################################################## +c ## ## +c ## subroutine lbfgs -- limited memory BFGS optimization ## +c ## ## +c ############################################################## +c +c +c "lbfgs" is a limited memory BFGS quasi-newton nonlinear +c optimization routine +c +c literature references: +c +c J. Nocedal, "Updating Quasi-Newton Matrices with Limited +c Storage", Mathematics of Computation, 35, 773-782 (1980) +c +c D. C. Lui and J. Nocedal, "On the Limited Memory BFGS Method +c for Large Scale Optimization", Mathematical Programming, +c 45, 503-528 (1989) +c +c J. Nocedal and S. J. Wright, "Numerical Optimization", +c Springer-Verlag, New York, 1999, Section 9.1 +c +c variables and parameters: +c +c nvar number of parameters in the objective function +c x0 contains starting point upon input, upon return +c contains the best point found +c minimum during optimization contains best current function +c value; returns final best function value +c grdmin normal exit if rms gradient gets below this value +c ncalls total number of function/gradient evaluations +c +c required external routines: +c +c fgvalue function to evaluate function and gradient values +c optsave subroutine to write out info about current status +c +c + subroutine lbfgs (nvar,x0,minimum,grdmin,fgvalue,optsave) + use inform + use iounit + use keys + use linmin + use math + use minima + use output + use scales + implicit none + integer i,j,k,m + integer nvar,next + integer msav,muse + integer niter,ncalls + integer nerr,maxerr + real*8 f,f_old,fgvalue + real*8 f_move,x_move + real*8 g_norm,g_rms + real*8 minimum,grdmin + real*8 angle,rms,beta + real*8 ys,yy,gamma + real*8 x0(*) + real*8, allocatable :: rho(:) + real*8, allocatable :: alpha(:) + real*8, allocatable :: x_old(:) + real*8, allocatable :: g(:) + real*8, allocatable :: g_old(:) + real*8, allocatable :: p(:) + real*8, allocatable :: q(:) + real*8, allocatable :: r(:) + real*8, allocatable :: h0(:) + real*8, allocatable :: s(:,:) + real*8, allocatable :: y(:,:) + logical done + character*9 blank,status + character*20 keyword + character*240 record + character*240 string + external fgvalue,optsave + common /lbfgstat/ status,niter,ncalls +c +c +c initialize some values to be used below +c + ncalls = 0 + rms = sqrt(dble(nvar)) + if (coordtype .eq. 'CARTESIAN') then + rms = rms / sqrt(3.0d0) + else if (coordtype .eq. 'RIGIDBODY') then + rms = rms / sqrt(6.0d0) + end if + blank = ' ' + done = .false. + nerr = 0 + maxerr = 2 +c +c perform dynamic allocation of some global arrays +c + if (.not. allocated(scale)) allocate (scale(nvar)) +c +c set default values for variable scale factors +c + if (.not. set_scale) then + do i = 1, nvar + if (scale(i) .eq. 0.0d0) scale(i) = 1.0d0 + end do + end if +c +c set default parameters for the optimization +c + msav = min(nvar,20) + if (fctmin .eq. 0.0d0) fctmin = -100000000.0d0 + if (maxiter .eq. 0) maxiter = 1000000 + if (nextiter .eq. 0) nextiter = 1 + if (jprint .lt. 0) jprint = 1 + if (iwrite .lt. 0) iwrite = 1 +c +c set default parameters for the line search +c + if (stpmax .eq. 0.0d0) stpmax = 5.0d0 + stpmin = 1.0d-16 + cappa = 0.9d0 + slpmax = 10000.0d0 + angmax = 180.0d0 + intmax = 5 +c +c search the keywords for optimization parameters +c +#ifdef LBFGSREAD + do i = 1, nkey + next = 1 + record = keyline(i) + call gettext (record,keyword,next) + call upcase (keyword) + string = record(next:240) + if (keyword(1:14) .eq. 'LBFGS-VECTORS ') then + read (string,*,err=10,end=10) msav + msav = max(0,min(msav,nvar)) + else if (keyword(1:17) .eq. 'STEEPEST-DESCENT ') then + msav = 0 + else if (keyword(1:7) .eq. 'FCTMIN ') then + read (string,*,err=10,end=10) fctmin + else if (keyword(1:8) .eq. 'MAXITER ') then + read (string,*,err=10,end=10) maxiter + else if (keyword(1:8) .eq. 'STEPMAX ') then + read (string,*,err=10,end=10) stpmax + else if (keyword(1:8) .eq. 'STEPMIN ') then + read (string,*,err=10,end=10) stpmin + else if (keyword(1:6) .eq. 'CAPPA ') then + read (string,*,err=10,end=10) cappa + else if (keyword(1:9) .eq. 'SLOPEMAX ') then + read (string,*,err=10,end=10) slpmax + else if (keyword(1:7) .eq. 'ANGMAX ') then + read (string,*,err=10,end=10) angmax + else if (keyword(1:7) .eq. 'INTMAX ') then + read (string,*,err=10,end=10) intmax + end if + 10 continue + end do +#endif +c +c print header information about the optimization method +c + if (jprint .gt. 0) then + if (msav .eq. 0) then + write (jout,20) + 20 format (/,' Steepest Descent Gradient Optimization :') + write (jout,30) + 30 format (/,' SD Iter F Value G RMS F Move', + & ' X Move Angle FG Call Comment',/) + else + write (jout,40) + 40 format (/,' Limited Memory BFGS Quasi-Newton', + & ' Optimization :') + write (jout,50) + 50 format (/,' QN Iter F Value G RMS F Move', + & ' X Move Angle FG Call Comment',/) + end if + flush (jout) + end if +c +c perform dynamic allocation of some local arrays +c + allocate (x_old(nvar)) + allocate (g(nvar)) + allocate (g_old(nvar)) + allocate (p(nvar)) + allocate (q(nvar)) + allocate (r(nvar)) + allocate (h0(nvar)) + if (msav .ne. 0) then + allocate (rho(msav)) + allocate (alpha(msav)) + allocate (s(nvar,msav)) + allocate (y(nvar,msav)) + end if +c +c evaluate the function and get the initial gradient +c + niter = nextiter - 1 + maxiter = niter + maxiter + ncalls = ncalls + 1 + f = fgvalue (x0,g) + f_old = f + m = 0 + gamma = 1.0d0 + g_norm = 0.0d0 + g_rms = 0.0d0 + do i = 1, nvar + g_norm = g_norm + g(i)*g(i) + g_rms = g_rms + (g(i)*scale(i))**2 + end do + g_norm = sqrt(g_norm) + g_rms = sqrt(g_rms) / rms + f_move = 0.5d0 * stpmax * g_norm +c +c print initial information prior to first iteration +c + if (jprint .gt. 0) then + if (f.lt.1.0d8 .and. f.gt.-1.0d7 .and. g_rms.lt.1.0d5) then + write (jout,60) niter,f,g_rms,ncalls + 60 format (i6,f14.4,f11.4,29x,i7) + else + write (jout,70) niter,f,g_rms,ncalls + 70 format (i6,d14.4,d11.4,29x,i7) + end if + flush (jout) + end if +c +c write initial intermediate prior to first iteration +c + if (iwrite .gt. 0) call optsave (niter,f,x0) +c +c tests of the various termination criteria +c + if (niter .ge. maxiter) then + status = 'IterLimit' + done = .true. + end if + if (f .le. fctmin) then + status = 'SmallFct ' + done = .true. + end if + if (g_rms .le. grdmin) then + status = 'SmallGrad' + done = .true. + end if +c +c start of a new limited memory BFGS iteration +c + do while (.not. done) + niter = niter + 1 +c write (jout,*) "LBFGS niter",niter + muse = min(niter-1,msav) + m = m + 1 + if (m .gt. msav) m = 1 +c +c estimate Hessian diagonal and compute the Hg product +c + do i = 1, nvar + h0(i) = gamma + q(i) = g(i) + end do + k = m + do j = 1, muse + k = k - 1 + if (k .eq. 0) k = msav + alpha(k) = 0.0d0 + do i = 1, nvar + alpha(k) = alpha(k) + s(i,k)*q(i) + end do + alpha(k) = alpha(k) * rho(k) + do i = 1, nvar + q(i) = q(i) - alpha(k)*y(i,k) + end do + end do + do i = 1, nvar + r(i) = h0(i) * q(i) + end do + do j = 1, muse + beta = 0.0d0 + do i = 1, nvar + beta = beta + y(i,k)*r(i) + end do + beta = beta * rho(k) + do i = 1, nvar + r(i) = r(i) + s(i,k)*(alpha(k)-beta) + end do + k = k + 1 + if (k .gt. msav) k = 1 + end do +c +c set search direction and store current point and gradient +c + do i = 1, nvar + p(i) = -r(i) + x_old(i) = x0(i) + g_old(i) = g(i) + end do +c +c perform line search along the new conjugate direction +c + status = blank +c write (jout,*) "Before search" + call search (nvar,f,g,x0,p,f_move,angle,ncalls,fgvalue,status) +c write (jout,*) "After search" +c +c update variables based on results of this iteration +c + if (msav .ne. 0) then + ys = 0.0d0 + yy = 0.0d0 + do i = 1, nvar + s(i,m) = x0(i) - x_old(i) + y(i,m) = g(i) - g_old(i) + ys = ys + y(i,m)*s(i,m) + yy = yy + y(i,m)*y(i,m) + end do + gamma = abs(ys/yy) + rho(m) = 1.0d0 / ys + end if +c +c get the sizes of the moves made during this iteration +c + f_move = f_old - f + f_old = f + x_move = 0.0d0 + do i = 1, nvar + x_move = x_move + ((x0(i)-x_old(i))/scale(i))**2 + end do + x_move = sqrt(x_move) / rms + if (coordtype .eq. 'INTERNAL') then + x_move = radian * x_move + end if +c +c compute the rms gradient per optimization parameter +c + g_rms = 0.0d0 + do i = 1, nvar + g_rms = g_rms + (g(i)*scale(i))**2 + end do + g_rms = sqrt(g_rms) / rms +c +c test for error due to line search problems +c + if (status.eq.'BadIntpln' .or. status.eq.'IntplnErr') then + nerr = nerr + 1 + if (nerr .ge. maxerr) done = .true. + else + nerr = 0 + end if +c +c test for too many total iterations +c + if (niter .ge. maxiter) then + status = 'IterLimit' + done = .true. + end if +c +c test the normal termination criteria +c + if (f .le. fctmin) then + status = 'SmallFct ' + done = .true. + end if + if (g_rms .le. grdmin) then + status = 'SmallGrad' + done = .true. + end if +c +c print intermediate results for the current iteration +c + if (jprint .gt. 0) then + if (done .or. mod(niter,jprint).eq.0) then + if (f.lt.1.0d8 .and. f.gt.-1.0d7 .and. + & g_rms.lt.1.0d5 .and. f_move.lt.1.0d6 .and. + & f_move.gt.-1.0d5) then + write (jout,80) niter,f,g_rms,f_move,x_move, + & angle,ncalls,status + 80 format (i6,f14.4,f11.4,f12.4,f9.4,f8.2,i7,3x,a9) + else + write (jout,90) niter,f,g_rms,f_move,x_move, + & angle,ncalls,status + 90 format (i6,d14.4,d11.4,d12.4,f9.4,f8.2,i7,3x,a9) + end if + end if + flush (jout) + end if +c +c write intermediate results for the current iteration +c + if (iwrite .gt. 0) then + if (done .or. mod(niter,iwrite).eq.0) then + call optsave (niter,f,x0) + end if + end if + end do +c +c perform deallocation of some local arrays +c + deallocate (x_old) + deallocate (g) + deallocate (g_old) + deallocate (p) + deallocate (q) + deallocate (r) + deallocate (h0) + if (msav .ne. 0) then + deallocate (rho) + deallocate (alpha) + deallocate (s) + deallocate (y) + end if +c +c set final value of the objective function +c + minimum = f + if (jprint .gt. 0) then + if (status.eq.'SmallGrad' .or. status.eq.'SmallFct ') then + write (jout,100) status + 100 format (/,' LBFGS -- Normal Termination due to ',a9) + else + write (jout,110) status + 110 format (/,' LBFGS -- Incomplete Convergence due to ',a9) + end if + flush (jout) + end if + return + end diff --git a/source/unres/src-HCD-5D/linmin.f b/source/unres/src-HCD-5D/linmin.f new file mode 100644 index 0000000..ac28d03 --- /dev/null +++ b/source/unres/src-HCD-5D/linmin.f @@ -0,0 +1,32 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1992 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ############################################################## +c ## ## +c ## module linmin -- line search minimization parameters ## +c ## ## +c ############################################################## +c +c +c stpmin minimum step length in current line search direction +c stpmax maximum step length in current line search direction +c cappa stringency of line search (0=tight < cappa < 1=loose) +c slpmax projected gradient above which stepsize is reduced +c angmax maximum angle between search direction and -gradient +c intmax maximum number of interpolations during line search +c +c + module linmin + implicit none + integer intmax + real*8 stpmin + real*8 stpmax + real*8 cappa + real*8 slpmax + real*8 angmax + save + end diff --git a/source/unres/src-HCD-5D/machpd.f b/source/unres/src-HCD-5D/machpd.f new file mode 100644 index 0000000..b5e62e6 --- /dev/null +++ b/source/unres/src-HCD-5D/machpd.f @@ -0,0 +1,8 @@ +C[KA{F 0}{Auxiliary Library}{Auxiliary Library}*) + INTEGER FUNCTION MACHPD(X) +C[IX{MACHPD}*) + DOUBLE PRECISION X + MACHPD=0 + IF (1.0D0 .LT. X) MACHPD=1 + RETURN + END diff --git a/source/unres/src-HCD-5D/map.F b/source/unres/src-HCD-5D/map.F new file mode 100644 index 0000000..ad139c8 --- /dev/null +++ b/source/unres/src-HCD-5D/map.F @@ -0,0 +1,99 @@ + subroutine map + implicit none + include 'DIMENSIONS' + include 'COMMON.MAP' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.TORCNSTR' + double precision energia(0:n_ene) + character*5 angid(4) /'PHI','THETA','ALPHA','OMEGA'/ + double precision ang_list(10) + double precision g(maxvar),x(maxvar),gnorm,etot + integer i,ii,iii,j,k,nf,nfun,iretcode,nmax,ntot + integer uiparm(1) + double precision urparm(1),fdum + external fdum + double precision funcgrad,ff + external funcgrad + integer nn(10) + write (iout,'(a,i3,a)')'Energy map constructed in the following ', + & nmap,' groups of variables:' + do i=1,nmap + write (iout,'(2a,i3,a,i3)') angid(kang(i)),' of residues ', + & res1(i),' to ',res2(i) + enddo + nmax=nstep(1) + do i=2,nmap + if (nmax.lt.nstep(i)) nmax=nstep(i) + enddo + ntot=nmax**nmap + iii=0 + write (istat,'(1h#,a14,29a15)') (" ",k=1,nmap), + & (ename(print_order(k)),k=1,nprint_ene),"ETOT","GNORM" + do i=0,ntot-1 + ii=i + do j=1,nmap + nn(j)=mod(ii,nmax)+1 + ii=ii/nmax + enddo + do j=1,nmap + if (nn(j).gt.nstep(j)) goto 10 + enddo + iii=iii+1 +Cd write (iout,*) i,iii,(nn(j),j=1,nmap) + do j=1,nmap + ang_list(j)=ang_from(j) + & +(nn(j)-1)*(ang_to(j)-ang_from(j))/nstep(j) + do k=res1(j),res2(j) + goto (1,2,3,4), kang(j) + 1 phi(k)=deg2rad*ang_list(j) + if (minim) phi0(k-res1(j)+1)=deg2rad*ang_list(j) + goto 5 + 2 theta(k)=deg2rad*ang_list(j) + goto 5 + 3 alph(k)=deg2rad*ang_list(j) + goto 5 + 4 omeg(k)=deg2rad*ang_list(j) + 5 continue + enddo ! k + enddo ! j + call chainbuild + if (minim) then + call geom_to_var(nvar,x) + call minimize(etot,x,iretcode,nfun) + print *,'SUMSL return code is',iretcode,' eval ',nfun +c call intout + else + call zerograd + call geom_to_var(nvar,x) + endif + call etotal(energia(0)) + etot = energia(0) + nf=1 + nfl=3 +#ifdef LBFGS + ff=funcgrad(x,g) +#else + call gradient(nvar,x,nf,g,uiparm,urparm,fdum) +#endif + gnorm=0.0d0 + do k=1,nvar + gnorm=gnorm+g(k)**2 + enddo + etot=energia(0) + + gnorm=dsqrt(gnorm) +c write (iout,'(6(1pe15.5))') (ang_list(k),k=1,nmap),etot,gnorm + write (istat,'(30e15.5)') (ang_list(k),k=1,nmap), + & (energia(print_order(ii)),ii=1,nprint_ene),etot,gnorm +c write (iout,*) 'POINT',I,' ANGLES:',(ang_list(k),k=1,nmap) +c call intout +c call enerprint(energia) + 10 continue + enddo ! i + return + end diff --git a/source/unres/src-HCD-5D/math.f b/source/unres/src-HCD-5D/math.f new file mode 100644 index 0000000..e340081 --- /dev/null +++ b/source/unres/src-HCD-5D/math.f @@ -0,0 +1,40 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1992 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ############################################################### +c ## ## +c ## module math -- mathematical and geometrical constants ## +c ## ## +c ############################################################### +c +c +c pi numerical value of the geometric constant +c elog numerical value of the natural logarithm base +c radian conversion factor from radians to degrees +c logten numerical value of the natural log of ten +c twosix numerical value of the sixth root of two +c sqrtpi numerical value of the square root of Pi +c sqrttwo numerical value of the square root of two +c sqrtthree numerical value of the square root of three +c +c + module math + implicit none + real*8 pi,elog + real*8 radian,logten + real*8 twosix,sqrtpi + real*8 sqrttwo,sqrtthree + parameter (pi=3.141592653589793238d0) + parameter (elog=2.718281828459045235d0) + parameter (radian=57.29577951308232088d0) + parameter (logten=2.302585092994045684d0) + parameter (twosix=1.122462048309372981d0) + parameter (sqrtpi=1.772453850905516027d0) + parameter (sqrttwo=1.414213562373095049d0) + parameter (sqrtthree=1.732050807568877294d0) + save + end diff --git a/source/unres/src-HCD-5D/minima.f b/source/unres/src-HCD-5D/minima.f new file mode 100644 index 0000000..ffab0b6 --- /dev/null +++ b/source/unres/src-HCD-5D/minima.f @@ -0,0 +1,28 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1992 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ############################################################### +c ## ## +c ## module minima -- general parameters for minimizations ## +c ## ## +c ############################################################### +c +c +c fctmin value below which function is deemed optimized +c hguess initial value for the H-matrix diagonal elements +c maxiter maximum number of iterations during optimization +c nextiter iteration number to use for the first iteration +c +c + module minima + implicit none + integer maxiter + integer nextiter + real*8 fctmin + real*8 hguess + save + end diff --git a/source/unres/src-HCD-5D/moments.F b/source/unres/src-HCD-5D/moments.F new file mode 100644 index 0000000..4f57331 --- /dev/null +++ b/source/unres/src-HCD-5D/moments.F @@ -0,0 +1,723 @@ +#ifdef FIVEDIAG + subroutine inertia_tensor +c Calculating the intertia tensor for the entire protein in order to +c remove the perpendicular components of velocity matrix which cause +c the molecule to rotate. + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + + double precision Im(3,3),Imcp(3,3),cm(3),pr(3),M_SC, + & eigvec(3,3),Id(3,3),eigval(3),L(3),vp(3),vrot(3), + & vpp(3,0:MAXRES),vs_p(3),pr1(3,3), + & pr2(3,3),pp(3),incr(3),v(3),mag,mag2 + common /gucio/ cm + integer iti,inres,i,j,k + do i=1,3 + do j=1,3 + Im(i,j)=0.0d0 + pr1(i,j)=0.0d0 + pr2(i,j)=0.0d0 + enddo + L(i)=0.0d0 + cm(i)=0.0d0 + vrot(i)=0.0d0 + enddo +c caulating the center of the mass of the protein + do i=nnt,nct-1 + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + do j=1,3 + cm(j)=cm(j)+c(j,i)+0.5d0*dc(j,i) + enddo + enddo + do j=1,3 + cm(j)=mp*cm(j) + enddo + M_SC=0.0d0 + do i=nnt,nct + iti=iabs(itype(i)) + if (iti.eq.ntyp1) cycle + M_SC=M_SC+msc(iabs(iti)) + inres=i+nres + do j=1,3 + cm(j)=cm(j)+msc(iabs(iti))*c(j,inres) + enddo + enddo + do j=1,3 + cm(j)=cm(j)/(M_SC+dimenp*mp) + enddo + + do i=nnt,nct-1 + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + do j=1,3 + pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) + enddo + Im(1,1)=Im(1,1)+mp*(pr(2)*pr(2)+pr(3)*pr(3)) + Im(1,2)=Im(1,2)-mp*pr(1)*pr(2) + Im(1,3)=Im(1,3)-mp*pr(1)*pr(3) + Im(2,3)=Im(2,3)-mp*pr(2)*pr(3) + Im(2,2)=Im(2,2)+mp*(pr(3)*pr(3)+pr(1)*pr(1)) + Im(3,3)=Im(3,3)+mp*(pr(1)*pr(1)+pr(2)*pr(2)) + enddo + + do i=nnt,nct + iti=iabs(itype(i)) + if (iti.eq.ntyp1) cycle + inres=i+nres + do j=1,3 + pr(j)=c(j,inres)-cm(j) + enddo + Im(1,1)=Im(1,1)+msc(iabs(iti))*(pr(2)*pr(2)+pr(3)*pr(3)) + Im(1,2)=Im(1,2)-msc(iabs(iti))*pr(1)*pr(2) + Im(1,3)=Im(1,3)-msc(iabs(iti))*pr(1)*pr(3) + Im(2,3)=Im(2,3)-msc(iabs(iti))*pr(2)*pr(3) + Im(2,2)=Im(2,2)+msc(iabs(iti))*(pr(3)*pr(3)+pr(1)*pr(1)) + Im(3,3)=Im(3,3)+msc(iabs(iti))*(pr(1)*pr(1)+pr(2)*pr(2)) + enddo + + do i=nnt,nct-1 + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + Im(1,1)=Im(1,1)+Ip*(1-dc_norm(1,i)*dc_norm(1,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(1,2)=Im(1,2)+Ip*(-dc_norm(1,i)*dc_norm(2,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(1,3)=Im(1,3)+Ip*(-dc_norm(1,i)*dc_norm(3,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(2,3)=Im(2,3)+Ip*(-dc_norm(2,i)*dc_norm(3,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(2,2)=Im(2,2)+Ip*(1-dc_norm(2,i)*dc_norm(2,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(3,3)=Im(3,3)+Ip*(1-dc_norm(3,i)*dc_norm(3,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + enddo + do i=nnt,nct + iti=iabs(itype(i)) + if (iti.ne.10 .and. iti.ne.ntyp1) then + inres=i+nres + Im(1,1)=Im(1,1)+Isc(iti)*(1-dc_norm(1,inres)* + & dc_norm(1,inres))*vbld(inres)*vbld(inres) + Im(1,2)=Im(1,2)-Isc(iti)*(dc_norm(1,inres)* + & dc_norm(2,inres))*vbld(inres)*vbld(inres) + Im(1,3)=Im(1,3)-Isc(iti)*(dc_norm(1,inres)* + & dc_norm(3,inres))*vbld(inres)*vbld(inres) + Im(2,3)=Im(2,3)-Isc(iti)*(dc_norm(2,inres)* + & dc_norm(3,inres))*vbld(inres)*vbld(inres) + Im(2,2)=Im(2,2)+Isc(iti)*(1-dc_norm(2,inres)* + & dc_norm(2,inres))*vbld(inres)*vbld(inres) + Im(3,3)=Im(3,3)+Isc(iti)*(1-dc_norm(3,inres)* + & dc_norm(3,inres))*vbld(inres)*vbld(inres) + endif + enddo + + call angmom(cm,L) +c write(iout,*) "The angular momentum before adjustment:" +c write(iout,*) (L(j),j=1,3) + + Im(2,1)=Im(1,2) + Im(3,1)=Im(1,3) + Im(3,2)=Im(2,3) + +c Copng the Im matrix for the djacob subroutine + do i=1,3 + do j=1,3 + Imcp(i,j)=Im(i,j) + Id(i,j)=0.0d0 + enddo + enddo +c Finding the eigenvectors and eignvalues of the inertia tensor + call djacob(3,3,10000,1.0d-10,Imcp,eigvec,eigval) +c write (iout,*) "Eigenvalues & Eigenvectors" +c write (iout,'(5x,3f10.5)') (eigval(i),i=1,3) +c write (iout,*) +c do i=1,3 +c write (iout,'(i5,3f10.5)') i,(eigvec(i,j),j=1,3) +c enddo +c Constructing the diagonalized matrix + do i=1,3 + if (dabs(eigval(i)).gt.1.0d-15) then + Id(i,i)=1.0d0/eigval(i) + else + Id(i,i)=0.0d0 + endif + enddo + do i=1,3 + do j=1,3 + Imcp(i,j)=eigvec(j,i) + enddo + enddo + do i=1,3 + do j=1,3 + do k=1,3 + pr1(i,j)=pr1(i,j)+Id(i,k)*Imcp(k,j) + enddo + enddo + enddo + do i=1,3 + do j=1,3 + do k=1,3 + pr2(i,j)=pr2(i,j)+eigvec(i,k)*pr1(k,j) + enddo + enddo + enddo +c Calculating the total rotational velocity of the molecule + do i=1,3 + do j=1,3 + vrot(i)=vrot(i)+pr2(i,j)*L(j) + enddo + enddo +c Resetting the velocities +#ifdef FIVEDIAG + do i=nnt,nct-1 + write (iout,*) itype(i+1),itype(i) + if (itype(i+1).ne.ntyp1 .and. itype(i).eq.ntyp1 .or. + & itype(i).ne.ntyp1 .and. itype(i+1).eq.ntyp1) cycle + call vecpr(vrot(1),dc(1,i),vp) + do j=1,3 + d_t(j,i)=d_t(j,i)-vp(j) + enddo + enddo +#else + do i=nnt,nct-1 + call vecpr(vrot(1),dc(1,i),vp) + do j=1,3 + d_t(j,i)=d_t(j,i)-vp(j) + enddo + enddo +#endif + do i=nnt,nct + if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + call vecpr(vrot(1),dc(1,inres),vp) + do j=1,3 + d_t(j,inres)=d_t(j,inres)-vp(j) + enddo + endif + enddo + call angmom(cm,L) +c write(iout,*) "The angular momentum after adjustment:" +c write(iout,*) (L(j),j=1,3) + return + end +c---------------------------------------------------------------------------- + subroutine angmom(cm,L) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + double precision L(3),cm(3),pr(3),vp(3),vrot(3),incr(3),v(3), + & pp(3) + integer iti,inres,i,j +c Calculate the angular momentum + do j=1,3 + L(j)=0.0d0 + enddo + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct-1 + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + do j=1,3 + pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) + enddo + do j=1,3 + v(j)=incr(j)+0.5d0*d_t(j,i) + enddo + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + call vecpr(pr(1),v(1),vp) + do j=1,3 + L(j)=L(j)+mp*vp(j) + enddo + do j=1,3 + pr(j)=0.5d0*dc(j,i) + pp(j)=0.5d0*d_t(j,i) + enddo + call vecpr(pr(1),pp(1),vp) + do j=1,3 + L(j)=L(j)+Ip*vp(j) + enddo + enddo + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct + iti=iabs(itype(i)) + inres=i+nres + do j=1,3 + pr(j)=c(j,inres)-cm(j) + enddo + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + v(j)=incr(j)+d_t(j,inres) + enddo + else + do j=1,3 + v(j)=incr(j) + enddo + endif + call vecpr(pr(1),v(1),vp) +c write (iout,*) "i",i," iti",iti," pr",(pr(j),j=1,3), +c & " v",(v(j),j=1,3)," vp",(vp(j),j=1,3) + do j=1,3 + L(j)=L(j)+msc(iabs(iti))*vp(j) + enddo +c write (iout,*) "L",(l(j),j=1,3) + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + v(j)=incr(j)+d_t(j,inres) + enddo + call vecpr(dc(1,inres),d_t(1,inres),vp) + do j=1,3 + L(j)=L(j)+Isc(iti)*vp(j) + enddo + endif + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo + return + end +c------------------------------------------------------------------------------ + subroutine vcm_vel(vcm) + implicit none + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + double precision vcm(3),vv(3),summas,amas + integer i,j + do j=1,3 + vcm(j)=0.0d0 + vv(j)=d_t(j,0) + enddo + summas=0.0d0 + do i=nnt,nct + if (i.lt.nct) then + summas=summas+mp + do j=1,3 + vcm(j)=vcm(j)+mp*(vv(j)+0.5d0*d_t(j,i)) + enddo + endif + amas=msc(iabs(itype(i))) + summas=summas+amas + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + vcm(j)=vcm(j)+amas*(vv(j)+d_t(j,i+nres)) + enddo + else + do j=1,3 + vcm(j)=vcm(j)+amas*vv(j) + enddo + endif + do j=1,3 + vv(j)=vv(j)+d_t(j,i) + enddo + enddo +c write (iout,*) "vcm",(vcm(j),j=1,3)," summas",summas + do j=1,3 + vcm(j)=vcm(j)/summas + enddo + return + end +#else + subroutine inertia_tensor +c Calculating the intertia tensor for the entire protein in order to +c remove the perpendicular components of velocity matrix which cause +c the molecule to rotate. + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + + double precision Im(3,3),Imcp(3,3),cm(3),pr(3),M_SC, + & eigvec(3,3),Id(3,3),eigval(3),L(3),vp(3),vrot(3), + & vpp(3,0:MAXRES),vs_p(3),pr1(3,3), + & pr2(3,3),pp(3),incr(3),v(3),mag,mag2 + common /gucio/ cm + integer iti,inres,i,j,k + do i=1,3 + do j=1,3 + Im(i,j)=0.0d0 + pr1(i,j)=0.0d0 + pr2(i,j)=0.0d0 + enddo + L(i)=0.0d0 + cm(i)=0.0d0 + vrot(i)=0.0d0 + enddo +c calculating the center of the mass of the protein + do i=nnt,nct-1 + do j=1,3 + cm(j)=cm(j)+c(j,i)+0.5d0*dc(j,i) + enddo + enddo + do j=1,3 + cm(j)=mp*cm(j) + enddo + M_SC=0.0d0 + do i=nnt,nct + iti=iabs(itype(i)) + M_SC=M_SC+msc(iabs(iti)) + inres=i+nres + do j=1,3 + cm(j)=cm(j)+msc(iabs(iti))*c(j,inres) + enddo + enddo + do j=1,3 + cm(j)=cm(j)/(M_SC+(nct-nnt)*mp) + enddo + + do i=nnt,nct-1 + do j=1,3 + pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) + enddo + Im(1,1)=Im(1,1)+mp*(pr(2)*pr(2)+pr(3)*pr(3)) + Im(1,2)=Im(1,2)-mp*pr(1)*pr(2) + Im(1,3)=Im(1,3)-mp*pr(1)*pr(3) + Im(2,3)=Im(2,3)-mp*pr(2)*pr(3) + Im(2,2)=Im(2,2)+mp*(pr(3)*pr(3)+pr(1)*pr(1)) + Im(3,3)=Im(3,3)+mp*(pr(1)*pr(1)+pr(2)*pr(2)) + enddo + + do i=nnt,nct + iti=iabs(itype(i)) + inres=i+nres + do j=1,3 + pr(j)=c(j,inres)-cm(j) + enddo + Im(1,1)=Im(1,1)+msc(iabs(iti))*(pr(2)*pr(2)+pr(3)*pr(3)) + Im(1,2)=Im(1,2)-msc(iabs(iti))*pr(1)*pr(2) + Im(1,3)=Im(1,3)-msc(iabs(iti))*pr(1)*pr(3) + Im(2,3)=Im(2,3)-msc(iabs(iti))*pr(2)*pr(3) + Im(2,2)=Im(2,2)+msc(iabs(iti))*(pr(3)*pr(3)+pr(1)*pr(1)) + Im(3,3)=Im(3,3)+msc(iabs(iti))*(pr(1)*pr(1)+pr(2)*pr(2)) + enddo + + do i=nnt,nct-1 + Im(1,1)=Im(1,1)+Ip*(1-dc_norm(1,i)*dc_norm(1,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(1,2)=Im(1,2)+Ip*(-dc_norm(1,i)*dc_norm(2,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(1,3)=Im(1,3)+Ip*(-dc_norm(1,i)*dc_norm(3,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(2,3)=Im(2,3)+Ip*(-dc_norm(2,i)*dc_norm(3,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(2,2)=Im(2,2)+Ip*(1-dc_norm(2,i)*dc_norm(2,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + Im(3,3)=Im(3,3)+Ip*(1-dc_norm(3,i)*dc_norm(3,i))* + & vbld(i+1)*vbld(i+1)*0.25d0 + enddo + + + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + iti=iabs(itype(i)) + inres=i+nres + Im(1,1)=Im(1,1)+Isc(iti)*(1-dc_norm(1,inres)* + & dc_norm(1,inres))*vbld(inres)*vbld(inres) + Im(1,2)=Im(1,2)-Isc(iti)*(dc_norm(1,inres)* + & dc_norm(2,inres))*vbld(inres)*vbld(inres) + Im(1,3)=Im(1,3)-Isc(iti)*(dc_norm(1,inres)* + & dc_norm(3,inres))*vbld(inres)*vbld(inres) + Im(2,3)=Im(2,3)-Isc(iti)*(dc_norm(2,inres)* + & dc_norm(3,inres))*vbld(inres)*vbld(inres) + Im(2,2)=Im(2,2)+Isc(iti)*(1-dc_norm(2,inres)* + & dc_norm(2,inres))*vbld(inres)*vbld(inres) + Im(3,3)=Im(3,3)+Isc(iti)*(1-dc_norm(3,inres)* + & dc_norm(3,inres))*vbld(inres)*vbld(inres) + endif + enddo + + call angmom(cm,L) +c write(iout,*) "The angular momentum before adjustment:" +c write(iout,*) (L(j),j=1,3) + + Im(2,1)=Im(1,2) + Im(3,1)=Im(1,3) + Im(3,2)=Im(2,3) + +c Copying the Im matrix for the djacob subroutine + do i=1,3 + do j=1,3 + Imcp(i,j)=Im(i,j) + Id(i,j)=0.0d0 + enddo + enddo + +c Finding the eigenvectors and eignvalues of the inertia tensor + call djacob(3,3,10000,1.0d-10,Imcp,eigvec,eigval) +c write (iout,*) "Eigenvalues & Eigenvectors" +c write (iout,'(5x,3f10.5)') (eigval(i),i=1,3) +c write (iout,*) +c do i=1,3 +c write (iout,'(i5,3f10.5)') i,(eigvec(i,j),j=1,3) +c enddo +c Constructing the diagonalized matrix + do i=1,3 + if (dabs(eigval(i)).gt.1.0d-15) then + Id(i,i)=1.0d0/eigval(i) + else + Id(i,i)=0.0d0 + endif + enddo + do i=1,3 + do j=1,3 + Imcp(i,j)=eigvec(j,i) + enddo + enddo + do i=1,3 + do j=1,3 + do k=1,3 + pr1(i,j)=pr1(i,j)+Id(i,k)*Imcp(k,j) + enddo + enddo + enddo + do i=1,3 + do j=1,3 + do k=1,3 + pr2(i,j)=pr2(i,j)+eigvec(i,k)*pr1(k,j) + enddo + enddo + enddo +c Calculating the total rotational velocity of the molecule + do i=1,3 + do j=1,3 + vrot(i)=vrot(i)+pr2(i,j)*L(j) + enddo + enddo +c Resetting the velocities + do i=nnt,nct-1 + call vecpr(vrot(1),dc(1,i),vp) + do j=1,3 + d_t(j,i)=d_t(j,i)-vp(j) + enddo + enddo + do i=nnt,nct + if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then + inres=i+nres + call vecpr(vrot(1),dc(1,inres),vp) + do j=1,3 + d_t(j,inres)=d_t(j,inres)-vp(j) + enddo + endif + enddo + call angmom(cm,L) +c write(iout,*) "The angular momentum after adjustment:" +c write(iout,*) (L(j),j=1,3) + return + end +c---------------------------------------------------------------------------- + subroutine angmom(cm,L) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + + double precision L(3),cm(3),pr(3),vp(3),vrot(3),incr(3),v(3), + & pp(3) + integer iti,inres,i,j +c Calculate the angular momentum + do j=1,3 + L(j)=0.0d0 + enddo + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct-1 + do j=1,3 + pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) + enddo + do j=1,3 + v(j)=incr(j)+0.5d0*d_t(j,i) + enddo + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + call vecpr(pr(1),v(1),vp) + do j=1,3 + L(j)=L(j)+mp*vp(j) + enddo + do j=1,3 + pr(j)=0.5d0*dc(j,i) + pp(j)=0.5d0*d_t(j,i) + enddo + call vecpr(pr(1),pp(1),vp) + do j=1,3 + L(j)=L(j)+Ip*vp(j) + enddo + enddo + do j=1,3 + incr(j)=d_t(j,0) + enddo + do i=nnt,nct + iti=iabs(itype(i)) + inres=i+nres + do j=1,3 + pr(j)=c(j,inres)-cm(j) + enddo + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + v(j)=incr(j)+d_t(j,inres) + enddo + else + do j=1,3 + v(j)=incr(j) + enddo + endif + call vecpr(pr(1),v(1),vp) +c write (iout,*) "i",i," iti",iti," pr",(pr(j),j=1,3), +c & " v",(v(j),j=1,3)," vp",(vp(j),j=1,3) + do j=1,3 + L(j)=L(j)+msc(iabs(iti))*vp(j) + enddo +c write (iout,*) "L",(l(j),j=1,3) + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + v(j)=incr(j)+d_t(j,inres) + enddo + call vecpr(dc(1,inres),d_t(1,inres),vp) + do j=1,3 + L(j)=L(j)+Isc(iti)*vp(j) + enddo + endif + do j=1,3 + incr(j)=incr(j)+d_t(j,i) + enddo + enddo + return + end +c------------------------------------------------------------------------------ + subroutine vcm_vel(vcm) + implicit none + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + double precision vcm(3),vv(3),summas,amas + integer i,j + do j=1,3 + vcm(j)=0.0d0 + vv(j)=d_t(j,0) + enddo + summas=0.0d0 + do i=nnt,nct + if (i.lt.nct) then + summas=summas+mp + do j=1,3 + vcm(j)=vcm(j)+mp*(vv(j)+0.5d0*d_t(j,i)) + enddo + endif + amas=msc(iabs(itype(i))) + summas=summas+amas + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + vcm(j)=vcm(j)+amas*(vv(j)+d_t(j,i+nres)) + enddo + else + do j=1,3 + vcm(j)=vcm(j)+amas*vv(j) + enddo + endif + do j=1,3 + vv(j)=vv(j)+d_t(j,i) + enddo + enddo +c write (iout,*) "vcm",(vcm(j),j=1,3)," summas",summas + do j=1,3 + vcm(j)=vcm(j)/summas + enddo + return + end +#endif diff --git a/source/unres/src-HCD-5D/muca_md.F b/source/unres/src-HCD-5D/muca_md.F new file mode 100644 index 0000000..ec89a4c --- /dev/null +++ b/source/unres/src-HCD-5D/muca_md.F @@ -0,0 +1,365 @@ + subroutine muca_delta(remd_t_bath,remd_ene,i,iex,delta) + implicit none + include 'DIMENSIONS' + include 'COMMON.MUCA' + include 'COMMON.MD' +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif + double precision remd_t_bath(maxprocs) + double precision remd_ene(maxprocs) + double precision muca_ene + double precision betai,betaiex,delta + integer i,iex + + betai=1.0/(Rb*remd_t_bath(i)) + betaiex=1.0/(Rb*remd_t_bath(iex)) + + delta=betai*(muca_ene(remd_ene(iex),i,remd_t_bath)- + & muca_ene(remd_ene(i),i,remd_t_bath)) + & -betaiex*(muca_ene(remd_ene(iex),iex,remd_t_bath)- + & muca_ene(remd_ene(i),iex,remd_t_bath)) + + return + end + + double precision function muca_ene(energy,i,remd_t_bath) + implicit none + include 'DIMENSIONS' + include 'COMMON.MUCA' + include 'COMMON.MD' +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif + double precision y,yp,energy + double precision remd_t_bath(maxprocs) + integer i + + if (energy.lt.elowi(i)) then + call splint(emuca,nemuca,nemuca2,nmuca,elowi(i),y,yp) + muca_ene=remd_t_bath(i)*Rb*(yp*(energy-elowi(i))+y) + elseif (energy.gt.ehighi(i)) then + call splint(emuca,nemuca,nemuca2,nmuca,ehighi(i),y,yp) + muca_ene=remd_t_bath(i)*Rb*(yp*(energy-ehighi(i))+y) + else + call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) + muca_ene=remd_t_bath(i)*Rb*y + endif + return + end + + subroutine read_muca + implicit none + include 'DIMENSIONS' + include 'COMMON.MUCA' + include 'COMMON.CONTROL' + include 'COMMON.MD' + include 'COMMON.REMD' + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision yp1,ypn,yp,x,muca_factor,y,muca_ene + integer i,j,k + imtime=0 + do i=1,4*maxres + hist(i)=0 + enddo + if (modecalc.eq.14.and..not.remd_tlist) then + print *,"MUCAREMD works only with TLIST" + stop + endif + open(89,file='muca.input') + read(89,*) + read(89,*) + if (modecalc.eq.14) then + read(89,*) (elowi(i),ehighi(i),i=1,nrep) + if (remd_mlist) then + k=0 + do i=1,nrep + do j=1,remd_m(i) + i2rep(k)=i + k=k+1 + enddo + enddo + elow=elowi(i2rep(me)) + ehigh=ehighi(i2rep(me)) + elowi(me+1)=elow + ehighi(me+1)=ehigh + else + elow=elowi(me+1) + ehigh=ehighi(me+1) + endif + else + read(89,*) elow,ehigh + elowi(1)=elow + ehighi(1)=ehigh + endif + i=0 + do while(.true.) + i=i+1 + read(89,*,end=100) emuca(i),nemuca(i) +cd nemuca(i)=nemuca(i)*remd_t(me+1)*Rb + enddo + 100 continue + nmuca=i-1 + hbin=emuca(nmuca)-emuca(nmuca-1) + write (iout,*) 'hbin',hbin + write (iout,*) me,'elow,ehigh',elow,ehigh + yp1=0 + ypn=0 + call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) + factor_min=0.0d0 + factor_min=muca_factor(ehigh) + call print_muca + return + end + + + subroutine print_muca + implicit none + include 'DIMENSIONS' + include 'COMMON.MUCA' + include 'COMMON.CONTROL' + include 'COMMON.MD' +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif + include 'COMMON.REMD' + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision yp1,ypn,yp,x,muca_factor,y,muca_ene + double precision dummy(maxprocs) + integer i,j,k + if (remd_mlist) then + k=0 + do i=1,nrep + do j=1,remd_m(i) + i2rep(k)=i + k=k+1 + enddo + enddo + endif + + do i=1,nmuca +c print *,'nemuca ',emuca(i),nemuca(i) + do j=0,4 + x=emuca(i)+hbin/5*j + if (modecalc.eq.14) then + if (remd_mlist) then + yp=muca_factor(x)*remd_t(i2rep(me))*Rb + dummy(me+1)=remd_t(i2rep(me)) + y=muca_ene(x,me+1,dummy) + else + yp=muca_factor(x)*remd_t(me+1)*Rb + y=muca_ene(x,me+1,remd_t) + endif + write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime, + & 'muca factor ',x,yp,' muca ene',y + else + yp=muca_factor(x)*t_bath*Rb + dummy(1)=t_bath + y=muca_ene(x,1,dummy) + write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime, + & 'muca factor ',x,yp,' muca ene',y + endif + enddo + enddo + if(mucadyn.gt.0) then + do i=1,nmuca + write(iout,'(a13,i8,2f12.5)') 'nemuca after ', + & imtime,emuca(i),nemuca(i) + enddo + endif + return + end + + subroutine muca_update(energy) + implicit none + include 'DIMENSIONS' + include 'COMMON.MUCA' + include 'COMMON.CONTROL' + include 'COMMON.MD' + include 'COMMON.REMD' + include 'COMMON.SETUP' + include 'COMMON.IOUNITS' + double precision energy + double precision yp1,ypn + integer i,j,k,ismooth,ist,ien + logical lnotend + + k=int((energy-emuca(1))/hbin)+1 + + IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN + if(energy.ge.ehigh) + & write (iout,*) 'MUCA reject',energy,emuca(k) + if(energy.ge.ehigh.and.(energy-ehigh).lt.hbin) then + write (iout,*) 'MUCA ehigh',energy,emuca(k) + do i=k,nmuca + hist(i)=hist(i)+1 + enddo + endif + if(k.gt.0.and.energy.lt.ehigh) hist(k)=hist(k)+1 + ELSE + if(k.gt.0.and.k.lt.4*maxres) hist(k)=hist(k)+1 + ENDIF + if(mod(imtime,mucadyn).eq.0) then + + do i=1,nmuca + IF(muca_smooth.eq.2.or.muca_smooth.eq.3) THEN + nemuca(i)=nemuca(i)+dlog(hist(i)+1) + ELSE + if (hist(i).gt.0) hist(i)=dlog(hist(i)) + nemuca(i)=nemuca(i)+hist(i) + ENDIF + hist(i)=0 + write(iout,'(a24,i8,2f12.5)')'nemuca before smoothing ', + & imtime,emuca(i),nemuca(i) + enddo + + + lnotend=.true. + ismooth=0 + ist=2 + ien=nmuca-1 + IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN +c lnotend=.false. +c do i=1,nmuca-1 +c do j=i+1,nmuca +c if(nemuca(j).lt.nemuca(i)) lnotend=.true. +c enddo +c enddo + do while(lnotend) + ismooth=ismooth+1 + write (iout,*) 'MUCA update smoothing',ist,ien + do i=ist,ien + nemuca(i)=(nemuca(i-1)+nemuca(i)+nemuca(i+1))/3 + enddo + lnotend=.false. + ist=0 + ien=0 + do i=1,nmuca-1 + do j=i+1,nmuca + if(nemuca(j).lt.nemuca(i)) then + lnotend=.true. + if(ist.eq.0) ist=i-1 + if(ien.lt.j+1) ien=j+1 + endif + enddo + enddo + enddo + ENDIF + + write (iout,*) 'MUCA update ',imtime,' smooth= ',ismooth + yp1=0 + ypn=0 + call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) + call print_muca + + endif + return + end + + double precision function muca_factor(energy) + implicit none + include 'DIMENSIONS' + include 'COMMON.MUCA' + double precision y,yp,energy + + if (energy.lt.elow) then + call splint(emuca,nemuca,nemuca2,nmuca,elow,y,yp) + elseif (energy.gt.ehigh) then + call splint(emuca,nemuca,nemuca2,nmuca,ehigh,y,yp) + else + call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) + endif + + if(yp.ge.factor_min) then + muca_factor=yp + else + muca_factor=factor_min + endif +cd print *,'energy, muca_factor',energy,muca_factor + return + end + + + SUBROUTINE spline(x,y,n,yp1,ypn,y2) + implicit none + INTEGER n,NMAX + REAL*8 yp1,ypn,x(n),y(n),y2(n) + PARAMETER (NMAX=500) + INTEGER i,k + REAL*8 p,qn,sig,un,u(NMAX) + if (yp1.gt..99e30) then + y2(1)=0. + u(1)=0. + else + y2(1)=-0.5 + u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + endif + do i=2,n-1 + sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) + p=sig*y2(i-1)+2. + y2(i)=(sig-1.)/p + u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) + * /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p + enddo + if (ypn.gt..99e30) then + qn=0. + un=0. + else + qn=0.5 + un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) + endif + y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) + do k=n-1,1,-1 + y2(k)=y2(k)*y2(k+1)+u(k) + enddo + return + END + + + SUBROUTINE splint(xa,ya,y2a,n,x,y,yp) + implicit none + INTEGER n + REAL*8 x,y,xa(n),y2a(n),ya(n),yp + INTEGER k,khi,klo + REAL*8 a,b,h + klo=1 + khi=n + 1 if (khi-klo.gt.1) then + k=(khi+klo)/2 + if (xa(k).gt.x) then + khi=k + else + klo=k + endif + goto 1 + endif + h=xa(khi)-xa(klo) + if (h.eq.0.) pause 'bad xa input in splint' + a=(xa(khi)-x)/h + b=(x-xa(klo))/h + y=a*ya(klo)+b*ya(khi)+ + * ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6. + yp=-ya(klo)/h+ya(khi)/h-3*(a**2)*y2a(klo)*h/6. + + +(3*(b**2)-1)*y2a(khi)*h/6. + return + END diff --git a/source/unres/src-HCD-5D/optsave.f b/source/unres/src-HCD-5D/optsave.f new file mode 100644 index 0000000..ab9d3ec --- /dev/null +++ b/source/unres/src-HCD-5D/optsave.f @@ -0,0 +1,224 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1990 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ################################################################## +c ## ## +c ## subroutine optsave -- save optimization info and results ## +c ## ## +c ################################################################## +c +c +c "optsave" is used by the optimizers to write imtermediate +c coordinates and other relevant information; also checks for +c user requested termination of an optimization +c +c + subroutine optsave (ncycle,f,xx) + use atomid + use atoms + use bound + use deriv + use files + use iounit + use math + use mpole + use omega + use output + use polar + use potent + use scales + use socket + use titles + use units + use usage + use zcoord + implicit none + integer i,j,k,lext + integer iopt,ifrc + integer iind,iend + integer ncycle,nvar + integer freeunit + integer trimtext + real*8 f,xx(*) + logical exist + character*7 ext + character*240 optfile + character*240 frcfile + character*240 indfile + character*240 endfile +c +c +c nothing to do if coordinate type is undefined +c + if (coordtype .eq. 'NONE') return +c +c check scaling factors for optimization parameters +c + if (.not. set_scale) then + set_scale = .true. + if (coordtype .eq. 'CARTESIAN') then + if (.not. allocated(scale)) allocate (scale(3*n)) + do i = 1, 3*n + scale(i) = 1.0d0 + end do + else if (coordtype .eq. 'INTERNAL') then + if (.not. allocated(scale)) allocate (scale(nomega)) + do i = 1, nomega + scale(i) = 1.0d0 + end do + end if + end if +c +c convert optimization parameters to atomic coordinates +c + if (coordtype .eq. 'CARTESIAN') then + nvar = 0 + do i = 1, n + if (use(i)) then + nvar = nvar + 1 + x(i) = xx(nvar) / scale(nvar) + nvar = nvar + 1 + y(i) = xx(nvar) / scale(nvar) + nvar = nvar + 1 + z(i) = xx(nvar) / scale(nvar) + end if + end do + if (use_bounds) call bounds + else if (coordtype .eq. 'INTERNAL') then + do i = 1, nomega + dihed(i) = xx(i) / scale(i) + ztors(zline(i)) = dihed(i) * radian + end do + end if +c +c get name of archive or intermediate coordinates file +c + iopt = freeunit () + if (cyclesave) then + if (archive) then + optfile = filename(1:leng) + call suffix (optfile,'arc','old') + inquire (file=optfile,exist=exist) + if (exist) then + call openend (iopt,optfile) + else + open (unit=iopt,file=optfile,status='new') + end if + else + lext = 3 + call numeral (ncycle,ext,lext) + optfile = filename(1:leng)//'.'//ext(1:lext) + call version (optfile,'new') + open (unit=iopt,file=optfile,status='new') + end if + else + optfile = outfile + call version (optfile,'old') + open (unit=iopt,file=optfile,status='old') + rewind (unit=iopt) + end if +c +c update intermediate file with desired coordinate type +c + if (coordtype .eq. 'CARTESIAN') then + call prtxyz (iopt) + else if (coordtype .eq. 'INTERNAL') then + call prtint (iopt) + else if (coordtype .eq. 'RIGIDBODY') then + call prtxyz (iopt) + end if + close (unit=iopt) +c +c save the force vector components for the current step +c + if (frcsave .and. coordtype.eq.'CARTESIAN') then + ifrc = freeunit () + if (archive) then + frcfile = filename(1:leng) + call suffix (frcfile,'frc','old') + inquire (file=frcfile,exist=exist) + if (exist) then + call openend (ifrc,frcfile) + else + open (unit=ifrc,file=frcfile,status='new') + end if + else + frcfile = filename(1:leng)//'.'//ext(1:lext)//'f' + call version (frcfile,'new') + open (unit=ifrc,file=frcfile,status='new') + end if + write (ifrc,250) n,title(1:ltitle) + 250 format (i6,2x,a) + do i = 1, n + write (ifrc,260) i,name(i),(-desum(j,i),j=1,3) + 260 format (i6,2x,a3,3x,d13.6,3x,d13.6,3x,d13.6) + end do + close (unit=ifrc) + write (iout,270) frcfile(1:trimtext(frcfile)) + 270 format (' Force Vector File',11x,a) + end if +c +c save the current induced dipole moment at each site +c + if (uindsave .and. use_polar .and. coordtype.eq.'CARTESIAN') then + iind = freeunit () + if (archive) then + indfile = filename(1:leng) + call suffix (indfile,'uind','old') + inquire (file=indfile,exist=exist) + if (exist) then + call openend (iind,indfile) + else + open (unit=iind,file=indfile,status='new') + end if + else + indfile = filename(1:leng)//'.'//ext(1:lext)//'u' + call version (indfile,'new') + open (unit=iind,file=indfile,status='new') + end if + write (iind,280) n,title(1:ltitle) + 280 format (i6,2x,a) + do i = 1, npole + if (polarity(i) .ne. 0.0d0) then + k = ipole(i) + write (iind,290) k,name(k),(debye*uind(j,i),j=1,3) + 290 format (i6,2x,a3,3f12.6) + end if + end do + close (unit=iind) + write (iout,300) indfile(1:trimtext(indfile)) + 300 format (' Induced Dipole File',10x,a) + end if +c +c send data via external socket communication if desired +c + if (.not.sktstart .or. use_socket) then + if (coordtype .eq. 'INTERNAL') call makexyz + call sktopt (ncycle,f) + end if +c +c test for requested termination of the optimization +c + endfile = 'tinker.end' + inquire (file=endfile,exist=exist) + if (.not. exist) then + endfile = filename(1:leng)//'.end' + inquire (file=endfile,exist=exist) + if (exist) then + iend = freeunit () + open (unit=iend,file=endfile,status='old') + close (unit=iend,status='delete') + end if + end if + if (exist) then + write (iout,10) + 10 format (/,' OPTSAVE -- Optimization Calculation Ending', + & ' due to User Request') + call fatal + end if + return + end diff --git a/source/unres/src-HCD-5D/optsave_dum.f b/source/unres/src-HCD-5D/optsave_dum.f new file mode 100644 index 0000000..23f35c2 --- /dev/null +++ b/source/unres/src-HCD-5D/optsave_dum.f @@ -0,0 +1,7 @@ + subroutine optsave (ncycle,f,xx) + implicit none + integer ncycle + double precision f + double precision xx(*) + return + end diff --git a/source/unres/src-HCD-5D/output.f b/source/unres/src-HCD-5D/output.f new file mode 100644 index 0000000..c08e04e --- /dev/null +++ b/source/unres/src-HCD-5D/output.f @@ -0,0 +1,36 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1992 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ################################################################ +c ## ## +c ## module output -- output file format control parameters ## +c ## ## +c ################################################################ +c +c +c archive logical flag to save structures in an archive +c noversion logical flag governing use of filename versions +c overwrite logical flag to overwrite intermediate files inplace +c cyclesave logical flag to mark use of numbered cycle files +c velsave logical flag to save velocity vector components +c frcsave logical flag to save force vector components +c uindsave logical flag to save induced atomic dipoles +c coordtype selects Cartesian, internal, rigid body or none +c +c + module output + implicit none + logical archive + logical noversion + logical overwrite + logical cyclesave + logical velsave + logical frcsave + logical uindsave + character*9 coordtype + save + end diff --git a/source/unres/src-HCD-5D/sc_minimize.F b/source/unres/src-HCD-5D/sc_minimize.F new file mode 100644 index 0000000..a284a7c --- /dev/null +++ b/source/unres/src-HCD-5D/sc_minimize.F @@ -0,0 +1,85 @@ + subroutine sc_minimize(etot,iretcode,nfun) +c Minimizes side-chains only, leaving backbone frozen +crc implicit none + +c Includes + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + +c Output arguments + double precision etot + integer iretcode,nfun + +c Local variables + integer i + double precision orig_w(n_ene),energy(0:n_ene) + double precision var(maxvar) + + +c Set non side-chain weights to zero (minimization is faster) +c NOTE: e(2) does not actually depend on the side-chain, only CA + orig_w(2)=wscp + orig_w(3)=welec + orig_w(4)=wcorr + orig_w(5)=wcorr5 + orig_w(6)=wcorr6 + orig_w(7)=wel_loc + orig_w(8)=wturn3 + orig_w(9)=wturn4 + orig_w(10)=wturn6 + orig_w(11)=wang + orig_w(13)=wtor + orig_w(14)=wtor_d + + wscp=0.D0 + welec=0.D0 + wcorr=0.D0 + wcorr5=0.D0 + wcorr6=0.D0 + wel_loc=0.D0 + wturn3=0.D0 + wturn4=0.D0 + wturn6=0.D0 + wang=0.D0 + wtor=0.D0 + wtor_d=0.D0 + +c Prepare to freeze backbone + do i=1,nres + mask_phi(i)=0 + mask_theta(i)=0 + mask_side(i)=1 + enddo + +c Minimize the side-chains + mask_r=.true. + call geom_to_var(nvar,var) + call minimize(etot,var,iretcode,nfun) + call var_to_geom(nvar,var) + mask_r=.false. + +c Put the original weights back and calculate the full energy + wscp=orig_w(2) + welec=orig_w(3) + wcorr=orig_w(4) + wcorr5=orig_w(5) + wcorr6=orig_w(6) + wel_loc=orig_w(7) + wturn3=orig_w(8) + wturn4=orig_w(9) + wturn6=orig_w(10) + wang=orig_w(11) + wtor=orig_w(13) + wtor_d=orig_w(14) + + call chainbuild_extconf + call etotal(energy) + etot=energy(0) + + return + end + + diff --git a/source/unres/src-HCD-5D/scales.f b/source/unres/src-HCD-5D/scales.f new file mode 100644 index 0000000..e98aac7 --- /dev/null +++ b/source/unres/src-HCD-5D/scales.f @@ -0,0 +1,24 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1992 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ############################################################### +c ## ## +c ## module scales -- optimization parameter scale factors ## +c ## ## +c ############################################################### +c +c +c scale multiplicative factor for each optimization parameter +c set_scale logical flag to show if scale factors have been set +c +c + module scales + implicit none + real*8, allocatable :: scale(:) + logical set_scale + save + end diff --git a/source/unres/src-HCD-5D/search.f b/source/unres/src-HCD-5D/search.f new file mode 100644 index 0000000..b3adbbd --- /dev/null +++ b/source/unres/src-HCD-5D/search.f @@ -0,0 +1,360 @@ +c +c +c ################################################### +c ## COPYRIGHT (C) 1990 by Jay William Ponder ## +c ## All Rights Reserved ## +c ################################################### +c +c ################################################################# +c ## ## +c ## subroutine search -- perform unidimensional line search ## +c ## ## +c ################################################################# +c +c +c "search" is a unidimensional line search based upon parabolic +c extrapolation and cubic interpolation using both function and +c gradient values +c +c variables used by the routine : +c +c f function value at the best line search point +c x current values of variables during line search +c g gradient at the current point during line search +c p initial search vector, unchanged by this routine +c s scaled search vector at current line search point +c angle angle between search and negative gradient vector +c +c parameters used by the routine : +c +c stpmin minimum step length in current line search direction +c stpmax maximum step length in current line search direction +c cappa stringency of line search (0=tight < cappa < 1=loose) +c slpmax projected gradient above which stepsize is reduced +c angmax maximum angle between search direction and -gradient +c intmax maximum number of interpolations during line search +c +c status codes upon return : +c +c Success normal termination after satisfying "cappa" test +c ScaleStep normal termination after a step size rescaling +c ReSearch normal termination after a reinterpolation +c WideAngle large angle between search direction and -gradient +c BadIntpln unsatisfied "cappa" test after two searches +c IntplnErr function value increase or serious gradient error +c +c + subroutine search (nvar,f,g,x,p,f_move,angle,ncalls, + & fgvalue,status) + use linmin + use math + implicit none + integer i,nvar + integer ncalls + integer intpln + real*8 fgvalue + real*8 f,f_move + real*8 s_norm,g_norm + real*8 cosang,angle + real*8 step,parab + real*8 cube,cubstp + real*8 sss,ttt + real*8 f_0,f_1 + real*8 f_a,f_b,f_c + real*8 sg_0,sg_1 + real*8 sg_a,sg_b,sg_c + real*8 x(*) + real*8 g(*) + real*8 p(*) + real*8, allocatable :: x_0(:) + real*8, allocatable :: s(:) + logical restart + character*9 status + character*9 blank + external fgvalue +c +c +c use default parameters for the line search if needed +c + blank = ' ' + if (stpmin .eq. 0.0d0) stpmin = 1.0d-16 + if (stpmax .eq. 0.0d0) stpmax = 2.0d0 + if (cappa .eq. 0.0d0) cappa = 0.1d0 + if (slpmax .eq. 0.0d0) slpmax = 10000.0d0 + if (angmax .eq. 0.0d0) angmax = 180.0d0 + if (intmax .eq. 0) intmax = 5 +c +c perform dynamic allocation of some local arrays +c + allocate (x_0(nvar)) + allocate (s(nvar)) +c +c copy the search direction into a new vector +c + do i = 1, nvar + s(i) = p(i) + end do +c +c compute the length of gradient and search direction +c + g_norm = 0.0d0 + s_norm = 0.0d0 + do i = 1, nvar + g_norm = g_norm + g(i)*g(i) + s_norm = s_norm + s(i)*s(i) + end do + g_norm = sqrt(g_norm) + s_norm = sqrt(s_norm) +c +c store initial function, then normalize the +c search vector and find projected gradient +c + f_0 = f + sg_0 = 0.0d0 + do i = 1, nvar + x_0(i) = x(i) + s(i) = s(i) / s_norm + sg_0 = sg_0 + s(i)*g(i) + end do +c +c check the angle between the search direction +c and the negative gradient vector +c + cosang = -sg_0 / g_norm + cosang = min(1.0d0,max(-1.0d0,cosang)) + angle = radian * acos(cosang) + if (angle .gt. angmax) then + status = 'WideAngle' + deallocate (x_0) + deallocate (s) + return + end if +c +c set the initial stepsize to the length of the passed +c search vector, or based on previous function decrease +c + step = 2.0d0 * abs(f_move/sg_0) + step = min(step,s_norm) + if (step .gt. stpmax) step = stpmax + if (step .lt. stpmin) step = stpmin +c +c beginning of the parabolic extrapolation procedure +c + 10 continue + restart = .true. + intpln = 0 + f_b = f_0 + sg_b = sg_0 +c +c replace last point by latest and take another step +c + 20 continue + f_a = f_b + sg_a = sg_b + do i = 1, nvar + x(i) = x(i) + step*s(i) + end do +c +c get new function and projected gradient following a step +c + ncalls = ncalls + 1 +c 3/14/2020 Adam Liwo: added the condition to prevent from infinite +c iteration loop + if (ncalls.gt.200) then + do i = 1, nvar + x(i) = x_0(i) + end do + f_b=f_a + deallocate (x_0) + deallocate (s) + return + endif + f_b = fgvalue (x,g) +c write (2,*) "ncalls",ncalls," f_a",f_a," f_b",f_b," sg_a",sg_a + sg_b = 0.0d0 + do i = 1, nvar + sg_b = sg_b + s(i)*g(i) + end do +c +c scale stepsize if initial gradient change is too large +c + if (abs(sg_b/sg_a).ge.slpmax .and. restart) then + do i = 1, nvar + x(i) = x_0(i) + end do + step = step / 10.0d0 + status = 'ScaleStep' + goto 10 + end if + restart = .false. +c +c return if the gradient is small and function decreases +c + if (abs(sg_b/sg_0).le.cappa .and. f_b.lt.f_a) then + f = f_b + if (status .eq. blank) status = ' Success ' + deallocate (x_0) + deallocate (s) + return + end if +c +c interpolate if gradient changes sign or function increases +c + if (sg_b*sg_a.lt.0.0d0 .or. f_b.gt.f_a) goto 30 +c +c if the finite difference curvature is negative double the step; +c or if (step < parabolic estimate < 4*step) use this estimate, +c otherwise truncate to step or 4*step, respectively +c + step = 2.0d0 * step + if (sg_b .gt. sg_a) then + parab = (f_a-f_b) / (sg_b-sg_a) + if (parab .gt. 2.0d0*step) parab = 2.0d0 * step + if (parab .lt. 0.5d0*step) parab = 0.5d0 * step + step = parab + end if + if (step .gt. stpmax) step = stpmax + goto 20 +c +c beginning of the cubic interpolation procedure +c + 30 continue + intpln = intpln + 1 + sss = 3.0d0*(f_b-f_a)/step - sg_a - sg_b + ttt = sss*sss - sg_a*sg_b + if (ttt .lt. 0.0d0) then + f = f_b + status = 'IntplnErr' + deallocate (x_0) + deallocate (s) + return + end if + ttt = sqrt(ttt) + cube = step * (sg_b+ttt+sss)/(sg_b-sg_a+2.0d0*ttt) + if (cube.lt.0.0d0 .or. cube.gt.step) then + f = f_b + status = 'IntplnErr' + deallocate (x_0) + deallocate (s) + return + end if + do i = 1, nvar + x(i) = x(i) - cube*s(i) + end do +c +c get new function and gradient, then test for termination +c + ncalls = ncalls + 1 + f_c = fgvalue (x,g) + sg_c = 0.0d0 + do i = 1, nvar + sg_c = sg_c + s(i)*g(i) + end do + if (abs(sg_c/sg_0) .le. cappa) then + f = f_c + if (status .eq. blank) status = ' Success ' + deallocate (x_0) + deallocate (s) + return + end if +c +c get the next pair of bracketing points by replacing one +c of the current brackets with the interpolated point +c + if (f_c.le.f_a .or. f_c.le.f_b) then + cubstp = min(abs(cube),abs(step-cube)) + if (cubstp.ge.stpmin .and. intpln.lt.intmax) then +c +c if the current brackets have slopes of opposite sign, +c then substitute the interpolated point for the bracket +c point with slope of same sign as the interpolated point +c + if (sg_a*sg_b .lt. 0.0d0) then + if (sg_a*sg_c .lt. 0.0d0) then + f_b = f_c + sg_b = sg_c + step = step - cube + else + f_a = f_c + sg_a = sg_c + step = cube + do i = 1, nvar + x(i) = x(i) + cube*s(i) + end do + end if +c +c if current brackets have slope of same sign, then replace +c the far bracket if the interpolated point has a slope of +c the opposite sign or a lower function value than the near +c bracket, otherwise replace the near bracket point +c + else + if (sg_a*sg_c.lt.0.0d0 .or. f_a.le.f_c) then + f_b = f_c + sg_b = sg_c + step = step - cube + else + f_a = f_c + sg_a = sg_c + step = cube + do i = 1, nvar + x(i) = x(i) + cube*s(i) + end do + end if + end if + goto 30 + end if + end if +c +c interpolation has failed, reset to best current point +c + f_1 = min(f_a,f_b,f_c) + if (f_1 .eq. f_a) then + sg_1 = sg_a + do i = 1, nvar + x(i) = x(i) + (cube-step)*s(i) + end do + else if (f_1 .eq. f_b) then + sg_1 = sg_b + do i = 1, nvar + x(i) = x(i) + cube*s(i) + end do + else if (f_1 .eq. f_c) then + sg_1 = sg_c + end if +c +c try to restart from best point with smaller stepsize +c + if (f_1 .gt. f_0) then + ncalls = ncalls + 1 + f = fgvalue (x,g) + status = 'IntplnErr' + deallocate (x_0) + deallocate (s) + return + end if + f_0 = f_1 + sg_0 = sg_1 + if (sg_1 .gt. 0.0d0) then + do i = 1, nvar + s(i) = -s(i) + end do + sg_0 = -sg_1 + end if + step = max(cube,step-cube) / 10.0d0 + if (step .lt. stpmin) step = stpmin +c +c if already restarted once, then return with best point +c + if (status .eq. ' ReSearch') then + ncalls = ncalls + 1 + f = fgvalue (x,g) + status = 'BadIntpln' + deallocate (x_0) + deallocate (s) + return + else + status = ' ReSearch' + goto 10 + end if + end diff --git a/source/wham/src-HCD-5D/COMMON.CONTMAT b/source/wham/src-HCD-5D/COMMON.CONTMAT new file mode 100644 index 0000000..e681360 --- /dev/null +++ b/source/wham/src-HCD-5D/COMMON.CONTMAT @@ -0,0 +1,39 @@ +C Change 12/1/95 - common block CONTACTS1 included. + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + double precision gacontp_hb1,gacontp_hb2,gacontp_hb3,gacont_hbr, + & gacontm_hb1,gacontm_hb2,gacontm_hb3,grij_hb_cont,facont_hb, + & ees0p,ees0m,d_cont + integer num_cont_hb,jcont_hb + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +c 7/25/08 Commented out; not needed when cumulants used +C Interactions of pseudo-dipoles generated by loc-el interactions. +c double precision dip,dipderg,dipderx +c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), +c & dipderx(3,5,4,maxconts,maxres) +C 12/13/2008 (again Poland-Jaruzel war anniversary) +C RE: Parallelization of 4th and higher order loc-el correlations + integer ncont_sent,ncont_recv,iint_sent,iisent_local, + & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to, + & nat_sent,iat_sent,iint_sent_local + integer iturn3_sent,iturn4_sent,iturn3_sent_local, + & iturn4_sent_local + common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres), + & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres), + & nat_sent,iat_sent(maxres),itask_cont_from(0:max_fg_procs-1), + & itask_cont_to(0:max_fg_procs-1),ntask_cont_from,ntask_cont_to, + & iturn3_sent(4,maxres),iturn4_sent(4,maxres), + & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres) diff --git a/source/wham/src-HCD-5D/COMMON.CORRMAT b/source/wham/src-HCD-5D/COMMON.CORRMAT new file mode 100644 index 0000000..5f154e0 --- /dev/null +++ b/source/wham/src-HCD-5D/COMMON.CORRMAT @@ -0,0 +1,47 @@ +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,gmu,gUb2, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der, + & gtEug + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres), + & gmu(2,maxres),gUb2(2,maxres), + & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres), + & Dtobr2(2,maxres),Dtobr2der(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),gtEUg(2,2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder,Ug2DtEUg,Ug2DtEUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), + & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont,EAEA,EAEAderg,EAEAderx, + & ADtEA1,AdTEA1derg,ADtEA1derx + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/wham/src-HCD-5D/chainbuild.rrr b/source/wham/src-HCD-5D/chainbuild.rrr new file mode 100644 index 0000000000000000000000000000000000000000..3d96cab9ea2272fba87a8382e9faf2454eb0af0b GIT binary patch literal 20568 zcmchf4S1B*mB(Mq06|CIi3W@-Xx5H3)EI*VH&)aH1D%8jv5h*jMw5^a5;u@Y28(T! zSkO8RgKX;u+f|o!vCCFnskK#Uy9+8TQg{ry3hJ^9id|4tj7$9hW&h{ib0#;3On0}> zvwNQ>dGGss&pr3tbI(2Z{Rk|XQ9bj75hJoZE+f3lyb*HZ99LaAcv5DnW!_0%_8?R> z(h=}JI;OBU79eYwcH<2{zUMOyKS8VUnhj5zoxa|I+6eR@MJ!wbkOhl$Sq3n|;dw0Z zjNw^ch|fjOF6Q})(?F@;V#QCzkcdlrIewM7^e6o5%nOvB*TJ*AkxT~<2MixI2)K6G z@X^QdV}_48j-Ln@XL%qlKdr0vt zT8Jn=Q5=ifly!>NTI@Zo_)(lw*`Rnyufg6{#XVY}DE*3Oa|oATU0(aG$n6JvAv55I z%xn$#IThi8{nQNTQaVQZ?3D@@i8M_#mvKH}x75Pv+W7|gIVbb6C!9Y};pfzai|NoD zE~P_9I8yl=67al3msclD8$Pu9AHF=43_Tn0>vq7(anzQtL=whAw0x7Rd;zk%oRL|( z{Ty?gF=bzM;vB2R9Q=Z*bmmVo2XtYMt^R4|$g5XxlN3mPs5V?S;KyFUPn{9#2p6Dk%!atV`dibm2HXjPx=nEKJ_N?w zxY`_!h}w>DnP2cKWcTA|M0gHE5|s7_Q{7AR3b(4;{^R zlB)Lz*`Y$TFs<_)Y8jT(=wUi7v8R%6(0a!}xgXsM$8fiP>@%E9W4Y)?oCM5Cbz*NM zu{DzD_m`gwmscm^;ZS8_Q+1*zoE=FNh9k-AzNk#R7D*r`A_342J7)*s4%6tp@h%SPu&~TnQ1#%!F=_nM^TylC!;y}OM5Uw zo3g$DDKYS7W)or0pjeo3L%l(jPQQ2n= z^h1SqMsUH9%06pUpV0$_p(Ghel}DuV3sXtYD(1+URH~kF>4Tc=j6e0^&BILRlhw3PsA?~_hyv=DO#vXFh8VT66)`nWpJQ*K@-edOX1LSlV2Ise zW(8NbkOf_@D9kXYbH{}m^; zP36+fk;MmJKG?zg(4& zjTU#(5Vc#oP|E3Py_DM_VfSL8CdtbQ;v2~x4zfB0%dskH+g2s*zF(EJy&2zEH(dhl zp+cKIY4U6h88v8YSQ*vf{5eQlbCTg>BrLNU+g{Z-AwAc;d~n^es=mQEunP#GpO)se zhk*qT8(;g_C8qnaLXnVl28lwJz(zr?lC!tzOqM3L3Y=N3RSBCVc(cF)GEJ(I)t6wa z4DnqJ;>tz`5r6q6T=SSBJyH%i6W+ae;gOE+(=fJFF#gZ>(C2Nm;0{wO20?N5YVXVJ0YY(;z+!W(Z z7}kZRy=uD0yp>oN(hR0+?07JqFx0~KDk%=Zd2$Xn@|2_>$6G_`k4(U%#;G zR=WRIuV9AlRdOY5(}Q=`={H#R?Le)0J7DjuNvs1&$Gxql{Ae>}DQcNBWwC^JbGQIG z=>-UKvVkMPY02C#$j5G6F;z3Fwq(BOrY zrgwQOhUE1I$xqnMCfl7SlCax4F5z|>*ZD>Sqd!2W_Ra@6q^!IS>Eo%dQtPYjty|Ms zktX92I54o=sKrjf6}&ghk7T`vOY*1}%6;F;VD)1zvCr8XIaL4G`z5w~>F1BwF6n-I z=qsa0GWSiGis*12t|H0!d}JE);)q^`VwA7)DD7P_926?F2sPeIQDZUG?Cmef@%D$> z1W^*^irj=E-P_5b=PW?J`)Qsynx>$DZ_r(g6!3%ff7%3a{0?zCMij9p~wa$}dV zaAa_Ff$1|ix*^aCBXB<0XZ~QHd1NFtrtV>h-q>pF7fp}D0CGy&KOyoO$zjIun@Uq#WBY=+i`qMy zi)MO7-SLI-#<@7>$8IEsNvcyq3;-uYJMI9W4v$t$e+=uroftF<$T8+_;dL(NXW! z*LSqfonPPG-Ev`lcl&~-&Tg-0VP|t=ywR(_u)U+WwWG5!-qqOj7cKFki@c(_-Q8YC zXH#Rm1=7te^~Rj~a5P#}TvXzri}{N>&<%?$fI0OGTe{JW)-`#u*SWBLUVZDr#`!J7 zU7spSoPLH;Q+ho6v*Xd^3x{DBc?(-w;lV{susGh<5^sc|=2+i2w|zl-yd8e*ZlbYt z)O%emUGce{3!2Hb&FxJzC^!=u06G^z8lZIn27_Z)OiZKDEWMkvg2) z*?bGs#}~H5o7(EVq6MAtmZERWzWV&`IK1r@HMh)NG!K)rpv5a{X|sO9)U4j+$tA%76A zU{2o~Nq;uW&vy7Y;(UHBAI1J<=U7nh@Y7J2WYwoQEm$f)v_~nX++0H7(d)S_DDqgYIHn?8#u`#5 z@$)XtInMVfE^&3x;S|qxd#(K+E53~V@VVkoF&{w_f+F*>ocUOXlbtfIaSo?`*RcEq z#l_D>4mWyuTvHuRdc@Du98U6*H?B}z)+zs;NjeY6y0}WoOP-7>F7er*xX8~_yoBvv zq&aM*a+~6khwspw^(h+B>OSs^r5gU*mA)G11@(jT_i z`;n55vi{YYv;M~wFJL|IIGn~RpXBE@IzcH` z+`Gy0ixoe_d3Czt*(^UxagR6fTE(-Ow=3Sy`)^$F#nv3}yNdTR|DNJe=JwCO2FJ_h zdp}n4cd`86D!zpqtW`Y4{0YTBWxihVe&!n$-^F~3;-9h~UQ;~6cJ5Jp3(LQ+_#x*1 zsd$9r@QC7~=LAa1C=w?tS$@3Y4MxiI&QiRFd4b|7w&ya%_p=}7XwLF;72m~t9&?KS zGw>t%woA#2{ol^OdmV1p9X|&p98T+H75iaj27bTdt66@v!znKnhpNxwX|PIu&uA9%j19Zt`!A^cEjaJU&4>z}817xND0IkUjK6<)@B3xlrPBv%}r{oZSw0^Y-c4MqPS6%6d6lamm}~DZZG;Rie1~`BKFt zKg?9Tm-Wn1yp4HO@fzlhir>ZjMu(euxzCQXTk$UDy$+|imHjBGxa>!(9ZvciSkGGK zG{01pdHI==Px1ZCOG=)%U2m6?-_PMNgQgfF7mg16s>J%?U-&DF3mprgUbJo8?anWypt#txh`HD=aek|k|CH^&L-8`UC#gBx zbFbnBEdQY9EdPk&lK&r9TzLoBc$DqDQ}G7of2DW<^S@JkE$e?$ z@qXs(6)$Byn-#BN{;J|-%=ai>%>01j8@S)2inp=+i9FAAndWN?`}q{b*D^m-@eRxi z72m@BmMFf9<;xXc$Gk@IXIM{EbCz#Vd>6~NDPE8=Vd8ZuF7qYvE`I1@`CD0@;@rL8 z{(+;%tfR?R|2>KyqKhaGDc;5Rt4}-J?1L#I?meG@Z+AHDgZ(^@I~`7X7PFo`8TbK* zlb&6y=Oc%co?g~-#Ni~LV)>CL;{=8LM%%J={{Wgz1QJ1-Vp2gF>{?i*Ja?_ z9Zp-i?E5<%{cb-0*pYYdw@)04#wfbqYUVVLG+zZ>B;|S6Xr40IYf!w5`HhN4n8y{5 zGQUmn2IeaiFJ->U;U<3W^GtbIar;j!Jnw0T)3`!Bu8j^SJs#`Xs(2prH#6{kis!TZ z2Z|RkKjLt*Cy(tp(I+DY-#-*H&(l0*#JqgwG>>%8BKJ{WbL7W^-^KUaGn70pXK#*@ zU&--K6uL;|bDCdT*D_yMJKVh= zyWZg>FW=3ZGw=?@<-2*e!^v-w4{v2o`GNGyck}N%-2HC8($Pcm^4)xu!)dQzO1->-`TCWd}rUMxO``SPjUIqKA<_jfBRB#Sr?;nFc=h?FB+G8&mF6{ zd}kc*aPqV8vo+^^ut@Pjw4pN9;neRk_RloMkETf4^R7@_zV}rrF5kJXayZ#ZdkK{~ z#pUk-nlxv7IvsA}li%Zg+u>xt=wG6^68Xz84QDE`L|> znc{2MpZH%5Op!R3zoQtf_){!DR`CG)d7R?%{cD2awJaabz|V6y#iz{gMVj+Ey42w& z-dKNy;$h~q6z^dEO~nhD#}tn=2W|88uE_xJ~I9#f@P_9amh=Y9q#UfyEE_+r&_}(Zt0bV z_;aGe-TUMchr9Z}<8Zp~5YeR6bVvC4P=5`5M+gmJ`18Tf_QKXHN6w-rwdc zF8(jbz%Ot(jZ41QU&dVe&Brw=-%#?hF6JnC`QCkl=4}6b#S5%@Z@JPh_gD8i^5n}; z*`W_9zL?(|tW*5c$+m-M9qvAdZe>pXbmKXdfq&s}@{z>nC{l_-Oy-=<&t^{gsj0|c z>~Oc=?>c%Y56g4eGR5UNbcNzwDKtV^rMSHJcv$hfQbyc+O!1Y>f2sIt<{K1W%lt*f zm*>I#4ktgz^Wb5{<#{lhl%h!7%JXTV!%5Go6iIpB6y~yyWL_>; zT=tQOqlc=i`T6b!#aA)EQR$KO*sbK(viyCD%lCyx6qolrPbi+p>+4yE(|FgV@C)U6 zhf`Jb>{ML73;a%Td5?5R@qF(0bHznINJgN@yvTd|(-oKZLT4*p!1~WqT;%hOcKT1f z2A}l_J)^k%LkanNRFRkeaB49D6yd$R&Wmla7ytO*A zMyB!CchqcI$%19<9^w2nCa32AXQTGohW<0GNNHNqR>%&wEWrse{wuHarEK2E^3%jt zbpQ1KrHxiHbSmxjC9>5m^#7`9M%VwR?dkttqxO3I(te9lF8&uA=