--- /dev/null
+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)
--- /dev/null
+ 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
--- /dev/null
+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
--- /dev/null
+ 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)
+
--- /dev/null
+! 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
--- /dev/null
+ 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
--- /dev/null
+ 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)
--- /dev/null
+! 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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)
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+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.
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
+
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
+
--- /dev/null
+ 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 (r<sigma).
+C
+ if (fcont.gt.0.0D0) then
+C If the SC-SC distance if close to sigma, apply spline.
+cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
+cAdam & fcont1,fprimcont1)
+cAdam fcont1=1.0d0-fcont1
+cAdam if (fcont1.gt.0.0d0) then
+cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
+cAdam fcont=fcont*fcont1
+cAdam endif
+C Uncomment following 4 lines to have the geometric average of the epsilon0's
+cga do k=1,3
+cga gg(k)=gg(k)*eps0ij
+cga enddo
+cga eps0ij=-evdwij*eps0ij
+C Uncomment for AL's type of SC correlation interactions.
+cadam eps0ij=-evdwij
+ num_conti=num_conti+1
+ jcont(num_conti,i)=j
+ facont(num_conti,i)=fcont*eps0ij
+ fprimcont=eps0ij*fprimcont/rij
+ fcont=expon*fcont
+cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
+cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
+cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
+C Uncomment following 3 lines for Skolnick's type of SC correlation.
+ gacont(1,num_conti,i)=-fprimcont*xj
+ gacont(2,num_conti,i)=-fprimcont*yj
+ gacont(3,num_conti,i)=-fprimcont*zj
+cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
+cd write (iout,'(2i3,3f10.5)')
+cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
+ endif
+ endif
+ enddo ! j
+ enddo ! iint
+C Change 12/1/95
+ num_cont(i)=num_conti
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+C******************************************************************************
+C
+C N O T E !!!
+C
+C To save time, the factor of 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 eljk(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJK potential of interaction.
+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.IOUNITS'
+ include 'COMMON.NAMES'
+ dimension gg(3)
+ logical scheck
+c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ do i=iatsc_s,iatsc_e
+ itypi=iabs(itype(i))
+ if (itypi.eq.ntyp1) cycle
+ itypi1=iabs(itype(i+1))
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ r_inv_ij=dsqrt(rrij)
+ rij=1.0D0/r_inv_ij
+ r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
+ fac=r_shift_inv**expon
+C have you changed here?
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=e_augm+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),8(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
+cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
+cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
+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=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+ do k=1,3
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)
+ enddo
+cgrad do k=i,j-1
+cgrad do l=1,3
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
+cgrad enddo
+cgrad enddo
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine ebp(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Berne-Pechukas potential of interaction.
+C
+ 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'
+ integer icall
+ common /srutu/ icall
+c double precision rrsave(maxdim)
+ logical lprn
+ evdw=0.0D0
+c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+c if (icall.eq.0) then
+c lprn=.true.
+c else
+ lprn=.false.
+c endif
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=iabs(itype(i))
+ if (itypi.eq.ntyp1) cycle
+ itypi1=iabs(itype(i+1))
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+cd if (icall.eq.0) then
+cd rrsave(ind)=rrij
+cd else
+cd rrij=rrsave(ind)
+cd endif
+ rij=dsqrt(rrij)
+C Calculate the angle-dependent terms of energy & contributions to derivatives.
+ call sc_angular
+C Calculate whole angle-dependent part of epsilon and contributions
+C to its derivatives
+C have you changed here?
+ fac=(rrij*sigsq)**expon2
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij
+ if (lprn) then
+ sigm=dabs(aa/bb)**(1.0D0/6.0D0)
+ epsi=bb**2/aa
+cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & epsi,sigm,chi1,chi2,chip1,chip2,
+cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
+cd & om1,om2,om12,1.0D0/dsqrt(rrij),
+cd & evdwij
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)
+ sigder=fac/sigsq
+ fac=rrij*fac
+C Calculate radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate the angular part of the gradient and sum add the contributions
+C to the appropriate components of the Cartesian gradient.
+ call sc_grad
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+c stop
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egb(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne potential of interaction.
+C
+ 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'
+ logical lprn
+ integer xshift,yshift,zshift
+
+ evdw=0.0D0
+ccccc energy_dec=.false.
+C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.eq.0) lprn=.false.
+ ind=0
+C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
+C we have the original box)
+C do xshift=-1,1
+C do yshift=-1,1
+C do zshift=-1,1
+ 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 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 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
+ 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 define scaling factor for lipids
+
+C if (positi.le.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 ((zi.gt.bordlipbot)
+ &.and.(zi.lt.bordliptop)) then
+C the energy transfer exist
+ if (zi.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zi.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipi=1.0d0
+ ssgradlipi=0.0
+ endif
+ else
+ sslipi=0.0d0
+ ssgradlipi=0.0
+ endif
+
+C xi=xi+xshift*boxxsize
+C yi=yi+yshift*boxysize
+C zi=zi+zshift*boxzsize
+
+ 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(i+nres)
+c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
+c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
+
+c write(iout,*) "PRZED ZWYKLE", evdwij
+ call dyn_ssbond_ene(i,j,evdwij)
+c write(iout,*) "PO ZWYKLE", evdwij
+
+ evdw=evdw+evdwij
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
+ & 'evdw',i,j,evdwij,' ss'
+C triple bond artifac removal
+ do k=j+1,iend(i,iint)
+C search over all next residues
+ if (dyn_ss_mask(k)) then
+C check if they are cysteins
+C write(iout,*) 'k=',k
+
+c write(iout,*) "PRZED TRI", evdwij
+ evdwij_przed_tri=evdwij
+ call triple_ssbond_ene(i,j,k,evdwij)
+c if(evdwij_przed_tri.ne.evdwij) then
+c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
+c endif
+
+c write(iout,*) "PO TRI", evdwij
+C call the energy function that removes the artifical triple disulfide
+C bond the soubroutine is located in ssMD.F
+ evdw=evdw+evdwij
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
+ & 'evdw',i,j,evdwij,'tss'
+ endif!dyn_ss_mask(k)
+ enddo! k
+ ELSE
+ ind=ind+1
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
+c & 1.0d0/vbld(j+nres)
+c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
+ sig0ij=sigma(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)
+ yj=c(2,nres+j)
+ zj=c(3,nres+j)
+C Return atom J into box the original box
+c 137 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 137
+c endif
+c 138 continue
+c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
+c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
+C 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 138
+c endif
+c 139 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 139
+c endif
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.gt.bordlipbot)
+ &.and.(zj.lt.bordliptop)) then
+C the energy transfer exist
+ if (zj.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zj-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zj.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipj=1.0d0
+ ssgradlipj=0.0
+ endif
+ else
+ sslipj=0.0d0
+ ssgradlipj=0.0
+ endif
+ aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+ bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
+C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
+C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
+C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
+C print *,sslipi,sslipj,bordlipbot,zi,zj
+ dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ subchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (subchap.eq.1) then
+ xj=xj_temp-xi
+ yj=yj_temp-yi
+ zj=zj_temp-zi
+ else
+ xj=xj_safe-xi
+ yj=yj_safe-yi
+ zj=zj_safe-zi
+ endif
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+C xj=xj-xi
+C yj=yj-yi
+C zj=zj-zi
+c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
+c write (iout,*) "j",j," dc_norm",
+c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij)
+ sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
+ sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
+
+c write (iout,'(a7,4f8.3)')
+c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
+ if (sss.gt.0.0d0) then
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+sig0ij
+c for diagnostics; uncomment
+c rij_shift=1.2*sig0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+C here to start with
+C if (c(i,3).gt.
+ faclip=fac
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
+C &((sslipi+sslipj)/2.0d0+
+C &(2.0d0-sslipi-sslipj)/2.0d0)
+c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
+c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij*sss
+ if (lprn) then
+ sigm=dabs(aa/bb)**(1.0D0/6.0D0)
+ epsi=bb**2/aa
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+ & evdwij
+ endif
+
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'evdw',i,j,evdwij
+
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac
+c print '(2i4,6f8.4)',i,j,sss,sssgrad*
+c & evdwij,fac,sigma(itypi,itypj),expon
+ fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
+c fac=0.0d0
+C Calculate the radial part of the gradient
+ gg_lipi(3)=eps1*(eps2rt*eps2rt)
+ &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
+ & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
+ &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
+ gg_lipj(3)=ssgradlipj*gg_lipi(3)
+ gg_lipi(3)=gg_lipi(3)*ssgradlipi
+C gg_lipi(3)=0.0d0
+C gg_lipj(3)=0.0d0
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad
+ endif
+ ENDIF ! dyn_ss
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+C enddo ! zshift
+C enddo ! yshift
+C enddo ! xshift
+c write (iout,*) "Number of loop steps in EGB:",ind
+cccc energy_dec=.false.
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egbv(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne-Vorobjev potential of interaction.
+C
+ 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'
+ integer xshift,yshift,zshift
+ integer icall
+ common /srutu/ icall
+ logical lprn
+ evdw=0.0D0
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.eq.0) lprn=.true.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=iabs(itype(i))
+ if (itypi.eq.ntyp1) cycle
+ itypi1=iabs(itype(i+1))
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ 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 define scaling factor for lipids
+
+C if (positi.le.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 ((zi.gt.bordlipbot)
+ &.and.(zi.lt.bordliptop)) then
+C the energy transfer exist
+ if (zi.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zi.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipi=1.0d0
+ ssgradlipi=0.0
+ endif
+ else
+ sslipi=0.0d0
+ ssgradlipi=0.0
+ endif
+
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+ sig0ij=sigma(itypi,itypj)
+ r0ij=r0(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+C xj=c(1,nres+j)-xi
+C yj=c(2,nres+j)-yi
+C zj=c(3,nres+j)-zi
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.gt.bordlipbot)
+ &.and.(zj.lt.bordliptop)) then
+C the energy transfer exist
+ if (zj.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zj-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zj.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipj=1.0d0
+ ssgradlipj=0.0
+ endif
+ else
+ sslipj=0.0d0
+ ssgradlipj=0.0
+ endif
+ aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+ bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
+C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
+C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
+ dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ subchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (subchap.eq.1) then
+ xj=xj_temp-xi
+ yj=yj_temp-yi
+ zj=zj_temp-zi
+ else
+ xj=xj_safe-xi
+ yj=yj_safe-yi
+ zj=zj_safe-zi
+ endif
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij)
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+r0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij+e_augm
+ if (lprn) then
+ sigm=dabs(aa/bb)**(1.0D0/6.0D0)
+ epsi=bb**2/aa
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
+ & chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+ & evdwij+e_augm
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac-2*expon*rrij*e_augm
+ fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ end
+C-----------------------------------------------------------------------------
+ subroutine sc_angular
+C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
+C om12. Called by ebp, egb, and egbv.
+ implicit none
+ include 'COMMON.CALC'
+ include 'COMMON.IOUNITS'
+ 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
+ chiom12=chi12*om12
+C Calculate eps1(om12) and its derivative in om12
+ faceps1=1.0D0-om12*chiom12
+ faceps1_inv=1.0D0/faceps1
+ eps1=dsqrt(faceps1_inv)
+C Following variable is eps1*deps1/dom12
+ eps1_om12=faceps1_inv*chiom12
+c diagnostics only
+c faceps1_inv=om12
+c eps1=om12
+c eps1_om12=1.0d0
+c write (iout,*) "om12",om12," eps1",eps1
+C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
+C and om12.
+ om1om2=om1*om2
+ chiom1=chi1*om1
+ chiom2=chi2*om2
+ facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
+ sigsq=1.0D0-facsig*faceps1_inv
+ sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
+ sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
+ sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
+c diagnostics only
+c sigsq=1.0d0
+c sigsq_om1=0.0d0
+c sigsq_om2=0.0d0
+c sigsq_om12=0.0d0
+c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
+c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
+c & " eps1",eps1
+C Calculate eps2 and its derivatives in om1, om2, and om12.
+ chipom1=chip1*om1
+ chipom2=chip2*om2
+ chipom12=chip12*om12
+ facp=1.0D0-om12*chipom12
+ facp_inv=1.0D0/facp
+ facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
+c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
+c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
+C Following variable is the square root of eps2
+ eps2rt=1.0D0-facp1*facp_inv
+C Following three variables are the derivatives of the square root of eps
+C in om1, om2, and om12.
+ eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
+ eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
+ eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
+C Evaluate the "asymmetric" factor in the VDW constant, eps3
+ eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
+c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
+c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
+c & " eps2rt_om12",eps2rt_om12
+C Calculate whole angle-dependent part of epsilon and contributions
+C to its derivatives
+ return
+ end
+C----------------------------------------------------------------------------
+ subroutine sc_grad
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.CALC'
+ include 'COMMON.IOUNITS'
+ double precision dcosom1(3),dcosom2(3)
+cc print *,'sss=',sss
+ eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
+ eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
+ eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
+ & -2.0D0*alf12*eps3der+sigder*sigsq_om12
+c diagnostics only
+c eom1=0.0d0
+c eom2=0.0d0
+c eom12=evdwij*eps1_om12
+c end diagnostics
+c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
+c & " sigder",sigder
+c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
+c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
+ do k=1,3
+ dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
+ dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
+ enddo
+ do k=1,3
+ gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
+ enddo
+c write (iout,*) "gg",(gg(k),k=1,3)
+ do k=1,3
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
+ & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+ & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
+ & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+ & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
+c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
+c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
+ enddo
+C
+C Calculate the components of the gradient in DC and X
+C
+cgrad do k=i,j-1
+cgrad do l=1,3
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
+cgrad enddo
+cgrad enddo
+ do l=1,3
+ gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
+ gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
+ enddo
+ return
+ end
+C-----------------------------------------------------------------------
+ subroutine e_softsphere(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'
+ 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'
+ dimension gg(3)
+cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
+ 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
+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
+ rij=xj*xj+yj*yj+zj*zj
+c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
+ r0ij=r0(itypi,itypj)
+ r0ijsq=r0ij*r0ij
+c print *,i,j,r0ij,dsqrt(rij)
+ if (rij.lt.r0ijsq) then
+ evdwij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdwij=0.0d0
+ fac=0.0d0
+ endif
+ evdw=evdw+evdwij
+C
+C Calculate the components of the gradient in DC and X
+C
+ 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
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ return
+ end
+C--------------------------------------------------------------------------
+ subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
+ & eello_turn4)
+C
+C Soft-sphere potential of p-p interaction
+C
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ dimension ggg(3)
+ integer xshift,yshift,zshift
+C write(iout,*) 'In EELEC_soft_sphere'
+ ees=0.0D0
+ evdw1=0.0D0
+ eel_loc=0.0d0
+ eello_turn3=0.0d0
+ eello_turn4=0.0d0
+ ind=0
+ do i=iatel_s,iatel_e
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+ num_conti=0
+c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
+ do j=ielstart(i),ielend(i)
+ if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
+ ind=ind+1
+ iteli=itel(i)
+ itelj=itel(j)
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2
+ r0ij=rpp(iteli,itelj)
+ r0ijsq=r0ij*r0ij
+ dxj=dc(1,j)
+ dyj=dc(2,j)
+ dzj=dc(3,j)
+ xj=c(1,j)+0.5D0*dxj
+ yj=c(2,j)+0.5D0*dyj
+ zj=c(3,j)+0.5D0*dzj
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ isubchap=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
+ isubchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (isubchap.eq.1) then
+ xj=xj_temp-xmedi
+ yj=yj_temp-ymedi
+ zj=zj_temp-zmedi
+ else
+ xj=xj_safe-xmedi
+ yj=yj_safe-ymedi
+ zj=zj_safe-zmedi
+ endif
+ rij=xj*xj+yj*yj+zj*zj
+ sss=sscale(sqrt(rij))
+ sssgrad=sscagrad(sqrt(rij))
+ if (rij.lt.r0ijsq) then
+ evdw1ij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdw1ij=0.0d0
+ fac=0.0d0
+ endif
+ evdw1=evdw1+evdw1ij*sss
+C
+C Calculate contributions to the Cartesian gradient.
+C
+ ggg(1)=fac*xj*sssgrad
+ ggg(2)=fac*yj*sssgrad
+ ggg(3)=fac*zj*sssgrad
+ do k=1,3
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+ enddo ! j
+ enddo ! i
+cgrad do i=nnt,nct-1
+cgrad do k=1,3
+cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
+cgrad enddo
+cgrad do j=i+1,nct-1
+cgrad do k=1,3
+cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
+cgrad enddo
+cgrad enddo
+cgrad enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine vec_and_deriv
+ implicit none
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VECTORS'
+ include 'COMMON.SETUP'
+ include 'COMMON.TIME1'
+ dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
+C Compute the local reference systems. For reference system (i), the
+C X-axis points from CA(i) to CA(i+1), the Y axis is in the
+C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
+#ifdef PARVEC
+ do i=ivec_start,ivec_end
+#else
+ do i=1,nres-1
+#endif
+ if (i.eq.nres-1) then
+C Case of the last full residue
+C Compute the Z-axis
+ call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
+ costh=dcos(pi-theta(nres))
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)
+ do k=1,3
+ uz(k,i)=fac*uz(k,i)
+ enddo
+C Compute the derivatives of uz
+ uzder(1,1,1)= 0.0d0
+ uzder(2,1,1)=-dc_norm(3,i-1)
+ uzder(3,1,1)= dc_norm(2,i-1)
+ uzder(1,2,1)= dc_norm(3,i-1)
+ uzder(2,2,1)= 0.0d0
+ uzder(3,2,1)=-dc_norm(1,i-1)
+ uzder(1,3,1)=-dc_norm(2,i-1)
+ uzder(2,3,1)= dc_norm(1,i-1)
+ uzder(3,3,1)= 0.0d0
+ uzder(1,1,2)= 0.0d0
+ uzder(2,1,2)= dc_norm(3,i)
+ uzder(3,1,2)=-dc_norm(2,i)
+ uzder(1,2,2)=-dc_norm(3,i)
+ uzder(2,2,2)= 0.0d0
+ uzder(3,2,2)= dc_norm(1,i)
+ uzder(1,3,2)= dc_norm(2,i)
+ uzder(2,3,2)=-dc_norm(1,i)
+ uzder(3,3,2)= 0.0d0
+C Compute the Y-axis
+ facy=fac
+ do k=1,3
+ uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
+ enddo
+C Compute the derivatives of uy
+ do j=1,3
+ do k=1,3
+ uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
+ & -dc_norm(k,i)*dc_norm(j,i-1)
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
+ enddo
+ uyder(j,j,1)=uyder(j,j,1)-costh
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)
+ enddo
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=uyder(l,k,j)
+ uzgrad(l,k,j,i)=uzder(l,k,j)
+ enddo
+ enddo
+ enddo
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
+ else
+C Other residues
+C Compute the Z-axis
+ call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
+ costh=dcos(pi-theta(i+2))
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)
+ do k=1,3
+ uz(k,i)=fac*uz(k,i)
+ enddo
+C Compute the derivatives of uz
+ uzder(1,1,1)= 0.0d0
+ uzder(2,1,1)=-dc_norm(3,i+1)
+ uzder(3,1,1)= dc_norm(2,i+1)
+ uzder(1,2,1)= dc_norm(3,i+1)
+ uzder(2,2,1)= 0.0d0
+ uzder(3,2,1)=-dc_norm(1,i+1)
+ uzder(1,3,1)=-dc_norm(2,i+1)
+ uzder(2,3,1)= dc_norm(1,i+1)
+ uzder(3,3,1)= 0.0d0
+ uzder(1,1,2)= 0.0d0
+ uzder(2,1,2)= dc_norm(3,i)
+ uzder(3,1,2)=-dc_norm(2,i)
+ uzder(1,2,2)=-dc_norm(3,i)
+ uzder(2,2,2)= 0.0d0
+ uzder(3,2,2)= dc_norm(1,i)
+ uzder(1,3,2)= dc_norm(2,i)
+ uzder(2,3,2)=-dc_norm(1,i)
+ uzder(3,3,2)= 0.0d0
+C Compute the Y-axis
+ facy=fac
+ do k=1,3
+ uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
+ enddo
+C Compute the derivatives of uy
+ do j=1,3
+ do k=1,3
+ uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
+ & -dc_norm(k,i)*dc_norm(j,i+1)
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
+ enddo
+ uyder(j,j,1)=uyder(j,j,1)-costh
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)
+ enddo
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=uyder(l,k,j)
+ uzgrad(l,k,j,i)=uzder(l,k,j)
+ enddo
+ enddo
+ enddo
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
+ endif
+ enddo
+ do i=1,nres-1
+ vbld_inv_temp(1)=vbld_inv(i+1)
+ if (i.lt.nres-1) then
+ vbld_inv_temp(2)=vbld_inv(i+2)
+ else
+ vbld_inv_temp(2)=vbld_inv(i)
+ endif
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
+ uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
+ enddo
+ enddo
+ enddo
+ enddo
+#if defined(PARVEC) && defined(MPI)
+ if (nfgtasks1.gt.1) then
+ time00=MPI_Wtime()
+c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
+c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
+c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
+ call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
+ & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
+ call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
+ & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
+ time_gather=time_gather+MPI_Wtime()-time00
+ endif
+#endif
+#ifdef DEBUG
+ if (fg_rank.eq.0) then
+ write (iout,*) "Arrays UY and UZ"
+ do i=1,nres-1
+ write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
+ & (uz(k,i),k=1,3)
+ enddo
+ endif
+#endif
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine check_vecgrad
+ implicit none
+ 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
+C--------------------------------------------------------------------------
+ subroutine set_matrices
+ implicit none
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+ include "COMMON.SETUP"
+ integer IERR
+ integer status(MPI_STATUS_SIZE)
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ double precision auxvec(2),auxmat(2,2)
+C
+C Compute the virtual-bond-torsional-angle dependent quantities needed
+C to calculate the el-loc multibody terms of various order.
+C
+c write(iout,*) 'nphi=',nphi,nres
+c write(iout,*) "itype2loc",itype2loc
+#ifdef PARMAT
+ do i=ivec_start+2,ivec_end+2
+#else
+ do i=3,nres+1
+#endif
+ if (i.gt. nnt+2 .and. i.lt.nct+2) then
+ iti = itype2loc(itype(i-2))
+ else
+ iti=nloctyp
+ endif
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ iti1 = itype2loc(itype(i-1))
+ else
+ iti1=nloctyp
+ endif
+c write(iout,*),i
+#ifdef NEWCORR
+ cost1=dcos(theta(i-1))
+ sint1=dsin(theta(i-1))
+ sint1sq=sint1*sint1
+ sint1cub=sint1sq*sint1
+ sint1cost1=2*sint1*cost1
+c write (iout,*) "bnew1",i,iti
+c write (iout,*) (bnew1(k,1,iti),k=1,3)
+c write (iout,*) (bnew1(k,2,iti),k=1,3)
+c write (iout,*) "bnew2",i,iti
+c write (iout,*) (bnew2(k,1,iti),k=1,3)
+c write (iout,*) (bnew2(k,2,iti),k=1,3)
+ do k=1,2
+ b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
+ b1(k,i-2)=sint1*b1k
+ gtb1(k,i-2)=cost1*b1k-sint1sq*
+ & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
+ b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
+ b2(k,i-2)=sint1*b2k
+ gtb2(k,i-2)=cost1*b2k-sint1sq*
+ & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
+ enddo
+ do k=1,2
+ aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
+ cc(1,k,i-2)=sint1sq*aux
+ gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
+ & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
+ aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
+ dd(1,k,i-2)=sint1sq*aux
+ gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
+ & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
+ enddo
+ cc(2,1,i-2)=cc(1,2,i-2)
+ cc(2,2,i-2)=-cc(1,1,i-2)
+ gtcc(2,1,i-2)=gtcc(1,2,i-2)
+ gtcc(2,2,i-2)=-gtcc(1,1,i-2)
+ dd(2,1,i-2)=dd(1,2,i-2)
+ dd(2,2,i-2)=-dd(1,1,i-2)
+ gtdd(2,1,i-2)=gtdd(1,2,i-2)
+ gtdd(2,2,i-2)=-gtdd(1,1,i-2)
+ do k=1,2
+ do l=1,2
+ aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
+ EE(l,k,i-2)=sint1sq*aux
+ gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
+ enddo
+ enddo
+ EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
+ EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
+ EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
+ EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
+ gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
+ gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
+ gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
+c b1tilde(1,i-2)=b1(1,i-2)
+c b1tilde(2,i-2)=-b1(2,i-2)
+c b2tilde(1,i-2)=b2(1,i-2)
+c b2tilde(2,i-2)=-b2(2,i-2)
+#ifdef DEBUG
+ write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
+ write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
+ write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
+ write (iout,*) 'theta=', theta(i-1)
+#endif
+#else
+ if (i.gt. nnt+2 .and. i.lt.nct+2) then
+ iti = itype2loc(itype(i-2))
+ else
+ iti=nloctyp
+ endif
+c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ iti1 = itype2loc(itype(i-1))
+ else
+ iti1=nloctyp
+ endif
+ b1(1,i-2)=b(3,iti)
+ b1(2,i-2)=b(5,iti)
+ b2(1,i-2)=b(2,iti)
+ b2(2,i-2)=b(4,iti)
+ do k=1,2
+ do l=1,2
+ CC(k,l,i-2)=ccold(k,l,iti)
+ DD(k,l,i-2)=ddold(k,l,iti)
+ EE(k,l,i-2)=eeold(k,l,iti)
+ gtEE(k,l,i-2)=0.0d0
+ enddo
+ enddo
+#endif
+ b1tilde(1,i-2)= b1(1,i-2)
+ b1tilde(2,i-2)=-b1(2,i-2)
+ b2tilde(1,i-2)= b2(1,i-2)
+ b2tilde(2,i-2)=-b2(2,i-2)
+c
+ Ctilde(1,1,i-2)= CC(1,1,i-2)
+ Ctilde(1,2,i-2)= CC(1,2,i-2)
+ Ctilde(2,1,i-2)=-CC(2,1,i-2)
+ Ctilde(2,2,i-2)=-CC(2,2,i-2)
+c
+ Dtilde(1,1,i-2)= DD(1,1,i-2)
+ Dtilde(1,2,i-2)= DD(1,2,i-2)
+ Dtilde(2,1,i-2)=-DD(2,1,i-2)
+ Dtilde(2,2,i-2)=-DD(2,2,i-2)
+#ifdef DEBUG
+ write(iout,*) "i",i," iti",iti
+ write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
+ write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
+#endif
+ enddo
+#ifdef PARMAT
+ do i=ivec_start+2,ivec_end+2
+#else
+ do i=3,nres+1
+#endif
+ if (i .lt. nres+1) then
+ sin1=dsin(phi(i))
+ cos1=dcos(phi(i))
+ sintab(i-2)=sin1
+ costab(i-2)=cos1
+ obrot(1,i-2)=cos1
+ obrot(2,i-2)=sin1
+ sin2=dsin(2*phi(i))
+ cos2=dcos(2*phi(i))
+ sintab2(i-2)=sin2
+ costab2(i-2)=cos2
+ obrot2(1,i-2)=cos2
+ obrot2(2,i-2)=sin2
+ Ug(1,1,i-2)=-cos1
+ Ug(1,2,i-2)=-sin1
+ Ug(2,1,i-2)=-sin1
+ Ug(2,2,i-2)= cos1
+ Ug2(1,1,i-2)=-cos2
+ Ug2(1,2,i-2)=-sin2
+ Ug2(2,1,i-2)=-sin2
+ Ug2(2,2,i-2)= cos2
+ else
+ costab(i-2)=1.0d0
+ sintab(i-2)=0.0d0
+ obrot(1,i-2)=1.0d0
+ obrot(2,i-2)=0.0d0
+ obrot2(1,i-2)=0.0d0
+ obrot2(2,i-2)=0.0d0
+ Ug(1,1,i-2)=1.0d0
+ Ug(1,2,i-2)=0.0d0
+ Ug(2,1,i-2)=0.0d0
+ Ug(2,2,i-2)=1.0d0
+ Ug2(1,1,i-2)=0.0d0
+ Ug2(1,2,i-2)=0.0d0
+ Ug2(2,1,i-2)=0.0d0
+ Ug2(2,2,i-2)=0.0d0
+ endif
+ if (i .gt. 3 .and. i .lt. nres+1) then
+ obrot_der(1,i-2)=-sin1
+ obrot_der(2,i-2)= cos1
+ Ugder(1,1,i-2)= sin1
+ Ugder(1,2,i-2)=-cos1
+ Ugder(2,1,i-2)=-cos1
+ Ugder(2,2,i-2)=-sin1
+ dwacos2=cos2+cos2
+ dwasin2=sin2+sin2
+ obrot2_der(1,i-2)=-dwasin2
+ obrot2_der(2,i-2)= dwacos2
+ Ug2der(1,1,i-2)= dwasin2
+ Ug2der(1,2,i-2)=-dwacos2
+ Ug2der(2,1,i-2)=-dwacos2
+ Ug2der(2,2,i-2)=-dwasin2
+ else
+ obrot_der(1,i-2)=0.0d0
+ obrot_der(2,i-2)=0.0d0
+ Ugder(1,1,i-2)=0.0d0
+ Ugder(1,2,i-2)=0.0d0
+ Ugder(2,1,i-2)=0.0d0
+ Ugder(2,2,i-2)=0.0d0
+ obrot2_der(1,i-2)=0.0d0
+ obrot2_der(2,i-2)=0.0d0
+ Ug2der(1,1,i-2)=0.0d0
+ Ug2der(1,2,i-2)=0.0d0
+ Ug2der(2,1,i-2)=0.0d0
+ Ug2der(2,2,i-2)=0.0d0
+ endif
+c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
+ if (i.gt. nnt+2 .and. i.lt.nct+2) then
+ iti = itype2loc(itype(i-2))
+ else
+ iti=nloctyp
+ endif
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ iti1 = itype2loc(itype(i-1))
+ else
+ iti1=nloctyp
+ endif
+cd write (iout,*) '*******i',i,' iti1',iti
+cd write (iout,*) 'b1',b1(:,iti)
+cd write (iout,*) 'b2',b2(:,iti)
+cd write (iout,*) 'Ug',Ug(:,:,i-2)
+c if (i .gt. iatel_s+2) then
+ if (i .gt. nnt+2) then
+ call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
+#ifdef NEWCORR
+ call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
+c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
+#endif
+c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
+c & EE(1,2,iti),EE(2,2,i)
+ call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
+ call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
+c write(iout,*) "Macierz EUG",
+c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
+c & eug(2,2,i-2)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
+ & then
+ call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
+ call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
+ call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
+ call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
+ call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
+ endif
+ else
+ do k=1,2
+ Ub2(k,i-2)=0.0d0
+ Ctobr(k,i-2)=0.0d0
+ Dtobr2(k,i-2)=0.0d0
+ do l=1,2
+ EUg(l,k,i-2)=0.0d0
+ CUg(l,k,i-2)=0.0d0
+ DUg(l,k,i-2)=0.0d0
+ DtUg2(l,k,i-2)=0.0d0
+ enddo
+ enddo
+ endif
+ call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
+ call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
+ do k=1,2
+ muder(k,i-2)=Ub2der(k,i-2)
+ enddo
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ if (itype(i-1).le.ntyp) then
+ iti1 = itype2loc(itype(i-1))
+ else
+ iti1=nloctyp
+ endif
+ else
+ iti1=nloctyp
+ endif
+ do k=1,2
+ mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
+c mu(k,i-2)=b1(k,i-1)
+c mu(k,i-2)=Ub2(k,i-2)
+ enddo
+#ifdef MUOUT
+ write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
+ & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
+ & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
+ & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
+ & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
+ & ((ee(l,k,i-2),l=1,2),k=1,2)
+#endif
+cd write (iout,*) 'mu1',mu1(:,i-2)
+cd write (iout,*) 'mu2',mu2(:,i-2)
+cd write (iout,*) 'mu',i-2,mu(:,i-2)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
+ & then
+ call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
+ call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
+ call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
+ call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
+ call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
+C Vectors and matrices dependent on a single virtual-bond dihedral.
+ call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
+ call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
+ call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
+ call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
+ call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
+ call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
+ call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
+ call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
+ call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
+ endif
+ enddo
+C Matrices dependent on two consecutive virtual-bond dihedrals.
+C The order of matrices is from left to right.
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
+ &then
+c do i=max0(ivec_start,2),ivec_end
+ do i=2,nres-1
+ call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
+ call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
+ call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
+ call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
+ call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
+ call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
+ call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
+ call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
+ enddo
+ endif
+#if defined(MPI) && defined(PARMAT)
+#ifdef DEBUG
+c if (fg_rank.eq.0) then
+ write (iout,*) "Arrays UG and UGDER before GATHER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug(l,k,i),l=1,2),k=1,2),
+ & ((ugder(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays UG2 and UG2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug2(l,k,i),l=1,2),k=1,2),
+ & ((ug2der(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
+ & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
+ enddo
+ write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & costab(i),sintab(i),costab2(i),sintab2(i)
+ enddo
+ write (iout,*) "Array MUDER"
+ do i=1,nres-1
+ write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
+ enddo
+c endif
+#endif
+ if (nfgtasks.gt.1) then
+ time00=MPI_Wtime()
+c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
+c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
+c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
+#ifdef MATGATHER
+ call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
+ & then
+ call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
+ & MPI_MAT2,FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
+ & MPI_MAT2,FG_COMM1,IERR)
+ endif
+#else
+c Passes matrix info through the ring
+ isend=fg_rank1
+ irecv=fg_rank1-1
+ if (irecv.lt.0) irecv=nfgtasks1-1
+ iprev=irecv
+ inext=fg_rank1+1
+ if (inext.ge.nfgtasks1) inext=0
+ do i=1,nfgtasks1-1
+c write (iout,*) "isend",isend," irecv",irecv
+c call flush(iout)
+ lensend=lentyp(isend)
+ lenrecv=lentyp(irecv)
+c write (iout,*) "lensend",lensend," lenrecv",lenrecv
+c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
+c & MPI_ROTAT1(lensend),inext,2200+isend,
+c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
+c & iprev,2200+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather ROTAT1"
+c call flush(iout)
+c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
+c & MPI_ROTAT2(lensend),inext,3300+isend,
+c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
+c & iprev,3300+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather ROTAT2"
+c call flush(iout)
+ call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
+ & MPI_ROTAT_OLD(lensend),inext,4400+isend,
+ & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
+ & iprev,4400+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather ROTAT_OLD"
+c call flush(iout)
+ call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP11(lensend),inext,5500+isend,
+ & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
+ & iprev,5500+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP11"
+c call flush(iout)
+ call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP12(lensend),inext,6600+isend,
+ & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
+ & iprev,6600+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP12"
+c call flush(iout)
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
+ & then
+ call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
+ & MPI_ROTAT2(lensend),inext,7700+isend,
+ & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
+ & iprev,7700+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP21"
+c call flush(iout)
+ call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP22(lensend),inext,8800+isend,
+ & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
+ & iprev,8800+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP22"
+c call flush(iout)
+ call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP23(lensend),inext,9900+isend,
+ & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
+ & MPI_PRECOMP23(lenrecv),
+ & iprev,9900+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP23"
+c call flush(iout)
+ endif
+ isend=irecv
+ irecv=irecv-1
+ if (irecv.lt.0) irecv=nfgtasks1-1
+ enddo
+#endif
+ time_gather=time_gather+MPI_Wtime()-time00
+ endif
+#ifdef DEBUG
+c if (fg_rank.eq.0) then
+ write (iout,*) "Arrays UG and UGDER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug(l,k,i),l=1,2),k=1,2),
+ & ((ugder(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays UG2 and UG2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug2(l,k,i),l=1,2),k=1,2),
+ & ((ug2der(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
+ & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
+ enddo
+ write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & costab(i),sintab(i),costab2(i),sintab2(i)
+ enddo
+ write (iout,*) "Array MUDER"
+ do i=1,nres-1
+ write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
+ enddo
+c endif
+#endif
+#endif
+cd do i=1,nres
+cd iti = itype2loc(itype(i))
+cd write (iout,*) i
+cd do j=1,2
+cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
+cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
+cd enddo
+cd enddo
+ return
+ end
+C--------------------------------------------------------------------------
+ subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
+C
+C This subroutine calculates the average interaction energy and its gradient
+C in the virtual-bond vectors between non-adjacent peptide groups, based on
+C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
+C The potential depends both on the distance of peptide-group centers and on
+C the orientation of the CA-CA virtual bonds.
+C
+ implicit none
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.TIME1'
+ include 'COMMON.SPLITELE'
+ dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
+ & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
+ double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
+#ifdef MOMENT
+ double precision scal_el /1.0d0/
+#else
+ double precision scal_el /0.5d0/
+#endif
+C 12/13/98
+C 13-go grudnia roku pamietnego...
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
+ & 0.0d0,1.0d0,0.0d0,
+ & 0.0d0,0.0d0,1.0d0/
+cd write(iout,*) 'In EELEC'
+cd do i=1,nloctyp
+cd write(iout,*) 'Type',i
+cd write(iout,*) 'B1',B1(:,i)
+cd write(iout,*) 'B2',B2(:,i)
+cd write(iout,*) 'CC',CC(:,:,i)
+cd write(iout,*) 'DD',DD(:,:,i)
+cd write(iout,*) 'EE',EE(:,:,i)
+cd enddo
+cd call check_vecgrad
+cd stop
+ if (icheckgrad.eq.1) then
+ do i=1,nres-1
+ fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
+ do k=1,3
+ dc_norm(k,i)=dc(k,i)*fac
+ enddo
+c write (iout,*) 'i',i,' fac',fac
+ enddo
+ endif
+ if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
+ & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
+c call vec_and_deriv
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call set_matrices
+#ifdef TIMING
+ time_mat=time_mat+MPI_Wtime()-time01
+#endif
+ endif
+cd do i=1,nres-1
+cd write (iout,*) 'i=',i
+cd do k=1,3
+cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
+cd enddo
+cd do k=1,3
+cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
+cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
+cd enddo
+cd enddo
+ t_eelecij=0.0d0
+ ees=0.0D0
+ evdw1=0.0D0
+ eel_loc=0.0d0
+ eello_turn3=0.0d0
+ eello_turn4=0.0d0
+ ind=0
+ do i=1,nres
+ num_cont_hb(i)=0
+ enddo
+cd print '(a)','Enter EELEC'
+cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
+ do i=1,nres
+ gel_loc_loc(i)=0.0d0
+ gcorr_loc(i)=0.0d0
+ enddo
+c
+c
+c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
+C
+C Loop over i,i+2 and i,i+3 pairs of the peptide groups
+C
+C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
+ do i=iturn3_start,iturn3_end
+c if (i.le.1) cycle
+C write(iout,*) "tu jest i",i
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+C Adam: Unnecessary: handled by iturn3_end and iturn3_start
+c & .or.((i+4).gt.nres)
+c & .or.((i-1).le.0)
+C end of changes by Ana
+ & .or. itype(i+2).eq.ntyp1
+ & .or. itype(i+3).eq.ntyp1) cycle
+C Adam: Instructions below will switch off existing interactions
+c if(i.gt.1)then
+c if(itype(i-1).eq.ntyp1)cycle
+c end if
+c if(i.LT.nres-3)then
+c if (itype(i+4).eq.ntyp1) cycle
+c end if
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+ num_conti=0
+ call eelecij(i,i+2,ees,evdw1,eel_loc)
+ if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
+ num_cont_hb(i)=num_conti
+ enddo
+ do i=iturn4_start,iturn4_end
+ if (i.lt.1) cycle
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+c & .or.((i+5).gt.nres)
+c & .or.((i-1).le.0)
+C end of changes suggested by Ana
+ & .or. itype(i+3).eq.ntyp1
+ & .or. itype(i+4).eq.ntyp1
+c & .or. itype(i+5).eq.ntyp1
+c & .or. itype(i).eq.ntyp1
+c & .or. itype(i-1).eq.ntyp1
+ & ) cycle
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+C Return atom into box, boxxsize is size of box in x dimension
+c 194 continue
+c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
+c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
+C Condition for being inside the proper box
+c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
+c & (xmedi.lt.((-0.5d0)*boxxsize))) then
+c go to 194
+c endif
+c 195 continue
+c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
+c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
+C Condition for being inside the proper box
+c if ((ymedi.gt.((0.5d0)*boxysize)).or.
+c & (ymedi.lt.((-0.5d0)*boxysize))) then
+c go to 195
+c endif
+c 196 continue
+c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
+c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
+C Condition for being inside the proper box
+c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
+c & (zmedi.lt.((-0.5d0)*boxzsize))) then
+c go to 196
+c endif
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+
+ num_conti=num_cont_hb(i)
+c write(iout,*) "JESTEM W PETLI"
+ call eelecij(i,i+3,ees,evdw1,eel_loc)
+ if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
+ & call eturn4(i,eello_turn4)
+ num_cont_hb(i)=num_conti
+ enddo ! i
+C Loop over all neighbouring boxes
+C do xshift=-1,1
+C do yshift=-1,1
+C do zshift=-1,1
+c
+c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
+c
+CTU KURWA
+ do i=iatel_s,iatel_e
+C do i=75,75
+c if (i.le.1) cycle
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+c & .or.((i+2).gt.nres)
+c & .or.((i-1).le.0)
+C end of changes by Ana
+c & .or. itype(i+2).eq.ntyp1
+c & .or. itype(i-1).eq.ntyp1
+ & ) cycle
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+C xmedi=xmedi+xshift*boxxsize
+C ymedi=ymedi+yshift*boxysize
+C zmedi=zmedi+zshift*boxzsize
+
+C Return tom into box, boxxsize is size of box in x dimension
+c 164 continue
+c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
+c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
+C Condition for being inside the proper box
+c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
+c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
+c go to 164
+c endif
+c 165 continue
+c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
+c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
+C Condition for being inside the proper box
+c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
+c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
+c go to 165
+c endif
+c 166 continue
+c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
+c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
+cC Condition for being inside the proper box
+c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
+c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
+c go to 166
+c endif
+
+c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
+ num_conti=num_cont_hb(i)
+C I TU KURWA
+ do j=ielstart(i),ielend(i)
+C do j=16,17
+C write (iout,*) i,j
+C if (j.le.1) cycle
+ if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+c & .or.((j+2).gt.nres)
+c & .or.((j-1).le.0)
+C end of changes by Ana
+c & .or.itype(j+2).eq.ntyp1
+c & .or.itype(j-1).eq.ntyp1
+ &) cycle
+ call eelecij(i,j,ees,evdw1,eel_loc)
+ enddo ! j
+ num_cont_hb(i)=num_conti
+ enddo ! i
+C enddo ! zshift
+C enddo ! yshift
+C enddo ! xshift
+
+c write (iout,*) "Number of loop steps in EELEC:",ind
+cd do i=1,nres
+cd write (iout,'(i3,3f10.5,5x,3f10.5)')
+cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
+cd enddo
+c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
+ccc eel_loc=eel_loc+eello_turn3
+cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
+ return
+ end
+C-------------------------------------------------------------------------------
+ subroutine eelecij(i,j,ees,evdw1,eel_loc)
+ implicit none
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.TIME1'
+ include 'COMMON.SPLITELE'
+ include 'COMMON.SHIELD'
+ dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
+ & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
+ double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
+ & gmuij2(4),gmuji2(4)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
+#ifdef MOMENT
+ double precision scal_el /1.0d0/
+#else
+ double precision scal_el /0.5d0/
+#endif
+C 12/13/98
+C 13-go grudnia roku pamietnego...
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
+ & 0.0d0,1.0d0,0.0d0,
+ & 0.0d0,0.0d0,1.0d0/
+ integer xshift,yshift,zshift
+c time00=MPI_Wtime()
+cd write (iout,*) "eelecij",i,j
+c ind=ind+1
+ iteli=itel(i)
+ itelj=itel(j)
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2
+ aaa=app(iteli,itelj)
+ bbb=bpp(iteli,itelj)
+ ael6i=ael6(iteli,itelj)
+ ael3i=ael3(iteli,itelj)
+ dxj=dc(1,j)
+ dyj=dc(2,j)
+ dzj=dc(3,j)
+ dx_normj=dc_norm(1,j)
+ dy_normj=dc_norm(2,j)
+ dz_normj=dc_norm(3,j)
+C xj=c(1,j)+0.5D0*dxj-xmedi
+C yj=c(2,j)+0.5D0*dyj-ymedi
+C zj=c(3,j)+0.5D0*dzj-zmedi
+ xj=c(1,j)+0.5D0*dxj
+ yj=c(2,j)+0.5D0*dyj
+ zj=c(3,j)+0.5D0*dzj
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
+ dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ isubchap=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-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ isubchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (isubchap.eq.1) then
+ xj=xj_temp-xmedi
+ yj=yj_temp-ymedi
+ zj=zj_temp-zmedi
+ else
+ xj=xj_safe-xmedi
+ yj=yj_safe-ymedi
+ zj=zj_safe-zmedi
+ endif
+C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
+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
+C 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
+C endif !endPBC condintion
+C xj=xj-xmedi
+C yj=yj-ymedi
+C zj=zj-zmedi
+ rij=xj*xj+yj*yj+zj*zj
+
+ sss=sscale(sqrt(rij))
+ sssgrad=sscagrad(sqrt(rij))
+c if (sss.gt.0.0d0) then
+ rrmij=1.0D0/rij
+ rij=dsqrt(rij)
+ rmij=1.0D0/rij
+ r3ij=rrmij*rmij
+ r6ij=r3ij*r3ij
+ cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
+ cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
+ cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
+ fac=cosa-3.0D0*cosb*cosg
+ ev1=aaa*r6ij*r6ij
+c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
+ if (j.eq.i+2) ev1=scal_el*ev1
+ ev2=bbb*r6ij
+ fac3=ael6i*r6ij
+ fac4=ael3i*r3ij
+ evdwij=(ev1+ev2)
+ el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
+ el2=fac4*fac
+C MARYSIA
+C eesij=(el1+el2)
+C 12/26/95 - for the evaluation of multi-body H-bonding interactions
+ ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
+ if (shield_mode.gt.0) then
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ el1=el1*fac_shield(i)**2*fac_shield(j)**2
+ el2=el2*fac_shield(i)**2*fac_shield(j)**2
+ eesij=(el1+el2)
+ ees=ees+eesij
+ else
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+ eesij=(el1+el2)
+ ees=ees+eesij
+ endif
+ evdw1=evdw1+evdwij*sss
+cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
+cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
+cd & xmedi,ymedi,zmedi,xj,yj,zj
+
+ if (energy_dec) then
+ write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
+ &'evdw1',i,j,evdwij
+ &,iteli,itelj,aaa,evdw1,sss
+ write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
+ &fac_shield(i),fac_shield(j)
+ endif
+
+C
+C Calculate contributions to the Cartesian gradient.
+C
+#ifdef SPLITELE
+ facvdw=-6*rrmij*(ev1+evdwij)*sss
+ facel=-3*rrmij*(el1+eesij)
+ fac1=fac
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ ggg(1)=facel*xj
+ ggg(2)=facel*yj
+ ggg(3)=facel*zj
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
+ & *2.0
+ gshieldx(k,iresshield)=gshieldx(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
+C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
+C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C if (iresshield.gt.i) then
+C do ishi=i+1,iresshield-1
+C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
+C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C
+C enddo
+C else
+C do ishi=iresshield,i
+C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
+C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C
+C enddo
+C endif
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
+ & *2.0
+ gshieldx(k,iresshield)=gshieldx(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
+ gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
+
+C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
+C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C if (iresshield.gt.j) then
+C do ishi=j+1,iresshield-1
+C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
+C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C
+C enddo
+C else
+C do ishi=iresshield,j
+C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
+C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C enddo
+C endif
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc(k,i)=gshieldc(k,i)+
+ & grad_shield(k,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,j)=gshieldc(k,j)+
+ & grad_shield(k,j)*eesij/fac_shield(j)*2.0
+ gshieldc(k,i-1)=gshieldc(k,i-1)+
+ & grad_shield(k,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,j-1)=gshieldc(k,j-1)+
+ & grad_shield(k,j)*eesij/fac_shield(j)*2.0
+
+ enddo
+ endif
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c gelc(k,j)=gelc(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+C print *,"before", gelc_long(1,i), gelc_long(1,j)
+ do k=1,3
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)
+C & +grad_shield(k,j)*eesij/fac_shield(j)
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)
+C & +grad_shield(k,i)*eesij/fac_shield(i)
+C gelc_long(k,i-1)=gelc_long(k,i-1)
+C & +grad_shield(k,i)*eesij/fac_shield(i)
+C gelc_long(k,j-1)=gelc_long(k,j-1)
+C & +grad_shield(k,j)*eesij/fac_shield(j)
+ enddo
+C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
+
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+ if (sss.gt.0.0) then
+ ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
+ ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
+ ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
+ else
+ ggg(1)=0.0
+ ggg(2)=0.0
+ ggg(3)=0.0
+ endif
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
+c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+#else
+C MARYSIA
+ facvdw=(ev1+evdwij)*sss
+ facel=(el1+eesij)
+ fac1=fac
+ fac=-3*rrmij*(facvdw+facvdw+facel)
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ ggg(1)=fac*xj
+C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
+ ggg(2)=fac*yj
+C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
+ ggg(3)=fac*zj
+C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c gelc(k,j)=gelc(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gelc_long(k,j)=gelc(k,j)+ggg(k)
+ gelc_long(k,i)=gelc(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
+ ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
+ ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
+ do k=1,3
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ enddo
+#endif
+*
+* Angular part
+*
+ ecosa=2.0D0*fac3*fac1+fac4
+ fac4=-3.0D0*fac4
+ fac3=-6.0D0*fac3
+ ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
+ ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
+ do k=1,3
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
+ enddo
+cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
+cd & (dcosg(k),k=1,3)
+ do k=1,3
+ ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
+ & fac_shield(i)**2*fac_shield(j)**2
+ enddo
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
+c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+c gelc(k,j)=gelc(k,j)+ghalf
+c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
+c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+c enddo
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+C print *,"before22", gelc_long(1,i), gelc_long(1,j)
+ do k=1,3
+ gelc(k,i)=gelc(k,i)
+ & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
+ & *fac_shield(i)**2*fac_shield(j)**2
+ gelc(k,j)=gelc(k,j)
+ & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
+ & *fac_shield(i)**2*fac_shield(j)**2
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)
+ enddo
+C print *,"before33", gelc_long(1,i), gelc_long(1,j)
+
+C MARYSIA
+c endif !sscale
+ IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
+ & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
+C
+C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
+C energy of a peptide unit is assumed in the form of a second-order
+C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
+C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
+C are computed for EVERY pair of non-contiguous peptide groups.
+C
+
+ if (j.lt.nres-1) then
+ j1=j+1
+ j2=j-1
+ else
+ j1=j-1
+ j2=j-2
+ endif
+ kkk=0
+ lll=0
+ do k=1,2
+ do l=1,2
+ kkk=kkk+1
+ muij(kkk)=mu(k,i)*mu(l,j)
+c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
+#ifdef NEWCORR
+ gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
+c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
+ gmuij2(kkk)=gUb2(k,i)*mu(l,j)
+ gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
+c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
+ gmuji2(kkk)=mu(k,i)*gUb2(l,j)
+#endif
+ enddo
+ enddo
+#ifdef DEBUG
+ write (iout,*) 'EELEC: i',i,' j',j
+ write (iout,*) 'j',j,' j1',j1,' j2',j2
+ write(iout,*) 'muij',muij
+#endif
+ ury=scalar(uy(1,i),erij)
+ urz=scalar(uz(1,i),erij)
+ vry=scalar(uy(1,j),erij)
+ vrz=scalar(uz(1,j),erij)
+ a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
+ a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
+ a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
+ a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
+ fac=dsqrt(-ael6i)*r3ij
+#ifdef DEBUG
+ write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
+ write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
+ & "uyvz",scalar(uy(1,i),uz(1,j)),
+ & "uzvy",scalar(uz(1,i),uy(1,j)),
+ & "uzvz",scalar(uz(1,i),uz(1,j))
+ write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
+ write (iout,*) "fac",fac
+#endif
+ a22=a22*fac
+ a23=a23*fac
+ a32=a32*fac
+ a33=a33*fac
+#ifdef DEBUG
+ write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
+#endif
+#undef DEBUG
+cd write (iout,'(4i5,4f10.5)')
+cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
+cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
+cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
+cd & uy(:,j),uz(:,j)
+cd write (iout,'(4f10.5)')
+cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
+cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
+cd write (iout,'(4f10.5)') ury,urz,vry,vrz
+cd write (iout,'(9f10.5/)')
+cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
+C Derivatives of the elements of A in virtual-bond vectors
+ call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
+ do k=1,3
+ uryg(k,1)=scalar(erder(1,k),uy(1,i))
+ uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
+ uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
+ urzg(k,1)=scalar(erder(1,k),uz(1,i))
+ urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
+ urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
+ vryg(k,1)=scalar(erder(1,k),uy(1,j))
+ vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
+ vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
+ vrzg(k,1)=scalar(erder(1,k),uz(1,j))
+ vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
+ vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
+ enddo
+C Compute radial contributions to the gradient
+ facr=-3.0d0*rrmij
+ a22der=a22*facr
+ a23der=a23*facr
+ a32der=a32*facr
+ a33der=a33*facr
+ agg(1,1)=a22der*xj
+ agg(2,1)=a22der*yj
+ agg(3,1)=a22der*zj
+ agg(1,2)=a23der*xj
+ agg(2,2)=a23der*yj
+ agg(3,2)=a23der*zj
+ agg(1,3)=a32der*xj
+ agg(2,3)=a32der*yj
+ agg(3,3)=a32der*zj
+ agg(1,4)=a33der*xj
+ agg(2,4)=a33der*yj
+ agg(3,4)=a33der*zj
+C Add the contributions coming from er
+ fac3=-3.0d0*fac
+ do k=1,3
+ agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
+ agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
+ agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
+ agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
+ enddo
+ do k=1,3
+C Derivatives in DC(i)
+cgrad ghalf1=0.5d0*agg(k,1)
+cgrad ghalf2=0.5d0*agg(k,2)
+cgrad ghalf3=0.5d0*agg(k,3)
+cgrad ghalf4=0.5d0*agg(k,4)
+ aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
+ & -3.0d0*uryg(k,2)*vry)!+ghalf1
+ aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
+ & -3.0d0*uryg(k,2)*vrz)!+ghalf2
+ aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
+ & -3.0d0*urzg(k,2)*vry)!+ghalf3
+ aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
+ & -3.0d0*urzg(k,2)*vrz)!+ghalf4
+C Derivatives in DC(i+1)
+ aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
+ & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
+ aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
+ & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
+ aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
+ & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
+ aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
+ & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
+C Derivatives in DC(j)
+ aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
+ & -3.0d0*vryg(k,2)*ury)!+ghalf1
+ aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
+ & -3.0d0*vrzg(k,2)*ury)!+ghalf2
+ aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
+ & -3.0d0*vryg(k,2)*urz)!+ghalf3
+ aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
+ & -3.0d0*vrzg(k,2)*urz)!+ghalf4
+C Derivatives in DC(j+1) or DC(nres-1)
+ aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
+ & -3.0d0*vryg(k,3)*ury)
+ aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
+ & -3.0d0*vrzg(k,3)*ury)
+ aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
+ & -3.0d0*vryg(k,3)*urz)
+ aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
+ & -3.0d0*vrzg(k,3)*urz)
+cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
+cgrad do l=1,4
+cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
+cgrad enddo
+cgrad endif
+ enddo
+ acipa(1,1)=a22
+ acipa(1,2)=a23
+ acipa(2,1)=a32
+ acipa(2,2)=a33
+ a22=-a22
+ a23=-a23
+ do l=1,2
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ if (j.lt.nres-1) then
+ a22=-a22
+ a32=-a32
+ do l=1,3,2
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ else
+ a22=-a22
+ a23=-a23
+ a32=-a32
+ a33=-a33
+ do l=1,4
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ endif
+ ENDIF ! WCORR
+ IF (wel_loc.gt.0.0d0) THEN
+C Contribution to the local-electrostatic energy coming from the i-j pair
+ eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
+ & +a33*muij(4)
+#ifdef DEBUG
+ write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
+ & " a33",a33
+ write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
+ & " wel_loc",wel_loc
+#endif
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ endif
+ eel_loc_ij=eel_loc_ij
+ & *fac_shield(i)*fac_shield(j)
+c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+c & 'eelloc',i,j,eel_loc_ij
+C Now derivative over eel_loc
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
+ & /fac_shield(i)
+C & *2.0
+ gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
+ & /fac_shield(j)
+C & *2.0
+ gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
+ gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc_ll(k,i)=gshieldc_ll(k,i)+
+ & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,j)=gshieldc_ll(k,j)+
+ & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
+ gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
+ & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
+ & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
+ enddo
+ endif
+
+
+c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
+c & ' eel_loc_ij',eel_loc_ij
+C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
+C Calculate patrial derivative for theta angle
+#ifdef NEWCORR
+ geel_loc_ij=(a22*gmuij1(1)
+ & +a23*gmuij1(2)
+ & +a32*gmuij1(3)
+ & +a33*gmuij1(4))
+ & *fac_shield(i)*fac_shield(j)
+c write(iout,*) "derivative over thatai"
+c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
+c & a33*gmuij1(4)
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)+
+ & geel_loc_ij*wel_loc
+c write(iout,*) "derivative over thatai-1"
+c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
+c & a33*gmuij2(4)
+ geel_loc_ij=
+ & a22*gmuij2(1)
+ & +a23*gmuij2(2)
+ & +a32*gmuij2(3)
+ & +a33*gmuij2(4)
+ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
+ & geel_loc_ij*wel_loc
+ & *fac_shield(i)*fac_shield(j)
+
+c Derivative over j residue
+ geel_loc_ji=a22*gmuji1(1)
+ & +a23*gmuji1(2)
+ & +a32*gmuji1(3)
+ & +a33*gmuji1(4)
+c write(iout,*) "derivative over thataj"
+c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
+c & a33*gmuji1(4)
+
+ gloc(nphi+j,icg)=gloc(nphi+j,icg)+
+ & geel_loc_ji*wel_loc
+ & *fac_shield(i)*fac_shield(j)
+
+ geel_loc_ji=
+ & +a22*gmuji2(1)
+ & +a23*gmuji2(2)
+ & +a32*gmuji2(3)
+ & +a33*gmuji2(4)
+c write(iout,*) "derivative over thataj-1"
+c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
+c & a33*gmuji2(4)
+ gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
+ & geel_loc_ji*wel_loc
+ & *fac_shield(i)*fac_shield(j)
+#endif
+cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
+
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'eelloc',i,j,eel_loc_ij
+c if (eel_loc_ij.ne.0)
+c & write (iout,'(a4,2i4,8f9.5)')'chuj',
+c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
+
+ eel_loc=eel_loc+eel_loc_ij
+C Partial derivatives in virtual-bond dihedral angles gamma
+ if (i.gt.1)
+ & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
+ & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
+ & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc_loc(j-1)=gel_loc_loc(j-1)+
+ & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
+ & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
+ do l=1,3
+ ggg(l)=(agg(l,1)*muij(1)+
+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+ gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
+ gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
+cgrad ghalf=0.5d0*ggg(l)
+cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
+cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
+ enddo
+cgrad do k=i+1,j2
+cgrad do l=1,3
+cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+C Remaining derivatives of eello
+ do l=1,3
+ gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
+ & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
+ & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
+ & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
+ & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ enddo
+ ENDIF
+C Change 12/26/95 to calculate four-body contributions to H-bonding energy
+c if (j.gt.i+1 .and. num_conti.le.maxconts) then
+ if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
+ & .and. num_conti.le.maxconts) then
+c write (iout,*) i,j," entered corr"
+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 r0ij=1.02D0*rpp(iteli,itelj)
+c r0ij=1.11D0*rpp(iteli,itelj)
+ r0ij=2.20D0*rpp(iteli,itelj)
+c r0ij=1.55D0*rpp(iteli,itelj)
+ call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
+ if (fcont.gt.0.0D0) then
+ num_conti=num_conti+1
+ if (num_conti.gt.maxconts) then
+ write (iout,*) 'WARNING - max. # of contacts exceeded;',
+ & ' will skip next contacts for this conf.'
+ else
+ jcont_hb(num_conti,i)=j
+cd write (iout,*) "i",i," j",j," num_conti",num_conti,
+cd & " jcont_hb",jcont_hb(num_conti,i)
+ IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
+ & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
+C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
+C terms.
+ d_cont(num_conti,i)=rij
+cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
+C --- Electrostatic-interaction matrix ---
+ a_chuj(1,1,num_conti,i)=a22
+ a_chuj(1,2,num_conti,i)=a23
+ a_chuj(2,1,num_conti,i)=a32
+ a_chuj(2,2,num_conti,i)=a33
+C --- Gradient of rij
+ do kkk=1,3
+ grij_hb_cont(kkk,num_conti,i)=erij(kkk)
+ enddo
+ kkll=0
+ do k=1,2
+ do l=1,2
+ kkll=kkll+1
+ do m=1,3
+ a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
+ a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
+ a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
+ a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
+ a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
+ enddo
+ enddo
+ enddo
+ ENDIF
+ IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
+C Calculate contact energies
+ cosa4=4.0D0*cosa
+ wij=cosa-3.0D0*cosb*cosg
+ cosbg1=cosb+cosg
+ cosbg2=cosb-cosg
+c fac3=dsqrt(-ael6i)/r0ij**3
+ fac3=dsqrt(-ael6i)*r3ij
+c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
+ ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
+ if (ees0tmp.gt.0) then
+ ees0pij=dsqrt(ees0tmp)
+ else
+ ees0pij=0
+ endif
+c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
+ ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
+ if (ees0tmp.gt.0) then
+ ees0mij=dsqrt(ees0tmp)
+ else
+ ees0mij=0
+ endif
+c ees0mij=0.0D0
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0d0
+ fac_shield(j)=1.0d0
+ else
+ ees0plist(num_conti,i)=j
+C fac_shield(i)=0.4d0
+C fac_shield(j)=0.6d0
+ endif
+ ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
+ & *fac_shield(i)*fac_shield(j)
+ ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
+ & *fac_shield(i)*fac_shield(j)
+C Diagnostics. Comment out or remove after debugging!
+c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
+c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
+c ees0m(num_conti,i)=0.0D0
+C End diagnostics.
+c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
+c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
+C Angular derivatives of the contact function
+ ees0pij1=fac3/ees0pij
+ ees0mij1=fac3/ees0mij
+ fac3p=-3.0D0*fac3*rrmij
+ ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
+ ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
+c ees0mij1=0.0D0
+ ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
+ ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
+ ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
+ ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
+ ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
+ ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
+ ecosap=ecosa1+ecosa2
+ ecosbp=ecosb1+ecosb2
+ ecosgp=ecosg1+ecosg2
+ ecosam=ecosa1-ecosa2
+ ecosbm=ecosb1-ecosb2
+ ecosgm=ecosg1-ecosg2
+C Diagnostics
+c ecosap=ecosa1
+c ecosbp=ecosb1
+c ecosgp=ecosg1
+c ecosam=0.0D0
+c ecosbm=0.0D0
+c ecosgm=0.0D0
+C End diagnostics
+ facont_hb(num_conti,i)=fcont
+ fprimcont=fprimcont/rij
+cd facont_hb(num_conti,i)=1.0D0
+C Following line is for diagnostics.
+cd fprimcont=0.0D0
+ do k=1,3
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
+ enddo
+ do k=1,3
+ gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
+ gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
+ enddo
+ gggp(1)=gggp(1)+ees0pijp*xj
+ gggp(2)=gggp(2)+ees0pijp*yj
+ gggp(3)=gggp(3)+ees0pijp*zj
+ gggm(1)=gggm(1)+ees0mijp*xj
+ gggm(2)=gggm(2)+ees0mijp*yj
+ gggm(3)=gggm(3)+ees0mijp*zj
+C Derivatives due to the contact function
+ gacont_hbr(1,num_conti,i)=fprimcont*xj
+ gacont_hbr(2,num_conti,i)=fprimcont*yj
+ gacont_hbr(3,num_conti,i)=fprimcont*zj
+ do k=1,3
+c
+c 10/24/08 cgrad and ! comments indicate the parts of the code removed
+c following the change of gradient-summation algorithm.
+c
+cgrad ghalfp=0.5D0*gggp(k)
+cgrad ghalfm=0.5D0*gggm(k)
+ gacontp_hb1(k,num_conti,i)=!ghalfp
+ & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontp_hb2(k,num_conti,i)=!ghalfp
+ & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontp_hb3(k,num_conti,i)=gggp(k)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb1(k,num_conti,i)=!ghalfm
+ & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb2(k,num_conti,i)=!ghalfm
+ & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb3(k,num_conti,i)=gggm(k)
+ & *fac_shield(i)*fac_shield(j)
+
+ enddo
+C Diagnostics. Comment out or remove after debugging!
+cdiag do k=1,3
+cdiag gacontp_hb1(k,num_conti,i)=0.0D0
+cdiag gacontp_hb2(k,num_conti,i)=0.0D0
+cdiag gacontp_hb3(k,num_conti,i)=0.0D0
+cdiag gacontm_hb1(k,num_conti,i)=0.0D0
+cdiag gacontm_hb2(k,num_conti,i)=0.0D0
+cdiag gacontm_hb3(k,num_conti,i)=0.0D0
+cdiag enddo
+ ENDIF ! wcorr
+ endif ! num_conti.le.maxconts
+ endif ! fcont.gt.0
+ endif ! j.gt.i+1
+ if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
+ do k=1,4
+ do l=1,3
+ ghalf=0.5d0*agg(l,k)
+ aggi(l,k)=aggi(l,k)+ghalf
+ aggi1(l,k)=aggi1(l,k)+agg(l,k)
+ aggj(l,k)=aggj(l,k)+ghalf
+ enddo
+ enddo
+ if (j.eq.nres-1 .and. i.lt.j-2) then
+ do k=1,4
+ do l=1,3
+ aggj1(l,k)=aggj1(l,k)+agg(l,k)
+ enddo
+ enddo
+ endif
+ endif
+c t_eelecij=t_eelecij+MPI_Wtime()-time00
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine eturn3(i,eello_turn3)
+C Third- and fourth-order contributions from turns
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SHIELD'
+ dimension ggg(3)
+ double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
+ & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
+ & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
+ & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
+ & auxgmat2(2,2),auxgmatt2(2,2)
+ double precision agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+ j=i+2
+c write (iout,*) "eturn3",i,j,j1,j2
+ a_temp(1,1)=a22
+ a_temp(1,2)=a23
+ a_temp(2,1)=a32
+ a_temp(2,2)=a33
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C Third-order contributions
+C
+C (i+2)o----(i+3)
+C | |
+C | |
+C (i+1)o----i
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+cd call checkint_turn3(i,a_temp,eello_turn3_num)
+ call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
+c auxalary matices for theta gradient
+c auxalary matrix for i+1 and constant i+2
+ call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
+c auxalary matrix for i+2 and constant i+1
+ call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
+ call transpose2(auxmat(1,1),auxmat1(1,1))
+ call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
+ call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
+ call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ endif
+ eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
+ & eello_t3
+C#ifdef NEWCORR
+C Derivatives in theta
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)
+ & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
+ & *fac_shield(i)*fac_shield(j)
+ gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
+ & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
+ & *fac_shield(i)*fac_shield(j)
+C#endif
+
+C Derivatives in shield mode
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
+C & *2.0
+ gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
+C & *2.0
+ gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
+ gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc_t3(k,i)=gshieldc_t3(k,i)+
+ & grad_shield(k,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,j)=gshieldc_t3(k,j)+
+ & grad_shield(k,j)*eello_t3/fac_shield(j)
+ gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
+ & grad_shield(k,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
+ & grad_shield(k,j)*eello_t3/fac_shield(j)
+ enddo
+ endif
+
+C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+cd write (2,*) 'i,',i,' j',j,'eello_turn3',
+cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
+cd & ' eello_turn3_num',4*eello_turn3_num
+C Derivatives in gamma(i)
+ call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
+ call transpose2(auxmat2(1,1),auxmat3(1,1))
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
+ gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives in gamma(i+1)
+ call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
+ call transpose2(auxmat2(1,1),auxmat3(1,1))
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
+ gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+C Cartesian derivatives
+ do l=1,3
+c ghalf1=0.5d0*agg(l,1)
+c ghalf2=0.5d0*agg(l,2)
+c ghalf3=0.5d0*agg(l,3)
+c ghalf4=0.5d0*agg(l,4)
+ a_temp(1,1)=aggi(l,1)!+ghalf1
+ a_temp(1,2)=aggi(l,2)!+ghalf2
+ a_temp(2,1)=aggi(l,3)!+ghalf3
+ a_temp(2,2)=aggi(l,4)!+ghalf4
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,i)=gcorr3_turn(l,i)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+
+ a_temp(1,1)=aggi1(l,1)!+agg(l,1)
+ a_temp(1,2)=aggi1(l,2)!+agg(l,2)
+ a_temp(2,1)=aggi1(l,3)!+agg(l,3)
+ a_temp(2,2)=aggi1(l,4)!+agg(l,4)
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj(l,1)!+ghalf1
+ a_temp(1,2)=aggj(l,2)!+ghalf2
+ a_temp(2,1)=aggj(l,3)!+ghalf3
+ a_temp(2,2)=aggj(l,4)!+ghalf4
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,j)=gcorr3_turn(l,j)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj1(l,1)
+ a_temp(1,2)=aggj1(l,2)
+ a_temp(2,1)=aggj1(l,3)
+ a_temp(2,2)=aggj1(l,4)
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ enddo
+ return
+ end
+C-------------------------------------------------------------------------------
+ subroutine eturn4(i,eello_turn4)
+C Third- and fourth-order contributions from turns
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SHIELD'
+ dimension ggg(3)
+ double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
+ & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
+ & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
+ & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
+ & gte1t(2,2),gte2t(2,2),gte3t(2,2),
+ & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
+ & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
+ double precision agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+ j=i+3
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C Fourth-order contributions
+C
+C (i+3)o----(i+4)
+C / |
+C (i+2)o |
+C \ |
+C (i+1)o----i
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+cd call checkint_turn4(i,a_temp,eello_turn4_num)
+c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
+c write(iout,*)"WCHODZE W PROGRAM"
+ a_temp(1,1)=a22
+ a_temp(1,2)=a23
+ a_temp(2,1)=a32
+ a_temp(2,2)=a33
+ iti1=itype2loc(itype(i+1))
+ iti2=itype2loc(itype(i+2))
+ iti3=itype2loc(itype(i+3))
+c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
+ call transpose2(EUg(1,1,i+1),e1t(1,1))
+ call transpose2(Eug(1,1,i+2),e2t(1,1))
+ call transpose2(Eug(1,1,i+3),e3t(1,1))
+C Ematrix derivative in theta
+ call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
+ call transpose2(gtEug(1,1,i+2),gte2t(1,1))
+ call transpose2(gtEug(1,1,i+3),gte3t(1,1))
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+c eta1 in derivative theta
+ call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+c auxgvec is derivative of Ub2 so i+3 theta
+ call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
+c auxalary matrix of E i+1
+ call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
+c s1=0.0
+c gs1=0.0
+ s1=scalar2(b1(1,i+2),auxvec(1))
+c derivative of theta i+2 with constant i+3
+ gs23=scalar2(gtb1(1,i+2),auxvec(1))
+c derivative of theta i+2 with constant i+2
+ gs32=scalar2(b1(1,i+2),auxgvec(1))
+c derivative of E matix in theta of i+1
+ gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
+
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+c ea31 in derivative theta
+ call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+c auxilary matrix auxgvec of Ub2 with constant E matirx
+ call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
+c auxilary matrix auxgEvec1 of E matix with Ub2 constant
+ call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
+
+c s2=0.0
+c gs2=0.0
+ s2=scalar2(b1(1,i+1),auxvec(1))
+c derivative of theta i+1 with constant i+3
+ gs13=scalar2(gtb1(1,i+1),auxvec(1))
+c derivative of theta i+2 with constant i+1
+ gs21=scalar2(b1(1,i+1),auxgvec(1))
+c derivative of theta i+3 with constant i+1
+ gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
+c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
+c & gtb1(1,i+1)
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+c two derivatives over diffetent matrices
+c gtae3e2 is derivative over i+3
+ call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
+c ae3gte2 is derivative over i+2
+ call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+c three possible derivative over theta E matices
+c i+1
+ call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
+c i+2
+ call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
+c i+3
+ call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+
+ gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
+ gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
+ gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.6
+C fac_shield(j)=0.4
+ endif
+ eello_turn4=eello_turn4-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ eello_t4=-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
+ & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
+C Now derivative over shield:
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
+C & *2.0
+ gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
+C & *2.0
+ gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
+ gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc_t4(k,i)=gshieldc_t4(k,i)+
+ & grad_shield(k,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,j)=gshieldc_t4(k,j)+
+ & grad_shield(k,j)*eello_t4/fac_shield(j)
+ gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
+ & grad_shield(k,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
+ & grad_shield(k,j)*eello_t4/fac_shield(j)
+ enddo
+ endif
+
+#ifdef NEWCORR
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)
+ & -(gs13+gsE13+gsEE1)*wturn4
+ & *fac_shield(i)*fac_shield(j)
+ gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
+ & -(gs23+gs21+gsEE2)*wturn4
+ & *fac_shield(i)*fac_shield(j)
+
+ gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
+ & -(gs32+gsE31+gsEE3)*wturn4
+ & *fac_shield(i)*fac_shield(j)
+
+c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
+c & gs2
+#endif
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'eturn4',i,j,-(s1+s2+s3)
+c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
+c & ' eello_turn4_num',8*eello_turn4_num
+C Derivatives in gamma(i)
+ call transpose2(EUgder(1,1,i+1),e1tder(1,1))
+ call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives in gamma(i+1)
+ call transpose2(EUgder(1,1,i+2),e2tder(1,1))
+ call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
+ call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives in gamma(i+2)
+ call transpose2(EUgder(1,1,i+3),e3tder(1,1))
+ call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
+ call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+C Cartesian derivatives
+C Derivatives of this turn contributions in DC(i+2)
+ if (j.lt.nres-1) then
+ do l=1,3
+ a_temp(1,1)=agg(l,1)
+ a_temp(1,2)=agg(l,2)
+ a_temp(2,1)=agg(l,3)
+ a_temp(2,2)=agg(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ ggg(l)=-(s1+s2+s3)
+ gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ enddo
+ endif
+C Remaining derivatives of this turn contribution
+ do l=1,3
+ a_temp(1,1)=aggi(l,1)
+ a_temp(1,2)=aggi(l,2)
+ a_temp(2,1)=aggi(l,3)
+ a_temp(2,2)=aggi(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggi1(l,1)
+ a_temp(1,2)=aggi1(l,2)
+ a_temp(2,1)=aggi1(l,3)
+ a_temp(2,2)=aggi1(l,4)
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggi1(l,1)
+ a_temp(1,2)=aggi1(l,2)
+ a_temp(2,1)=aggi1(l,3)
+ a_temp(2,2)=aggi1(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj(l,1)
+ a_temp(1,2)=aggj(l,2)
+ a_temp(2,1)=aggj(l,3)
+ a_temp(2,2)=aggj(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj1(l,1)
+ a_temp(1,2)=aggj1(l,2)
+ a_temp(2,1)=aggj1(l,3)
+ a_temp(2,2)=aggj1(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
+ gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ enddo
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine vecpr(u,v,w)
+ implicit none
+ double precision u(3),v(3),w(3)
+ w(1)=u(2)*v(3)-u(3)*v(2)
+ w(2)=-u(1)*v(3)+u(3)*v(1)
+ w(3)=u(1)*v(2)-u(2)*v(1)
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine unormderiv(u,ugrad,unorm,ungrad)
+C This subroutine computes the derivatives of a normalized vector u, given
+C the derivatives computed without normalization conditions, ugrad. Returns
+C ungrad.
+ implicit none
+ double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
+ double precision vec(3)
+ double precision scalar
+ integer i,j
+c write (2,*) 'ugrad',ugrad
+c write (2,*) 'u',u
+ do i=1,3
+ vec(i)=scalar(ugrad(1,i),u(1))
+ enddo
+c write (2,*) 'vec',vec
+ do i=1,3
+ do j=1,3
+ ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
+ enddo
+ enddo
+c write (2,*) 'ungrad',ungrad
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine escp_soft_sphere(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'
+ dimension ggg(3)
+ integer xshift,yshift,zshift
+ evdw2=0.0D0
+ evdw2_14=0.0d0
+ r0_scp=4.5d0
+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
+ 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))
+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 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 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
+cC 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
+ 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
+ do iint=1,nscp_gr(i)
+
+ do j=iscpstart(i,iint),iscpend(i,iint)
+ if (itype(j).eq.ntyp1) cycle
+ itypj=iabs(itype(j))
+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)
+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
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ subchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (subchap.eq.1) then
+ xj=xj_temp-xi
+ yj=yj_temp-yi
+ zj=zj_temp-zi
+ else
+ xj=xj_safe-xi
+ yj=yj_safe-yi
+ zj=zj_safe-zi
+ endif
+c c endif
+C xj=xj-xi
+C yj=yj-yi
+C zj=zj-zi
+ rij=xj*xj+yj*yj+zj*zj
+
+ r0ij=r0_scp
+ r0ijsq=r0ij*r0ij
+ if (rij.lt.r0ijsq) then
+ evdwij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdwij=0.0d0
+ fac=0.0d0
+ endif
+ evdw2=evdw2+evdwij
+C
+C Calculate contributions to the gradient in the virtual-bond and SC vectors.
+C
+ ggg(1)=xj*fac
+ ggg(2)=yj*fac
+ ggg(3)=zj*fac
+cgrad if (j.lt.i) then
+cd write (iout,*) 'j<i'
+C Uncomment following three lines for SC-p interactions
+c do k=1,3
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+c enddo
+cgrad else
+cd write (iout,*) 'j>i'
+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,*) 'j<i'
+C Uncomment following three lines for SC-p interactions
+c do k=1,3
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+c enddo
+cgrad else
+cd write (iout,*) 'j>i'
+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
--- /dev/null
+ 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 (r<sigma).
+C
+ if (fcont.gt.0.0D0) then
+C If the SC-SC distance if close to sigma, apply spline.
+cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
+cAdam & fcont1,fprimcont1)
+cAdam fcont1=1.0d0-fcont1
+cAdam if (fcont1.gt.0.0d0) then
+cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
+cAdam fcont=fcont*fcont1
+cAdam endif
+C Uncomment following 4 lines to have the geometric average of the epsilon0's
+cga eps0ij=1.0d0/dsqrt(eps0ij)
+cga do k=1,3
+cga gg(k)=gg(k)*eps0ij
+cga enddo
+cga eps0ij=-evdwij*eps0ij
+C Uncomment for AL's type of SC correlation interactions.
+cadam eps0ij=-evdwij
+ num_conti=num_conti+1
+ jcont(num_conti,i)=j
+ facont(num_conti,i)=fcont*eps0ij
+ fprimcont=eps0ij*fprimcont/rij
+ fcont=expon*fcont
+cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
+cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
+cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
+C Uncomment following 3 lines for Skolnick's type of SC correlation.
+ gacont(1,num_conti,i)=-fprimcont*xj
+ gacont(2,num_conti,i)=-fprimcont*yj
+ gacont(3,num_conti,i)=-fprimcont*zj
+cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
+cd write (iout,'(2i3,3f10.5)')
+cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
+ endif
+ endif
+#endif
+ enddo ! j
+ enddo ! iint
+C Change 12/1/95
+#ifdef FOURBODY
+ num_cont(i)=num_conti
+#endif
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+C******************************************************************************
+C
+C N O T E !!!
+C
+C To save time, the factor of 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 eljk(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJK potential of interaction.
+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.IOUNITS'
+ include 'COMMON.NAMES'
+ double precision gg(3)
+ double precision evdw,evdwij
+ integer i,j,k,itypi,itypj,itypi1,iint
+ double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
+ & fac_augm,e_augm,r_inv_ij,r_shift_inv
+ logical scheck
+c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ do i=iatsc_s,iatsc_e
+ itypi=iabs(itype(i))
+ if (itypi.eq.ntyp1) cycle
+ itypi1=iabs(itype(i+1))
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ r_inv_ij=dsqrt(rrij)
+ rij=1.0D0/r_inv_ij
+ r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
+ fac=r_shift_inv**expon
+C have you changed here?
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=e_augm+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),8(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
+cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
+cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
+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=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+ do k=1,3
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)
+ gvdwc(k,i)=gvdwc(k,i)-gg(k)
+ gvdwc(k,j)=gvdwc(k,j)+gg(k)
+ enddo
+cgrad do k=i,j-1
+cgrad do l=1,3
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
+cgrad enddo
+cgrad enddo
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ do i=1,nct
+ do j=1,3
+ gvdwc(j,i)=expon*gvdwc(j,i)
+ gvdwx(j,i)=expon*gvdwx(j,i)
+ enddo
+ enddo
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine ebp(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Berne-Pechukas potential of interaction.
+C
+ 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'
+ integer icall
+ common /srutu/ icall
+ double precision evdw
+ integer itypi,itypj,itypi1,iint,ind
+ double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
+c double precision rrsave(maxdim)
+ logical lprn
+ evdw=0.0D0
+c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+c if (icall.eq.0) then
+c lprn=.true.
+c else
+ lprn=.false.
+c endif
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=iabs(itype(i))
+ if (itypi.eq.ntyp1) cycle
+ itypi1=iabs(itype(i+1))
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)-xi
+ yj=c(2,nres+j)-yi
+ zj=c(3,nres+j)-zi
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+cd if (icall.eq.0) then
+cd rrsave(ind)=rrij
+cd else
+cd rrij=rrsave(ind)
+cd endif
+ rij=dsqrt(rrij)
+C Calculate the angle-dependent terms of energy & contributions to derivatives.
+ call sc_angular
+C Calculate whole angle-dependent part of epsilon and contributions
+C to its derivatives
+C have you changed here?
+ fac=(rrij*sigsq)**expon2
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij
+ if (lprn) then
+ sigm=dabs(aa/bb)**(1.0D0/6.0D0)
+ epsi=bb**2/aa
+cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & epsi,sigm,chi1,chi2,chip1,chip2,
+cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
+cd & om1,om2,om12,1.0D0/dsqrt(rrij),
+cd & evdwij
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)
+ sigder=fac/sigsq
+ fac=rrij*fac
+C Calculate radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate the angular part of the gradient and sum add the contributions
+C to the appropriate components of the Cartesian gradient.
+ call sc_grad
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+c stop
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egb(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne potential of interaction.
+C
+ 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'
+ logical lprn
+ integer xshift,yshift,zshift,subchap
+ double precision evdw
+ integer itypi,itypj,itypi1,iint,ind
+ double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
+ double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
+ & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
+ & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
+ double precision dist,sscale,sscagrad,sscagradlip,sscalelip
+ evdw=0.0D0
+ccccc energy_dec=.false.
+C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.eq.0) lprn=.false.
+ ind=0
+C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
+C we have the original box)
+C do xshift=-1,1
+C do yshift=-1,1
+C do zshift=-1,1
+ 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 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 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
+ 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 define scaling factor for lipids
+
+C if (positi.le.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 ((zi.gt.bordlipbot)
+ &.and.(zi.lt.bordliptop)) then
+C the energy transfer exist
+ if (zi.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zi.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipi=1.0d0
+ ssgradlipi=0.0
+ endif
+ else
+ sslipi=0.0d0
+ ssgradlipi=0.0
+ endif
+
+C xi=xi+xshift*boxxsize
+C yi=yi+yshift*boxysize
+C zi=zi+zshift*boxzsize
+
+ 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(i+nres)
+c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
+c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
+
+c write(iout,*) "PRZED ZWYKLE", evdwij
+ call dyn_ssbond_ene(i,j,evdwij)
+c write(iout,*) "PO ZWYKLE", evdwij
+
+ evdw=evdw+evdwij
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
+ & 'evdw',i,j,evdwij,' ss'
+C triple bond artifac removal
+ do k=j+1,iend(i,iint)
+C search over all next residues
+ if (dyn_ss_mask(k)) then
+C check if they are cysteins
+C write(iout,*) 'k=',k
+
+c write(iout,*) "PRZED TRI", evdwij
+ evdwij_przed_tri=evdwij
+ call triple_ssbond_ene(i,j,k,evdwij)
+c if(evdwij_przed_tri.ne.evdwij) then
+c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
+c endif
+
+c write(iout,*) "PO TRI", evdwij
+C call the energy function that removes the artifical triple disulfide
+C bond the soubroutine is located in ssMD.F
+ evdw=evdw+evdwij
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
+ & 'evdw',i,j,evdwij,'tss'
+ endif!dyn_ss_mask(k)
+ enddo! k
+ ELSE
+ ind=ind+1
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
+c & 1.0d0/vbld(j+nres)
+c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
+ sig0ij=sigma(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+ xj=c(1,nres+j)
+ yj=c(2,nres+j)
+ zj=c(3,nres+j)
+C Return atom J into box the original box
+c 137 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 137
+c endif
+c 138 continue
+c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
+c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
+C 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 138
+c endif
+c 139 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 139
+c endif
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.gt.bordlipbot)
+ &.and.(zj.lt.bordliptop)) then
+C the energy transfer exist
+ if (zj.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zj-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zj.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipj=1.0d0
+ ssgradlipj=0.0
+ endif
+ else
+ sslipj=0.0d0
+ ssgradlipj=0.0
+ endif
+ aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+ bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
+C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
+C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
+C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
+C print *,sslipi,sslipj,bordlipbot,zi,zj
+ dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ subchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (subchap.eq.1) then
+ xj=xj_temp-xi
+ yj=yj_temp-yi
+ zj=zj_temp-zi
+ else
+ xj=xj_safe-xi
+ yj=yj_safe-yi
+ zj=zj_safe-zi
+ endif
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+C xj=xj-xi
+C yj=yj-yi
+C zj=zj-zi
+c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
+c write (iout,*) "j",j," dc_norm",
+c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij)
+ sss=sscale(1.0d0/rij,r_cut_int)
+ sssgrad=sscagrad(1.0d0/rij,r_cut_int)
+
+c write (iout,'(a7,4f8.3)')
+c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
+ if (sss.gt.0.0d0) then
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+sig0ij
+c for diagnostics; uncomment
+c rij_shift=1.2*sig0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+cd & restyp(itypi),i,restyp(itypj),j,
+cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+C here to start with
+C if (c(i,3).gt.
+ faclip=fac
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
+C &((sslipi+sslipj)/2.0d0+
+C &(2.0d0-sslipi-sslipj)/2.0d0)
+c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
+c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij*sss
+ if (lprn) then
+ sigm=dabs(aa/bb)**(1.0D0/6.0D0)
+ epsi=bb**2/aa
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+ & evdwij
+ endif
+
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'evdw',i,j,evdwij
+
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac
+c print '(2i4,6f8.4)',i,j,sss,sssgrad*
+c & evdwij,fac,sigma(itypi,itypj),expon
+ fac=fac+evdwij/sss*sssgrad*rij
+c fac=0.0d0
+C Calculate the radial part of the gradient
+ gg_lipi(3)=eps1*(eps2rt*eps2rt)
+ &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
+ & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
+ &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
+ gg_lipj(3)=ssgradlipj*gg_lipi(3)
+ gg_lipi(3)=gg_lipi(3)*ssgradlipi
+C gg_lipi(3)=0.0d0
+C gg_lipj(3)=0.0d0
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad
+ endif
+ ENDIF ! dyn_ss
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+C enddo ! zshift
+C enddo ! yshift
+C enddo ! xshift
+c write (iout,*) "Number of loop steps in EGB:",ind
+cccc energy_dec=.false.
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine egbv(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the Gay-Berne-Vorobjev potential of interaction.
+C
+ 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'
+ integer xshift,yshift,zshift,subchap
+ integer icall
+ common /srutu/ icall
+ logical lprn
+ double precision evdw
+ integer itypi,itypj,itypi1,iint,ind
+ double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
+ & xi,yi,zi,fac_augm,e_augm
+ double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
+ & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
+ & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
+ double precision dist,sscale,sscagrad,sscagradlip,sscalelip
+ evdw=0.0D0
+c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
+ evdw=0.0D0
+ lprn=.false.
+c if (icall.eq.0) lprn=.true.
+ ind=0
+ do i=iatsc_s,iatsc_e
+ itypi=iabs(itype(i))
+ if (itypi.eq.ntyp1) cycle
+ itypi1=iabs(itype(i+1))
+ xi=c(1,nres+i)
+ yi=c(2,nres+i)
+ zi=c(3,nres+i)
+ 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 define scaling factor for lipids
+
+C if (positi.le.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 ((zi.gt.bordlipbot)
+ &.and.(zi.lt.bordliptop)) then
+C the energy transfer exist
+ if (zi.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zi-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zi.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
+ sslipi=sscalelip(fracinbuf)
+ ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipi=1.0d0
+ ssgradlipi=0.0
+ endif
+ else
+ sslipi=0.0d0
+ ssgradlipi=0.0
+ endif
+
+ dxi=dc_norm(1,nres+i)
+ dyi=dc_norm(2,nres+i)
+ dzi=dc_norm(3,nres+i)
+c dsci_inv=dsc_inv(itypi)
+ dsci_inv=vbld_inv(i+nres)
+C
+C Calculate SC interaction energy.
+C
+ do iint=1,nint_gr(i)
+ do j=istart(i,iint),iend(i,iint)
+ ind=ind+1
+ itypj=iabs(itype(j))
+ if (itypj.eq.ntyp1) cycle
+c dscj_inv=dsc_inv(itypj)
+ dscj_inv=vbld_inv(j+nres)
+ sig0ij=sigma(itypi,itypj)
+ r0ij=r0(itypi,itypj)
+ chi1=chi(itypi,itypj)
+ chi2=chi(itypj,itypi)
+ chi12=chi1*chi2
+ chip1=chip(itypi)
+ chip2=chip(itypj)
+ chip12=chip1*chip2
+ alf1=alp(itypi)
+ alf2=alp(itypj)
+ alf12=0.5D0*(alf1+alf2)
+C For diagnostics only!!!
+c chi1=0.0D0
+c chi2=0.0D0
+c chi12=0.0D0
+c chip1=0.0D0
+c chip2=0.0D0
+c chip12=0.0D0
+c alf1=0.0D0
+c alf2=0.0D0
+c alf12=0.0D0
+C xj=c(1,nres+j)-xi
+C yj=c(2,nres+j)-yi
+C zj=c(3,nres+j)-zi
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.gt.bordlipbot)
+ &.and.(zj.lt.bordliptop)) then
+C the energy transfer exist
+ if (zj.lt.buflipbot) then
+C what fraction I am in
+ fracinbuf=1.0d0-
+ & ((zj-bordlipbot)/lipbufthick)
+C lipbufthick is thickenes of lipid buffore
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
+ elseif (zj.gt.bufliptop) then
+ fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
+ sslipj=sscalelip(fracinbuf)
+ ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
+ else
+ sslipj=1.0d0
+ ssgradlipj=0.0
+ endif
+ else
+ sslipj=0.0d0
+ ssgradlipj=0.0
+ endif
+ aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+ bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
+ & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
+C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
+C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
+C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
+ dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ subchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (subchap.eq.1) then
+ xj=xj_temp-xi
+ yj=yj_temp-yi
+ zj=zj_temp-zi
+ else
+ xj=xj_safe-xi
+ yj=yj_safe-yi
+ zj=zj_safe-zi
+ endif
+ dxj=dc_norm(1,nres+j)
+ dyj=dc_norm(2,nres+j)
+ dzj=dc_norm(3,nres+j)
+ rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
+ rij=dsqrt(rrij)
+C Calculate angle-dependent terms of energy and contributions to their
+C derivatives.
+ call sc_angular
+ sigsq=1.0D0/sigsq
+ sig=sig0ij*dsqrt(sigsq)
+ rij_shift=1.0D0/rij-sig+r0ij
+C I hate to put IF's in the loops, but here don't have another choice!!!!
+ if (rij_shift.le.0.0D0) then
+ evdw=1.0D20
+ return
+ endif
+ sigder=-sig*sigsq
+c---------------------------------------------------------------
+ rij_shift=1.0D0/rij_shift
+ fac=rij_shift**expon
+ e1=fac*fac*aa
+ e2=fac*bb
+ evdwij=eps1*eps2rt*eps3rt*(e1+e2)
+ eps2der=evdwij*eps3rt
+ eps3der=evdwij*eps2rt
+ fac_augm=rrij**expon
+ e_augm=augm(itypi,itypj)*fac_augm
+ evdwij=evdwij*eps2rt*eps3rt
+ evdw=evdw+evdwij+e_augm
+ if (lprn) then
+ sigm=dabs(aa/bb)**(1.0D0/6.0D0)
+ epsi=bb**2/aa
+ write (iout,'(2(a3,i3,2x),17(0pf7.3))')
+ & restyp(itypi),i,restyp(itypj),j,
+ & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
+ & chi1,chi2,chip1,chip2,
+ & eps1,eps2rt**2,eps3rt**2,
+ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
+ & evdwij+e_augm
+ endif
+C Calculate gradient components.
+ e1=e1*eps1*eps2rt**2*eps3rt**2
+ fac=-expon*(e1+evdwij)*rij_shift
+ sigder=fac*sigder
+ fac=rij*fac-2*expon*rrij*e_augm
+ fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
+C Calculate the radial part of the gradient
+ gg(1)=xj*fac
+ gg(2)=yj*fac
+ gg(3)=zj*fac
+C Calculate angular part of the gradient.
+ call sc_grad
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ end
+C-----------------------------------------------------------------------------
+ subroutine sc_angular
+C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
+C om12. Called by ebp, egb, and egbv.
+ implicit none
+ include 'COMMON.CALC'
+ include 'COMMON.IOUNITS'
+ 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
+ chiom12=chi12*om12
+C Calculate eps1(om12) and its derivative in om12
+ faceps1=1.0D0-om12*chiom12
+ faceps1_inv=1.0D0/faceps1
+ eps1=dsqrt(faceps1_inv)
+C Following variable is eps1*deps1/dom12
+ eps1_om12=faceps1_inv*chiom12
+c diagnostics only
+c faceps1_inv=om12
+c eps1=om12
+c eps1_om12=1.0d0
+c write (iout,*) "om12",om12," eps1",eps1
+C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
+C and om12.
+ om1om2=om1*om2
+ chiom1=chi1*om1
+ chiom2=chi2*om2
+ facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
+ sigsq=1.0D0-facsig*faceps1_inv
+ sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
+ sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
+ sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
+c diagnostics only
+c sigsq=1.0d0
+c sigsq_om1=0.0d0
+c sigsq_om2=0.0d0
+c sigsq_om12=0.0d0
+c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
+c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
+c & " eps1",eps1
+C Calculate eps2 and its derivatives in om1, om2, and om12.
+ chipom1=chip1*om1
+ chipom2=chip2*om2
+ chipom12=chip12*om12
+ facp=1.0D0-om12*chipom12
+ facp_inv=1.0D0/facp
+ facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
+c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
+c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
+C Following variable is the square root of eps2
+ eps2rt=1.0D0-facp1*facp_inv
+C Following three variables are the derivatives of the square root of eps
+C in om1, om2, and om12.
+ eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
+ eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
+ eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
+C Evaluate the "asymmetric" factor in the VDW constant, eps3
+ eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
+c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
+c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
+c & " eps2rt_om12",eps2rt_om12
+C Calculate whole angle-dependent part of epsilon and contributions
+C to its derivatives
+ return
+ end
+C----------------------------------------------------------------------------
+ subroutine sc_grad
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.CALC'
+ include 'COMMON.IOUNITS'
+ double precision dcosom1(3),dcosom2(3)
+cc print *,'sss=',sss
+ eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
+ eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
+ eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
+ & -2.0D0*alf12*eps3der+sigder*sigsq_om12
+c diagnostics only
+c eom1=0.0d0
+c eom2=0.0d0
+c eom12=evdwij*eps1_om12
+c end diagnostics
+c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
+c & " sigder",sigder
+c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
+c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
+ do k=1,3
+ dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
+ dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
+ enddo
+ do k=1,3
+ gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
+ enddo
+c write (iout,*) "gg",(gg(k),k=1,3)
+ do k=1,3
+ gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
+ & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+ & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
+ gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
+ & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+ & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
+c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
+c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
+c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
+c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
+ enddo
+C
+C Calculate the components of the gradient in DC and X
+C
+cgrad do k=i,j-1
+cgrad do l=1,3
+cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
+cgrad enddo
+cgrad enddo
+ do l=1,3
+ gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
+ gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
+ enddo
+ return
+ end
+C-----------------------------------------------------------------------
+ subroutine e_softsphere(evdw)
+C
+C This subroutine calculates the interaction energy of nonbonded side chains
+C assuming the LJ potential of interaction.
+C
+ implicit real*8 (a-h,o-z)
+ 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'
+c include 'COMMON.CONTACTS'
+ dimension gg(3)
+cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
+ 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
+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
+ rij=xj*xj+yj*yj+zj*zj
+c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
+ r0ij=r0(itypi,itypj)
+ r0ijsq=r0ij*r0ij
+c print *,i,j,r0ij,dsqrt(rij)
+ if (rij.lt.r0ijsq) then
+ evdwij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdwij=0.0d0
+ fac=0.0d0
+ endif
+ evdw=evdw+evdwij
+C
+C Calculate the components of the gradient in DC and X
+C
+ 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
+ enddo ! j
+ enddo ! iint
+ enddo ! i
+ return
+ end
+C--------------------------------------------------------------------------
+ subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
+ & eello_turn4)
+C
+C Soft-sphere potential of p-p interaction
+C
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+c include 'COMMON.CONTACTS'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ dimension ggg(3)
+ integer xshift,yshift,zshift
+C write(iout,*) 'In EELEC_soft_sphere'
+ ees=0.0D0
+ evdw1=0.0D0
+ eel_loc=0.0d0
+ eello_turn3=0.0d0
+ eello_turn4=0.0d0
+ ind=0
+ do i=iatel_s,iatel_e
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+ num_conti=0
+c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
+ do j=ielstart(i),ielend(i)
+ if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
+ ind=ind+1
+ iteli=itel(i)
+ itelj=itel(j)
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2
+ r0ij=rpp(iteli,itelj)
+ r0ijsq=r0ij*r0ij
+ dxj=dc(1,j)
+ dyj=dc(2,j)
+ dzj=dc(3,j)
+ xj=c(1,j)+0.5D0*dxj
+ yj=c(2,j)+0.5D0*dyj
+ zj=c(3,j)+0.5D0*dzj
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ isubchap=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
+ isubchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (isubchap.eq.1) then
+ xj=xj_temp-xmedi
+ yj=yj_temp-ymedi
+ zj=zj_temp-zmedi
+ else
+ xj=xj_safe-xmedi
+ yj=yj_safe-ymedi
+ zj=zj_safe-zmedi
+ endif
+ rij=xj*xj+yj*yj+zj*zj
+ sss=sscale(sqrt(rij),r_cut_int)
+ sssgrad=sscagrad(sqrt(rij),r_cut_int)
+ if (rij.lt.r0ijsq) then
+ evdw1ij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdw1ij=0.0d0
+ fac=0.0d0
+ endif
+ evdw1=evdw1+evdw1ij*sss
+C
+C Calculate contributions to the Cartesian gradient.
+C
+ ggg(1)=fac*xj*sssgrad
+ ggg(2)=fac*yj*sssgrad
+ ggg(3)=fac*zj*sssgrad
+ do k=1,3
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+ enddo ! j
+ enddo ! i
+cgrad do i=nnt,nct-1
+cgrad do k=1,3
+cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
+cgrad enddo
+cgrad do j=i+1,nct-1
+cgrad do k=1,3
+cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
+cgrad enddo
+cgrad enddo
+cgrad enddo
+ return
+ end
+c------------------------------------------------------------------------------
+ subroutine vec_and_deriv
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VECTORS'
+ include 'COMMON.SETUP'
+ include 'COMMON.TIME1'
+ dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
+C Compute the local reference systems. For reference system (i), the
+C X-axis points from CA(i) to CA(i+1), the Y axis is in the
+C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
+#ifdef PARVEC
+ do i=ivec_start,ivec_end
+#else
+ do i=1,nres-1
+#endif
+ if (i.eq.nres-1) then
+C Case of the last full residue
+C Compute the Z-axis
+ call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
+ costh=dcos(pi-theta(nres))
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)
+ do k=1,3
+ uz(k,i)=fac*uz(k,i)
+ enddo
+C Compute the derivatives of uz
+ uzder(1,1,1)= 0.0d0
+ uzder(2,1,1)=-dc_norm(3,i-1)
+ uzder(3,1,1)= dc_norm(2,i-1)
+ uzder(1,2,1)= dc_norm(3,i-1)
+ uzder(2,2,1)= 0.0d0
+ uzder(3,2,1)=-dc_norm(1,i-1)
+ uzder(1,3,1)=-dc_norm(2,i-1)
+ uzder(2,3,1)= dc_norm(1,i-1)
+ uzder(3,3,1)= 0.0d0
+ uzder(1,1,2)= 0.0d0
+ uzder(2,1,2)= dc_norm(3,i)
+ uzder(3,1,2)=-dc_norm(2,i)
+ uzder(1,2,2)=-dc_norm(3,i)
+ uzder(2,2,2)= 0.0d0
+ uzder(3,2,2)= dc_norm(1,i)
+ uzder(1,3,2)= dc_norm(2,i)
+ uzder(2,3,2)=-dc_norm(1,i)
+ uzder(3,3,2)= 0.0d0
+C Compute the Y-axis
+ facy=fac
+ do k=1,3
+ uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
+ enddo
+C Compute the derivatives of uy
+ do j=1,3
+ do k=1,3
+ uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
+ & -dc_norm(k,i)*dc_norm(j,i-1)
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
+ enddo
+ uyder(j,j,1)=uyder(j,j,1)-costh
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)
+ enddo
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=uyder(l,k,j)
+ uzgrad(l,k,j,i)=uzder(l,k,j)
+ enddo
+ enddo
+ enddo
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
+ else
+C Other residues
+C Compute the Z-axis
+ call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
+ costh=dcos(pi-theta(i+2))
+ fac=1.0d0/dsqrt(1.0d0-costh*costh)
+ do k=1,3
+ uz(k,i)=fac*uz(k,i)
+ enddo
+C Compute the derivatives of uz
+ uzder(1,1,1)= 0.0d0
+ uzder(2,1,1)=-dc_norm(3,i+1)
+ uzder(3,1,1)= dc_norm(2,i+1)
+ uzder(1,2,1)= dc_norm(3,i+1)
+ uzder(2,2,1)= 0.0d0
+ uzder(3,2,1)=-dc_norm(1,i+1)
+ uzder(1,3,1)=-dc_norm(2,i+1)
+ uzder(2,3,1)= dc_norm(1,i+1)
+ uzder(3,3,1)= 0.0d0
+ uzder(1,1,2)= 0.0d0
+ uzder(2,1,2)= dc_norm(3,i)
+ uzder(3,1,2)=-dc_norm(2,i)
+ uzder(1,2,2)=-dc_norm(3,i)
+ uzder(2,2,2)= 0.0d0
+ uzder(3,2,2)= dc_norm(1,i)
+ uzder(1,3,2)= dc_norm(2,i)
+ uzder(2,3,2)=-dc_norm(1,i)
+ uzder(3,3,2)= 0.0d0
+C Compute the Y-axis
+ facy=fac
+ do k=1,3
+ uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
+ enddo
+C Compute the derivatives of uy
+ do j=1,3
+ do k=1,3
+ uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
+ & -dc_norm(k,i)*dc_norm(j,i+1)
+ uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
+ enddo
+ uyder(j,j,1)=uyder(j,j,1)-costh
+ uyder(j,j,2)=1.0d0+uyder(j,j,2)
+ enddo
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=uyder(l,k,j)
+ uzgrad(l,k,j,i)=uzder(l,k,j)
+ enddo
+ enddo
+ enddo
+ call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
+ call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
+ call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
+ call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
+ endif
+ enddo
+ do i=1,nres-1
+ vbld_inv_temp(1)=vbld_inv(i+1)
+ if (i.lt.nres-1) then
+ vbld_inv_temp(2)=vbld_inv(i+2)
+ else
+ vbld_inv_temp(2)=vbld_inv(i)
+ endif
+ do j=1,2
+ do k=1,3
+ do l=1,3
+ uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
+ uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
+ enddo
+ enddo
+ enddo
+ enddo
+#if defined(PARVEC) && defined(MPI)
+ if (nfgtasks1.gt.1) then
+ time00=MPI_Wtime()
+c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
+c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
+c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
+ call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
+ & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
+ call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
+ & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
+ time_gather=time_gather+MPI_Wtime()-time00
+ endif
+#endif
+#ifdef DEBUG
+ if (fg_rank.eq.0) then
+ write (iout,*) "Arrays UY and UZ"
+ do i=1,nres-1
+ write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
+ & (uz(k,i),k=1,3)
+ enddo
+ endif
+#endif
+ return
+ end
+C--------------------------------------------------------------------------
+ subroutine set_matrices
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+ include "COMMON.SETUP"
+ integer IERR
+ integer status(MPI_STATUS_SIZE)
+#endif
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CORRMAT'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ double precision auxvec(2),auxmat(2,2)
+C
+C Compute the virtual-bond-torsional-angle dependent quantities needed
+C to calculate the el-loc multibody terms of various order.
+C
+c write(iout,*) 'nphi=',nphi,nres
+c write(iout,*) "itype2loc",itype2loc
+#ifdef PARMAT
+ do i=ivec_start+2,ivec_end+2
+#else
+ do i=3,nres+1
+#endif
+ ii=ireschain(i-2)
+c write (iout,*) "i",i,i-2," ii",ii
+ if (ii.eq.0) cycle
+ innt=chain_border(1,ii)
+ inct=chain_border(2,ii)
+c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
+c if (i.gt. nnt+2 .and. i.lt.nct+2) then
+ if (i.gt. innt+2 .and. i.lt.inct+2) then
+ iti = itype2loc(itype(i-2))
+ else
+ iti=nloctyp
+ endif
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. innt+1 .and. i.lt.inct+1) then
+ iti1 = itype2loc(itype(i-1))
+ else
+ iti1=nloctyp
+ endif
+c write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
+c & " iti1",itype(i-1),iti1
+#ifdef NEWCORR
+ cost1=dcos(theta(i-1))
+ sint1=dsin(theta(i-1))
+ sint1sq=sint1*sint1
+ sint1cub=sint1sq*sint1
+ sint1cost1=2*sint1*cost1
+c write (iout,*) "bnew1",i,iti
+c write (iout,*) (bnew1(k,1,iti),k=1,3)
+c write (iout,*) (bnew1(k,2,iti),k=1,3)
+c write (iout,*) "bnew2",i,iti
+c write (iout,*) (bnew2(k,1,iti),k=1,3)
+c write (iout,*) (bnew2(k,2,iti),k=1,3)
+ do k=1,2
+ b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
+ b1(k,i-2)=sint1*b1k
+ gtb1(k,i-2)=cost1*b1k-sint1sq*
+ & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
+ b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
+ b2(k,i-2)=sint1*b2k
+ gtb2(k,i-2)=cost1*b2k-sint1sq*
+ & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
+ enddo
+ do k=1,2
+ aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
+ cc(1,k,i-2)=sint1sq*aux
+ gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
+ & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
+ aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
+ dd(1,k,i-2)=sint1sq*aux
+ gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
+ & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
+ enddo
+ cc(2,1,i-2)=cc(1,2,i-2)
+ cc(2,2,i-2)=-cc(1,1,i-2)
+ gtcc(2,1,i-2)=gtcc(1,2,i-2)
+ gtcc(2,2,i-2)=-gtcc(1,1,i-2)
+ dd(2,1,i-2)=dd(1,2,i-2)
+ dd(2,2,i-2)=-dd(1,1,i-2)
+ gtdd(2,1,i-2)=gtdd(1,2,i-2)
+ gtdd(2,2,i-2)=-gtdd(1,1,i-2)
+ do k=1,2
+ do l=1,2
+ aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
+ EE(l,k,i-2)=sint1sq*aux
+ gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
+ enddo
+ enddo
+ EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
+ EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
+ EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
+ EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
+ gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
+ gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
+ gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
+c b1tilde(1,i-2)=b1(1,i-2)
+c b1tilde(2,i-2)=-b1(2,i-2)
+c b2tilde(1,i-2)=b2(1,i-2)
+c b2tilde(2,i-2)=-b2(2,i-2)
+#ifdef DEBUG
+ write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
+ write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
+ write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
+ write (iout,*) 'theta=', theta(i-1)
+#endif
+#else
+ if (i.gt. innt+2 .and. i.lt.inct+2) then
+c if (i.gt. nnt+2 .and. i.lt.nct+2) then
+ iti = itype2loc(itype(i-2))
+ else
+ iti=nloctyp
+ endif
+c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ iti1 = itype2loc(itype(i-1))
+ else
+ iti1=nloctyp
+ endif
+ b1(1,i-2)=b(3,iti)
+ b1(2,i-2)=b(5,iti)
+ b2(1,i-2)=b(2,iti)
+ b2(2,i-2)=b(4,iti)
+ do k=1,2
+ do l=1,2
+ CC(k,l,i-2)=ccold(k,l,iti)
+ DD(k,l,i-2)=ddold(k,l,iti)
+ EE(k,l,i-2)=eeold(k,l,iti)
+ gtEE(k,l,i-2)=0.0d0
+ enddo
+ enddo
+#endif
+ b1tilde(1,i-2)= b1(1,i-2)
+ b1tilde(2,i-2)=-b1(2,i-2)
+ b2tilde(1,i-2)= b2(1,i-2)
+ b2tilde(2,i-2)=-b2(2,i-2)
+c
+ Ctilde(1,1,i-2)= CC(1,1,i-2)
+ Ctilde(1,2,i-2)= CC(1,2,i-2)
+ Ctilde(2,1,i-2)=-CC(2,1,i-2)
+ Ctilde(2,2,i-2)=-CC(2,2,i-2)
+c
+ Dtilde(1,1,i-2)= DD(1,1,i-2)
+ Dtilde(1,2,i-2)= DD(1,2,i-2)
+ Dtilde(2,1,i-2)=-DD(2,1,i-2)
+ Dtilde(2,2,i-2)=-DD(2,2,i-2)
+#ifdef DEBUG
+ write(iout,*) "i",i," iti",iti
+ write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
+ write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
+#endif
+ enddo
+ mu=0.0d0
+#ifdef PARMAT
+ do i=ivec_start+2,ivec_end+2
+#else
+ do i=3,nres+1
+#endif
+c if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
+ if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
+ sin1=dsin(phi(i))
+ cos1=dcos(phi(i))
+ sintab(i-2)=sin1
+ costab(i-2)=cos1
+ obrot(1,i-2)=cos1
+ obrot(2,i-2)=sin1
+ sin2=dsin(2*phi(i))
+ cos2=dcos(2*phi(i))
+ sintab2(i-2)=sin2
+ costab2(i-2)=cos2
+ obrot2(1,i-2)=cos2
+ obrot2(2,i-2)=sin2
+ Ug(1,1,i-2)=-cos1
+ Ug(1,2,i-2)=-sin1
+ Ug(2,1,i-2)=-sin1
+ Ug(2,2,i-2)= cos1
+ Ug2(1,1,i-2)=-cos2
+ Ug2(1,2,i-2)=-sin2
+ Ug2(2,1,i-2)=-sin2
+ Ug2(2,2,i-2)= cos2
+ else
+ costab(i-2)=1.0d0
+ sintab(i-2)=0.0d0
+ obrot(1,i-2)=1.0d0
+ obrot(2,i-2)=0.0d0
+ obrot2(1,i-2)=0.0d0
+ obrot2(2,i-2)=0.0d0
+ Ug(1,1,i-2)=1.0d0
+ Ug(1,2,i-2)=0.0d0
+ Ug(2,1,i-2)=0.0d0
+ Ug(2,2,i-2)=1.0d0
+ Ug2(1,1,i-2)=0.0d0
+ Ug2(1,2,i-2)=0.0d0
+ Ug2(2,1,i-2)=0.0d0
+ Ug2(2,2,i-2)=0.0d0
+ endif
+ if (i .gt. 3) then
+ obrot_der(1,i-2)=-sin1
+ obrot_der(2,i-2)= cos1
+ Ugder(1,1,i-2)= sin1
+ Ugder(1,2,i-2)=-cos1
+ Ugder(2,1,i-2)=-cos1
+ Ugder(2,2,i-2)=-sin1
+ dwacos2=cos2+cos2
+ dwasin2=sin2+sin2
+ obrot2_der(1,i-2)=-dwasin2
+ obrot2_der(2,i-2)= dwacos2
+ Ug2der(1,1,i-2)= dwasin2
+ Ug2der(1,2,i-2)=-dwacos2
+ Ug2der(2,1,i-2)=-dwacos2
+ Ug2der(2,2,i-2)=-dwasin2
+ else
+ obrot_der(1,i-2)=0.0d0
+ obrot_der(2,i-2)=0.0d0
+ Ugder(1,1,i-2)=0.0d0
+ Ugder(1,2,i-2)=0.0d0
+ Ugder(2,1,i-2)=0.0d0
+ Ugder(2,2,i-2)=0.0d0
+ obrot2_der(1,i-2)=0.0d0
+ obrot2_der(2,i-2)=0.0d0
+ Ug2der(1,1,i-2)=0.0d0
+ Ug2der(1,2,i-2)=0.0d0
+ Ug2der(2,1,i-2)=0.0d0
+ Ug2der(2,2,i-2)=0.0d0
+ endif
+c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
+c if (i.gt. nnt+2 .and. i.lt.nct+2) then
+ if (i.gt.nnt+2 .and.i.lt.nct+2) then
+ iti = itype2loc(itype(i-2))
+ else
+ iti=nloctyp
+ endif
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ iti1 = itype2loc(itype(i-1))
+ else
+ iti1=nloctyp
+ endif
+cd write (iout,*) '*******i',i,' iti1',iti
+cd write (iout,*) 'b1',b1(:,iti)
+cd write (iout,*) 'b2',b2(:,iti)
+cd write (iout,*) 'Ug',Ug(:,:,i-2)
+c if (i .gt. iatel_s+2) then
+ if (i .gt. nnt+2) then
+ call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
+#ifdef NEWCORR
+ call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
+c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
+#endif
+c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
+c & EE(1,2,iti),EE(2,2,i)
+ call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
+ call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
+c write(iout,*) "Macierz EUG",
+c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
+c & eug(2,2,i-2)
+#ifdef FOURBODY
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
+ & then
+ call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
+ call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
+ call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
+ call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
+ call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
+ endif
+#endif
+ else
+ do k=1,2
+ Ub2(k,i-2)=0.0d0
+ Ctobr(k,i-2)=0.0d0
+ Dtobr2(k,i-2)=0.0d0
+ do l=1,2
+ EUg(l,k,i-2)=0.0d0
+ CUg(l,k,i-2)=0.0d0
+ DUg(l,k,i-2)=0.0d0
+ DtUg2(l,k,i-2)=0.0d0
+ enddo
+ enddo
+ endif
+ call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
+ call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
+ do k=1,2
+ muder(k,i-2)=Ub2der(k,i-2)
+ enddo
+c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
+ if (i.gt. nnt+1 .and. i.lt.nct+1) then
+ if (itype(i-1).le.ntyp) then
+ iti1 = itype2loc(itype(i-1))
+ else
+ iti1=nloctyp
+ endif
+ else
+ iti1=nloctyp
+ endif
+ do k=1,2
+ mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
+c mu(k,i-2)=b1(k,i-1)
+c mu(k,i-2)=Ub2(k,i-2)
+ enddo
+#ifdef MUOUT
+ write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
+ & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
+ & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
+ & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
+ & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
+ & ((ee(l,k,i-2),l=1,2),k=1,2)
+#endif
+cd write (iout,*) 'mu1',mu1(:,i-2)
+cd write (iout,*) 'mu2',mu2(:,i-2)
+cd write (iout,*) 'mu',i-2,mu(:,i-2)
+#ifdef FOURBODY
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
+ & then
+ call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
+ call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
+ call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
+ call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
+ call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
+C Vectors and matrices dependent on a single virtual-bond dihedral.
+ call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
+ call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
+ call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
+ call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
+ call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
+ call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
+ call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
+ call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
+ call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
+ endif
+#endif
+ enddo
+#ifdef FOURBODY
+C Matrices dependent on two consecutive virtual-bond dihedrals.
+C The order of matrices is from left to right.
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
+ &then
+c do i=max0(ivec_start,2),ivec_end
+ do i=2,nres-1
+ call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
+ call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
+ call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
+ call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
+ call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
+ call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
+ call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
+ call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
+ enddo
+ endif
+#endif
+#if defined(MPI) && defined(PARMAT)
+#ifdef DEBUG
+c if (fg_rank.eq.0) then
+ write (iout,*) "Arrays UG and UGDER before GATHER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug(l,k,i),l=1,2),k=1,2),
+ & ((ugder(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays UG2 and UG2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug2(l,k,i),l=1,2),k=1,2),
+ & ((ug2der(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
+ & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
+ enddo
+ write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & costab(i),sintab(i),costab2(i),sintab2(i)
+ enddo
+ write (iout,*) "Array MUDER"
+ do i=1,nres-1
+ write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
+ enddo
+c endif
+#endif
+ if (nfgtasks.gt.1) then
+ time00=MPI_Wtime()
+c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
+c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
+c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
+#ifdef MATGATHER
+ call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+ call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
+ & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
+ & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+#ifdef FOURBODY
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
+ & then
+ call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
+ & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
+ & FG_COMM1,IERR)
+ call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
+ & MPI_MAT2,FG_COMM1,IERR)
+ call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
+ & ivec_count(fg_rank1),
+ & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
+ & MPI_MAT2,FG_COMM1,IERR)
+ endif
+#endif
+#else
+c Passes matrix info through the ring
+ isend=fg_rank1
+ irecv=fg_rank1-1
+ if (irecv.lt.0) irecv=nfgtasks1-1
+ iprev=irecv
+ inext=fg_rank1+1
+ if (inext.ge.nfgtasks1) inext=0
+ do i=1,nfgtasks1-1
+c write (iout,*) "isend",isend," irecv",irecv
+c call flush(iout)
+ lensend=lentyp(isend)
+ lenrecv=lentyp(irecv)
+c write (iout,*) "lensend",lensend," lenrecv",lenrecv
+c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
+c & MPI_ROTAT1(lensend),inext,2200+isend,
+c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
+c & iprev,2200+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather ROTAT1"
+c call flush(iout)
+c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
+c & MPI_ROTAT2(lensend),inext,3300+isend,
+c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
+c & iprev,3300+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather ROTAT2"
+c call flush(iout)
+ call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
+ & MPI_ROTAT_OLD(lensend),inext,4400+isend,
+ & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
+ & iprev,4400+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather ROTAT_OLD"
+c call flush(iout)
+ call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP11(lensend),inext,5500+isend,
+ & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
+ & iprev,5500+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP11"
+c call flush(iout)
+ call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP12(lensend),inext,6600+isend,
+ & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
+ & iprev,6600+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP12"
+c call flush(iout)
+#ifdef FOURBODY
+ if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
+ & then
+ call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
+ & MPI_ROTAT2(lensend),inext,7700+isend,
+ & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
+ & iprev,7700+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP21"
+c call flush(iout)
+ call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP22(lensend),inext,8800+isend,
+ & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
+ & iprev,8800+irecv,FG_COMM,status,IERR)
+c write (iout,*) "Gather PRECOMP22"
+c call flush(iout)
+ call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
+ & MPI_PRECOMP23(lensend),inext,9900+isend,
+ & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
+ & MPI_PRECOMP23(lenrecv),
+ & iprev,9900+irecv,FG_COMM,status,IERR)
+#endif
+c write (iout,*) "Gather PRECOMP23"
+c call flush(iout)
+ endif
+ isend=irecv
+ irecv=irecv-1
+ if (irecv.lt.0) irecv=nfgtasks1-1
+ enddo
+#endif
+ time_gather=time_gather+MPI_Wtime()-time00
+ endif
+#ifdef DEBUG
+c if (fg_rank.eq.0) then
+ write (iout,*) "Arrays UG and UGDER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug(l,k,i),l=1,2),k=1,2),
+ & ((ugder(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays UG2 and UG2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & ((ug2(l,k,i),l=1,2),k=1,2),
+ & ((ug2der(l,k,i),l=1,2),k=1,2)
+ enddo
+ write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
+ & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
+ enddo
+ write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
+ do i=1,nres-1
+ write (iout,'(i5,4f10.5,5x,4f10.5)') i,
+ & costab(i),sintab(i),costab2(i),sintab2(i)
+ enddo
+ write (iout,*) "Array MUDER"
+ do i=1,nres-1
+ write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
+ enddo
+c endif
+#endif
+#endif
+cd do i=1,nres
+cd iti = itype2loc(itype(i))
+cd write (iout,*) i
+cd do j=1,2
+cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
+cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
+cd enddo
+cd enddo
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
+C
+C This subroutine calculates the average interaction energy and its gradient
+C in the virtual-bond vectors between non-adjacent peptide groups, based on
+C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
+C The potential depends both on the distance of peptide-group centers and on
+C the orientation of the CA-CA virtual bonds.
+C
+ implicit real*8 (a-h,o-z)
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SETUP'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+#ifdef FOURBODY
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+#endif
+ include 'COMMON.CORRMAT'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.TIME1'
+ include 'COMMON.SPLITELE'
+ dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
+ & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
+ double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
+#ifdef MOMENT
+ double precision scal_el /1.0d0/
+#else
+ double precision scal_el /0.5d0/
+#endif
+C 12/13/98
+C 13-go grudnia roku pamietnego...
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
+ & 0.0d0,1.0d0,0.0d0,
+ & 0.0d0,0.0d0,1.0d0/
+cd write(iout,*) 'In EELEC'
+cd do i=1,nloctyp
+cd write(iout,*) 'Type',i
+cd write(iout,*) 'B1',B1(:,i)
+cd write(iout,*) 'B2',B2(:,i)
+cd write(iout,*) 'CC',CC(:,:,i)
+cd write(iout,*) 'DD',DD(:,:,i)
+cd write(iout,*) 'EE',EE(:,:,i)
+cd enddo
+cd call check_vecgrad
+cd stop
+ if (icheckgrad.eq.1) then
+ do i=1,nres-1
+ fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
+ do k=1,3
+ dc_norm(k,i)=dc(k,i)*fac
+ enddo
+c write (iout,*) 'i',i,' fac',fac
+ enddo
+ endif
+ if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
+ & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
+c call vec_and_deriv
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call set_matrices
+#ifdef TIMING
+ time_mat=time_mat+MPI_Wtime()-time01
+#endif
+ endif
+cd do i=1,nres-1
+cd write (iout,*) 'i=',i
+cd do k=1,3
+cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
+cd enddo
+cd do k=1,3
+cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
+cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
+cd enddo
+cd enddo
+ t_eelecij=0.0d0
+ ees=0.0D0
+ evdw1=0.0D0
+ eel_loc=0.0d0
+ eello_turn3=0.0d0
+ eello_turn4=0.0d0
+ ind=0
+#ifdef FOURBODY
+ do i=1,nres
+ num_cont_hb(i)=0
+ enddo
+#endif
+cd print '(a)','Enter EELEC'
+cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
+ do i=1,nres
+ gel_loc_loc(i)=0.0d0
+ gcorr_loc(i)=0.0d0
+ enddo
+c
+c
+c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
+C
+C Loop over i,i+2 and i,i+3 pairs of the peptide groups
+C
+C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
+ do i=iturn3_start,iturn3_end
+c if (i.le.1) cycle
+C write(iout,*) "tu jest i",i
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+C Adam: Unnecessary: handled by iturn3_end and iturn3_start
+c & .or.((i+4).gt.nres)
+c & .or.((i-1).le.0)
+C end of changes by Ana
+ & .or. itype(i+2).eq.ntyp1
+ & .or. itype(i+3).eq.ntyp1) cycle
+C Adam: Instructions below will switch off existing interactions
+c if(i.gt.1)then
+c if(itype(i-1).eq.ntyp1)cycle
+c end if
+c if(i.LT.nres-3)then
+c if (itype(i+4).eq.ntyp1) cycle
+c end if
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+ num_conti=0
+ call eelecij(i,i+2,ees,evdw1,eel_loc)
+ if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
+#ifdef FOURBODY
+ num_cont_hb(i)=num_conti
+#endif
+ enddo
+ do i=iturn4_start,iturn4_end
+ if (i.lt.1) cycle
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+c & .or.((i+5).gt.nres)
+c & .or.((i-1).le.0)
+C end of changes suggested by Ana
+ & .or. itype(i+3).eq.ntyp1
+ & .or. itype(i+4).eq.ntyp1
+c & .or. itype(i+5).eq.ntyp1
+c & .or. itype(i).eq.ntyp1
+c & .or. itype(i-1).eq.ntyp1
+ & ) cycle
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+C Return atom into box, boxxsize is size of box in x dimension
+c 194 continue
+c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
+c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
+C Condition for being inside the proper box
+c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
+c & (xmedi.lt.((-0.5d0)*boxxsize))) then
+c go to 194
+c endif
+c 195 continue
+c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
+c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
+C Condition for being inside the proper box
+c if ((ymedi.gt.((0.5d0)*boxysize)).or.
+c & (ymedi.lt.((-0.5d0)*boxysize))) then
+c go to 195
+c endif
+c 196 continue
+c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
+c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
+C Condition for being inside the proper box
+c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
+c & (zmedi.lt.((-0.5d0)*boxzsize))) then
+c go to 196
+c endif
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+
+#ifdef FOURBODY
+ num_conti=num_cont_hb(i)
+#endif
+c write(iout,*) "JESTEM W PETLI"
+ call eelecij(i,i+3,ees,evdw1,eel_loc)
+ if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
+ & call eturn4(i,eello_turn4)
+#ifdef FOURBODY
+ num_cont_hb(i)=num_conti
+#endif
+ enddo ! i
+C Loop over all neighbouring boxes
+C do xshift=-1,1
+C do yshift=-1,1
+C do zshift=-1,1
+c
+c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
+c
+CTU KURWA
+ do i=iatel_s,iatel_e
+C do i=75,75
+c if (i.le.1) cycle
+ if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+c & .or.((i+2).gt.nres)
+c & .or.((i-1).le.0)
+C end of changes by Ana
+c & .or. itype(i+2).eq.ntyp1
+c & .or. itype(i-1).eq.ntyp1
+ & ) cycle
+ dxi=dc(1,i)
+ dyi=dc(2,i)
+ dzi=dc(3,i)
+ dx_normi=dc_norm(1,i)
+ dy_normi=dc_norm(2,i)
+ dz_normi=dc_norm(3,i)
+ xmedi=c(1,i)+0.5d0*dxi
+ ymedi=c(2,i)+0.5d0*dyi
+ zmedi=c(3,i)+0.5d0*dzi
+ xmedi=mod(xmedi,boxxsize)
+ if (xmedi.lt.0) xmedi=xmedi+boxxsize
+ ymedi=mod(ymedi,boxysize)
+ if (ymedi.lt.0) ymedi=ymedi+boxysize
+ zmedi=mod(zmedi,boxzsize)
+ if (zmedi.lt.0) zmedi=zmedi+boxzsize
+C xmedi=xmedi+xshift*boxxsize
+C ymedi=ymedi+yshift*boxysize
+C zmedi=zmedi+zshift*boxzsize
+
+C Return tom into box, boxxsize is size of box in x dimension
+c 164 continue
+c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
+c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
+C Condition for being inside the proper box
+c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
+c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
+c go to 164
+c endif
+c 165 continue
+c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
+c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
+C Condition for being inside the proper box
+c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
+c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
+c go to 165
+c endif
+c 166 continue
+c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
+c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
+cC Condition for being inside the proper box
+c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
+c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
+c go to 166
+c endif
+
+c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
+#ifdef FOURBODY
+ num_conti=num_cont_hb(i)
+#endif
+C I TU KURWA
+ do j=ielstart(i),ielend(i)
+C do j=16,17
+C write (iout,*) i,j
+C if (j.le.1) cycle
+ if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
+C changes suggested by Ana to avoid out of bounds
+c & .or.((j+2).gt.nres)
+c & .or.((j-1).le.0)
+C end of changes by Ana
+c & .or.itype(j+2).eq.ntyp1
+c & .or.itype(j-1).eq.ntyp1
+ &) cycle
+ call eelecij(i,j,ees,evdw1,eel_loc)
+ enddo ! j
+#ifdef FOURBODY
+ num_cont_hb(i)=num_conti
+#endif
+ enddo ! i
+C enddo ! zshift
+C enddo ! yshift
+C enddo ! xshift
+
+c write (iout,*) "Number of loop steps in EELEC:",ind
+cd do i=1,nres
+cd write (iout,'(i3,3f10.5,5x,3f10.5)')
+cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
+cd enddo
+c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
+ccc eel_loc=eel_loc+eello_turn3
+cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
+ return
+ end
+C-------------------------------------------------------------------------------
+ subroutine eelecij(i,j,ees,evdw1,eel_loc)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+#ifdef FOURBODY
+ include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+#endif
+ include 'COMMON.CORRMAT'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.TIME1'
+ include 'COMMON.SPLITELE'
+ include 'COMMON.SHIELD'
+ dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
+ & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
+ double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
+ & gmuij2(4),gmuji2(4)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
+#ifdef MOMENT
+ double precision scal_el /1.0d0/
+#else
+ double precision scal_el /0.5d0/
+#endif
+C 12/13/98
+C 13-go grudnia roku pamietnego...
+ double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
+ & 0.0d0,1.0d0,0.0d0,
+ & 0.0d0,0.0d0,1.0d0/
+ integer xshift,yshift,zshift
+c time00=MPI_Wtime()
+cd write (iout,*) "eelecij",i,j
+c ind=ind+1
+ iteli=itel(i)
+ itelj=itel(j)
+ if (j.eq.i+2 .and. itelj.eq.2) iteli=2
+ aaa=app(iteli,itelj)
+ bbb=bpp(iteli,itelj)
+ ael6i=ael6(iteli,itelj)
+ ael3i=ael3(iteli,itelj)
+ dxj=dc(1,j)
+ dyj=dc(2,j)
+ dzj=dc(3,j)
+ dx_normj=dc_norm(1,j)
+ dy_normj=dc_norm(2,j)
+ dz_normj=dc_norm(3,j)
+C xj=c(1,j)+0.5D0*dxj-xmedi
+C yj=c(2,j)+0.5D0*dyj-ymedi
+C zj=c(3,j)+0.5D0*dzj-zmedi
+ xj=c(1,j)+0.5D0*dxj
+ yj=c(2,j)+0.5D0*dyj
+ zj=c(3,j)+0.5D0*dzj
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
+ dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ isubchap=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-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ isubchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (isubchap.eq.1) then
+ xj=xj_temp-xmedi
+ yj=yj_temp-ymedi
+ zj=zj_temp-zmedi
+ else
+ xj=xj_safe-xmedi
+ yj=yj_safe-ymedi
+ zj=zj_safe-zmedi
+ endif
+C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
+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
+C 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
+C endif !endPBC condintion
+C xj=xj-xmedi
+C yj=yj-ymedi
+C zj=zj-zmedi
+ rij=xj*xj+yj*yj+zj*zj
+
+ sss=sscale(sqrt(rij),r_cut_int)
+ sssgrad=sscagrad(sqrt(rij),r_cut_int)
+c if (sss.gt.0.0d0) then
+ rrmij=1.0D0/rij
+ rij=dsqrt(rij)
+ rmij=1.0D0/rij
+ r3ij=rrmij*rmij
+ r6ij=r3ij*r3ij
+ cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
+ cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
+ cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
+ fac=cosa-3.0D0*cosb*cosg
+ ev1=aaa*r6ij*r6ij
+c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
+ if (j.eq.i+2) ev1=scal_el*ev1
+ ev2=bbb*r6ij
+ fac3=ael6i*r6ij
+ fac4=ael3i*r3ij
+ evdwij=(ev1+ev2)
+ el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
+ el2=fac4*fac
+C MARYSIA
+C eesij=(el1+el2)
+C 12/26/95 - for the evaluation of multi-body H-bonding interactions
+ ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
+ if (shield_mode.gt.0) then
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ el1=el1*fac_shield(i)**2*fac_shield(j)**2
+ el2=el2*fac_shield(i)**2*fac_shield(j)**2
+ eesij=(el1+el2)
+ ees=ees+eesij
+ else
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+ eesij=(el1+el2)
+ ees=ees+eesij
+ endif
+ evdw1=evdw1+evdwij*sss
+cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
+cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
+cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
+cd & xmedi,ymedi,zmedi,xj,yj,zj
+
+ if (energy_dec) then
+ write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
+ &'evdw1',i,j,evdwij
+ &,iteli,itelj,aaa,evdw1,sss
+ write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
+ &fac_shield(i),fac_shield(j)
+ endif
+
+C
+C Calculate contributions to the Cartesian gradient.
+C
+#ifdef SPLITELE
+ facvdw=-6*rrmij*(ev1+evdwij)*sss
+ facel=-3*rrmij*(el1+eesij)
+ fac1=fac
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ ggg(1)=facel*xj
+ ggg(2)=facel*yj
+ ggg(3)=facel*zj
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
+ & *2.0
+ gshieldx(k,iresshield)=gshieldx(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
+C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
+C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C if (iresshield.gt.i) then
+C do ishi=i+1,iresshield-1
+C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
+C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C
+C enddo
+C else
+C do ishi=iresshield,i
+C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
+C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
+C
+C enddo
+C endif
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
+ & *2.0
+ gshieldx(k,iresshield)=gshieldx(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
+ gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
+
+C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
+C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C if (iresshield.gt.j) then
+C do ishi=j+1,iresshield-1
+C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
+C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C
+C enddo
+C else
+C do ishi=iresshield,j
+C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
+C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
+C enddo
+C endif
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc(k,i)=gshieldc(k,i)+
+ & grad_shield(k,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,j)=gshieldc(k,j)+
+ & grad_shield(k,j)*eesij/fac_shield(j)*2.0
+ gshieldc(k,i-1)=gshieldc(k,i-1)+
+ & grad_shield(k,i)*eesij/fac_shield(i)*2.0
+ gshieldc(k,j-1)=gshieldc(k,j-1)+
+ & grad_shield(k,j)*eesij/fac_shield(j)*2.0
+
+ enddo
+ endif
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c gelc(k,j)=gelc(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+C print *,"before", gelc_long(1,i), gelc_long(1,j)
+ do k=1,3
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)
+C & +grad_shield(k,j)*eesij/fac_shield(j)
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)
+C & +grad_shield(k,i)*eesij/fac_shield(i)
+C gelc_long(k,i-1)=gelc_long(k,i-1)
+C & +grad_shield(k,i)*eesij/fac_shield(i)
+C gelc_long(k,j-1)=gelc_long(k,j-1)
+C & +grad_shield(k,j)*eesij/fac_shield(j)
+ enddo
+C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
+
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+ if (sss.gt.0.0) then
+ ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
+ ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
+ ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
+ else
+ ggg(1)=0.0
+ ggg(2)=0.0
+ ggg(3)=0.0
+ endif
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
+c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+#else
+C MARYSIA
+ facvdw=(ev1+evdwij)*sss
+ facel=(el1+eesij)
+ fac1=fac
+ fac=-3*rrmij*(facvdw+facvdw+facel)
+ erij(1)=xj*rmij
+ erij(2)=yj*rmij
+ erij(3)=zj*rmij
+*
+* Radial derivatives. First process both termini of the fragment (i,j)
+*
+ ggg(1)=fac*xj
+C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
+ ggg(2)=fac*yj
+C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
+ ggg(3)=fac*zj
+C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c gelc(k,j)=gelc(k,j)+ghalf
+c enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ do k=1,3
+ gelc_long(k,j)=gelc(k,j)+ggg(k)
+ gelc_long(k,i)=gelc(k,i)-ggg(k)
+ enddo
+*
+* Loop over residues i+1 thru j-1.
+*
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+c 9/28/08 AL Gradient compotents will be summed only at the end
+ ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
+ ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
+ ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
+ do k=1,3
+ gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
+ gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
+ enddo
+#endif
+*
+* Angular part
+*
+ ecosa=2.0D0*fac3*fac1+fac4
+ fac4=-3.0D0*fac4
+ fac3=-6.0D0*fac3
+ ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
+ ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
+ do k=1,3
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
+ enddo
+cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
+cd & (dcosg(k),k=1,3)
+ do k=1,3
+ ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
+ & fac_shield(i)**2*fac_shield(j)**2
+ enddo
+c do k=1,3
+c ghalf=0.5D0*ggg(k)
+c gelc(k,i)=gelc(k,i)+ghalf
+c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
+c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+c gelc(k,j)=gelc(k,j)+ghalf
+c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
+c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+c enddo
+cgrad do k=i+1,j-1
+cgrad do l=1,3
+cgrad gelc(l,k)=gelc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+C print *,"before22", gelc_long(1,i), gelc_long(1,j)
+ do k=1,3
+ gelc(k,i)=gelc(k,i)
+ & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
+ & *fac_shield(i)**2*fac_shield(j)**2
+ gelc(k,j)=gelc(k,j)
+ & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
+ & *fac_shield(i)**2*fac_shield(j)**2
+ gelc_long(k,j)=gelc_long(k,j)+ggg(k)
+ gelc_long(k,i)=gelc_long(k,i)-ggg(k)
+ enddo
+C print *,"before33", gelc_long(1,i), gelc_long(1,j)
+
+C MARYSIA
+c endif !sscale
+ IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
+ & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
+ & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
+C
+C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
+C energy of a peptide unit is assumed in the form of a second-order
+C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
+C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
+C are computed for EVERY pair of non-contiguous peptide groups.
+C
+
+ if (j.lt.nres-1) then
+ j1=j+1
+ j2=j-1
+ else
+ j1=j-1
+ j2=j-2
+ endif
+ kkk=0
+ lll=0
+ do k=1,2
+ do l=1,2
+ kkk=kkk+1
+ muij(kkk)=mu(k,i)*mu(l,j)
+c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
+#ifdef NEWCORR
+ gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
+c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
+ gmuij2(kkk)=gUb2(k,i)*mu(l,j)
+ gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
+c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
+ gmuji2(kkk)=mu(k,i)*gUb2(l,j)
+#endif
+ enddo
+ enddo
+#ifdef DEBUG
+ write (iout,*) 'EELEC: i',i,' j',j
+ write (iout,*) 'j',j,' j1',j1,' j2',j2
+ write(iout,*) 'muij',muij
+#endif
+ ury=scalar(uy(1,i),erij)
+ urz=scalar(uz(1,i),erij)
+ vry=scalar(uy(1,j),erij)
+ vrz=scalar(uz(1,j),erij)
+ a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
+ a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
+ a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
+ a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
+ fac=dsqrt(-ael6i)*r3ij
+#ifdef DEBUG
+ write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
+ write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
+ & "uyvz",scalar(uy(1,i),uz(1,j)),
+ & "uzvy",scalar(uz(1,i),uy(1,j)),
+ & "uzvz",scalar(uz(1,i),uz(1,j))
+ write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
+ write (iout,*) "fac",fac
+#endif
+ a22=a22*fac
+ a23=a23*fac
+ a32=a32*fac
+ a33=a33*fac
+#ifdef DEBUG
+ write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
+#endif
+#undef DEBUG
+cd write (iout,'(4i5,4f10.5)')
+cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
+cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
+cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
+cd & uy(:,j),uz(:,j)
+cd write (iout,'(4f10.5)')
+cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
+cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
+cd write (iout,'(4f10.5)') ury,urz,vry,vrz
+cd write (iout,'(9f10.5/)')
+cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
+C Derivatives of the elements of A in virtual-bond vectors
+ call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
+ do k=1,3
+ uryg(k,1)=scalar(erder(1,k),uy(1,i))
+ uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
+ uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
+ urzg(k,1)=scalar(erder(1,k),uz(1,i))
+ urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
+ urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
+ vryg(k,1)=scalar(erder(1,k),uy(1,j))
+ vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
+ vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
+ vrzg(k,1)=scalar(erder(1,k),uz(1,j))
+ vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
+ vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
+ enddo
+C Compute radial contributions to the gradient
+ facr=-3.0d0*rrmij
+ a22der=a22*facr
+ a23der=a23*facr
+ a32der=a32*facr
+ a33der=a33*facr
+ agg(1,1)=a22der*xj
+ agg(2,1)=a22der*yj
+ agg(3,1)=a22der*zj
+ agg(1,2)=a23der*xj
+ agg(2,2)=a23der*yj
+ agg(3,2)=a23der*zj
+ agg(1,3)=a32der*xj
+ agg(2,3)=a32der*yj
+ agg(3,3)=a32der*zj
+ agg(1,4)=a33der*xj
+ agg(2,4)=a33der*yj
+ agg(3,4)=a33der*zj
+C Add the contributions coming from er
+ fac3=-3.0d0*fac
+ do k=1,3
+ agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
+ agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
+ agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
+ agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
+ enddo
+ do k=1,3
+C Derivatives in DC(i)
+cgrad ghalf1=0.5d0*agg(k,1)
+cgrad ghalf2=0.5d0*agg(k,2)
+cgrad ghalf3=0.5d0*agg(k,3)
+cgrad ghalf4=0.5d0*agg(k,4)
+ aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
+ & -3.0d0*uryg(k,2)*vry)!+ghalf1
+ aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
+ & -3.0d0*uryg(k,2)*vrz)!+ghalf2
+ aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
+ & -3.0d0*urzg(k,2)*vry)!+ghalf3
+ aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
+ & -3.0d0*urzg(k,2)*vrz)!+ghalf4
+C Derivatives in DC(i+1)
+ aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
+ & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
+ aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
+ & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
+ aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
+ & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
+ aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
+ & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
+C Derivatives in DC(j)
+ aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
+ & -3.0d0*vryg(k,2)*ury)!+ghalf1
+ aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
+ & -3.0d0*vrzg(k,2)*ury)!+ghalf2
+ aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
+ & -3.0d0*vryg(k,2)*urz)!+ghalf3
+ aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
+ & -3.0d0*vrzg(k,2)*urz)!+ghalf4
+C Derivatives in DC(j+1) or DC(nres-1)
+ aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
+ & -3.0d0*vryg(k,3)*ury)
+ aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
+ & -3.0d0*vrzg(k,3)*ury)
+ aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
+ & -3.0d0*vryg(k,3)*urz)
+ aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
+ & -3.0d0*vrzg(k,3)*urz)
+cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
+cgrad do l=1,4
+cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
+cgrad enddo
+cgrad endif
+ enddo
+ acipa(1,1)=a22
+ acipa(1,2)=a23
+ acipa(2,1)=a32
+ acipa(2,2)=a33
+ a22=-a22
+ a23=-a23
+ do l=1,2
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ if (j.lt.nres-1) then
+ a22=-a22
+ a32=-a32
+ do l=1,3,2
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ else
+ a22=-a22
+ a23=-a23
+ a32=-a32
+ a33=-a33
+ do l=1,4
+ do k=1,3
+ agg(k,l)=-agg(k,l)
+ aggi(k,l)=-aggi(k,l)
+ aggi1(k,l)=-aggi1(k,l)
+ aggj(k,l)=-aggj(k,l)
+ aggj1(k,l)=-aggj1(k,l)
+ enddo
+ enddo
+ endif
+ ENDIF ! WCORR
+ IF (wel_loc.gt.0.0d0) THEN
+C Contribution to the local-electrostatic energy coming from the i-j pair
+ eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
+ & +a33*muij(4)
+#ifdef DEBUG
+ write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
+ & " a33",a33
+ write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
+ & " wel_loc",wel_loc
+#endif
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ endif
+ eel_loc_ij=eel_loc_ij
+ & *fac_shield(i)*fac_shield(j)
+c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+c & 'eelloc',i,j,eel_loc_ij
+C Now derivative over eel_loc
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
+ & /fac_shield(i)
+C & *2.0
+ gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
+ & /fac_shield(j)
+C & *2.0
+ gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
+ gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc_ll(k,i)=gshieldc_ll(k,i)+
+ & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,j)=gshieldc_ll(k,j)+
+ & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
+ gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
+ & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
+ gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
+ & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
+ enddo
+ endif
+
+
+c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
+c & ' eel_loc_ij',eel_loc_ij
+C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
+C Calculate patrial derivative for theta angle
+#ifdef NEWCORR
+ geel_loc_ij=(a22*gmuij1(1)
+ & +a23*gmuij1(2)
+ & +a32*gmuij1(3)
+ & +a33*gmuij1(4))
+ & *fac_shield(i)*fac_shield(j)
+c write(iout,*) "derivative over thatai"
+c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
+c & a33*gmuij1(4)
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)+
+ & geel_loc_ij*wel_loc
+c write(iout,*) "derivative over thatai-1"
+c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
+c & a33*gmuij2(4)
+ geel_loc_ij=
+ & a22*gmuij2(1)
+ & +a23*gmuij2(2)
+ & +a32*gmuij2(3)
+ & +a33*gmuij2(4)
+ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
+ & geel_loc_ij*wel_loc
+ & *fac_shield(i)*fac_shield(j)
+
+c Derivative over j residue
+ geel_loc_ji=a22*gmuji1(1)
+ & +a23*gmuji1(2)
+ & +a32*gmuji1(3)
+ & +a33*gmuji1(4)
+c write(iout,*) "derivative over thataj"
+c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
+c & a33*gmuji1(4)
+
+ gloc(nphi+j,icg)=gloc(nphi+j,icg)+
+ & geel_loc_ji*wel_loc
+ & *fac_shield(i)*fac_shield(j)
+
+ geel_loc_ji=
+ & +a22*gmuji2(1)
+ & +a23*gmuji2(2)
+ & +a32*gmuji2(3)
+ & +a33*gmuji2(4)
+c write(iout,*) "derivative over thataj-1"
+c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
+c & a33*gmuji2(4)
+ gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
+ & geel_loc_ji*wel_loc
+ & *fac_shield(i)*fac_shield(j)
+#endif
+cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
+
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'eelloc',i,j,eel_loc_ij
+c if (eel_loc_ij.ne.0)
+c & write (iout,'(a4,2i4,8f9.5)')'chuj',
+c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
+
+ eel_loc=eel_loc+eel_loc_ij
+C Partial derivatives in virtual-bond dihedral angles gamma
+ if (i.gt.1)
+ & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
+ & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
+ & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc_loc(j-1)=gel_loc_loc(j-1)+
+ & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
+ & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
+ do l=1,3
+ ggg(l)=(agg(l,1)*muij(1)+
+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+ gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
+ gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
+cgrad ghalf=0.5d0*ggg(l)
+cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
+cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
+ enddo
+cgrad do k=i+1,j2
+cgrad do l=1,3
+cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
+cgrad enddo
+cgrad enddo
+C Remaining derivatives of eello
+ do l=1,3
+ gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
+ & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
+ & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
+ & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
+ & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
+ & *fac_shield(i)*fac_shield(j)
+
+ enddo
+ ENDIF
+C Change 12/26/95 to calculate four-body contributions to H-bonding energy
+c if (j.gt.i+1 .and. num_conti.le.maxconts) then
+#ifdef FOURBODY
+ if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
+ & .and. num_conti.le.maxconts) then
+c write (iout,*) i,j," entered corr"
+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 r0ij=1.02D0*rpp(iteli,itelj)
+c r0ij=1.11D0*rpp(iteli,itelj)
+ r0ij=2.20D0*rpp(iteli,itelj)
+c r0ij=1.55D0*rpp(iteli,itelj)
+ call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
+ if (fcont.gt.0.0D0) then
+ num_conti=num_conti+1
+ if (num_conti.gt.maxconts) then
+ write (iout,*) 'WARNING - max. # of contacts exceeded;',
+ & ' will skip next contacts for this conf.'
+ else
+ jcont_hb(num_conti,i)=j
+cd write (iout,*) "i",i," j",j," num_conti",num_conti,
+cd & " jcont_hb",jcont_hb(num_conti,i)
+ IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
+ & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
+C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
+C terms.
+ d_cont(num_conti,i)=rij
+cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
+C --- Electrostatic-interaction matrix ---
+ a_chuj(1,1,num_conti,i)=a22
+ a_chuj(1,2,num_conti,i)=a23
+ a_chuj(2,1,num_conti,i)=a32
+ a_chuj(2,2,num_conti,i)=a33
+C --- Gradient of rij
+ do kkk=1,3
+ grij_hb_cont(kkk,num_conti,i)=erij(kkk)
+ enddo
+ kkll=0
+ do k=1,2
+ do l=1,2
+ kkll=kkll+1
+ do m=1,3
+ a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
+ a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
+ a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
+ a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
+ a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
+ enddo
+ enddo
+ enddo
+ ENDIF
+ IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
+C Calculate contact energies
+ cosa4=4.0D0*cosa
+ wij=cosa-3.0D0*cosb*cosg
+ cosbg1=cosb+cosg
+ cosbg2=cosb-cosg
+c fac3=dsqrt(-ael6i)/r0ij**3
+ fac3=dsqrt(-ael6i)*r3ij
+c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
+ ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
+ if (ees0tmp.gt.0) then
+ ees0pij=dsqrt(ees0tmp)
+ else
+ ees0pij=0
+ endif
+c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
+ ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
+ if (ees0tmp.gt.0) then
+ ees0mij=dsqrt(ees0tmp)
+ else
+ ees0mij=0
+ endif
+c ees0mij=0.0D0
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0d0
+ fac_shield(j)=1.0d0
+ else
+ ees0plist(num_conti,i)=j
+C fac_shield(i)=0.4d0
+C fac_shield(j)=0.6d0
+ endif
+ ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
+ & *fac_shield(i)*fac_shield(j)
+ ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
+ & *fac_shield(i)*fac_shield(j)
+C Diagnostics. Comment out or remove after debugging!
+c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
+c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
+c ees0m(num_conti,i)=0.0D0
+C End diagnostics.
+c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
+c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
+C Angular derivatives of the contact function
+ ees0pij1=fac3/ees0pij
+ ees0mij1=fac3/ees0mij
+ fac3p=-3.0D0*fac3*rrmij
+ ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
+ ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
+c ees0mij1=0.0D0
+ ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
+ ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
+ ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
+ ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
+ ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
+ ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
+ ecosap=ecosa1+ecosa2
+ ecosbp=ecosb1+ecosb2
+ ecosgp=ecosg1+ecosg2
+ ecosam=ecosa1-ecosa2
+ ecosbm=ecosb1-ecosb2
+ ecosgm=ecosg1-ecosg2
+C Diagnostics
+c ecosap=ecosa1
+c ecosbp=ecosb1
+c ecosgp=ecosg1
+c ecosam=0.0D0
+c ecosbm=0.0D0
+c ecosgm=0.0D0
+C End diagnostics
+ facont_hb(num_conti,i)=fcont
+ fprimcont=fprimcont/rij
+cd facont_hb(num_conti,i)=1.0D0
+C Following line is for diagnostics.
+cd fprimcont=0.0D0
+ do k=1,3
+ dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
+ dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
+ enddo
+ do k=1,3
+ gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
+ gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
+ enddo
+ gggp(1)=gggp(1)+ees0pijp*xj
+ gggp(2)=gggp(2)+ees0pijp*yj
+ gggp(3)=gggp(3)+ees0pijp*zj
+ gggm(1)=gggm(1)+ees0mijp*xj
+ gggm(2)=gggm(2)+ees0mijp*yj
+ gggm(3)=gggm(3)+ees0mijp*zj
+C Derivatives due to the contact function
+ gacont_hbr(1,num_conti,i)=fprimcont*xj
+ gacont_hbr(2,num_conti,i)=fprimcont*yj
+ gacont_hbr(3,num_conti,i)=fprimcont*zj
+ do k=1,3
+c
+c 10/24/08 cgrad and ! comments indicate the parts of the code removed
+c following the change of gradient-summation algorithm.
+c
+cgrad ghalfp=0.5D0*gggp(k)
+cgrad ghalfm=0.5D0*gggm(k)
+ gacontp_hb1(k,num_conti,i)=!ghalfp
+ & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontp_hb2(k,num_conti,i)=!ghalfp
+ & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontp_hb3(k,num_conti,i)=gggp(k)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb1(k,num_conti,i)=!ghalfm
+ & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
+ & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb2(k,num_conti,i)=!ghalfm
+ & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
+ & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
+ & *fac_shield(i)*fac_shield(j)
+
+ gacontm_hb3(k,num_conti,i)=gggm(k)
+ & *fac_shield(i)*fac_shield(j)
+
+ enddo
+C Diagnostics. Comment out or remove after debugging!
+cdiag do k=1,3
+cdiag gacontp_hb1(k,num_conti,i)=0.0D0
+cdiag gacontp_hb2(k,num_conti,i)=0.0D0
+cdiag gacontp_hb3(k,num_conti,i)=0.0D0
+cdiag gacontm_hb1(k,num_conti,i)=0.0D0
+cdiag gacontm_hb2(k,num_conti,i)=0.0D0
+cdiag gacontm_hb3(k,num_conti,i)=0.0D0
+cdiag enddo
+ ENDIF ! wcorr
+ endif ! num_conti.le.maxconts
+ endif ! fcont.gt.0
+ endif ! j.gt.i+1
+#endif
+ if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
+ do k=1,4
+ do l=1,3
+ ghalf=0.5d0*agg(l,k)
+ aggi(l,k)=aggi(l,k)+ghalf
+ aggi1(l,k)=aggi1(l,k)+agg(l,k)
+ aggj(l,k)=aggj(l,k)+ghalf
+ enddo
+ enddo
+ if (j.eq.nres-1 .and. i.lt.j-2) then
+ do k=1,4
+ do l=1,3
+ aggj1(l,k)=aggj1(l,k)+agg(l,k)
+ enddo
+ enddo
+ endif
+ endif
+c t_eelecij=t_eelecij+MPI_Wtime()-time00
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine eturn3(i,eello_turn3)
+C Third- and fourth-order contributions from turns
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CORRMAT'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SHIELD'
+ dimension ggg(3)
+ double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
+ & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
+ & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
+ & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
+ & auxgmat2(2,2),auxgmatt2(2,2)
+ double precision agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+ j=i+2
+c write (iout,*) "eturn3",i,j,j1,j2
+ a_temp(1,1)=a22
+ a_temp(1,2)=a23
+ a_temp(2,1)=a32
+ a_temp(2,2)=a33
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C Third-order contributions
+C
+C (i+2)o----(i+3)
+C | |
+C | |
+C (i+1)o----i
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+cd call checkint_turn3(i,a_temp,eello_turn3_num)
+ call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
+c auxalary matices for theta gradient
+c auxalary matrix for i+1 and constant i+2
+ call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
+c auxalary matrix for i+2 and constant i+1
+ call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
+ call transpose2(auxmat(1,1),auxmat1(1,1))
+ call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
+ call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
+ call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.4
+C fac_shield(j)=0.6
+ endif
+ eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
+ & eello_t3
+C#ifdef NEWCORR
+C Derivatives in theta
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)
+ & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
+ & *fac_shield(i)*fac_shield(j)
+ gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
+ & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
+ & *fac_shield(i)*fac_shield(j)
+C#endif
+
+C Derivatives in shield mode
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
+C & *2.0
+ gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
+C & *2.0
+ gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
+ gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc_t3(k,i)=gshieldc_t3(k,i)+
+ & grad_shield(k,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,j)=gshieldc_t3(k,j)+
+ & grad_shield(k,j)*eello_t3/fac_shield(j)
+ gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
+ & grad_shield(k,i)*eello_t3/fac_shield(i)
+ gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
+ & grad_shield(k,j)*eello_t3/fac_shield(j)
+ enddo
+ endif
+
+C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+cd write (2,*) 'i,',i,' j',j,'eello_turn3',
+cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
+cd & ' eello_turn3_num',4*eello_turn3_num
+C Derivatives in gamma(i)
+ call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
+ call transpose2(auxmat2(1,1),auxmat3(1,1))
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
+ gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives in gamma(i+1)
+ call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
+ call transpose2(auxmat2(1,1),auxmat3(1,1))
+ call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
+ gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+C Cartesian derivatives
+ do l=1,3
+c ghalf1=0.5d0*agg(l,1)
+c ghalf2=0.5d0*agg(l,2)
+c ghalf3=0.5d0*agg(l,3)
+c ghalf4=0.5d0*agg(l,4)
+ a_temp(1,1)=aggi(l,1)!+ghalf1
+ a_temp(1,2)=aggi(l,2)!+ghalf2
+ a_temp(2,1)=aggi(l,3)!+ghalf3
+ a_temp(2,2)=aggi(l,4)!+ghalf4
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,i)=gcorr3_turn(l,i)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+
+ a_temp(1,1)=aggi1(l,1)!+agg(l,1)
+ a_temp(1,2)=aggi1(l,2)!+agg(l,2)
+ a_temp(2,1)=aggi1(l,3)!+agg(l,3)
+ a_temp(2,2)=aggi1(l,4)!+agg(l,4)
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj(l,1)!+ghalf1
+ a_temp(1,2)=aggj(l,2)!+ghalf2
+ a_temp(2,1)=aggj(l,3)!+ghalf3
+ a_temp(2,2)=aggj(l,4)!+ghalf4
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,j)=gcorr3_turn(l,j)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj1(l,1)
+ a_temp(1,2)=aggj1(l,2)
+ a_temp(2,1)=aggj1(l,3)
+ a_temp(2,2)=aggj1(l,4)
+ call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
+ gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
+ & +0.5d0*(pizda(1,1)+pizda(2,2))
+ & *fac_shield(i)*fac_shield(j)
+ enddo
+ return
+ end
+C-------------------------------------------------------------------------------
+ subroutine eturn4(i,eello_turn4)
+C Third- and fourth-order contributions from turns
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CORRMAT'
+ include 'COMMON.TORSION'
+ include 'COMMON.VECTORS'
+ include 'COMMON.FFIELD'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SHIELD'
+ dimension ggg(3)
+ double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
+ & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
+ & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
+ & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
+ & gte1t(2,2),gte2t(2,2),gte3t(2,2),
+ & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
+ & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
+ double precision agg(3,4),aggi(3,4),aggi1(3,4),
+ & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
+ common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
+ & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
+ & num_conti,j1,j2
+ j=i+3
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C Fourth-order contributions
+C
+C (i+3)o----(i+4)
+C / |
+C (i+2)o |
+C \ |
+C (i+1)o----i
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+cd call checkint_turn4(i,a_temp,eello_turn4_num)
+c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
+c write(iout,*)"WCHODZE W PROGRAM"
+ a_temp(1,1)=a22
+ a_temp(1,2)=a23
+ a_temp(2,1)=a32
+ a_temp(2,2)=a33
+ iti1=itype2loc(itype(i+1))
+ iti2=itype2loc(itype(i+2))
+ iti3=itype2loc(itype(i+3))
+c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
+ call transpose2(EUg(1,1,i+1),e1t(1,1))
+ call transpose2(Eug(1,1,i+2),e2t(1,1))
+ call transpose2(Eug(1,1,i+3),e3t(1,1))
+C Ematrix derivative in theta
+ call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
+ call transpose2(gtEug(1,1,i+2),gte2t(1,1))
+ call transpose2(gtEug(1,1,i+3),gte3t(1,1))
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+c eta1 in derivative theta
+ call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+c auxgvec is derivative of Ub2 so i+3 theta
+ call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
+c auxalary matrix of E i+1
+ call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
+c s1=0.0
+c gs1=0.0
+ s1=scalar2(b1(1,i+2),auxvec(1))
+c derivative of theta i+2 with constant i+3
+ gs23=scalar2(gtb1(1,i+2),auxvec(1))
+c derivative of theta i+2 with constant i+2
+ gs32=scalar2(b1(1,i+2),auxgvec(1))
+c derivative of E matix in theta of i+1
+ gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
+
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+c ea31 in derivative theta
+ call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+c auxilary matrix auxgvec of Ub2 with constant E matirx
+ call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
+c auxilary matrix auxgEvec1 of E matix with Ub2 constant
+ call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
+
+c s2=0.0
+c gs2=0.0
+ s2=scalar2(b1(1,i+1),auxvec(1))
+c derivative of theta i+1 with constant i+3
+ gs13=scalar2(gtb1(1,i+1),auxvec(1))
+c derivative of theta i+2 with constant i+1
+ gs21=scalar2(b1(1,i+1),auxgvec(1))
+c derivative of theta i+3 with constant i+1
+ gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
+c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
+c & gtb1(1,i+1)
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+c two derivatives over diffetent matrices
+c gtae3e2 is derivative over i+3
+ call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
+c ae3gte2 is derivative over i+2
+ call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+c three possible derivative over theta E matices
+c i+1
+ call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
+c i+2
+ call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
+c i+3
+ call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+
+ gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
+ gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
+ gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
+ if (shield_mode.eq.0) then
+ fac_shield(i)=1.0
+ fac_shield(j)=1.0
+C else
+C fac_shield(i)=0.6
+C fac_shield(j)=0.4
+ endif
+ eello_turn4=eello_turn4-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ eello_t4=-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
+ & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
+C Now derivative over shield:
+ if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
+ & (shield_mode.gt.0)) then
+C print *,i,j
+
+ do ilist=1,ishield_list(i)
+ iresshield=shield_list(ilist,i)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
+C & *2.0
+ gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
+ & +rlocshield
+ enddo
+ enddo
+ do ilist=1,ishield_list(j)
+ iresshield=shield_list(ilist,j)
+ do k=1,3
+ rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
+C & *2.0
+ gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
+ & rlocshield
+ & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
+ gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
+ & +rlocshield
+
+ enddo
+ enddo
+
+ do k=1,3
+ gshieldc_t4(k,i)=gshieldc_t4(k,i)+
+ & grad_shield(k,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,j)=gshieldc_t4(k,j)+
+ & grad_shield(k,j)*eello_t4/fac_shield(j)
+ gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
+ & grad_shield(k,i)*eello_t4/fac_shield(i)
+ gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
+ & grad_shield(k,j)*eello_t4/fac_shield(j)
+ enddo
+ endif
+
+
+
+
+
+
+cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
+cd & ' eello_turn4_num',8*eello_turn4_num
+#ifdef NEWCORR
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)
+ & -(gs13+gsE13+gsEE1)*wturn4
+ & *fac_shield(i)*fac_shield(j)
+ gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
+ & -(gs23+gs21+gsEE2)*wturn4
+ & *fac_shield(i)*fac_shield(j)
+
+ gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
+ & -(gs32+gsE31+gsEE3)*wturn4
+ & *fac_shield(i)*fac_shield(j)
+
+c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
+c & gs2
+#endif
+ if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
+ & 'eturn4',i,j,-(s1+s2+s3)
+c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
+c & ' eello_turn4_num',8*eello_turn4_num
+C Derivatives in gamma(i)
+ call transpose2(EUgder(1,1,i+1),e1tder(1,1))
+ call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives in gamma(i+1)
+ call transpose2(EUgder(1,1,i+2),e2tder(1,1))
+ call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
+ call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+C Derivatives in gamma(i+2)
+ call transpose2(EUgder(1,1,i+3),e3tder(1,1))
+ call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
+ call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
+ call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+C Cartesian derivatives
+C Derivatives of this turn contributions in DC(i+2)
+ if (j.lt.nres-1) then
+ do l=1,3
+ a_temp(1,1)=agg(l,1)
+ a_temp(1,2)=agg(l,2)
+ a_temp(2,1)=agg(l,3)
+ a_temp(2,2)=agg(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ ggg(l)=-(s1+s2+s3)
+ gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ enddo
+ endif
+C Remaining derivatives of this turn contribution
+ do l=1,3
+ a_temp(1,1)=aggi(l,1)
+ a_temp(1,2)=aggi(l,2)
+ a_temp(2,1)=aggi(l,3)
+ a_temp(2,2)=aggi(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggi1(l,1)
+ a_temp(1,2)=aggi1(l,2)
+ a_temp(2,1)=aggi1(l,3)
+ a_temp(2,2)=aggi1(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj(l,1)
+ a_temp(1,2)=aggj(l,2)
+ a_temp(2,1)=aggj(l,3)
+ a_temp(2,2)=aggj(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+ gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ a_temp(1,1)=aggj1(l,1)
+ a_temp(1,2)=aggj1(l,2)
+ a_temp(2,1)=aggj1(l,3)
+ a_temp(2,2)=aggj1(l,4)
+ call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
+ call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
+ s1=scalar2(b1(1,i+2),auxvec(1))
+ call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
+ call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
+ s2=scalar2(b1(1,i+1),auxvec(1))
+ call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
+ call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
+ s3=0.5d0*(pizda(1,1)+pizda(2,2))
+c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
+ gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
+ & *fac_shield(i)*fac_shield(j)
+ enddo
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine vecpr(u,v,w)
+ implicit real*8(a-h,o-z)
+ dimension u(3),v(3),w(3)
+ w(1)=u(2)*v(3)-u(3)*v(2)
+ w(2)=-u(1)*v(3)+u(3)*v(1)
+ w(3)=u(1)*v(2)-u(2)*v(1)
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine unormderiv(u,ugrad,unorm,ungrad)
+C This subroutine computes the derivatives of a normalized vector u, given
+C the derivatives computed without normalization conditions, ugrad. Returns
+C ungrad.
+ implicit none
+ double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
+ double precision vec(3)
+ double precision scalar
+ integer i,j
+c write (2,*) 'ugrad',ugrad
+c write (2,*) 'u',u
+ do i=1,3
+ vec(i)=scalar(ugrad(1,i),u(1))
+ enddo
+c write (2,*) 'vec',vec
+ do i=1,3
+ do j=1,3
+ ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
+ enddo
+ enddo
+c write (2,*) 'ungrad',ungrad
+ return
+ end
+C-----------------------------------------------------------------------------
+ subroutine escp_soft_sphere(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'
+ dimension ggg(3)
+ integer xshift,yshift,zshift
+ evdw2=0.0D0
+ evdw2_14=0.0d0
+ r0_scp=4.5d0
+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
+ 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))
+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 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 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
+cC 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
+ 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
+ do iint=1,nscp_gr(i)
+
+ do j=iscpstart(i,iint),iscpend(i,iint)
+ if (itype(j).eq.ntyp1) cycle
+ itypj=iabs(itype(j))
+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)
+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
+ xj=mod(xj,boxxsize)
+ if (xj.lt.0) xj=xj+boxxsize
+ yj=mod(yj,boxysize)
+ if (yj.lt.0) yj=yj+boxysize
+ zj=mod(zj,boxzsize)
+ if (zj.lt.0) zj=zj+boxzsize
+ dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ xj_safe=xj
+ yj_safe=yj
+ zj_safe=zj
+ subchap=0
+ do xshift=-1,1
+ do yshift=-1,1
+ do zshift=-1,1
+ xj=xj_safe+xshift*boxxsize
+ yj=yj_safe+yshift*boxysize
+ zj=zj_safe+zshift*boxzsize
+ dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+ if(dist_temp.lt.dist_init) then
+ dist_init=dist_temp
+ xj_temp=xj
+ yj_temp=yj
+ zj_temp=zj
+ subchap=1
+ endif
+ enddo
+ enddo
+ enddo
+ if (subchap.eq.1) then
+ xj=xj_temp-xi
+ yj=yj_temp-yi
+ zj=zj_temp-zi
+ else
+ xj=xj_safe-xi
+ yj=yj_safe-yi
+ zj=zj_safe-zi
+ endif
+c c endif
+C xj=xj-xi
+C yj=yj-yi
+C zj=zj-zi
+ rij=xj*xj+yj*yj+zj*zj
+
+ r0ij=r0_scp
+ r0ijsq=r0ij*r0ij
+ if (rij.lt.r0ijsq) then
+ evdwij=0.25d0*(rij-r0ijsq)**2
+ fac=rij-r0ijsq
+ else
+ evdwij=0.0d0
+ fac=0.0d0
+ endif
+ evdw2=evdw2+evdwij
+C
+C Calculate contributions to the gradient in the virtual-bond and SC vectors.
+C
+ ggg(1)=xj*fac
+ ggg(2)=yj*fac
+ ggg(3)=zj*fac
+cgrad if (j.lt.i) then
+cd write (iout,*) 'j<i'
+C Uncomment following three lines for SC-p interactions
+c do k=1,3
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+c enddo
+cgrad else
+cd write (iout,*) 'j>i'
+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,*) 'j<i'
+C Uncomment following three lines for SC-p interactions
+c do k=1,3
+c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
+c enddo
+cgrad else
+cd write (iout,*) 'j>i'
+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
--- /dev/null
+C[BA*)\r
+C[LE*)\r
+C[LE*)\r
+C[LE*)\r
+C[FE{F 4.12.1}{Systems with Five-Diagonal Matrices}\r
+C[ {Systems with Five-Diagonal Matrices}*)\r
+C[LE*)\r
+ SUBROUTINE FDIAG (N,DL2,DL1,DM,DU1,DU2,RS,X,MARK)\r
+C[IX{FDIAG}*)\r
+C\r
+C*****************************************************************\r
+C *\r
+C Solving a system of linear equations *\r
+C A * X = RS *\r
+C with a five-diagonal, strongly nonsingular matrix A via *\r
+C Gauss algorithm without pivoting. *\r
+C[BE*)\r
+C The matrix A is given as five N-vectors DL2, DL1, DM, DU1 *\r
+C and DU2. The linear system has the form: *\r
+C *\r
+C DM(1)*X(1)+DU1(1)*X(2)+DU2(1)*X(3) = RS(1) *\r
+C DL1(2)*X(1)+DM(2)*X(2)+DU1(2)*X(3)+DU2(2)*X(4) = RS(2) *\r
+C *\r
+C DL2(I)*X(I-2)+DL1(I)*X(I-1)+ *\r
+C +DM(I)*X(I)+DU1(I)*X(I+1)+DU2(I)*X(I+2) = RS(I) *\r
+C for I = 3, ..., N - 2, and *\r
+C *\r
+C DL2(N-1)*X(N-3)+DL1(N-1)*X(N-2)+ *\r
+C +DM(N-1)*X(N-1)+DU1(N-1)+X(N) = RS(N-1) *\r
+C DL2(N)*X(N-2)+DL1(N)*X(N-1)+DM(N)*X(N) = RS(N) *\r
+C *\r
+C *\r
+C *\r
+C INPUT PARAMETERS: *\r
+C ================= *\r
+C N : number of equations; N > 3 *\r
+C DL2 : N-vector DL2(1:N); second lower co-diagonal *\r
+C DL2(3), DL2(4), ... , DL2(N) *\r
+C DL1 : N-vector DL1(1:N); lower co-diagonal *\r
+C DL1(2), DL1(3), ... , DL1(N) *\r
+C DM : N-vector DM(1:N); main diagonal *\r
+C DM(1), DM(2), ... , DM(N) *\r
+C DU1 : N-vector DU1(1:N); upper co-diagonal *\r
+C DU1(1), DU1(2), ... , DU1(N-1) *\r
+C DU2 : N-vector DU2(1:N); second upper co-diagonal *\r
+C DU2(1), DU2(2), ... , DU2(N-2) *\r
+C RS : N-vector RS(1:N); the right hand side of the *\r
+C linear system *\r
+C *\r
+C *\r
+C OUTPUT PARAMETERS: *\r
+C ================== *\r
+C DL2 :) overwritten with auxiliary vectors defining the *\r
+C DL1 :) factorization of the cyclically tridiagonal *\r
+C DM :) matrix A *\r
+C DU1 :) *\r
+C DU2 :) *\r
+C X : N-vector X(1:N); containing the solution of the *\r
+C the system of equations *\r
+C MARK : error parameter *\r
+C MARK=-1 : condition N > 3 is not satisfied *\r
+C MARK= 0 : numerically the matrix A is not strongly *\r
+C nonsingular *\r
+C MARK= 1 : everything is o.k. *\r
+C *\r
+C NOTE: if MARK = 1, the determinant of A is given by: *\r
+C DET A = DM(1) * DM(2) * ... * DM(N) *\r
+C *\r
+C----------------------------------------------------------------*\r
+C *\r
+C subroutines required: FDIAGP, FDIAGS, MACHPD *\r
+C *\r
+C*****************************************************************\r
+C *\r
+C author : Gisela Engeln-Muellges *\r
+C date : 05.06.1988 *\r
+C source : FORTRAN 77 *\r
+C *\r
+C[BA*)\r
+C*****************************************************************\r
+C[BE*)\r
+C\r
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)\r
+ DOUBLE PRECISION DL1(1:N),DL2(1:N),DM(1:N)\r
+ DOUBLE PRECISION DU1(1:N),DU2(1:N),RS(1:N),X(1:N)\r
+ MARK = -1\r
+ IF (N .LT. 4) RETURN\r
+C\r
+C Factor the matrix A\r
+C\r
+ CALL FDIAGP(N,DL2,DL1,DM,DU1,DU2,MARK)\r
+C\r
+C if MARK = 1, update and bachsubstitute\r
+C\r
+ IF (MARK .EQ. 1) THEN\r
+ CALL FDIAGS(N,DL2,DL1,DM,DU1,DU2,RS,X)\r
+ END IF\r
+ RETURN\r
+ END\r
+C\r
+C\r
+C[BA*)\r
+C[LE*)\r
+ SUBROUTINE FDIAGP (N,DL2,DL1,DM,DU1,DU2,MARK)\r
+C[IX{FDIAGP}*)\r
+C\r
+C*****************************************************************\r
+C *\r
+C Factor a five-diagonal, strongly nonsingular matrix A *\r
+C that is defined by the five N-vectors DL2, DL1, DM, DU1 *\r
+C and DU2, into its triangular factors L * R by applying *\r
+C Gaussian elimination specialized for five-diagonal matrices*\r
+C (without pivoting). *\r
+C[BE*)\r
+C *\r
+C *\r
+C INPUT PARAMETERS: *\r
+C ================= *\r
+C N : number of equations; N > 3 *\r
+C DL2 : N-vector DL2(1:N); second lower co-diagonal *\r
+C DL2(3), DL2(4), ... , DL2(N) *\r
+C DL1 : N-vector DL1(1:N); lower co-diagonal *\r
+C DL1(2), DL1(3), ... , DL1(N) *\r
+C DM : N-vector DM(1:N); main diagonal *\r
+C DM(1), DM(2), ... , DM(N) *\r
+C DU1 : N-vector DU1(1:N); upper co-diagonal *\r
+C DU1(1), DU1(2), ... , DU1(N-1) *\r
+C DU2 : N-vector DU2(1:N); second upper co-diagonal *\r
+C DU2(1), DU2(2), ... , DU2(N-2) *\r
+C *\r
+C *\r
+C OUTPUT PARAMETERS: *\r
+C ================== *\r
+C DL2 :) overwritten with auxiliary vectors that define *\r
+C DL1 :) the factors of the five-diagonal matrix A; *\r
+C DM :) the three co-diagonals of the lower triangular *\r
+C DU1 :) matrix L are stored in the vectors DL2, DL1 and *\r
+C DU2 :) DM. The two co-diagonals of the unit upper *\r
+C triangular matrix R are stored in the vectors DU1 *\r
+C and DU2, its diagonal elements each have the *\r
+C value 1. *\r
+C MARK : error parameter *\r
+C MARK=-1 : condition N > 3 is violated *\r
+C MARK= 0 : numerically the matrix is not strongly *\r
+C nonsingular *\r
+C MARK= 1 : everything is o.k. *\r
+C *\r
+C----------------------------------------------------------------*\r
+C *\r
+C subroutines required: MACHPD *\r
+C *\r
+C*****************************************************************\r
+C *\r
+C author : Gisela Engeln-Muellges *\r
+C date : 05.06.1988 *\r
+C source : FORTRAN 77 *\r
+C *\r
+C[BA*)\r
+C*****************************************************************\r
+C[BE*)\r
+C\r
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)\r
+ DOUBLE PRECISION DL2(1:N),DL1(1:N),DM(1:N),DU1(1:N),DU2(1:N)\r
+C\r
+C testing whether N > 3\r
+C\r
+ MARK = -1\r
+ IF (N .LT. 4) RETURN\r
+C\r
+C calculating the machine constant\r
+C\r
+ FMACHP = 1.0D0\r
+ 10 FMACHP = 0.5D0 * FMACHP\r
+ IF (MACHPD(1.0D0+FMACHP) .EQ. 1) GOTO 10\r
+ FMACHP = FMACHP * 2.0D0\r
+C\r
+C determining relative error bounds\r
+C\r
+ EPS = 4.0D0 * FMACHP\r
+C\r
+C initializing the undefined vector components\r
+C\r
+ DL2(1) = 0.0D0\r
+ DL2(2) = 0.0D0\r
+ DL1(1) = 0.0D0\r
+ DU1(N) = 0.0D0\r
+ DU2(N-1) = 0.0D0\r
+ DU2(N) = 0.0D0\r
+C\r
+C factoring the matrix A while checking for strong nonsingularity\r
+C for N=1, 2\r
+C\r
+ ROW = DABS(DM(1)) + DABS(DU1(1)) + DABS(DU2(1))\r
+ IF (ROW .EQ. 0.0D0) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+ D = 1.0D0/ROW\r
+ IF (DABS(DM(1))*D .LE. EPS) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+ DU1(1) = DU1(1)/DM(1)\r
+ DU2(1) = DU2(1)/DM(1)\r
+ ROW = DABS(DL1(2)) + DABS(DM(2)) + DABS(DU1(2)) + DABS(DU2(2))\r
+ IF (ROW .EQ. 0.0D0) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+ D = 1.0D0/ROW\r
+ DM(2) = DM(2)-DL1(2)*DU1(1)\r
+ IF (DABS(DM(2))*D .LE. EPS) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+ DU1(2) = (DU1(2)-DL1(2)*DU2(1))/DM(2)\r
+ DU2(2) = DU2(2)/DM(2)\r
+C\r
+C factoring A while checking for strong nonsingularity of A\r
+C\r
+ DO 20 I=3,N,1\r
+ ROW = DABS(DL2(I))+DABS(DL1(I))+DABS(DM(I))+\r
+ + DABS(DU1(I))+DABS(DU2(I))\r
+ IF (ROW .EQ. 0.0D0) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+ D = 1.0D0/ROW\r
+ DL1(I) = DL1(I)-DL2(I)*DU1(I-2)\r
+ DM(I) = DM(I)-DL2(I)*DU2(I-2)-DL1(I)*DU1(I-1)\r
+ IF (DABS(DM(I))*D .LE. EPS) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+ IF (I .LT. N) THEN\r
+ DU1(I) = (DU1(I)-DL1(I)*DU2(I-1))/DM(I)\r
+ ENDIF\r
+ IF (I .LT. (N-1)) THEN\r
+ DU2(I) = DU2(I)/DM(I)\r
+ ENDIF\r
+ 20 CONTINUE\r
+ MARK = 1\r
+ RETURN\r
+ END\r
+C\r
+C\r
+C[BA*)\r
+C[LE*)\r
+ SUBROUTINE FDIAGS (N,DL2,DL1,DM,DU1,DU2,RS,X)\r
+C[IX{FDIAGS}*)\r
+C\r
+C*****************************************************************\r
+C *\r
+C Solving a linear system of equations *\r
+C A * X = RS *\r
+C for a five-diagonal, strongly nonsingular matrix A, once *\r
+C the factor matrices L * R have been calculated by *\r
+C SUBROUTINE FDIAGP. *\r
+C[BE*)\r
+C Here they are used as input arrays and *\r
+C they are stored in the five N-vectors DL2, DL1, DM, DU1 *\r
+C and DU2. *\r
+C *\r
+C *\r
+C INPUT PARAMETERS: *\r
+C ================= *\r
+C N : number of equations; N > 3 *\r
+C DL2 : N-vector DL2(1:N); ) lower triangular matrix L *\r
+C DL1 : N-vector DL1(1:N); ) including the diagonal *\r
+C DM : N-vector DM(1:N); ) elements *\r
+C *\r
+C DU1 : N-vector DU1(1:N); ) unit upper triangular matrix *\r
+C DU2 : N-vector DU2(1:N); ) R without its unit diagonal *\r
+C elements *\r
+C RS : N-vector RS1(1:N); right side of the linear system *\r
+C *\r
+C *\r
+C OUTPUT PARAMETERS: *\r
+C ================== *\r
+C X : N-vector X(1:N); the solution of the linear system *\r
+C *\r
+C----------------------------------------------------------------*\r
+C *\r
+C subroutines required: none *\r
+C *\r
+C*****************************************************************\r
+C *\r
+C author : Gisela Engeln-Muellges *\r
+C date : 05.06.1988 *\r
+C source : FORTRAN 77 *\r
+C *\r
+C[BA*)\r
+C*****************************************************************\r
+C[BE*)\r
+C\r
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)\r
+ DOUBLE PRECISION DL2(1:N),DL1(1:N),DM(1:N)\r
+ DOUBLE PRECISION DU1(1:N),DU2(1:N),RS(1:N),X(1:N)\r
+C\r
+C updating\r
+C\r
+ RS(1)=RS(1)/DM(1)\r
+ RS(2)=(RS(2)-DL1(2)*RS(1))/DM(2)\r
+ DO 10 I=3,N\r
+ RS(I)=(RS(I)-DL2(I)*RS(I-2)-DL1(I)*RS(I-1))/DM(I)\r
+ 10 CONTINUE\r
+C\r
+C backsubstitution\r
+C\r
+ X(N)=RS(N)\r
+ X(N-1)=RS(N-1)-DU1(N-1)*X(N)\r
+ DO 20 I=N-2,1,-1\r
+ X(I)=RS(I)-DU1(I)*X(I+1)-DU2(I)*X(I+2)\r
+ 20 CONTINUE\r
+ RETURN\r
+ END\r
--- /dev/null
+C[BA*)\r
+C[LE*)\r
+C[LE*)\r
+C[LE*)\r
+C[FE{F 4.12.2}\r
+C[ {Systems with Five-Diagonal Symmetric Matrices}\r
+C[ {Systems with Five-Diagonal Symmetric Matrices}*)\r
+C[LE*)\r
+ SUBROUTINE FDISY (N,DM,DU1,DU2,RS,X,MARK)\r
+C[IX{FDISY}*)\r
+C\r
+C*****************************************************************\r
+C *\r
+C Solving a system of linear equations *\r
+C A * X = RS *\r
+C for a five-diagonal, symmetric and strongly nonsingular *\r
+C matrix A. *\r
+C[BE*)\r
+C The matrix A is given by the three N-vectors DM, *\r
+C DU1 and DU2. The system of equations has the form : *\r
+C *\r
+C DM(1)*X(1) + DU1(1)*X(2) + DU2(1)*X(3) = RS(1) *\r
+C DU1(1)*X(1) + DM(2)*X(2) + DU1(2)*X(3) + DU2(2)*X(4) = RS(2) *\r
+C *\r
+C DU2(I-2)*X(I-2) + DU1(I-1)*X(I-1) + DM(I)*X(I) + *\r
+C + DU1(I)*X(I+1) + DU2(I)*X(I+2) = RS(I) *\r
+C for I = 3, ..., N - 2, and *\r
+C *\r
+C DU2(N-3)*X(N-2) + DU1(N-2)*X(N-1) + DM(N-1)*X(N-1) + *\r
+C + DU1(N-1)*X(N) = RS(N-1)*\r
+C DU2(N-2)*X(N-2) + OD(N-1)*X(N-1) + DM(N)*X(N) = RS(N) *\r
+C *\r
+C *\r
+C *\r
+C INPUT PARAMETERS: *\r
+C ================= *\r
+C N : number of equations, N > 3 *\r
+C DM : N-vector DM(1:N); main diagonal of A *\r
+C DM(1), DM(2), ... , DM(N) *\r
+C DU1 : N-vector DU1(1:N); co-diagonal of A *\r
+C DU1(1), DU1(2), ... , DU1(N-1) *\r
+C DU2 : N-vector DU2(1:N); second co-diagonal of A *\r
+C DU2(1), DU2(2), ... , DU2(N-2) *\r
+C RS : N-vector RS(1:N); the right hand side *\r
+C *\r
+C *\r
+C OUTPUT PARAMETERS: *\r
+C ================== *\r
+C DM :) *\r
+C DU1 :) overwritten with intermediate quantities *\r
+C DU2 :) *\r
+C RS :) *\r
+C X : N-vector X(1:N) containing the solution vector *\r
+C MARK : error parameter *\r
+C MARK=-2 : condition N > 3 is not satisfied *\r
+C MARK=-1 : A is strongly nonsingular, but not positive *\r
+C definite *\r
+C MARK= 0 : numerically the matrix A is not strongly *\r
+C nonsingular *\r
+C MARK= 1 : A is positive definite *\r
+C *\r
+C NOTE: If MARK = +/- 1, then the determinant of A is: *\r
+C DET A = DM(1) * DM(2) * ... * DM(N) *\r
+C *\r
+C----------------------------------------------------------------*\r
+C *\r
+C subroutines required: FDISYP, FDISYS, MACHPD *\r
+C *\r
+C*****************************************************************\r
+C *\r
+C authors : Gisela Engeln-Muellges *\r
+C date : 01.07.1992 *\r
+C source : FORTRAN 77 *\r
+C *\r
+C[BA*)\r
+C*****************************************************************\r
+C[BE*)\r
+C\r
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)\r
+ DOUBLE PRECISION DM(1:N),DU1(1:N),DU2(1:N),RS(1:N),X(1:N)\r
+ MARK = -2\r
+ IF (N .LT. 4) RETURN\r
+C\r
+C Factorization of the matrix A\r
+C\r
+ CALL FDISYP (N,DM,DU1,DU2,MARK)\r
+C\r
+C if MARK = +/- 1 , update and backsubstitute\r
+C\r
+ IF (MARK .EQ. 1) THEN\r
+ CALL FDISYS (N,DM,DU1,DU2,RS,X)\r
+ ENDIF\r
+ RETURN\r
+ END\r
+C\r
+C\r
+C[BA*)\r
+C[LE*)\r
+ SUBROUTINE FDISYP (N,DM,DU1,DU2,MARK)\r
+C[IX{FDISYP}*)\r
+C\r
+C*****************************************************************\r
+C *\r
+C Factor a five-diagonal, symmetric and strongly nonsingular *\r
+C matrix A, that is given by the three N-vectors DM, DU1 and *\r
+C DU2, into its Cholesky factors A = R(TRANSP) * D * R by *\r
+C applying the root-free Cholesky method for five-diagonal *\r
+C matrices. The form of the linear system is identical with *\r
+C the one in SUBROUTINE FDISY. *\r
+C[BE*)\r
+C *\r
+C *\r
+C INPUT PARAMETERS: *\r
+C ================= *\r
+C N : number of equations, N > 3 *\r
+C DM : N-vector DM(1:N); main diagonal of A *\r
+C DM(1), DM(2), ... , DM(N) *\r
+C DU1 : N-vector DU1(1:N); upper co-diagonal of A *\r
+C DU1(1), DU1(2), ... , DU1(N-1) *\r
+C DU2 : N-vector DU2(1:N); second upper co-diagonal of A *\r
+C DU2(1), DU2(2), ... , DU2(N-2); *\r
+C due to symmetry the lower co-diagonals do not need to *\r
+C be stored separately. *\r
+C *\r
+C *\r
+C OUTPUT PARAMETERS: *\r
+C ================== *\r
+C DM :) overwritten with auxiliary vectors containing the *\r
+C DU1 :) Cholesky factors of A. The co-diagonals of the unit *\r
+C DU2 :) upper tridiagonal matrix R are stored in DU1 and DU2, *\r
+C the diagonal matrix D in DM. *\r
+C MARK : error parameter *\r
+C MARK=-2 : condition N > 3 is not satisfied *\r
+C MARK=-1 : A is strongly nonsingular, but not positive *\r
+C definite *\r
+C MARK= 0 : numerically the matrix is not strongly *\r
+C nonsingular *\r
+C MARK= 1 : A is positive definite *\r
+C *\r
+C NOTE : If MARK = +/-1, then the inertia of A, i. e., the *\r
+C number of positive and negative eigenvalues of A, *\r
+C is the same as the number of positive and negative *\r
+C numbers among the components of DM. *\r
+C *\r
+C----------------------------------------------------------------*\r
+C *\r
+C subroutines required: MACHPD *\r
+C *\r
+C*****************************************************************\r
+C *\r
+C authors : Gisela Engeln-Muellges *\r
+C date : 01.07.1988 *\r
+C source : FORTRAN 77 *\r
+C *\r
+C*****************************************************************\r
+C\r
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)\r
+ DOUBLE PRECISION DM(1:N),DU1(1:N),DU2(1:N)\r
+C\r
+C calculating the machine constant\r
+C\r
+ FMACHP = 1.0D0\r
+ 10 FMACHP = 0.5D0 * FMACHP\r
+ IF (MACHPD(1.0D0+FMACHP) .EQ. 1) GOTO 10\r
+ FMACHP = FMACHP * 2.0D0\r
+C\r
+C determining the relative error bound\r
+C\r
+ EPS = 4.0D0 * FMACHP\r
+C\r
+C checking for N > 3\r
+C\r
+ MARK = -2\r
+ IF (N .LT. 4) RETURN\r
+ DU1(N) = 0.0D0\r
+ DU2(N) = 0.0D0\r
+ DU2(N-1) = 0.0D0\r
+C\r
+C checking for strong nonsingularity of the matrix A for N=1\r
+C\r
+ ROW = DABS(DM(1)) + DABS(DU1(1)) + DABS(DU2(1))\r
+ IF (ROW .EQ. 0.0D0) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+ D = 1.0D0/ROW\r
+ IF (DM(1) .LT. 0.0D0) THEN\r
+ MARK =-1\r
+ RETURN\r
+ ELSEIF (DABS(DM(1))*D .LE. EPS) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+C\r
+C factoring A while checking for strong nonsingularity\r
+C\r
+ DUMMY = DU1(1)\r
+ DU1(1) = DU1(1)/DM(1)\r
+ DUMMY1 = DU2(1)\r
+ DU2(1) = DU2(1)/DM(1)\r
+ ROW = DABS(DUMMY) + DABS(DM(2)) + DABS(DU1(2)) + DABS(DU2(2))\r
+ IF (ROW .EQ. 0.0D0) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+ D = 1.0D0/ROW\r
+ DM(2) = DM(2) - DUMMY*DU1(1)\r
+ IF (DM(2) .LT. 0.0D0) THEN\r
+ MARK =-1\r
+ RETURN\r
+ ELSEIF (DABS(DM(2)) .LE. EPS) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+ DUMMY = DU1(2)\r
+ DU1(2) = (DU1(2)-DUMMY1*DU1(1))/DM(2)\r
+ DUMMY2 = DU2(2)\r
+ DU2(2) = DU2(2)/DM(2)\r
+ DO 20 I=3,N,1\r
+ ROW = DABS(DUMMY1)+DABS(DUMMY)+DABS(DM(I))+DABS(DU1(I))+\r
+ + DABS(DU2(I))\r
+ IF (ROW .EQ. 0.0D0) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+ D = 1.0D0/ROW\r
+ DM(I) = DM(I) - DM(I-1) * DU1(I-1) * DU1(I-1)\r
+ + -DUMMY1*DU2(I-2)\r
+ IF (DM(I) .LT. 0.0D0) THEN\r
+ MARK = -1\r
+ RETURN\r
+ ELSEIF (DABS(DM(I))*D .LE. EPS) THEN\r
+ MARK = 0\r
+ RETURN\r
+ ENDIF\r
+ IF (I .LT. N) THEN\r
+ DUMMY = DU1(I)\r
+ DU1(I) = (DU1(I)-DUMMY2*DU1(I-1))/DM(I)\r
+ DUMMY1 = DUMMY2\r
+ ENDIF\r
+ IF (I .LT. N-1) THEN\r
+ DUMMY2 = DU2(I)\r
+ DU2(I) = DU2(I)/DM(I)\r
+ ENDIF\r
+ 20 CONTINUE\r
+ MARK = 1\r
+ RETURN\r
+ END\r
+C\r
+C\r
+C[BA*)\r
+C[LE*)\r
+ SUBROUTINE FDISYS (N,DM,DU1,DU2,RS,X)\r
+C[IX{FDISYS}*)\r
+C\r
+C*****************************************************************\r
+C *\r
+C Solving a linear system of equations *\r
+C A * X = RS *\r
+C for a five-diagonal, symmetric and strongly nonsingular *\r
+C matrix A. *\r
+C[BE*)\r
+C Before this its Cholesky must factors have been calculated by *\r
+C SUBROUTINE FDISYP. Here the factors of A are used as input *\r
+C arrays and they are stored in the three N-vectors DM, DU1 *\r
+C and DU2. *\r
+C *\r
+C *\r
+C INPUT PARAMETER: *\r
+C ================ *\r
+C N : number of equations, N > 3 *\r
+C DM : N-vector DM(1:N); diagonal matrix D *\r
+C DU1 : N-vector DM(1:N); ) co-diagonals of the upper *\r
+C DU2 : N-vector DM(1:N); ) triangular matrix R *\r
+C RS : N-vector DM(1:N); the right hand side *\r
+C *\r
+C *\r
+C OUTPUT PARAMETER: *\r
+C ================= *\r
+C X : N-vector X(1:N) containing the solution vector *\r
+C *\r
+C----------------------------------------------------------------*\r
+C *\r
+C subroutines required: none *\r
+C *\r
+C*****************************************************************\r
+C *\r
+C author : Gisela Engeln-Muellges *\r
+C date : 29.04.1988 *\r
+C source : FORTRAN 77 *\r
+C *\r
+C[BA*)\r
+C*****************************************************************\r
+C[BE*)\r
+C\r
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)\r
+ DOUBLE PRECISION DM(1:N),DU1(1:N),DU2(1:N),RS(1:N),X(1:N)\r
+C\r
+C updating\r
+C\r
+ DUMMY1 = RS(1)\r
+ RS(1) = DUMMY1/DM(1)\r
+ DUMMY2 = RS(2)-DU1(1)*DUMMY1\r
+ RS(2) = DUMMY2/DM(2)\r
+ DO 10 I=3,N,1\r
+ DUMMY1 = RS(I)-DU1(I-1)*DUMMY2-DU2(I-2)*DUMMY1\r
+ RS(I) = DUMMY1/DM(I)\r
+ DUMMY3 = DUMMY2\r
+ DUMMY2 = DUMMY1\r
+ DUMMY1 = DUMMY3\r
+ 10 CONTINUE\r
+C\r
+C backsubstitution\r
+C\r
+ X(N) = RS(N)\r
+ X(N-1) = RS(N-1)-DU1(N-1)*X(N)\r
+ DO 20 I=N-2,1,-1\r
+ X(I) = RS(I)-DU1(I)*X(I+1)-DU2(I)*X(I+2)\r
+ 20 CONTINUE\r
+ RETURN\r
+ END\r
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+ 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
--- /dev/null
+#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
--- /dev/null
+ 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
+
+
+
+
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+C[KA{F 0}{Auxiliary Library}{Auxiliary Library}*)\r
+ INTEGER FUNCTION MACHPD(X)\r
+C[IX{MACHPD}*)\r
+ DOUBLE PRECISION X\r
+ MACHPD=0\r
+ IF (1.0D0 .LT. X) MACHPD=1\r
+ RETURN\r
+ END\r
--- /dev/null
+ 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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+#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
--- /dev/null
+ 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
--- /dev/null
+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
--- /dev/null
+ subroutine optsave (ncycle,f,xx)
+ implicit none
+ integer ncycle
+ double precision f
+ double precision xx(*)
+ return
+ end
--- /dev/null
+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
--- /dev/null
+ 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
+
+
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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)
--- /dev/null
+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
--- /dev/null
+C Change 12/1/95 - common block CONTACTS1 included.
+ integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont
+ double precision facont,gacont
+ common /contacts/ ncont,ncont_ref,icont(2,maxcont),
+ & icont_ref(2,maxcont)
+ common /contacts1/ facont(maxconts,maxres),
+ & gacont(3,maxconts,maxres),
+ & num_cont(maxres),jcont(maxconts,maxres)
+C 12/26/95 - H-bonding contacts
+ 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 Interactions of pseudo-dipoles generated by loc-el interactions.
+ double precision dip,dipderg,dipderx
+ common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres),
+ & dipderx(3,5,4,maxconts,maxres)
+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/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres),
+ & gmu(2,maxres),gUb2(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),Ctobr(2,maxres),
+ & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(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
+ 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),DtUg2EUgder(2,2,2,maxres),
+ & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres)
+ double precision costab,sintab,costab2,sintab2
+ common /rotat_old/ costab(maxres),sintab(maxres),
+ & costab2(maxres),sintab2(maxres),muder(2,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
+ 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
--- /dev/null
+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)
--- /dev/null
+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
--- /dev/null
+ subroutine readpdb
+C Read the PDB file and convert the peptide geometry into virtual-chain
+C geometry.
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.LOCAL'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.NAMES'
+ include 'COMMON.CONTROL'
+ include 'COMMON.DISTFIT'
+ include 'COMMON.SETUP'
+ character*3 seq,atom,res
+ character*80 card
+ dimension sccor(3,20)
+ integer rescode
+ ibeg=1
+ lsecondary=.false.
+ nhfrag=0
+ nbfrag=0
+ do
+ read (ipdbin,'(a80)',end=10) card
+ if (card(:5).eq.'HELIX') then
+ nhfrag=nhfrag+1
+ lsecondary=.true.
+ read(card(22:25),*) hfrag(1,nhfrag)
+ read(card(34:37),*) hfrag(2,nhfrag)
+ endif
+ if (card(:5).eq.'SHEET') then
+ nbfrag=nbfrag+1
+ lsecondary=.true.
+ read(card(24:26),*) bfrag(1,nbfrag)
+ read(card(35:37),*) bfrag(2,nbfrag)
+crc----------------------------------------
+crc to be corrected !!!
+ bfrag(3,nbfrag)=bfrag(1,nbfrag)
+ bfrag(4,nbfrag)=bfrag(2,nbfrag)
+crc----------------------------------------
+ endif
+ if (card(:3).eq.'END') then
+ goto 10
+ else if (card(:3).eq.'TER') then
+C End current chain
+ ires_old=ires+1
+ itype(ires_old)=21
+ ibeg=2
+c write (iout,*) "Chain ended",ires,ishift,ires_old
+ if (unres_pdb) then
+ do j=1,3
+ dc(j,ires)=sccor(j,iii)
+ enddo
+ else
+ call sccenter(ires,iii,sccor)
+ endif
+ endif
+C Fish out the ATOM cards.
+ if (index(card(1:4),'ATOM').gt.0) then
+ read (card(14:16),'(a3)') atom
+ if (atom.eq.'CA' .or. atom.eq.'CH3') then
+C Calculate the CM of the preceding residue.
+ if (ibeg.eq.0) then
+ if (unres_pdb) then
+ do j=1,3
+ dc(j,ires+nres)=sccor(j,iii)
+ enddo
+ else
+ call sccenter(ires,iii,sccor)
+ endif
+ endif
+C Start new residue.
+c write (iout,'(a80)') card
+ read (card(24:26),*) ires
+ read (card(18:20),'(a3)') res
+ if (ibeg.eq.1) then
+ ishift=ires-1
+ if (res.ne.'GLY' .and. res.ne. 'ACE') then
+ ishift=ishift-1
+ itype(1)=21
+ endif
+c write (iout,*) "ires",ires," ibeg",ibeg," ishift",ishift
+ ibeg=0
+ else if (ibeg.eq.2) then
+c Start a new chain
+ ishift=-ires_old+ires-1
+c write (iout,*) "New chain started",ires,ishift
+ ibeg=0
+ endif
+ ires=ires-ishift
+c write (2,*) "ires",ires," ishift",ishift
+ if (res.eq.'ACE') then
+ ity=10
+ else
+ itype(ires)=rescode(ires,res,0)
+ endif
+ read(card(31:54),'(3f8.3)') (c(j,ires),j=1,3)
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(2i3,2x,a,3f8.3)')
+ & ires,itype(ires),res,(c(j,ires),j=1,3)
+ iii=1
+ do j=1,3
+ sccor(j,iii)=c(j,ires)
+ enddo
+ else if (atom.ne.'O '.and.atom(1:1).ne.'H' .and.
+ & atom.ne.'N ' .and. atom.ne.'C ') then
+ iii=iii+1
+ read(card(31:54),'(3f8.3)') (sccor(j,iii),j=1,3)
+ endif
+ endif
+ enddo
+ 10 if(me.eq.king.or..not.out1file)
+ & write (iout,'(a,i5)') ' Nres: ',ires
+C Calculate dummy residue coordinates inside the "chain" of a multichain
+C system
+ nres=ires
+ do i=2,nres-1
+c write (iout,*) i,itype(i)
+ if (itype(i).eq.21) then
+c write (iout,*) "dummy",i,itype(i)
+ do j=1,3
+ c(j,i)=((c(j,i-1)+c(j,i+1))/2+2*c(j,i-1)-c(j,i-2))/2
+c c(j,i)=(c(j,i-1)+c(j,i+1))/2
+ dc(j,i)=c(j,i)
+ enddo
+ endif
+ enddo
+C Calculate the CM of the last side chain.
+ if (unres_pdb) then
+ do j=1,3
+ dc(j,ires)=sccor(j,iii)
+ enddo
+ else
+ call sccenter(ires,iii,sccor)
+ endif
+ nsup=nres
+ nstart_sup=1
+ if (itype(nres).ne.10) then
+ nres=nres+1
+ itype(nres)=21
+ if (unres_pdb) then
+ c(1,nres)=c(1,nres-1)+3.8d0
+ c(2,nres)=c(2,nres-1)
+ c(3,nres)=c(3,nres-1)
+ else
+ do j=1,3
+ dcj=c(j,nres-2)-c(j,nres-3)
+ c(j,nres)=c(j,nres-1)+dcj
+ c(j,2*nres)=c(j,nres)
+ enddo
+ endif
+ endif
+ do i=2,nres-1
+ do j=1,3
+ c(j,i+nres)=dc(j,i)
+ enddo
+ enddo
+ do j=1,3
+ c(j,nres+1)=c(j,1)
+ c(j,2*nres)=c(j,nres)
+ enddo
+ if (itype(1).eq.21) then
+ nsup=nsup-1
+ nstart_sup=2
+ if (unres_pdb) then
+ c(1,1)=c(1,2)-3.8d0
+ c(2,1)=c(2,2)
+ c(3,1)=c(3,2)
+ else
+ do j=1,3
+ dcj=c(j,4)-c(j,3)
+ c(j,1)=c(j,2)-dcj
+ c(j,nres+1)=c(j,1)
+ enddo
+ endif
+ endif
+C Calculate internal coordinates.
+ if(me.eq.king.or..not.out1file)then
+ do ires=1,nres
+ write (iout,'(2i3,2x,a,3f8.3,5x,3f8.3)')
+ & ires,itype(ires),restyp(itype(ires)),(c(j,ires),j=1,3),
+ & (c(j,nres+ires),j=1,3)
+ enddo
+ endif
+ call int_from_cart(.true.,.false.)
+ call sc_loc_geom(.true.)
+ do i=1,nres
+ thetaref(i)=theta(i)
+ phiref(i)=phi(i)
+ enddo
+ do i=1,nres-1
+ do j=1,3
+ dc(j,i)=c(j,i+1)-c(j,i)
+ dc_norm(j,i)=dc(j,i)*vbld_inv(i+1)
+ enddo
+ enddo
+ do i=2,nres-1
+ do j=1,3
+ dc(j,i+nres)=c(j,i+nres)-c(j,i)
+ dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres)
+ enddo
+c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3),
+c & vbld_inv(i+nres)
+ enddo
+c call chainbuild
+C Copy the coordinates to reference coordinates
+C Splits to single chain if occurs
+ kkk=1
+ lll=0
+ cou=1
+ do i=1,2*nres
+ lll=lll+1
+cc write (iout,*) "spraw lancuchy",(c(j,i),j=1,3)
+ if ((itype(i-1).eq.21)) then
+ chain_length=lll-1
+ kkk=kkk+1
+c write (iout,*) "spraw lancuchy",(c(j,i),j=1,3)
+ lll=1
+ endif
+ do j=1,3
+ cref(j,i,cou)=c(j,i)
+ if (i.le.nres) then
+ chain_rep(j,lll,kkk)=c(j,i)
+ chain_rep(j,lll+nres,kkk)=c(j,i+nres)
+ endif
+ enddo
+ enddo
+c diagnostic
+cc write (iout,*) "spraw lancuchy",chain_length,symetr
+cc do i=1,symetr
+cc do kkk=1,chain_length
+cc write (iout,*) itype(kkk),(chain_rep(j,kkk,i), j=1,3)
+cc enddo
+cc enddo
+c enddiagnostic
+C makes copy of chains
+c write (iout,*) "symetr", symetr
+
+ if (symetr.gt.1) then
+ call permut(symetr)
+ nperm=1
+ do i=1,symetr
+ nperm=nperm*i
+ enddo
+ do i=1,nperm
+ write(iout,*) (tabperm(i,kkk),kkk=1,4)
+ enddo
+ do i=1,nperm
+ do kkk=1,symetr
+ icha=tabperm(i,kkk)
+ write (iout,*) i,icha
+ do lll=1,chain_length
+ do j=1,3
+ cref(j,lll,i)=chain_rep(j,lll,icha)
+ cref(j,lll+nres,i)=chain_rep(j,lll+nres,icha)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+C-koniec robienia kopii
+c diag
+c do kkk=1,6
+c do lll=1,nres
+c write (iout,*) itype(lll),(cref(j,lll,kkk),j=1,3)
+c enddo
+c enddo
+c enddiag
+ do j=1,nbfrag
+ do i=1,4
+ bfrag(i,j)=bfrag(i,j)-ishift
+ enddo
+ enddo
+
+ do j=1,nhfrag
+ do i=1,2
+ hfrag(i,j)=hfrag(i,j)-ishift
+ enddo
+ enddo
+
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine int_from_cart(lside,lprn)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.LOCAL'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.NAMES'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SETUP'
+ character*3 seq,atom,res
+ character*80 card
+ dimension sccor(3,20)
+ integer rescode
+ logical lside,lprn
+#ifdef MPI
+ if(me.eq.king.or..not.out1file)then
+#endif
+ if (lprn) then
+ write (iout,'(/a)')
+ & 'Internal coordinates calculated from crystal structure.'
+ if (lside) then
+ write (iout,'(8a)') ' Res ',' dvb',' Theta',
+ & ' Phi',' Dsc_id',' Dsc',' Alpha',
+ & ' Omega'
+ else
+ write (iout,'(4a)') ' Res ',' dvb',' Theta',
+ & ' Phi'
+ endif
+ endif
+#ifdef MPI
+ endif
+#endif
+ do i=1,nres-1
+ iti=itype(i)
+ if (iti.ne.21 .and. itype(i+1).ne.21 .and.
+ & (dist(i,i+1).lt.2.0D0 .or. dist(i,i+1).gt.5.0D0)) then
+ write (iout,'(a,i4)') 'Bad Cartesians for residue',i
+ctest stop
+ endif
+ vbld(i+1)=dist(i,i+1)
+ vbld_inv(i+1)=1.0d0/vbld(i+1)
+ if (i.gt.1) theta(i+1)=alpha(i-1,i,i+1)
+ if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1)
+ enddo
+c if (unres_pdb) then
+c if (itype(1).eq.21) then
+c theta(3)=90.0d0*deg2rad
+c phi(4)=180.0d0*deg2rad
+c vbld(2)=3.8d0
+c vbld_inv(2)=1.0d0/vbld(2)
+c endif
+c if (itype(nres).eq.21) then
+c theta(nres)=90.0d0*deg2rad
+c phi(nres)=180.0d0*deg2rad
+c vbld(nres)=3.8d0
+c vbld_inv(nres)=1.0d0/vbld(2)
+c endif
+c endif
+ if (lside) then
+ do i=2,nres-1
+ do j=1,3
+ c(j,maxres2)=0.5D0*(2*c(j,i)+(c(j,i-1)-c(j,i))*vbld_inv(i)
+ & +(c(j,i+1)-c(j,i))*vbld_inv(i+1))
+ enddo
+ iti=itype(i)
+ di=dist(i,nres+i)
+ vbld(i+nres)=di
+ if (itype(i).ne.10) then
+ vbld_inv(i+nres)=1.0d0/di
+ else
+ vbld_inv(i+nres)=0.0d0
+ endif
+ if (iti.ne.10) then
+ alph(i)=alpha(nres+i,i,maxres2)
+ omeg(i)=beta(nres+i,i,maxres2,i+1)
+ endif
+ if(me.eq.king.or..not.out1file)then
+ if (lprn)
+ & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,vbld(i),
+ & rad2deg*theta(i),rad2deg*phi(i),dsc(iti),vbld(nres+i),
+ & rad2deg*alph(i),rad2deg*omeg(i)
+ endif
+ enddo
+ else if (lprn) then
+ do i=2,nres
+ iti=itype(i)
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(a3,i4,7f10.3)') restyp(iti),i,dist(i,i-1),
+ & rad2deg*theta(i),rad2deg*phi(i)
+ enddo
+ endif
+ return
+ end
+c-------------------------------------------------------------------------------
+ subroutine sc_loc_geom(lprn)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include "mpif.h"
+#endif
+ include 'COMMON.LOCAL'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.GEO'
+ include 'COMMON.NAMES'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SETUP'
+ double precision x_prime(3),y_prime(3),z_prime(3)
+ logical lprn
+ do i=1,nres-1
+ do j=1,3
+ dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i))
+ enddo
+ enddo
+ do i=2,nres-1
+ if (itype(i).ne.10 .and. itype(i).ne.21) then
+ do j=1,3
+ dc_norm(j,i+nres)=vbld_inv(i+nres)*(c(j,i+nres)-c(j,i))
+ enddo
+ else
+ do j=1,3
+ dc_norm(j,i+nres)=0.0d0
+ enddo
+ endif
+ enddo
+ do i=2,nres-1
+ costtab(i+1) =dcos(theta(i+1))
+ sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
+ cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
+ sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
+ cosfac2=0.5d0/(1.0d0+costtab(i+1))
+ cosfac=dsqrt(cosfac2)
+ sinfac2=0.5d0/(1.0d0-costtab(i+1))
+ sinfac=dsqrt(sinfac2)
+ it=itype(i)
+ if (it.ne.10 .and. itype(i).ne.21) then
+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
+ 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
+ call vecpr(x_prime,y_prime,z_prime)
+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
+
+ xxref(i)=xx
+ yyref(i)=yy
+ zzref(i)=zz
+ else
+ xxref(i)=0.0d0
+ yyref(i)=0.0d0
+ zzref(i)=0.0d0
+ endif
+ enddo
+ if (lprn) then
+ do i=2,nres
+ iti=itype(i)
+#ifdef MPI
+ if(me.eq.king.or..not.out1file)
+ & write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i),
+ & yyref(i),zzref(i)
+#else
+ write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i),yyref(i),
+ & zzref(i)
+#endif
+ enddo
+ endif
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine sccenter(ires,nscat,sccor)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ dimension sccor(3,20)
+ do j=1,3
+ sccmj=0.0D0
+ do i=1,nscat
+ sccmj=sccmj+sccor(j,i)
+ enddo
+ dc(j,ires)=sccmj/nscat
+ enddo
+ return
+ end
+c---------------------------------------------------------------------------
+ subroutine bond_regular
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.LOCAL'
+ include 'COMMON.CALC'
+ include 'COMMON.INTERACT'
+ include 'COMMON.CHAIN'
+ do i=1,nres-1
+ vbld(i+1)=vbl
+ vbld_inv(i+1)=1.0d0/vbld(i+1)
+ vbld(i+1+nres)=dsc(itype(i+1))
+ vbld_inv(i+1+nres)=dsc_inv(itype(i+1))
+c print *,vbld(i+1),vbld(i+1+nres)
+ enddo
+ return
+ end
+
projects / unres.git / commitdiff