From: Cezary Czaplewski Date: Wed, 28 Mar 2012 21:36:06 +0000 (+0200) Subject: removal of CSA from MD version of code X-Git-Tag: v.3.1~13 X-Git-Url: http://mmka.chem.univ.gda.pl/gitweb/?p=unres.git;a=commitdiff_plain;h=a3ef63eda7d771657cc2df1d275e0a03a5cc1966 removal of CSA from MD version of code backup *~ files deleted other minor changes in the code --- diff --git a/source/unres/src_MD/COMMON.BANK b/source/unres/src_MD/COMMON.BANK deleted file mode 100644 index 5b0fb34..0000000 --- a/source/unres/src_MD/COMMON.BANK +++ /dev/null @@ -1,29 +0,0 @@ - real*8 dihang,etot,bvar,bene,rene,rvar,avedif,difmin, - & ebmin,ebmax,ebmaxt,cutdif,dij,dihang_in - integer ibank,is,jbank,ibmin,ibmax,nbank,nconf,iuse,nstep,icycle, - & iseed,ntbank,ntbankm,iref,nconf_in,indb,ilastnstep, - & bvar_nss,bvar_ss,bvar_ns,bvar_s, - & nss_in,iss_in,jss_in,nadd - common/varin/dihang_in(mxang,maxres,mxch,mxio),nss_in(mxio), - & iss_in(maxss,mxio),jss_in(maxss,mxio) - common/minvar/dihang(mxang,maxres,mxch,mxio),etot(mxio),rmsn(mxio) - & ,pncn(mxio),nss_out(mxio), - & iss_out(maxss,mxio),jss_out(maxss,mxio) - common/bank/ - * bvar(mxang,maxres,mxch,mxio),bene(mxio),rene(mxio), - * brmsn(mxio),rrmsn(mxio), - * bpncn(mxio),rpncn(mxio), - * rvar(mxang,maxres,mxch,mxio),ibank(mxio),is(mxio), - * avedif,difmin,ebmin,ebmax,ebmaxt,dele,difcut,cutdif, - * rmscut,pnccut, - * jbank(mxio),dij(mxio,mxio),ibmin,ibmax, - * nbank,ntbank,ntbankm,nconf,iuse,nstep,icycle,iseed,iref, - * nconf_in,ilastnstep,nadd - common/bank_disulfid/ bvar_nss(mxio),bvar_ss(2,maxss,mxio), - * bvar_ns(mxio),bvar_s(maxss,mxio) - common/mvstat/ movenx(mxio),movernx(mxio), - & nstatnx(0:mxmv,3),nstatnx_tot(0:mxmv,3),indb(mxio,9), - & parent(3,mxio) - common/send2/isend2(mxio),iff_in(maxres,mxio2), - & dihang_in2(mxang,maxres,mxch,mxio2), - & idata(5,mxio) diff --git a/source/unres/src_MD/COMMON.CSA b/source/unres/src_MD/COMMON.CSA deleted file mode 100644 index 273a268..0000000 --- a/source/unres/src_MD/COMMON.CSA +++ /dev/null @@ -1,11 +0,0 @@ - integer ngroup,igroup,ntotgr,numch,irestart,ndiff - double precision diffcut - common/alphaa/ ngroup(mxgr),igroup(3,mxang,mxgr),ntotgr,numch - common/csa_input/cut1,cut2,eglob_csa,estop,jstart,jend, - & n1,n2,n3,n4,n5,n6,n7,n8,n9,n14,n15,n16,n17,n18,n0, - & is1,is2,nseed,ntotal,icmax,nstmax,irestart,nran0,nran1,irr, - & nglob_csa,nmin_csa,ndiff - logical ldih_bias - common/dih_control/rdih_bias,ldih_bias - common/diffcuta/ diffcut - diff --git a/source/unres/src_MD/COMMON.DERIV~ b/source/unres/src_MD/COMMON.DERIV~ deleted file mode 100644 index 524d72a..0000000 --- a/source/unres/src_MD/COMMON.DERIV~ +++ /dev/null @@ -1,35 +0,0 @@ - double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gelc_long, - & gvdwpp,gel_loc,gel_loc_long,gvdwc_scpp, - & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gloc_x,dtheta,dphi,dalpha, - & domega,gscloc,gsclocx,gradcorr,gradcorr_long,gradcorr5_long, - & gradcorr6_long,gcorr6_turn_long - integer nfl,icg - common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), - & gradx(3,maxres,2),gradc(3,maxres,2),gvdwx(3,maxres), - & gvdwc(3,maxres),gelc(3,maxres),gelc_long(3,maxres), - & gvdwpp(3,maxres),gvdwc_scpp(3,maxres), - & gradx_scp(3,maxres),gvdwc_scp(3,maxres),ghpbx(3,maxres), - & ghpbc(3,maxres),gloc(maxvar,2),gradcorr(3,maxres), - & gradcorr_long(3,maxres),gradcorr5_long(3,maxres), - & gradcorr6_long(3,maxres),gcorr6_turn_long(3,maxres), - & gradxorr(3,maxres),gradcorr5(3,maxres),gradcorr6(3,maxres), - & gloc_x(maxvar,2),gel_loc(3,maxres),gel_loc_long(3,maxres), - & gcorr3_turn(3,maxres), - & gcorr4_turn(3,maxres),gcorr6_turn(3,maxres),gradb(3,maxres), - & gradbx(3,maxres),gel_loc_loc(maxvar),gel_loc_turn3(maxvar), - & gel_loc_turn4(maxvar),gel_loc_turn6(maxvar),gcorr_loc(maxvar), - & g_corr5_loc(maxvar),g_corr6_loc(maxvar),gsccorc(3,maxres), - & gsccorx(3,maxres),gsccor_loc(maxres),dtheta(3,2,maxres), - & gscloc(3,maxres),gsclocx(3,maxres), - & dphi(3,3,maxres),dalpha(3,3,maxres),domega(3,3,maxres),nfl,icg - double precision derx,derx_turn - common /deriv_loc/ derx(3,5,2),derx_turn(3,5,2) - double precision dXX_C1tab(3,maxres),dYY_C1tab(3,maxres), - & dZZ_C1tab(3,maxres),dXX_Ctab(3,maxres),dYY_Ctab(3,maxres), - & dZZ_Ctab(3,maxres),dXX_XYZtab(3,maxres),dYY_XYZtab(3,maxres), - & dZZ_XYZtab(3,maxres) - common /deriv_scloc/ dXX_C1tab,dYY_C1tab,dZZ_C1tab,dXX_Ctab, - & dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,dZZ_XYZtab - integer igrad_start,igrad_end,jgrad_start(maxres), - & jgrad_end(maxres) - common /mpgrad/ igrad_start,igrad_end,jgrad_start,jgrad_end diff --git a/source/unres/src_MD/COMMON.DISTFIT b/source/unres/src_MD/COMMON.DISTFIT index 044225b..683228a 100644 --- a/source/unres/src_MD/COMMON.DISTFIT +++ b/source/unres/src_MD/COMMON.DISTFIT @@ -4,9 +4,9 @@ c parameter (maxres22=maxres*(maxres+1)/2) 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) +csa COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3), +csa 1 lvar_frag(mxio,3),svar_frag(mxio,3), +csa 2 avar_frag(mxio,5) COMMON /WAGI/ w(MAXRES22),d0(MAXRES22) COMMON /POCHODNE/ NX,NY,DRDG(MAXRES22,MAXRES),DD(MAXRES22), 1 H(MAXRES,MAXRES),XX(MAXRES) diff --git a/source/unres/src_MD/COMMON.FFIELD~ b/source/unres/src_MD/COMMON.FFIELD~ deleted file mode 100644 index d7d8cde..0000000 --- a/source/unres/src_MD/COMMON.FFIELD~ +++ /dev/null @@ -1,25 +0,0 @@ -C----------------------------------------------------------------------- -C The following COMMON block selects the type of the force field used in -C calculations and defines weights of various energy terms. -C 12/1/95 wcorr added -C----------------------------------------------------------------------- - integer n_ene_comp,rescale_mode - common /ffield/ wsc,wscp,welec,wbond,wstrain,wtor,wtor_d,wang, - & wscloc,wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4, - & wturn6,wvdwpp,weights(n_ene),temp0, - & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp, - & rescale_mode - common /potentials/ potname(5) - character*3 potname -C----------------------------------------------------------------------- -C wlong,welec,wtor,wang,wscloc are the weight of the energy terms -C corresponding to side-chain, electrostatic, torsional, valence-angle, -C and local side-chain terms. -C -C IPOT determines which SC...SC interaction potential will be used: -C 1 - LJ: 2n-n Lennard-Jones -C 2 - LJK: 2n-n Kihara type (shifted Lennard-Jones) -C 3 - BP; Berne-Pechukas (angular dependence) -C 4 - GB; Gay-Berne (angular dependence) -C 5 - GBV; Gay-Berne-Vorobjev; angularly-dependent Kihara potential -C------------------------------------------------------------------------ diff --git a/source/unres/src_MD/COMMON.INTERACT~ b/source/unres/src_MD/COMMON.INTERACT~ deleted file mode 100644 index f06d76f..0000000 --- a/source/unres/src_MD/COMMON.INTERACT~ +++ /dev/null @@ -1,29 +0,0 @@ - double precision aa,bb,augm,aad,bad,app,bpp,ale6,ael3,ael6 - integer expon,expon2 - integer nnt,nct,nint_gr,istart,iend,itype,itel,itypro, - & ielstart,ielend,ielstart_vdw,ielend_vdw,nscp_gr,iscpstart, - & iscpend,iatsc_s,iatsc_e, - & iatel_s,iatel_e,iatscp_s,iatscp_e,iatel_s_vdw,iatel_e_vdw, - & ispp,iscp - common /interact/aa(ntyp,ntyp),bb(ntyp,ntyp),augm(ntyp,ntyp), - & aad(ntyp,2),bad(ntyp,2),app(2,2),bpp(2,2),ael6(2,2),ael3(2,2), - & expon,expon2,nnt,nct,nint_gr(maxres),istart(maxres,maxint_gr), - & iend(maxres,maxint_gr),itype(maxres),itel(maxres),itypro, - & ielstart(maxres),ielend(maxres),ielstart_vdw(maxres), - & ielend_vdw(maxres),nscp_gr(maxres), - & iscpstart(maxres,maxint_gr),iscpend(maxres,maxint_gr), - & iatsc_s,iatsc_e,iatel_s,iatel_e,iatel_s_vdw,iatel_e_vdw, - & iatscp_s,iatscp_e,ispp,iscp -C 12/1/95 Array EPS included in the COMMON block. - double precision eps,sigma,sigmaii,rs0,chi,chip,alp,sigma0,sigii, - & rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp - common /body/eps(ntyp,ntyp),sigma(0:ntyp1,0:ntyp1), - & sigmaii(ntyp,ntyp), - & rs0(ntyp,ntyp),chi(ntyp,ntyp),chip(ntyp),alp(ntyp),sigma0(ntyp), - & sigii(ntyp),rr0(ntyp),r0(ntyp,ntyp),r0e(ntyp,ntyp),r0d(ntyp,2), - & rpp(2,2),epp(2,2),elpp6(2,2),elpp3(2,2),eps_scp(20,2),rscp(20,2) -c 12/5/03 modified 09/18/03 Bond stretching parameters. - double precision vbldp0,vbldsc0,akp,aksc,abond0 - integer nbondterm - common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp, - & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp),nbondterm(ntyp) diff --git a/source/unres/src_MD/COMMON.IOUNITS b/source/unres/src_MD/COMMON.IOUNITS index a9ace0b..49b6db3 100644 --- a/source/unres/src_MD/COMMON.IOUNITS +++ b/source/unres/src_MD/COMMON.IOUNITS @@ -11,11 +11,11 @@ C General I/O units & files integer inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,irotam, & itorp,itordp,ifourier,ielep,isidep,iscpp,icbase,istat, & ientin,ientout,izs1,isecpred,ibond,irest2,iifrag,icart, - & irest1,isccor + & irest1,isccor,ithep_pdb,irotam_pdb common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep, & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,icbase, & istat,ientin,ientout,izs1,isecpred,ibond,irest2,iifrag, - & icart,irest1,isccor + & icart,irest1,isccor,ithep_pdb,irotam_pdb character*256 outname,intname,pdbname,mol2name,statname,intinname, & entname,prefix,secpred,rest2name,qname,cartname,tmpdir, & mremd_rst_name,curdir,pref_orig @@ -38,9 +38,11 @@ C CSA I/O units & files & icsa_bank_reminimized,icsa_native_int,icsa_in,icsa_pdb C Parameter files character*256 bondname,thetname,rotname,torname,tordname, - & fouriername,elename,sidename,scpname,sccorname,patname + & fouriername,elename,sidename,scpname,sccorname,patname, + & thetname_pdb,rotname_pdb common /parfiles/ bondname,thetname,rotname,torname,tordname, - & fouriername,elename,sidename,scpname,sccorname,patname + & fouriername,elename,sidename,scpname,sccorname,patname, + & thetname_pdb,rotname_pdb character*3 pot C----------------------------------------------------------------------- C INP - main input file diff --git a/source/unres/src_MD/COMMON.LANGEVIN.lang0_ b/source/unres/src_MD/COMMON.LANGEVIN.lang0_ deleted file mode 100644 index 26eb500..0000000 --- a/source/unres/src_MD/COMMON.LANGEVIN.lang0_ +++ /dev/null @@ -1,11 +0,0 @@ - double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), - & fricmat(MAXRES6,MAXRES6),fric_work(MAXRES6), - & stoch_work(MAXRES6), - & fricgam(MAXRES6),fricvec(MAXRES6,MAXRES6) - logical flag_stoch(0:maxflag_stoch) - common /langforc/ friction,stochforc, - & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1, - & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat, - & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1, - & vrand0_mat2,flag_stoch - common /langmat/ mt1,mt2,mt3 diff --git a/source/unres/src_MD/COMMON.MD b/source/unres/src_MD/COMMON.MD index 22dba7c..6ce6a3f 100644 --- a/source/unres/src_MD/COMMON.MD +++ b/source/unres/src_MD/COMMON.MD @@ -66,9 +66,12 @@ & ng_start(0:MaxProcs-1),ng_counts(0:MaxProcs-1), & nginv_start(0:MaxProcs),nginv_counts(0:MaxProcs-1) double precision pi_np,pistar,s_np,s12_np,Q_np,E_old,H0,E_long, - & sold_np,d_t_half,Csplit + & sold_np,d_t_half,Csplit,hhh common /nosepoincare/ pi_np,pistar,s_np,s12_np,Q_np,E_old,H0, - & E_long,sold_np,d_t_half(3,0:MAXRES2),Csplit + & E_long,sold_np,d_t_half(3,0:MAXRES2),Csplit,hhh common /nosehoover/ glogs(maxmnh),qmass(maxmnh), & vlogs(maxmnh),xlogs(maxmnh), & nresn,nyosh,nnos,xiresp + integer hmc,hmc_acc + double precision dc_hmc,hmc_etot,totThmc + common /hmc_md/ dc_hmc(3,0:maxres2),hmc_etot,hmc,totThmc,hmc_acc diff --git a/source/unres/src_MD/COMMON.MD~ b/source/unres/src_MD/COMMON.MD~ deleted file mode 100644 index b0d62c9..0000000 --- a/source/unres/src_MD/COMMON.MD~ +++ /dev/null @@ -1,74 +0,0 @@ - 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 - 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) - double precision v_ini,d_time,d_time0,t_bath,tau_bath, - & EK,potE,potEcomp(0:n_ene+4),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), - & 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 - integer nresn,nyosh,nnos,hremd - double precision glogs,qmass,vlogs,xlogs - logical large,print_compon,tbf,rest,reset_moment,reset_vel, - & surfarea,rattle,usampl,mdpdb,RESPA,tnp,tnp1,tnh,xiresp - 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, - & wfrag_back,nfrag_back,ifrag_back - 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 - 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,tnp,tnp1,tnh,hremd - 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(ntyp),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) - double precision pi_np,pistar,s_np,s12_np,Q_np,E_old,H0,E_long, - & sold_np,d_t_half,Csplit - common /nosepoincare/ pi_np,pistar,s_np,s12_np,Q_np,E_old,H0, - & E_long,sold_np,d_t_half(3,0:MAXRES2),Csplit - common /nosehoover/ glogs(maxmnh),qmass(maxmnh), - & vlogs(maxmnh),xlogs(maxmnh), - & nresn,nyosh,nnos,xiresp diff --git a/source/unres/src_MD/COMMON.REMD~ b/source/unres/src_MD/COMMON.REMD~ deleted file mode 100644 index ea79752..0000000 --- a/source/unres/src_MD/COMMON.REMD~ +++ /dev/null @@ -1,35 +0,0 @@ - integer nrep,nstex,hremd - logical remd_tlist,remd_mlist,mremdsync,restart1file,traj1file - double precision retmin,retmax,remd_t(maxprocs) - double precision hweights(maxprocs/20,n_ene) - integer remd_m(maxprocs),i_sync_step - integer*2 i2rep(0:maxprocs),i2set(0:maxprocs) - integer*2 ifirst(maxprocs) - integer*2 nupa(0:maxprocs/4,0:maxprocs), - & ndowna(0:maxprocs/4,0:maxprocs) - real t_restart1(5,maxprocs) - integer iset_restart1(maxprocs) - common /remdcommon/ nrep,nstex,retmin,retmax,remd_t,remd_tlist, - & remd_mlist,remd_m,mremdsync,restart1file, - & traj1file,i_sync_step - common /hamilt_remd/ hweights,hremd - common /remdrestart/ i2rep,i2set,ifirst,nupa,ndowna,t_restart1, - & iset_restart1 - real totT_cache,EK_cache,potE_cache,t_bath_cache,Uconst_cache, - & qfrag_cache,qpair_cache,c_cache, - & ugamma_cache,utheta_cache - integer ntwx_cache,ii_write,max_cache_traj_use - common /traj1cache/ totT_cache(max_cache_traj), - & EK_cache(max_cache_traj), - & potE_cache(max_cache_traj), - & t_bath_cache(max_cache_traj), - & Uconst_cache(max_cache_traj), - & qfrag_cache(50,max_cache_traj), - & qpair_cache(100,max_cache_traj), - & ugamma_cache(maxfrag_back,max_cache_traj), - & utheta_cache(maxfrag_back,max_cache_traj), - & uscdiff_cache(maxfrag_back,max_cache_traj), - & c_cache(3,maxres2+2,max_cache_traj), - & iset_cache(max_cache_traj),ntwx_cache, - & ii_write,max_cache_traj_use - diff --git a/source/unres/src_MD/DIMENSIONS b/source/unres/src_MD/DIMENSIONS index e9c0e9b..224dade 100644 --- a/source/unres/src_MD/DIMENSIONS +++ b/source/unres/src_MD/DIMENSIONS @@ -106,18 +106,18 @@ C Maximum number of groups of angles C Maximum number of chains integer mxch parameter (mxch=1) -C Maximum number of generated conformations - integer mxio - parameter (mxio=2) -C Maximum number of n7 generated conformations - integer mxio2 - parameter (mxio2=2) -C Maximum number of moves (n1-n8) - integer mxmv - parameter (mxmv=18) -C Maximum number of seed - integer max_seed - parameter (max_seed=1) +csaC Maximum number of generated conformations +csa integer mxio +csa parameter (mxio=2) +csaC Maximum number of n7 generated conformations +csa integer mxio2 +csa parameter (mxio2=2) +csaC Maximum number of moves (n1-n8) +csa integer mxmv +csa parameter (mxmv=18) +csaC Maximum number of seed +csa integer max_seed +csa parameter (max_seed=1) C Maximum number of timesteps for which stochastic MD matrices can be stored integer maxflag_stoch parameter (maxflag_stoch=0) diff --git a/source/unres/src_MD/DIMENSIONS~ b/source/unres/src_MD/DIMENSIONS~ deleted file mode 100644 index c37025c..0000000 --- a/source/unres/src_MD/DIMENSIONS~ +++ /dev/null @@ -1,140 +0,0 @@ -******************************************************************************** -* Settings for the program of united-residue peptide simulation in real space * -* * -* ------- As of 6/23/01 ----------- * -* * -******************************************************************************** -C Max. number of processors. - integer maxprocs - parameter (maxprocs=2048) -C Max. number of fine-grain processors - integer max_fg_procs -c parameter (max_fg_procs=maxprocs) - parameter (max_fg_procs=512) -C Max. number of coarse-grain processors - integer max_cg_procs - parameter (max_cg_procs=maxprocs) -C Max. number of AA residues - integer maxres - parameter (maxres=800) -C Appr. max. number of interaction sites - integer maxres2,maxres6,mmaxres2 - parameter (maxres2=2*maxres,maxres6=6*maxres) - parameter (mmaxres2=(maxres2*(maxres2+1)/2)) -C Max. number of variables - integer maxvar - parameter (maxvar=6*maxres) -C Max. number of groups of interactions that a given SC is involved in - integer maxint_gr - parameter (maxint_gr=2) -C Max. number of derivatives of virtual-bond and side-chain vectors in theta -C or phi. - integer maxdim - parameter (maxdim=(maxres-1)*(maxres-2)/2) -C Max. number of SC contacts - integer maxcont - parameter (maxcont=12*maxres) -C Max. number of contacts per residue - integer maxconts - parameter (maxconts=maxres/4) -c parameter (maxconts=50) -C Number of AA types (at present only natural AA's will be handled - integer ntyp,ntyp1 - parameter (ntyp=20,ntyp1=ntyp+1) -C Max. number of types of dihedral angles & multiplicity of torsional barriers -C and the number of terms in double torsionals - integer maxtor,maxterm,maxlor,maxtermd_1,maxtermd_2 - parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) -C Max. number of residue types and parameters in expressions for -C virtual-bond angle bending potentials - integer maxthetyp,maxthetyp1,maxtheterm,maxtheterm2,maxtheterm3, - & maxsingle,maxdouble,mmaxtheterm - parameter (maxthetyp=3,maxthetyp1=maxthetyp+1,maxtheterm=20, - & maxtheterm2=6,maxtheterm3=4,maxsingle=6,maxdouble=4, - & mmaxtheterm=maxtheterm) -c Max number of torsional terms in SCCOR - integer maxterm_sccor - parameter (maxterm_sccor=3) -C Max. number of lobes in SC distribution - integer maxlob - parameter (maxlob=4) -C Max. number of S-S bridges - integer maxss - parameter (maxss=20) -C Max. number of dihedral angle constraints - integer maxdih_constr - parameter (maxdih_constr=maxres) -C Max. number of patterns in the pattern database - integer maxseq - parameter (maxseq=10) -C Max. number of residues in a peptide in the database - integer maxres_base - parameter (maxres_base=10) -C Max. number of threading attempts - integer maxthread - parameter (maxthread=20) -C Max. number of move types in MCM - integer maxmovetype - parameter (maxmovetype=4) -C Max. number of stored confs. in MC/MCM simulation - integer maxsave - parameter (maxsave=20) -C Max. number of energy intervals - integer max_ene - parameter (max_ene=10) -C Max. number of conformations in Master's cache array - integer max_cache - parameter (max_cache=10) -C Max. number of conformations in the pool - integer max_pool - parameter (max_pool=10) -C Number of energy components - integer n_ene,n_ene2 - parameter (n_ene=23,n_ene2=2*n_ene) -C Number of threads in deformation - integer max_thread,max_thread2 - parameter (max_thread=4,max_thread2=2*max_thread) -C Number of structures to compare at t=0 - integer max_threadss,max_threadss2 - parameter (max_threadss=8,max_threadss2=2*max_threadss) -C Maxmimum number of angles per residue - integer mxang - parameter (mxang=4) -C Maximum number of groups of angles - integer mxgr - parameter (mxgr=2*maxres) -C Maximum number of chains - integer mxch - parameter (mxch=1) -C Maximum number of generated conformations - integer mxio - parameter (mxio=2) -C Maximum number of n7 generated conformations - integer mxio2 - parameter (mxio2=2) -C Maximum number of moves (n1-n8) - integer mxmv - parameter (mxmv=18) -C Maximum number of seed - integer max_seed - parameter (max_seed=1) -C Maximum number of timesteps for which stochastic MD matrices can be stored - integer maxflag_stoch - parameter (maxflag_stoch=0) -C Maximum number of backbone fragments in restraining - integer maxfrag_back - parameter (maxfrag_back=4) -C Maximum number of SC local term fitting function coefficiants - integer maxsccoef - parameter (maxsccoef=65) -C Maximum number of terms in SC bond-stretching potential - integer maxbondterm - parameter (maxbondterm=3) -C Maximum number of conformation stored in cache on each CPU before sending -C to master; depends on nstex / ntwx ratio - integer max_cache_traj - parameter (max_cache_traj=10) -C Nose-Hoover chain - chain length and order of Yoshida algorithm - integer maxmnh,maxyosh - parameter(maxmnh=10,maxyosh=5) -C Hamiltonian dynamics \ No newline at end of file diff --git a/source/unres/src_MD/MD_A-MTS.F b/source/unres/src_MD/MD_A-MTS.F index 042fcc0..29e4fcb 100644 --- a/source/unres/src_MD/MD_A-MTS.F +++ b/source/unres/src_MD/MD_A-MTS.F @@ -592,13 +592,15 @@ c Backup the coordinates, velocities, and accelerations H=(HNose1-H0)*s_np cd write (iout,'(a,10f)') "hhh",EK,s_np,potE,pi_np,H0 cd & ,EK+potE+pi_np**2/(2*Q_np)+dimen3*0.001986d0*t_bath*log(s_np) - write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 +cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 + hhh=h endif if(tnh) then HNose1=Hnose_nh(EK,potE) H=HNose1-H0 - write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 + hhh=h +cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 endif if (large) then @@ -1104,14 +1106,16 @@ c Backup the coordinates, velocities, and accelerations H=(HNose1-H0)*s_np cd write (iout,'(a,10f)') "hhh",EK,s_np,potE,pi_np,H0 cd & ,EK+potE+pi_np**2/(2*Q_np)+dimen3*0.001986d0*t_bath*log(s_np) - write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 +cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 + hhh=h cd write (iout,'(a,3f)') "EE2 NP S, pi",totT, s_np, pi_np endif if(tnh) then HNose1=Hnose_nh(EK,potE) H=HNose1-H0 - write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 +cd write (iout,*) "HHH H=",H,abs(HNose1-H0)/H0 + hhh=h endif @@ -1888,6 +1892,17 @@ c Removing the velocity of the center of mass write (iout,*) 'H0= ',H0 endif + if (hmc.gt.0) then + hmc_acc=0 + hmc_etot=potE+EK + if(me.eq.king.or..not.out1file) + & write(iout,*) 'HMC',hmc_etot,potE,EK + do i=1,2*nres + do j=1,3 + dc_hmc(j,i)=dc(j,i) + enddo + enddo + endif call cartgrad call lagrangian @@ -2019,6 +2034,9 @@ C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array t_enegrad=t_enegrad+tcpu()-tt0 #endif endif + + + return end c----------------------------------------------------------- @@ -3379,3 +3397,61 @@ cd write(iout,'(a,4f)') 'mmm',EK,potE,HNose1,pi_np return end + + subroutine hmc_test(itime) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.MD' + include 'COMMON.CHAIN' + + hmc_acc=hmc_acc+1 + delta=-(potE+EK-hmc_etot)/(Rb*t_bath) + if (delta .lt. -50.0d0) then + delta=0.0d0 + else + delta=dexp(delta) + endif + xxx=ran_number(0.0d0,1.0d0) + + if (me.eq.king .or. .not. out1file) + & write(iout,'(a8,i5,6f10.4)') + & 'HMC',itime,potE+EK,potE,EK,hmc_etot,delta,xxx + + if (delta .le. xxx) then + do i=1,2*nres + do j=1,3 + dc(j,i)=dc_hmc(j,i) + enddo + enddo + itime=itime-hmc + totT=totThmc + else + if (me.eq.king .or. .not. out1file) + & write(iout,*) 'HMC accepting new' + totThmc=totT + do i=1,2*nres + do j=1,3 + dc_hmc(j,i)=dc(j,i) + enddo + enddo + endif + + call chainbuild_cart + call random_vel + do i=0,2*nres + do j=1,3 + d_t_old(j,i)=d_t(j,i) + enddo + enddo + call kinetic(EK) + kinetic_T=2.0d0/(dimen3*Rb)*EK + call etotal(potEcomp) + potE=potEcomp(0) + hmc_etot=potE+EK + if (me.eq.king .or. .not. out1file) + & write(iout,'(a8,i5,3f10.4)')'HMC new',itime,potE+EK,potE,EK + + + return + end diff --git a/source/unres/src_MD/MREMD.F b/source/unres/src_MD/MREMD.F index 2d184b6..9ddb9e9 100644 --- a/source/unres/src_MD/MREMD.F +++ b/source/unres/src_MD/MREMD.F @@ -479,6 +479,10 @@ c Variable time step algorithm. stop #endif endif + if(hmc.gt.0 .and. mod(itime,hmc).eq.0) then + call statout(itime) + call hmc_test(itime) + endif if(ntwe.ne.0) then if (mod(itime,ntwe).eq.0) call statout(itime) endif @@ -1403,6 +1407,8 @@ cd end & 'MD steps:',t_MD write (iout,'(/28(1h=),a25,27(1h=))') & ' End of MD calculation ' + if(hmc.gt.0) write (iout,*) 'HMC acceptance ratio', + & n_timestep*1.0d0/hmc/hmc_acc endif return end diff --git a/source/unres/src_MD/Makefile b/source/unres/src_MD/Makefile index d911d7a..696c70e 120000 --- a/source/unres/src_MD/Makefile +++ b/source/unres/src_MD/Makefile @@ -1 +1 @@ -Makefile_single_gfortran \ No newline at end of file +Makefile_ifort \ No newline at end of file diff --git a/source/unres/src_MD/TAU b/source/unres/src_MD/TAU deleted file mode 100644 index 231a93e..0000000 --- a/source/unres/src_MD/TAU +++ /dev/null @@ -1,6 +0,0 @@ -module load tau/tau-2.17 -#with preprocessor -setenv TAU_OPTIONS '-optPreProcess -optVerbose' -setenv TAU_THROTTLE 1 -setenv TAU_THROTTLE_NUMCALLS 400000 -setenv TAU_THROTTLE_PERCALL 3000 diff --git a/source/unres/src_MD/TAU_setup.sh b/source/unres/src_MD/TAU_setup.sh deleted file mode 100755 index 1423b72..0000000 --- a/source/unres/src_MD/TAU_setup.sh +++ /dev/null @@ -1,15 +0,0 @@ -#!/bin/bash -# -# Adding tau -# Must be executed from command line, don't know why! -#soft add +tau -# -# With preprocessor -# -export TAU_OPTIONS='-optPreProcess -optVerbose' -# -# sets tau makefile -# -export TAU_MAKEFILE=/soft/apps/tau/tau-2.17.1/bgp/lib/Makefile.tau-mpi-pdt - -export TAU_OPTIONS='-optTauSelectFile=select.tau -optPreProcess -optVerbose -optKeepFiles' diff --git a/source/unres/src_MD/bank.F b/source/unres/src_MD/bank.F deleted file mode 100644 index a48eac2..0000000 --- a/source/unres/src_MD/bank.F +++ /dev/null @@ -1,1086 +0,0 @@ -#ifdef MPI -cc--------------------------------- - subroutine refresh_bank(ntrial) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - character chacc - integer iaccn - double precision l_diff(mxio),denep - - do i=0,mxmv - do j=1,3 - nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) - nstatnx(i,j)=0 - enddo - enddo - -c loop over all newly obtained conformations - do n=1,ntrial - chacc=' ' - iaccn=0 - nstatnx(movernx(n),1)=nstatnx(movernx(n),1)+1 -cccccccccccccccccccccccccccccccccccccccccccc -cjlee - if(iref.ne.0) then - if(rmsn(n).gt.rmscut.or.pncn(n).lt.pnccut) goto 100 - endif -cjlee - if(etot(n).gt.ebmax) goto 100 -c Find the conformation closest to the conformation n in the bank - difmin=9.d9 - do m=1,nbank - call get_diff12(dihang(1,1,1,n),bvar(1,1,1,m),l_diff(m)) - if(l_diff(m).lt.difmin) then - difmin=l_diff(m) - idmin=m - endif - enddo - - if(difmin.lt.cutdif) then -c n is redundant to idmin - if(etot(n).lt.bene(idmin)) then - if(etot(n).lt.bene(idmin)-0.01d0) then - ibank(idmin)=0 - jbank(idmin)=0 - endif - denep=bene(idmin)-etot(n) - call replace_bvar(idmin,n) -crc Update dij - do i1=1,nbank - if (i1.ne.idmin) then - dij(i1,idmin)=l_diff(i1) - dij(idmin,i1)=l_diff(i1) - endif - enddo - chacc='c' - iaccn=idmin - nstatnx(movernx(n),2)=nstatnx(movernx(n),2)+1 - if(idmin.eq.ibmax) call find_max - endif - else -c got new conformation - del_ene=0.0d0 - if(ebmax-ebmin.gt.del_ene) then - denep=ebmax-etot(n) - call replace_bvar(ibmax,n) -crc Update dij - do i1=1,nbank - if (i1.ne.ibmax) then - dij(i1,ibmax)=l_diff(i1) - dij(ibmax,i1)=l_diff(i1) - endif - enddo - chacc='f' - iaccn=ibmax - nstatnx(movernx(n),3)=nstatnx(movernx(n),3)+1 - ibank(ibmax)=0 - jbank(ibmax)=0 - call find_max - else - if(del_ene.lt.0.0001) then - write (iout,*) 'ERROR in refresh_bank: ' - write (iout,*) 'ebmax: ',ebmax - write (iout,*) 'ebmin: ',ebmin - write (iout,*) 'del_ene: ',del_ene -crc call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif -cjp nbmax is never defined so condition below is always false -c if(nbank.lt.nbmax) then -c nbank=nbank+1 -c call replace_bvar(nbank,n) -c ibank(nbank)=0 -c jbank(nbank)=0 -c else - call replace_bvar(ibmax,n) - ibank(ibmax)=0 - jbank(ibmax)=0 - call find_max -c endif - endif - endif -cccccccccccccccccccccccccccccccccccccccccccc - 100 continue - if (iaccn.eq.0) then - if (iref.eq.0) then - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5)') - & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ', - & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9) - else - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5 - & ,a5,0pf4.1,a5,f3.0)') - & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ', - & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9), - & ' rms ',rmsn(n),' %NC ',pncn(n)*100 - endif - else - if (iref.eq.0) then - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5, - & 1x,a1,i4,0pf8.1,0pf8.1)') - & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ', - & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9), - & chacc,iaccn,difmin,denep - else - write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4,3i5,a5, - & 0pf4.1,a5,f3.0,1x,a1,i4,0pf8.1,0pf8.1)') - & indb(n,2),' e ',indb(n,3),indb(n,1),' etot ',etot(n),' mv ', - & indb(n,5),indb(n,4),indb(n,7),indb(n,8),indb(n,9), - & ' rms ',rmsn(n),' %NC ',pncn(n)*100, - & chacc,iaccn,difmin,denep - endif - endif - enddo -c end of loop over all newly obtained conformations - do i=0,mxmv - if(nstatnx(i,1).ne.0) then - if (i.le.9) then - write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '## N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) - else - write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '##N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',(nstatnx(i,2)+nstatnx(i,3))*100.0/nstatnx(i,1) - endif - else - if (i.le.9) then - write(iout,'(a4,i1,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '## N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',0.0 - else - write(iout,'(a3,i2,a7,i4,a7,i4,a5,i4,a5,f5.1)') - & '##N',i,' total=',nstatnx(i,1), - & ' close=',nstatnx(i,2),' far=',nstatnx(i,3), - & ' %acc',0.0 - endif - endif - enddo - call flush(iout) -crc Update dij -crc moved up, saves some get_diff12 calls -crc -crc do i1=1,nbank-1 -crc do i2=i1+1,nbank -crc if(jbank(i1).eq.0.or.jbank(i2).eq.0) then -crc call get_diff12(bvar(1,1,1,i1),bvar(1,1,1,i2),diff) -crc dij(i1,i2)=diff -crc dij(i2,i1)=diff -crc endif -crc enddo -crc enddo - - do i=1,nbank - jbank(i)=1 - enddo - - return - end -c--------------------------------- - subroutine replace_bvar(iold,inew) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - - if (iold.gt.mxio .or. iold.lt.1 .or. inew.gt.mxio .or. inew.lt.1) - & then - write (iout,*) 'Dimension ERROR in REPLACE_BVAR: IOLD',iold, - & ' INEW',inew - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - bvar(i,j,k,iold)=dihang(i,j,k,inew) - enddo - enddo - enddo - bene(iold)=etot(inew) - brmsn(iold)=rmsn(inew) - bpncn(iold)=pncn(inew) - - if(bene(iold).lt.ebmin) then - ebmin=bene(iold) - ibmin=iold - endif - - if(vdisulf) then - bvar_nss(iold)=nss_out(inew) -cd write(iout,*) 'SS BANK',iold,bvar_nss(iold) - do i=1,bvar_nss(iold) - bvar_ss(1,i,iold)=iss_out(i,inew) - bvar_ss(2,i,iold)=jss_out(i,inew) -cd write(iout,*) 'SS',bvar_ss(1,i,iold)-nres, -cd & bvar_ss(2,i,iold)-nres - enddo - - bvar_ns(iold)=ns-2*bvar_nss(iold) -cd write(iout,*) 'CYS #free ', bvar_ns(iold) - k=0 - do i=1,ns - j=1 - do while( iss(i).ne.iss_out(j,inew)-nres .and. - & iss(i).ne.jss_out(j,inew)-nres .and. - & j.le.nss_out(inew)) - j=j+1 - enddo - if (j.gt.nss_out(inew)) then - k=k+1 - bvar_s(k,iold)=iss(i) - endif - enddo -cd write(iout,*) 'CYS free',(bvar_s(k,iold),k=1,bvar_ns(iold)) - endif - - return - end -c--------------------------------------- - subroutine write_rbank(jlee,adif,nft) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - - open(icsa_rbank,file=csa_rbank,status="unknown") - write (icsa_rbank,900) jlee,nbank,nstep,nft,icycle,adif - do k=1,nbank - write (icsa_rbank,952) k,rene(k),rrmsn(k),rpncn(k) - do j=1,numch - do l=2,nres-1 - write (icsa_rbank,850) (rad2deg*rvar(i,l,j,k),i=1,4) - enddo - enddo - enddo - close(icsa_rbank) - - 850 format (10f8.3) - 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =", - & i8,i10,i2,f15.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3 - & ,' %NC ',0pf5.2) - - return - end -c--------------------------------------- - subroutine read_rbank(jlee,adif) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.SETUP' - character*80 karta - - open(icsa_rbank,file=csa_rbank,status="old") - read (icsa_rbank,901) jleer,nbankr,nstepr,nftr,icycler,adif - print *,jleer,nbankr,nstepr,nftr,icycler,adif -c print *, 'adif from read_rbank ',adif - if(nbankr.ne.nbank) then - write (iout,*) 'ERROR in READ_BANK: NBANKR',nbankr, - & ' NBANK',nbank - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - if(jleer.ne.jlee) then - write (iout,*) 'ERROR in READ_BANK: JLEER',jleer, - & ' JLEE',jlee - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - - kk=0 - do k=1,nbankr - read (icsa_rbank,'(a80)') karta - write(iout,*) "READ_RBANK: kk=",kk - write(iout,*) karta -c if (index(karta,"*").gt.0) then -c write (iout,*) "***** Stars in bankr ***** k=",k, -c & " skipped" -c do j=1,numch -c do l=2,nres-1 -c read (30,850) (rdummy,i=1,4) -c enddo -c enddo -c else - kk=kk+1 - call reada(karta,"total E",rene(kk),1.0d20) - call reada(karta,"rmsd from N",rrmsn(kk),0.0d0) - call reada(karta,"%NC",rpncn(kk),0.0d0) - write(iout,*)"total E",bene(kk),"rmsd from N",brmsn(kk), - & "%NC",bpncn(kk),ibank(kk) -c read (icsa_rbank,953) kdummy,rene(kk),rrmsn(kk),rpncn(kk) - do j=1,numch - do l=2,nres-1 - read (icsa_rbank,850) (rvar(i,l,j,kk),i=1,4) -c write (iout,850) (rvar(i,l,j,kk),i=1,4) - do i=1,4 - rvar(i,l,j,kk)=deg2rad*rvar(i,l,j,kk) - enddo - enddo - enddo -c endif - enddo -cd write (*,*) "read_rbank ******************* kk",kk, -cd & "nbankr",nbankr - if (kk.lt.nbankr) nbankr=kk -cd do kk=1,nbankr -cd print *,"kk=",kk -cd do j=1,numch -cd do l=2,nres-1 -cd write (*,850) (rvar(i,l,j,kk),i=1,4) -cd enddo -cd enddo -cd enddo - close(icsa_rbank) - - 850 format (10f8.3) - 901 format (1x,6x,i3,3x,7x,i4,3x,7x,i8,i10,i2,f15.5) - 953 format (1x,1x,i4,9x,f12.3,13x,f8.3,5x,f5.2) - - return - end -c--------------------------------------- - subroutine write_bank(jlee,nft) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - character*7 chtmp - character*40 chfrm - external ilen - - open(icsa_bank,file=csa_bank,status="unknown") - write (icsa_bank,900) jlee,nbank,nstep,nft,icycle,cutdif - write (icsa_bank,902) nglob_csa, eglob_csa - open (igeom,file=intname,status='UNKNOWN') - do k=1,nbank - write (icsa_bank,952) k,bene(k),brmsn(k),bpncn(k),ibank(k) - if (vdisulf) write (icsa_bank,'(101i4)') - & bvar_nss(k),((bvar_ss(j,i,k),j=1,2),i=1,bvar_nss(k)) - do j=1,numch - do l=2,nres-1 - write (icsa_bank,850) (rad2deg*bvar(i,l,j,k),i=1,4) - enddo - enddo - if (bvar_nss(k).le.9) then - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,bvar_nss(k)) - else - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,9) - write (igeom,'(3X,11(1X,2I3))') (bvar_ss(1,i,k), - & bvar_ss(2,i,k),i=10,bvar_nss(k)) - endif - write (igeom,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) - write (igeom,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) - enddo - close(icsa_bank) - close(igeom) - - if (nstep/200.gt.ilastnstep) then - - ilastnstep=(ilastnstep+1)*1.5 - write(chfrm,'(a2,i1,a1)') '(i',int(dlog10(dble(nstep))+1),')' - write(chtmp,chfrm) nstep - open(icsa_int,file=prefix(:ilen(prefix)) - & //'_'//chtmp(:ilen(chtmp))//'.int',status='UNKNOWN') - do k=1,nbank - if (bvar_nss(k).le.9) then - write (icsa_int,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,bvar_nss(k)) - else - write (icsa_int,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & bvar_nss(k),(bvar_ss(1,i,k),bvar_ss(2,i,k),i=1,9) - write (icsa_int,'(3X,11(1X,2I3))') (bvar_ss(1,i,k), - & bvar_ss(2,i,k),i=10,bvar_nss(k)) - endif - write (icsa_int,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) - write (icsa_int,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) - write (icsa_int,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) - write (icsa_int,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) - enddo - close(icsa_int) - endif - - - 200 format (8f10.4) - 850 format (10f8.3) - 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =", - & i8,i10,i2,f15.5) - 902 format (1x,'nglob_csa =',i4,' eglob_csa =',1pe14.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3, - & ' %NC ',0pf5.2,i5) - - return - end -c--------------------------------------- - subroutine write_bank_reminimized(jlee,nft) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.SBRIDGE' - - open(icsa_bank_reminimized,file=csa_bank_reminimized, - & status="unknown") - write (icsa_bank_reminimized,900) - & jlee,nbank,nstep,nft,icycle,cutdif - open (igeom,file=intname,status='UNKNOWN') - do k=1,nbank - write (icsa_bank_reminimized,952) k,bene(k),brmsn(k), - & bpncn(k),ibank(k) - do j=1,numch - do l=2,nres-1 - write (icsa_bank_reminimized,850) (rad2deg*bvar(i,l,j,k),i=1,4) - enddo - enddo - if (nss.le.9) then - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & nss,(ihpb(i),jhpb(i),i=1,nss) - else - write (igeom,'(I5,F10.3,I2,9(1X,2I3))') k,bene(k), - & nss,(ihpb(i),jhpb(i),i=1,9) - write (igeom,'(3X,11(1X,2I3))') (ihpb(i),jhpb(i),i=10,nss) - endif - write (igeom,200) (rad2deg*bvar(1,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(2,i,1,k),i=2,nres-2) - write (igeom,200) (rad2deg*bvar(3,i,1,k),i=2,nres-1) - write (igeom,200) (rad2deg*bvar(4,i,1,k),i=2,nres-1) - enddo - close(icsa_bank_reminimized) - close(igeom) - - 200 format (8f10.4) - 850 format (10f8.3) - 900 format (1x,"jlee =",i3,3x,"nbank =",i4,3x,"nstep =", - & i8,i10,i2,f15.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3 - & ,' %NC ',0pf5.2,i5) - - return - end -c--------------------------------- - subroutine read_bank(jlee,nft,cutdifr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - character*80 karta - integer ilen - external ilen - - open(icsa_bank,file=csa_bank,status="old") - read (icsa_bank,901) jlee,nbank,nstep,nft,icycle,cutdifr - read (icsa_bank,902) nglob_csa, eglob_csa -c if(jleer.ne.jlee) then -c write (iout,*) 'ERROR in READ_BANK: JLEER',jleer, -c & ' JLEE',jlee -c call mpi_abort(mpi_comm_world,ierror,ierrcode) -c endif - - kk=0 - do k=1,nbank - read (icsa_bank,'(a80)') karta - write(iout,*) "READ_BANK: kk=",kk - write(iout,*) karta -c if (index(karta,"*").gt.0) then -c write (iout,*) "***** Stars in bank ***** k=",k, -c & " skipped" -c do j=1,numch -c do l=2,nres-1 -c read (33,850) (rdummy,i=1,4) -c enddo -c enddo -c else - kk=kk+1 - call reada(karta,"total E",bene(kk),1.0d20) - call reada(karta,"rmsd from N",brmsn(kk),0.0d0) - call reada(karta,"%NC",bpncn(kk),0.0d0) - read (karta(ilen(karta)-1:),*,end=111,err=111) ibank(kk) - goto 112 - 111 ibank(kk)=0 - 112 continue - write(iout,*)"total E",bene(kk),"rmsd from N",brmsn(kk), - & "%NC",bpncn(kk),ibank(kk) -c read (icsa_bank,953) kdummy,bene(k),brmsn(k),bpncn(k),ibank(k) - if (vdisulf) then - read (icsa_bank,'(101i4)') - & bvar_nss(kk),((bvar_ss(j,i,kk),j=1,2),i=1,bvar_nss(kk)) - bvar_ns(kk)=ns-2*bvar_nss(kk) - write(iout,*) 'read SSBOND',bvar_nss(kk), - & ((bvar_ss(j,i,kk),j=1,2),i=1,bvar_nss(kk)) -cd write(iout,*) 'read CYS #free ', bvar_ns(kk) - l=0 - do i=1,ns - j=1 - do while( iss(i).ne.bvar_ss(1,j,kk)-nres .and. - & iss(i).ne.bvar_ss(2,j,kk)-nres .and. - & j.le.bvar_nss(kk)) - j=j+1 - enddo - if (j.gt.bvar_nss(kk)) then - l=l+1 - bvar_s(l,kk)=iss(i) - endif - enddo -cd write(iout,*)'read CYS free',(bvar_s(l,kk),l=1,bvar_ns(kk)) - endif - do j=1,numch - do l=2,nres-1 - read (icsa_bank,850) (bvar(i,l,j,kk),i=1,4) -c write (iout,850) (bvar(i,l,j,kk),i=1,4) - do i=1,4 - bvar(i,l,j,kk)=deg2rad*bvar(i,l,j,kk) - enddo ! l - enddo ! l - enddo ! j -c endif - enddo ! k - - if (kk.lt.nbank) nbank=kk -cd write (*,*) "read_bank ******************* kk",kk, -cd & "nbank",nbank -cd do kk=1,nbank -cd print *,"kk=",kk -cd do j=1,numch -cd do l=2,nres-1 -cd write (*,850) (bvar(i,l,j,kk),i=1,4) -cd enddo -cd enddo -cd enddo - -c do k=1,nbank -c read (33,953) kdummy,bene(k),brmsn(k),bpncn(k),ibank(k) -c do j=1,numch -c do l=2,nres-1 -c read (33,850) (bvar(i,l,j,k),i=1,4) -c do i=1,4 -c bvar(i,l,j,k)=deg2rad*bvar(i,l,j,k) -c enddo -c enddo -c enddo -c enddo - close(icsa_bank) - - 850 format (10f8.3) - 952 format (1x,'#',i4,' total E ',f12.3,' rmsd from N ',f8.3,i5) - 901 format (1x,6x,i3,3x,7x,i4,3x,7x,i8,i10,i2,f15.5) - 902 format (1x,11x,i4,12x,1pe14.5) - 953 format (1x,1x,i4,9x,f12.3,13x,f8.3,5x,f5.2,i5) - - return - end -c--------------------------------------- - subroutine write_bank1(jlee) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - -#if defined(AIX) || defined(PGI) - open(icsa_bank1,file=csa_bank1,position="append") -#else - open(icsa_bank1,file=csa_bank1,access="append") -#endif - write (icsa_bank1,900) jlee,nbank,nstep,cutdif - do k=1,nbank - write (icsa_bank1,952) k,bene(k),brmsn(k),bpncn(k),ibank(k) - do j=1,numch - do l=2,nres-1 - write (icsa_bank1,850) (rad2deg*bvar(i,l,j,k),i=1,4) - enddo - enddo - enddo - close(icsa_bank1) - 850 format (10f8.3) - 900 format (4x,"jlee =",i5,3x,"nbank =",i5,3x,"nstep =",i10,f15.5) - 952 format (1x,'#',i4,' total E ',1pe14.5,' rmsd from N ',0pf8.3 - & ,' %NC ',0pf5.2,i5) - - return - end -c--------------------------------- - subroutine save_is(ind) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - - index=nbank+ind -c print *, "nbank,ind,index,is(ind) ",nbank,ind,index,is(ind) - if (index.gt.mxio .or. index.lt.1 .or. - & is(ind).gt.mxio .or. is(ind).lt.1) then - write (iout,*) 'Dimension ERROR in SAVE_IS: INDEX',index, - & ' IND',ind,' IS',is(ind) - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - bvar(i,j,k,index)=bvar(i,j,k,is(ind)) - enddo - enddo - enddo - bene(index)=bene(is(ind)) - ibank(is(ind))=1 - - return - end -c--------------------------------- - subroutine select_is(n,ifar,idum) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - dimension itag(mxio),adiff(mxio) - - iuse=0 - do i=1,nbank - if(ibank(i).eq.0) then - iuse=iuse+1 - itag(iuse)=i - endif - enddo - iusesv=iuse - - if(iuse.eq.0) then - icycle=icycle+1 - do i=1,nbank - if(ibank(i).eq.2) then - ibank(i)=1 - else - ibank(i)=0 - endif - enddo - imade=0 - call get_is(idum,ifar,n,imade,0) -ctest3 call get_is_max(idum,ifar,n,imade,0) - else if(iuse.eq.n) then - do i=1,iuse - is(i)=itag(i) - call save_is(i) - enddo - else if(iuse.lt.n) then -c if(icycle.eq.0) then -c do i=1,n -c ind=mod(i-1,iuse)+1 -c is(i)=itag(ind) -c call save_is(i) -c enddo -c else -c endif - do i=1,iuse - is(i)=itag(i) - call save_is(i) - enddo - imade=iuse -c call get_is_ran(idum,n,imade,1) - call get_is(idum,ifar,n,imade,1) -ctest3 call get_is_max(idum,ifar,n,imade,1) -c if(iusesv.le.n/10) then - if(iusesv.le.0) then - icycle=icycle+1 - do i=1,nbank -c if(ibank(i).eq.2) then -c ibank(i)=1 - if(ibank(i).ge.2) then - ibank(i)=ibank(i)-1 - else - ibank(i)=0 - endif - enddo - endif - else - imade=0 - call get_is(idum,ifar,n,imade,0) -ctest3 call get_is_max(idum,ifar,n,imade,0) - endif - iuse=iusesv - - return - end -c--------------------------------- - subroutine get_is_ran(idum,n,imade,k) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - real ran1,ran2 - dimension itag(mxio),adiff(mxio) - - do j=imade+1,n - iuse=0 - do i=1,nbank - if(ibank(i).eq.k) then - iuse=iuse+1 - itag(iuse)=i - endif - enddo - iran=iuse* ran1(idum)+1 - is(j)=itag(iran) - call save_is(j) - enddo - - return - end -c--------------------------------- - subroutine get_is(idum,ifar,n,imade,k) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - real ran1,ran2 - dimension itag(mxio),adiff(mxio) - - iuse=0 - do i=1,nbank - if(ibank(i).eq.k) then - iuse=iuse+1 - itag(iuse)=i - endif - enddo - iran=iuse* ran1(idum)+1 - imade=imade+1 - is(imade)=itag(iran) - call save_is(imade) - - do i=imade+1,ifar-1 - if(icycle.eq.-1) then - call select_iseed_max(i,k) - else - call select_iseed_min(i,k) -ctest4 call select_iseed_max(i,k) - endif - call save_is(i) - enddo - - do i=ifar,n - call select_iseed_far(i,k) - call save_is(i) - enddo - - return - end -c--------------------------------- - subroutine select_iseed_max(imade1,ik) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - dimension itag(mxio),adiff(mxio) - - iuse=0 - avedif=0.d0 - difmax=0.d0 - do n=1,nbank - if(ibank(n).eq.ik) then - iuse=iuse+1 - diffmn=9.d190 - do imade=1,imade1-1 -c m=nbank+imade -c call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) - m=is(imade) - diff=dij(n,m) - if(diff.lt.diffmn) diffmn=diff - enddo - if(diffmn.gt.difmax) difmax=diffmn - adiff(iuse)=diffmn - itag(iuse)=n - avedif=avedif+diffmn - endif - enddo - - avedif=avedif/iuse -c avedif=(avedif+difmax)/2 - emax=-9.d190 - do i=1,iuse - if(adiff(i).ge.avedif) then - itagi=itag(i) - benei=bene(itagi) - if(benei.gt.emax) then - emax=benei - is(imade1)=itagi - endif - endif - enddo - - if(ik.eq.0) iuse=iuse-1 - - return - end -c--------------------------------- - subroutine select_iseed_min(imade1,ik) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - dimension itag(mxio),adiff(mxio) - - iuse=0 - avedif=0.d0 - difmax=0.d0 - do n=1,nbank - if(ibank(n).eq.ik) then - iuse=iuse+1 - diffmn=9.d190 - do imade=1,imade1-1 -c m=nbank+imade -c call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) - m=is(imade) - diff=dij(n,m) - if(diff.lt.diffmn) diffmn=diff - enddo - if(diffmn.gt.difmax) difmax=diffmn - adiff(iuse)=diffmn - itag(iuse)=n - avedif=avedif+diffmn - endif - enddo - - avedif=avedif/iuse -c avedif=(avedif+difmax)/2 - emin=9.d190 - do i=1,iuse -c print *,"i, adiff(i),avedif : ",i,adiff(i),avedif - if(adiff(i).ge.avedif) then - itagi=itag(i) - benei=bene(itagi) -c print *,"i, benei,emin : ",i,benei,emin - if(benei.lt.emin) then - emin=benei - is(imade1)=itagi - endif - endif - enddo - - if(ik.eq.0) iuse=iuse-1 - -c print *, "exiting select_iseed_min",is(imade1) - - return - end -c--------------------------------- - subroutine select_iseed_far(imade1,ik) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - - dmax=-9.d190 - do n=1,nbank - if(ibank(n).eq.ik) then - diffmn=9.d190 - do imade=1,imade1-1 -c m=nbank+imade -c call get_diff12(bvar(1,1,1,n),bvar(1,1,1,m),diff,idiff) - m=is(imade) - diff=dij(n,m) - if(diff.lt.diffmn) diffmn=diff - enddo - endif - if(diffmn.gt.dmax) then - dmax=diffmn - is(imade1)=n - endif - enddo - - return - end -c--------------------------------- - subroutine find_min - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - - ebmin=9.d190 - - do i=1,nbank - benei=bene(i) - if(benei.lt.ebmin) then - ebmin=benei - ibmin=i - endif - enddo - - return - end -c--------------------------------- - subroutine write_csa_pdb(var,ene,nft,ik,iw_pdb) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.MINIM' - include 'COMMON.SETUP' - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.SBRIDGE' - integer lenpre,lenpot,ilen - external ilen - dimension var(maxvar) - character*50 titelloc - character*3 zahl - - nmin_csa=nmin_csa+1 - if(ene.lt.eglob_csa) then - eglob_csa=ene - nglob_csa=nglob_csa+1 - call numstr(nglob_csa,zahl) - - call var_to_geom(nvar,var) - call chainbuild - call secondary2(.false.) - - lenpre=ilen(prefix) - open(icsa_pdb,file=prefix(:lenpre)//'@'//zahl//'.pdb') - - if (iw_pdb.eq.1) then - write(titelloc,'(a2,i3,a3,i9,a3,i6)') - & 'GM',nglob_csa,' e ',nft,' m ',nmin_csa - else - write(titelloc,'(a2,i3,a3,i9,a3,i6,a5,f5.2,a5,f5.1)') - & 'GM',nglob_csa,' e ',nft,' m ',nmin_csa,' rms ' - & ,rmsn(ik),' %NC ',pncn(ik)*100 - endif - call pdbout(eglob_csa,titelloc,icsa_pdb) - close(icsa_pdb) - endif - - return - end -c--------------------------------- - subroutine find_max - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - - ebmax=-9.d190 - - do i=1,nbank - benei=bene(i) - if(benei.gt.ebmax) then - ebmax=benei - ibmax=i - endif - enddo - - return - end -c--------------------------------- - subroutine get_diff - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - - tdiff=0.d0 - difmin=9.d190 - do i1=1,nbank-1 - do i2=i1+1,nbank - if(jbank(i1).eq.0.or.jbank(i2).eq.0) then - call get_diff12(bvar(1,1,1,i1),bvar(1,1,1,i2),diff) - dij(i1,i2)=diff - dij(i2,i1)=diff - else - diff=dij(i1,i2) - endif - tdiff=tdiff+diff - if(diff.lt.difmin) difmin=diff - enddo - dij(i1,i1)=0.0 - enddo - - do i=1,nbank - jbank(i)=1 - enddo - - avedif=tdiff/nbank/(nbank-1)*2 - - return - end -c--------------------------------- - subroutine estimate_cutdif(adif,xct,cutdifr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - - ctdif1=adif/cut2 - - exponent = cutdifr*cut1/adif - exponent = dlog(exponent)/dlog(xct) - - nexp=exponent+0.25 - cutdif= adif/cut1*xct**nexp - if(cutdif.lt.ctdif1) cutdif=ctdif1 - - return - end -c--------------------------------- - subroutine get_is_max(idum,ifar,n,imade,k) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - double precision emax - - do i=imade+1,n - emax=-9.d190 - do j=1,nbank - if(ibank(j).eq.k .and. bene(j).gt.emax) then - emax=bene(j) - is(i)=j - endif - enddo - call save_is(i) - enddo - - return - end -#endif diff --git a/source/unres/src_MD/cartder.F b/source/unres/src_MD/cartder.F index dd2b3f1..e2e8c1a 100644 --- a/source/unres/src_MD/cartder.F +++ b/source/unres/src_MD/cartder.F @@ -47,7 +47,7 @@ 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 +c 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 diff --git a/source/unres/src_MD/cinfo.f b/source/unres/src_MD/cinfo.f index 34bab46..aa00d45 100644 --- a/source/unres/src_MD/cinfo.f +++ b/source/unres/src_MD/cinfo.f @@ -1,26 +1,26 @@ C DO NOT EDIT THIS FILE - IT HAS BEEN GENERATED BY COMPINFO.C -C 2 4 3270 +C 2 5 26 subroutine cinfo include 'COMMON.IOUNITS' write(iout,*)'++++ Compile info ++++' - write(iout,*)'Version 2.4 build 3270' - write(iout,*)'compiled Thu Apr 7 15:31:29 2011' - write(iout,*)'compiled by adam@sun1.chem.univ.gda.pl' + write(iout,*)'Version 2.5 build 26' + write(iout,*)'compiled Wed Mar 28 23:34:22 2012' + write(iout,*)'compiled by czarek@piasek3' write(iout,*)'OS name: Linux ' - write(iout,*)'OS release: 2.6.30.5-43.fc11.x86_64 ' + write(iout,*)'OS release: 2.6.32-38-generic ' write(iout,*)'OS version:', - & ' #1 SMP Thu Aug 27 21:39:52 EDT 2009 ' + & ' #83-Ubuntu SMP Wed Jan 4 11:12:07 UTC 2012 ' write(iout,*)'flags:' - write(iout,*)'FC= gfortran' - write(iout,*)'CC = cc' - write(iout,*)'CFLAGS = -DLINUX -DPGI -c' - write(iout,*)'OPT = -fbounds-check -g' - write(iout,*)'OPT1 = -g' - write(iout,*)'FFLAGS = -c ${OPT} -I.' - write(iout,*)'FFLAGS1 = -c ${OPT1} -I.' - write(iout,*)'BIN = ../bin/unres_gfortran_single.exe' - write(iout,*)'LIBS = -L../xdrf -lxdrf' - write(iout,*)'CPPFLAGS = -DLINUX -DUNRES -DG77 -DSPLITELE -DP...' + write(iout,*)'CPPFLAGS = -DPROCOR -DLINUX -DUNRES -DMP -DMPI ...' + write(iout,*)'INSTALL_DIR = /users/local/mpi64/mpich-1.2.7p1/' + write(iout,*)'FC= ifort' + write(iout,*)'OPT = -O3 -ip -w ' + write(iout,*)'FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include ' + write(iout,*)'FFLAGS1 = -c -w -g -d2 -CA -CB -I$(INSTALL_DIR)...' + write(iout,*)'FFLAGS2 = -c -w -g -O0 -I$(INSTALL_DIR)/include ' + write(iout,*)'FFLAGSE = -c -w -O3 -ipo -ipo_obj -opt_report ...' + write(iout,*)'BIN = ../../../bin/unres/MD/unres_ifort_mpich-1...' + write(iout,*)'LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdr...' write(iout,*)'ARCH = LINUX' write(iout,*)'PP = /lib/cpp -P' write(iout,*)'object = unres.o arcos.o cartprint.o chainbuild...' diff --git a/source/unres/src_MD/common.size b/source/unres/src_MD/common.size deleted file mode 100644 index 3bc1f47..0000000 --- a/source/unres/src_MD/common.size +++ /dev/null @@ -1,130 +0,0 @@ -info 0x4010 gen_rand_conf.o -from_zscore 0x8 unres.o -mdcalc 0x108 unres.o -bank_disulfid 0x1f0 readrtns_CSA.o -parfiles 0xb00 unres.o -body 0x6180 unres.o -pool 0x697dc readrtns_CSA.o -interact 0xed94 unres.o -sclocal 0x22cc chainbuild.o -restraints 0x8 unres.o -peptbond 0x28 chainbuild.o -srutu 0x4 unres.o -mucarem 0x8000 readrtns_CSA.o -oldgeo 0xd2ff4 unres.o -minvar 0xe278 readrtns_CSA.o -spinka 0x2a3c newconf.o -torsiond 0x14200 initialize_p.o -przechowalnia 0x7b98a04 rattle.o -langforc 0x31a5054 readrtns_CSA.o -thetas 0x960 chainbuild.o -iounits 0x6c unres.o -rotat_old 0xa8c0 unres.o -remdcommon 0x6030 unres.o -chuju 0x4 minimize_p.o -refstruct 0x151ec unres.o -traj1cache 0x3679c unres.o -stretch 0x600 unres.o -mvstat 0x250 readrtns_CSA.o -thread 0x148 readrtns_CSA.o -dih_control 0xc readrtns_CSA.o -mdpar 0x6c unres.o -types 0x14 unres.o -par 0x20 eigen.o -bounds 0x3840 readrtns_CSA.o -pizda 0xe10 readrtns_CSA.o -machsw 0xc initialize_p.o -links_split 0x8 unres.o -integer_muca 0xc readrtns_CSA.o -calc 0x1f0 gen_rand_conf.o -csafiles 0xc00 unres.o -sbridge 0x9c unres.o -back_constr 0x11acc unres.o -rotat 0x2a300 unres.o -mpipriv2 0x18 unres.o -remdrestart 0x411808 unres.o -stochcalc 0xa8c0 MD_A-MTS.o -scrot 0x28a0 parmread.o -stoptim 0x4 unres.o -c_frag 0x1c28 geomout.o -precomp2 0x54600 unres.o -move 0x38b8 initialize_p.o -loc_work 0x30c local_move.o -store0 0x4 geomout.o -torsion 0x5adc parmread.o -wagi 0x10 geomout.o -vrandd 0x3f0 randgens.o -lagrange 0x15a93de0 unres.o -accept_stats 0x2008 initialize_p.o -mdpmpi 0x8010 unres.o -invlen 0x3840 chainbuild.o -locel 0x208 energy_p_new.o -frag 0xa0 geomout.o -inertia 0x160 unres.o -time1 0x30 unres.o -derivat 0x2638028 initialize_p.o -langmat 0xc readrtns_CSA.o -banii 0xa8c0 banach.o -mdgrad 0x151b0 unres.o -bank 0x1c320 readrtns_CSA.o -refer 0x98 bond_move.o -diploc 0x3938 unres.o -syfek 0xa8c0 stochfric.o -fnames 0x1007 unres.o -$BLNK_COM 0xc djacob.o -sccalc 0x28 energy_p_new.o -geo 0x40 unres.o -iofile 0x65c initialize_p.o -mapp 0x2a304 readrtns_CSA.o -theta_abinitio 0x24a70 chainbuild.o -sumsl_flag 0x4 unres.o -restr 0xd2f4 unres.o -chain 0x3f500 unres.o -torcnstr 0x5478 initialize_p.o -cipiszcze 0x4 lagrangian_lesyng.o -double_muca 0x1c228 readrtns_CSA.o -links 0x93d24c unres.o -deriv_loc 0x1e0 initialize_p.o -cache 0x69850 mcm.o -minimm 0x20 initialize_p.o -diffcuta 0x8 readrtns_CSA.o -aaaa 0x8 MP.o -fourier 0x344 initialize_p.o -mce 0x230 readrtns_CSA.o -var 0x286f0 unres.o -csa_input 0x98 readrtns_CSA.o -header 0x50 unres.o -splitele 0x10 initialize_p.o -setup 0x4028 unres.o -mcm 0x20a4 initialize_p.o -mce_counters 0x14 readrtns_CSA.o -frozen 0xe10 geomout.o -struct 0xa2c readrtns_CSA.o -info1 0x4024 gen_rand_conf.o -cntrl 0x78 unres.o -mpiprivc 0x2 unres.o -timing 0x58 unres.o -kutas 0x4 energy_p_new.o -precomp1 0x50dc0 unres.o -loc_const 0x40 local_move.o -contacts1 0x18c630 unres.o -alphaa 0x16da8 readrtns_CSA.o -thread1 0x1cd0 readrtns_CSA.o -qmeas 0x6f2bc unres.o -dipmat 0x15f9000 unres.o -indices 0x8040 chainbuild.o -ffield 0x174 unres.o -vectors 0x49d40 energy_p_new.o -varin 0xe248 readrtns_CSA.o -csaunits 0x34 unres.o -contacts_hb 0x9c9c30 unres.o -contacts 0x2a308 unres.o -deriv_scloc 0x2f760 initialize_p.o -secondarys 0x384 dihed_cons.o -pochodne 0x6318d0 geomout.o -maxgrad 0xa8 energy_p_new.o -send2 0xfd50 readrtns_CSA.o -windows 0x2a34 initialize_p.o -gucio 0x18 MD_A-MTS.o -rotmat 0x3f480 unres.o - diff --git a/source/unres/src_MD/common.size.orig b/source/unres/src_MD/common.size.orig deleted file mode 100644 index d009a52..0000000 --- a/source/unres/src_MD/common.size.orig +++ /dev/null @@ -1,130 +0,0 @@ -from_zscore 8 unres.o -mdcalc 108 unres.o -bank_disulfid 1f0 readrtns_CSA.o -parfiles b00 unres.o -body 6180 unres.o -mpipriv1 1c unres.o -pool 2459c readrtns_CSA.o -interact 6c84 unres.o -sclocal 22cc chainbuild.o -restraints 8 unres.o -peptbond 28 chainbuild.o -srutu 4 unres.o -mucarem 8000 readrtns_CSA.o -oldgeo 48b74 unres.o -minvar 4ef8 readrtns_CSA.o -spinka e88 newconf.o -torsiond 14200 initialize_p.o -langforc 34dc434 readrtns_CSA.o -thetas 960 chainbuild.o -iounits 6c unres.o -rotat_old 3a20 unres.o -remdcommon 6030 unres.o -chuju 4 minimize_p.o -dipint 31db480 unres.o -refstruct 74ac unres.o -traj1cache 13e7c unres.o -stretch 600 unres.o -mvstat 250 readrtns_CSA.o -thread 148 readrtns_CSA.o -dih_control c readrtns_CSA.o -mdpar 6c unres.o -types 14 unres.o -rattlemat ea9e84 rattle.o -par 20 eigen.o -bounds 1360 readrtns_CSA.o -pizda 4d8 readrtns_CSA.o -machsw c initialize_p.o -links_split 8 unres.o -integer_muca c readrtns_CSA.o -calc 1f0 gen_rand_conf.o -csafiles c00 unres.o -sbridge 9c unres.o -back_constr 874c unres.o -rotat e880 unres.o -mpipriv2 18 unres.o -remdrestart 411808 unres.o -stochcalc 3a20 MD_A-MTS.o -scrot 28a0 parmread.o -stoptim 4 unres.o -c_frag 9b0 geomout.o -precomp2 1d100 unres.o -move 13d8 initialize_p.o -loc_work 30c local_move.o -store0 4 geomout.o -torsion 5adc parmread.o -wagi bc4d0 geomout.o -vrandd 3f0 randgens.o -lagrange a468980 unres.o -accept_stats 2008 initialize_p.o -mdpmpi 8010 unres.o -invlen 1360 chainbuild.o -locel 208 energy_p_new.o -frag a0 geomout.o -inertia 160 unres.o -time1 30 unres.o -derivat 4cab48 initialize_p.o -langmat c readrtns_CSA.o -banii 3a20 banach.o -mdgrad 7470 unres.o -bank 9c20 readrtns_CSA.o -refer 98 bond_move.o -diploc 3938 unres.o -syfek 3a20 stochfric.o -fnames 1007 unres.o -$BLNK_COM c djacob.o -sccalc 28 energy_p_new.o -geo 40 unres.o -iofile 65c initialize_p.o -mapp e884 readrtns_CSA.o -theta_abinitio 24a70 chainbuild.o -sumsl_flag 4 unres.o -restr 48ac unres.o -chain 15d40 unres.o -torcnstr 1d28 initialize_p.o -cipiszcze 4 lagrangian_lesyng.o -double_muca 9b28 readrtns_CSA.o -links 116d34 unres.o -deriv_loc 1e0 initialize_p.o -cache 24610 mcm.o -minimm 20 initialize_p.o -diffcuta 8 readrtns_CSA.o -aaaa 8 MP.o -fourier 344 initialize_p.o -mce 230 readrtns_CSA.o -var dee0 unres.o -csa_input 98 readrtns_CSA.o -header 50 unres.o -splitele 10 initialize_p.o -setup 4028 unres.o -mcm 20a4 initialize_p.o -mce_counters 14 readrtns_CSA.o -frozen 4d8 geomout.o -struct a2c readrtns_CSA.o -info1 4024 gen_rand_conf.o -cntrl 78 unres.o -mpiprivc 2 unres.o -timing 58 unres.o -kutas 4 energy_p_new.o -precomp1 1bda0 unres.o -loc_const 40 local_move.o -contacts1 34cee8 unres.o -alphaa 7df8 readrtns_CSA.o -thread1 1cd0 readrtns_CSA.o -qmeas 6157c unres.o -dipmat 2eec800 unres.o -indices 8040 chainbuild.o -ffield 174 unres.o -vectors 196e0 energy_p_new.o -varin 4ec8 readrtns_CSA.o -csaunits 34 unres.o -contacts_hb 14e59e8 unres.o -contacts e888 unres.o -deriv_scloc 10590 initialize_p.o -secondarys 136 dihed_cons.o -pochodne 731d130 geomout.o -maxgrad a8 energy_p_new.o -send2 5760 readrtns_CSA.o -windows e8c initialize_p.o -gucio 18 MD_A-MTS.o -rotmat 15cc0 unres.o diff --git a/source/unres/src_MD/compinfo b/source/unres/src_MD/compinfo deleted file mode 100755 index 1b801ef..0000000 Binary files a/source/unres/src_MD/compinfo and /dev/null differ diff --git a/source/unres/src_MD/csa.f b/source/unres/src_MD/csa.f deleted file mode 100644 index 77fb71f..0000000 --- a/source/unres/src_MD/csa.f +++ /dev/null @@ -1,363 +0,0 @@ - subroutine make_array - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.CSA' - -ccccccccccccccccccccccccc -c Level-2: group -ccccccccccccccccccccccccc - - indg=0 - do k=1,numch -ccccccccccccccccccccccccccccccccccccccccc -! Groups the THETAs and the GAMMAs - do j=2,nres-1 - indg=indg+1 - if (j.lt.nres-1) then - ngroup(indg)=2 - else - ngroup(indg)=1 - endif - do i=1,ngroup(indg) - igroup(1,i,indg)=i - igroup(2,i,indg)=j - igroup(3,i,indg)=k - enddo - enddo -ccccccccccccccccccccccccccccccccccccccccc - enddo -! Groups the ALPHAs and the BETAs - do k=1,numch - do j=2,nres-1 - if(itype(j).ne.10) then - indg=indg+1 - ngroup(indg)=2 - do i=1,ngroup(indg) - igroup(1,i,indg)=i+2 - igroup(2,i,indg)=j - igroup(3,i,indg)=k - enddo - endif - enddo - enddo - - ntotgr=indg - write(iout,*) - write(iout,*) "# of groups: ",ntotgr - do i=1,ntotgr - write(iout,41) i,ngroup(i),((igroup(k,j,i),k=1,3),j=1,ngroup(i)) - enddo -! close(iout) - - 40 format(i3,3x,3i3) - 41 format(2i3,3x,6(3i3,2x)) - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine make_ranvar(n,m,idum) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.BANK' -c al m=0 - print *,'HOHOHOHO Make_RanVar!!!!!',n,m - itrial=0 - do while(m.lt.n .and. itrial.le.10000) - itrial=itrial+1 - jeden=1 - call gen_rand_conf(jeden,*10) -! call intout - m=m+1 - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - enddo - dihang_in(2,nres-1,1,m)=0.0d0 - goto 20 - 10 write (iout,*) 'Failed to generate conformation #',m+1, - & ' itrial=',itrial - 20 continue - enddo - print *,'Make_RanVar!!!!! m=',m,' itrial=',itrial - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine make_ranvar_reg(n,idum) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.BANK' - include 'COMMON.GEO' - m=0 - print *,'HOHOHOHO Make_RanVar!!!!!' - itrial=0 - do while(m.lt.n .and. itrial.le.10000) - itrial=itrial+1 - jeden=1 - call gen_rand_conf(jeden,*10) -! call intout - m=m+1 - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - if(m.le.n*0.1) then - dihang_in(1,j,1,m)=90.0*deg2rad - dihang_in(2,j,1,m)=50.0*deg2rad - endif - enddo - dihang_in(2,nres-1,1,m)=0.0d0 - goto 20 - 10 write (iout,*) 'Failed to generate conformation #',m+1, - & ' itrial=',itrial - 20 continue - enddo - print *,'Make_RanVar!!!!! m=',m,' itrial=',itrial - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine from_pdb(n,idum) -c This subroutine stores the UNRES int variables generated from -c subroutine readpdb into the 1st conformation of in dihang_in. -c Subsequent n-1 conformations of dihang_in have identical values -c of theta and phi as the 1st conformation but random values for -c alph and omeg. -c The array cref (also generated from subroutine readpdb) is stored -c to crefjlee to be used for rmsd calculation in CSA, if necessary. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.BANK' - include 'COMMON.GEO' - - m=1 - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - enddo - dihang_in(2,nres-1,1,k)=0.0d0 - - do m=2,n - do k=2,nres-1 - dihang_in(1,k,1,m)=dihang_in(1,k,1,1) - dihang_in(2,k,1,m)=dihang_in(2,k,1,1) - if(dabs(dihang_in(3,k,1,1)).gt.1.d-6) then - dihang_in(3,k,1,m)=90.d0*ran1(idum)+90.d0 - dihang_in(3,k,1,m)=dihang_in(3,k,1,m)*deg2rad - endif - if(dabs(dihang_in(4,k,1,1)).gt.1.d-6) then - dihang_in(4,k,1,m)=360.d0*ran1(idum)-180.d0 - dihang_in(4,k,1,m)=dihang_in(4,k,1,m)*deg2rad - endif - enddo - enddo - -c Store cref to crefjlee (they are in COMMON.CHAIN). - do k=1,2*nres - do kk=1,3 - crefjlee(kk,k)=cref(kk,k) - enddo - enddo - - open(icsa_native_int,file=csa_native_int,status="old") - do m=1,n - write(icsa_native_int,*) m,e - write(icsa_native_int,200) - & (dihang_in(1,k,1,m)*rad2deg,k=2,nres-1) - write(icsa_native_int,200) - & (dihang_in(2,k,1,m)*rad2deg,k=2,nres-2) - write(icsa_native_int,200) - & (dihang_in(3,k,1,m)*rad2deg,k=2,nres-1) - write(icsa_native_int,200) - & (dihang_in(4,k,1,m)*rad2deg,k=2,nres-1) - enddo - - do k=1,nres - write(icsa_native_int,200) (crefjlee(i,k),i=1,3) - enddo - close(icsa_native_int) - - 200 format (8f10.4) - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine from_int(n,mm,idum) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.BANK' - include 'COMMON.GEO' - include 'COMMON.CONTACTS' - integer ilen - external ilen - logical fail - double precision energia(0:n_ene) - - open(icsa_native_int,file=csa_native_int,status="old") - read (icsa_native_int,*) - call read_angles(icsa_native_int,*10) - goto 11 - 10 write (iout,'(2a)') "CHUJ NASTAPIL - error in ", - & csa_native_int(:ilen(csa_native_int)) - 11 continue - call intout - do j=2,nres-1 - dihang_in(1,j,1,1)=theta(j+1) - dihang_in(2,j,1,1)=phi(j+2) - dihang_in(3,j,1,1)=alph(j) - dihang_in(4,j,1,1)=omeg(j) - enddo - dihang_in(2,nres-1,1,1)=0.0d0 - -c read(icsa_native_int,*) ind,e -c read(icsa_native_int,200) (dihang_in(1,k,1,1),k=2,nres-1) -c read(icsa_native_int,200) (dihang_in(2,k,1,1),k=2,nres-2) -c read(icsa_native_int,200) (dihang_in(3,k,1,1),k=2,nres-1) -c read(icsa_native_int,200) (dihang_in(4,k,1,1),k=2,nres-1) -c dihang_in(2,nres-1,1,1)=0.d0 - - maxsi=100 - maxcount_fail=100 - - do m=mm+2,n -c do k=2,nres-1 -c dihang_in(1,k,1,m)=dihang_in(1,k,1,1) -c dihang_in(2,k,1,m)=dihang_in(2,k,1,1) -c if(abs(dihang_in(3,k,1,1)).gt.1.d-3) then -c dihang_in(3,k,1,m)=90.d0*ran1(idum)+90.d0 -c endif -c if(abs(dihang_in(4,k,1,1)).gt.1.d-3) then -c dihang_in(4,k,1,m)=360.d0*ran1(idum)-180.d0 -c endif -c enddo -c call intout - fail=.true. - - icount_fail=0 - - DO WHILE (FAIL .AND. ICOUNT_FAIL .LE. MAXCOUNT_FAIL) - - do i=nnt,nct - if (itype(i).ne.10) then -cd print *,'i=',i,' itype=',itype(i),' theta=',theta(i+1) - fail=.true. - ii=0 - do while (fail .and. ii .le. maxsi) - call gen_side(itype(i),theta(i+1),alph(i),omeg(i),fail) - ii = ii+1 - enddo - endif - enddo - call chainbuild - call etotal(energia(0)) - fail = (energia(0).ge.1.0d20) - icount_fail=icount_fail+1 - - ENDDO - - if (icount_fail.gt.maxcount_fail) then - write (iout,*) - & 'Failed to generate non-overlaping near-native conf.', - & m - endif - - do j=2,nres-1 - dihang_in(1,j,1,m)=theta(j+1) - dihang_in(2,j,1,m)=phi(j+2) - dihang_in(3,j,1,m)=alph(j) - dihang_in(4,j,1,m)=omeg(j) - enddo - dihang_in(2,nres-1,1,m)=0.0d0 - enddo - -c do m=1,n -c write(icsa_native_int,*) m,e -c write(icsa_native_int,200) (dihang_in(1,k,1,m),k=2,nres-1) -c write(icsa_native_int,200) (dihang_in(2,k,1,m),k=2,nres-2) -c write(icsa_native_int,200) (dihang_in(3,k,1,m),k=2,nres-1) -c write(icsa_native_int,200) (dihang_in(4,k,1,m),k=2,nres-1) -c enddo -c close(icsa_native_int) - -c do m=mm+2,n -c do i=1,4 -c do j=2,nres-1 -c dihang_in(i,j,1,m)=dihang_in(i,j,1,m)*deg2rad -c enddo -c enddo -c enddo - - call dihang_to_c(dihang_in(1,1,1,1)) - -c Store c to cref (they are in COMMON.CHAIN). - do k=1,2*nres - do kk=1,3 - crefjlee(kk,k)=c(kk,k) - enddo - enddo - - call contact(.true.,ncont_ref,icont_ref,co) - -c do k=1,nres -c write(icsa_native_int,200) (crefjlee(i,k),i=1,3) -c enddo - close(icsa_native_int) - - 200 format (8f10.4) - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine dihang_to_c(aarray) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.VAR' - - dimension aarray(mxang,maxres,mxch) - -c do i=4,nres -c phi(i)=dihang_in(1,i-2,1,1) -c enddo - do i=2,nres-1 - theta(i+1)=aarray(1,i,1) - phi(i+2)=aarray(2,i,1) - alph(i)=aarray(3,i,1) - omeg(i)=aarray(4,i,1) - enddo - - call chainbuild - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc diff --git a/source/unres/src_MD/diff12.f b/source/unres/src_MD/diff12.f deleted file mode 100644 index 3d347ed..0000000 --- a/source/unres/src_MD/diff12.f +++ /dev/null @@ -1,27 +0,0 @@ -cccccccccccccccccccccccccccccccccc - subroutine get_diff12(aarray,barray,diff) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - dimension aarray(mxang,maxres,mxch), - & barray(mxang,maxres,mxch) - - diff=0.d0 - do k=1,numch - do j=2,nres-1 -c do i=1,4 -c do i=1,2 - do i=1,ndiff - dif=rad2deg*dabs(aarray(i,j,k)-barray(i,j,k)) - if(dif.gt.180.) dif=360.-dif - if (dif.gt.diffcut) diff=diff+dif - enddo - enddo - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc diff --git a/source/unres/src_MD/distfit.f b/source/unres/src_MD/distfit.f deleted file mode 100644 index 80e8fe4..0000000 --- a/source/unres/src_MD/distfit.f +++ /dev/null @@ -1,207 +0,0 @@ - subroutine distfit(debug,maxit) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - DIMENSION X(MAXRES),DIAGH(MAXRES),phiold(maxres) - logical debug,sing - -cinput------------------------------------ -c NX=NRES-3 -c NY=((NRES-4)*(NRES-5))/2 -cinput------------------------------------ -ctest MAXIT=20 - TOL=0.5 - MAXMAR=10 - RL=100.0 - - CALL TRANSFER(NRES,phi,phiold) - - F0=RDIF() - -cd WRITE (IOUT,*) 'DISTFIT: F0=',F0 - - - DO IT=1,MAXIT - CALL RDERIV - CALL HEVAL - - DO I=1,NX - DIAGH(I)=H(I,I) - ENDDO - RL=RL*0.1 - - DO IMAR=1,MAXMAR - DO I=1,NX - H(I,I)=DIAGH(I)+RL - ENDDO - CALL TRANSFER(NX,XX,X) - CALL BANACH(NX,MAXRES,H,X,sing) - AIN=0.0 - DO I=1,NX - AIN=AIN+DABS(X(I)) - ENDDO - IF (AIN.LT.0.1*TOL .AND. RL.LT.1.0E-4) THEN - if (debug) then - WRITE (IOUT,*) 'DISTFIT: CONVERGENCE HAS BEEN ACHIEVED' - WRITE (IOUT,*) 'IT=',it,'F=',F0 - endif - RETURN - ENDIF - DO I=4,NRES - phi(I)=phiold(I)+mask(i)*X(I-3) -c print *,X(I-3) - ENDDO - - F1=RDIF() -cd WRITE (IOUT,*) 'IMAR=',IMAR,' RL=',RL,' F1=',F1 - IF (F1.LT.F0) THEN - CALL TRANSFER(NRES,phi,phiold) - F0=F1 - GOTO 1 - ELSE IF (DABS(F1-F0).LT.1.0E-5) THEN - if (debug) then - WRITE (IOUT,*) 'DISTFIT: CANNOT IMPROVE DISTANCE FIT' - WRITE (IOUT,*) 'IT=',it,'F=',F1 - endif - RETURN - ENDIF - RL=RL*10.0 - ENDDO - WRITE (IOUT,*) 'DISTFIT: MARQUARDT PROCEDURE HAS FAILED' - WRITE (IOUT,*) 'IT=',it,'F=',F0 - CALL TRANSFER(NRES,phiold,phi) - RETURN - 1 continue -cd write (iout,*) "it",it," imar",imar," f0",f0 - enddo - WRITE (IOUT,*) 'DISTFIT: FINAL F=',F0,'after MAXIT=',maxit - return - END - - double precision FUNCTION RDIF() - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DISTFIT' - -c print *,'in rdif' - - suma=0.0 - ind=0 - call chainbuild - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if (w(ind).ne.0.0) then - DIJ=DIST(i,j) - suma=suma+w(ind)*(DIJ-d0(ind))*(DIJ-d0(ind)) - DD(ind)=DIJ -c print '(2i3,i4,4f12.2)',i,j,ind,dij,d0(ind),w(ind),suma - endif - enddo - enddo - - RDIF=suma - RETURN - END - - SUBROUTINE RDERIV - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DISTFIT' - include 'COMMON.GEO' - DIMENSION E12(3),R13(3),R24(3),PRODU(3) - - DO I=1,NY - DO J=1,NX - DRDG(I,J)=0.0 - ENDDO - ENDDO - DO I=1,NX - I1=I+1 - I2=I+2 - CALL VEC(I1,I2,E12) - DO J=1,I - DO K=1,3 - R13(K)=C(K,J)-C(K,I1) - ENDDO - DO K=I2+1,NRES - DO L=1,3 - R24(L)=C(L,K)-C(L,I2) - ENDDO - IND=((J-1)*(2*NRES-J-6))/2+K-3 - PRODU(1)=R13(2)*R24(3)-R13(3)*R24(2) - PRODU(2)=R13(3)*R24(1)-R13(1)*R24(3) - PRODU(3)=R13(1)*R24(2)-R13(2)*R24(1) - DRDG(IND,I)=SCALAR(E12,PRODU)/DIST(J,K) - ENDDO - ENDDO - ENDDO - RETURN - END - - SUBROUTINE HEVAL - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DISTFIT' - - DO I=1,NX - XI=0.0 - HII=0.0 - DO K=1,NY - BKI=DRDG(K,I) - BKIWK=w(K)*BKI - XI=XI+BKIWK*(D0(K)-DD(K)) - HII=HII+BKI*BKIWK - ENDDO - H(I,I)=HII - XX(I)=XI - DO J=I+1,NX - HIJ=0.0 - DO K=1,NY - HIJ=HIJ+DRDG(K,I)*DRDG(K,J)*w(K) - ENDDO - H(I,J)=HIJ - H(J,I)=HIJ - ENDDO - ENDDO - RETURN - END - - - SUBROUTINE VEC(I,J,U) -* -* Find the unit vector from atom (I) to atom (J). Store in U. -* - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - DIMENSION U(3) - - ANORM=0.0 - DO K=1,3 - UK=C(K,J)-C(K,I) - ANORM=ANORM+UK*UK - U(K)=UK - ENDDO - ANORM=SQRT(ANORM) - DO K=1,3 - U(K)=U(K)/ANORM - ENDDO - RETURN - END - - SUBROUTINE TRANSFER(N,X1,X2) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION X1(N),X2(N) - DO 1 I=1,N - 1 X2(I)=X1(I) - RETURN - END - diff --git a/source/unres/src_MD/energy_p_new-sep_barrier.F.org b/source/unres/src_MD/energy_p_new-sep_barrier.F.org deleted file mode 100644 index 3e87099..0000000 --- a/source/unres/src_MD/energy_p_new-sep_barrier.F.org +++ /dev/null @@ -1,2234 +0,0 @@ -C----------------------------------------------------------------------- - double precision function sscale(r) - double precision r,gamm - include "COMMON.SPLITELE" - if(r.lt.r_cut-rlamb) then - sscale=1.0d0 - else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then - gamm=(r-(r_cut-rlamb))/rlamb - sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) - else - sscale=0d0 - endif - return - end -C----------------------------------------------------------------------- - subroutine elj_long(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' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=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=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) - if (sss.lt.1.0d0) then - rrij=1.0D0/rij - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 - evdw=evdw+(1.0d0-sss)*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij)*(1.0d0-sss) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo -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 elj_short(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' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=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=itype(j) - 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 - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) - if (sss.gt.0.0d0) then - rrij=1.0D0/rij - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 - evdw=evdw+sss*evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij)*sss - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo -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_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJK potential of interaction. -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.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=itype(i) - itypi1=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=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - r_inv_ij=dsqrt(rrij) - rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) - if (sss.lt.1.0d0) then - r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) - fac=r_shift_inv**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e_augm+e1+e2 -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+(1.0d0-sss)*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) - fac=fac*(1.0d0-sss) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo - return - end -C----------------------------------------------------------------------------- - subroutine eljk_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJK potential of interaction. -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.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=itype(i) - itypi1=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=itype(j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - r_inv_ij=dsqrt(rrij) - rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) - if (sss.gt.0.0d0) then - r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) - fac=r_shift_inv**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e_augm+e1+e2 -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+sss*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) - fac=fac*sss - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo - endif - enddo ! j - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc(j,i)=expon*gvdwc(j,i) - gvdwx(j,i)=expon*gvdwx(j,i) - enddo - enddo - return - end -C----------------------------------------------------------------------------- - subroutine ebp_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Berne-Pechukas potential of interaction. -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.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - 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=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -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=itype(j) -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) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -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 - fac=(rrij*sigsq)**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -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_scale(1.0d0-sss) - endif - enddo ! j - enddo ! iint - enddo ! i -c stop - return - end -C----------------------------------------------------------------------------- - subroutine ebp_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Berne-Pechukas potential of interaction. -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.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - 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=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -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=itype(j) -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) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -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 - fac=(rrij*sigsq)**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -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_scale(sss) - endif - enddo ! j - enddo ! iint - enddo ! i -c stop - return - end -C----------------------------------------------------------------------------- - subroutine egb_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne potential of interaction. -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.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - logical lprn - 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 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -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) - ind=ind+1 - itypj=itype(j) -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) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -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 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt -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*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij - -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -c fac=0.0d0 -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) - endif - enddo ! j - enddo ! iint - enddo ! i -c write (iout,*) "Number of loop steps in EGB:",ind -cccc energy_dec=.false. - return - end -C----------------------------------------------------------------------------- - subroutine egb_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne potential of interaction. -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.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - logical lprn - 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 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -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) - ind=ind+1 - itypj=itype(j) -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) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -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 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt -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(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij - endif - - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij - -C Calculate gradient components. - e1=e1*eps1*eps2rt**2*eps3rt**2 - fac=-expon*(e1+evdwij)*rij_shift - sigder=fac*sigder - fac=rij*fac -c fac=0.0d0 -C Calculate the radial part of the gradient - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac -C Calculate angular part of the gradient. - call sc_grad_scale(sss) - endif - enddo ! j - enddo ! iint - enddo ! i -c write (iout,*) "Number of loop steps in EGB:",ind -cccc energy_dec=.false. - return - end -C----------------------------------------------------------------------------- - subroutine egbv_long(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne-Vorobjev potential of interaction. -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.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - 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=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -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=itype(j) -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) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.lt.1.0d0) then - -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(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*(1.0d0-sss) - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0), - & chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij+e_augm - endif -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 -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_scale(1.0d0-sss) - endif - enddo ! j - enddo ! iint - enddo ! i - end -C----------------------------------------------------------------------------- - subroutine egbv_short(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the Gay-Berne-Vorobjev potential of interaction. -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.NAMES' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - 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=itype(i) - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -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=itype(j) -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) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - - if (sss.gt.0.0d0) then - -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(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=eps1*eps2rt*eps3rt*(e1+e2) - eps2der=evdwij*eps3rt - eps3der=evdwij*eps2rt - fac_augm=rrij**expon - e_augm=augm(itypi,itypj)*fac_augm - evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*sss - if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) - write (iout,'(2(a3,i3,2x),17(0pf7.3))') - & restyp(itypi),i,restyp(itypj),j, - & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0), - & chi1,chi2,chip1,chip2, - & eps1,eps2rt**2,eps3rt**2, - & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, - & evdwij+e_augm - endif -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 -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_scale(sss) - endif - enddo ! j - enddo ! iint - enddo ! i - end -C---------------------------------------------------------------------------- - subroutine sc_grad_scale(scalfac) - 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) - double precision scalfac - 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))*scalfac - enddo -c write (iout,*) "gg",(gg(k),k=1,3) - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac - gvdwx(k,j)=gvdwx(k,j)+gg(k) - & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac -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 - do l=1,3 - gvdwc(l,i)=gvdwc(l,i)-gg(l) - gvdwc(l,j)=gvdwc(l,j)+gg(l) - enddo - return - end -C-------------------------------------------------------------------------- - subroutine eelec_scale(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' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - include 'COMMON.TIME1' - 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) - 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 - do i=iturn3_start,iturn3_end - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 - call eelecij_scale(i,i+2,ees,evdw1,eel_loc) - if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) - num_cont_hb(i)=num_conti - enddo - do i=iturn4_start,iturn4_end - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=num_cont_hb(i) - call eelecij_scale(i,i+3,ees,evdw1,eel_loc) - if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4) - num_cont_hb(i)=num_conti - enddo ! i -c -c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 -c - do i=iatel_s,iatel_e - 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 write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) - num_conti=num_cont_hb(i) - do j=ielstart(i),ielend(i) - call eelecij_scale(i,j,ees,evdw1,eel_loc) - enddo ! j - num_cont_hb(i)=num_conti - enddo ! i -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_scale(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' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - include 'COMMON.TIME1' - 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) - 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/ -c time00=MPI_Wtime() -cd write (iout,*) "eelecij",i,j - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - ael6i=ael6(iteli,itelj) - ael3i=ael3(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - rmij=1.0D0/rij -c For extracting the short-range part of Evdwpp - sss=sscale(rij/rpp(iteli,itelj)) - - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj - cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij - cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij - fac=cosa-3.0D0*cosb*cosg - ev1=aaa*r6ij*r6ij -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 - 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) - ees=ees+eesij - evdw1=evdw1+evdwij*(1.0d0-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,f7.3)') 'evdw1',i,j,evdwij,sss - write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij - endif - -C -C Calculate contributions to the Cartesian gradient. -C -#ifdef SPLITELE - facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss) - facel=-3*rrmij*(el1+eesij) - fac1=fac - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=facel*xj - ggg(2)=facel*yj - ggg(3)=facel*zj -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_long(k,j)+ggg(k) - gelc_long(k,i)=gelc_long(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 - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj -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 - facvdw=ev1+evdwij*(1.0d0-sss) - facel=el1+eesij - fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij -* -* Radial derivatives. First process both termini of the fragment (i,j) -* - ggg(1)=fac*xj - ggg(2)=fac*yj - ggg(3)=fac*zj -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 - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo -#endif -* -* Angular part -* - ecosa=2.0D0*fac3*fac1+fac4 - fac4=-3.0D0*fac4 - fac3=-6.0D0*fac3 - ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) - ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo -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) - 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 - do k=1,3 - gelc(k,i)=gelc(k,i) - & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gelc(k,j)=gelc(k,j) - & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gelc_long(k,j)=gelc_long(k,j)+ggg(k) - gelc_long(k,i)=gelc_long(k,i)-ggg(k) - enddo - IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 - & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN -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 - do k=1,2 - do l=1,2 - kkk=kkk+1 - muij(kkk)=mu(k,i)*mu(l,j) - enddo - enddo -cd write (iout,*) 'EELEC: i',i,' j',j -cd write (iout,*) 'j',j,' j1',j1,' j2',j2 -cd write(iout,*) 'muij',muij - ury=scalar(uy(1,i),erij) - urz=scalar(uz(1,i),erij) - vry=scalar(uy(1,j),erij) - vrz=scalar(uz(1,j),erij) - a22=scalar(uy(1,i),uy(1,j))-3*ury*vry - a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz - a32=scalar(uz(1,i),uy(1,j))-3*urz*vry - a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz - fac=dsqrt(-ael6i)*r3ij - a22=a22*fac - a23=a23*fac - a32=a32*fac - a33=a33*fac -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) -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 - - 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) - 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) -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) - 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) - gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ - & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) - gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ - & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) - gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ - & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) - enddo - ENDIF -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 - ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) - ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) -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) - gacontp_hb2(k,num_conti,i)=!ghalfp - & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontp_hb3(k,num_conti,i)=gggp(k) - gacontm_hb1(k,num_conti,i)=!ghalfm - & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - gacontm_hb2(k,num_conti,i)=!ghalfm - & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - gacontm_hb3(k,num_conti,i)=gggm(k) - enddo - ENDIF ! wcorr - endif ! num_conti.le.maxconts - endif ! fcont.gt.0 - endif ! j.gt.i+1 - if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then - do k=1,4 - do l=1,3 - ghalf=0.5d0*agg(l,k) - aggi(l,k)=aggi(l,k)+ghalf - aggi1(l,k)=aggi1(l,k)+agg(l,k) - aggj(l,k)=aggj(l,k)+ghalf - enddo - enddo - if (j.eq.nres-1 .and. i.lt.j-2) then - do k=1,4 - do l=1,3 - aggj1(l,k)=aggj1(l,k)+agg(l,k) - enddo - enddo - endif - endif -c t_eelecij=t_eelecij+MPI_Wtime()-time00 - return - end -C----------------------------------------------------------------------- - subroutine evdwpp_short(evdw1) -C -C Compute Evdwpp -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' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VECTORS' - include 'COMMON.FFIELD' - dimension ggg(3) -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 - evdw1=0.0D0 -c write (iout,*) "iatel_s_vdw",iatel_s_vdw, -c & " iatel_e_vdw",iatel_e_vdw - call flush(iout) - do i=iatel_s_vdw,iatel_e_vdw - dxi=dc(1,i) - dyi=dc(2,i) - dzi=dc(3,i) - dx_normi=dc_norm(1,i) - dy_normi=dc_norm(2,i) - dz_normi=dc_norm(3,i) - xmedi=c(1,i)+0.5d0*dxi - ymedi=c(2,i)+0.5d0*dyi - zmedi=c(3,i)+0.5d0*dzi - num_conti=0 -c write (iout,*) 'i',i,' ielstart',ielstart_vdw(i), -c & ' ielend',ielend_vdw(i) - call flush(iout) - do j=ielstart_vdw(i),ielend_vdw(i) - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - sss=sscale(rij/rpp(iteli,itelj)) - if (sss.gt.0.0d0) then - rmij=1.0D0/rij - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - ev1=aaa*r6ij*r6ij -c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - evdwij=ev1+ev2 - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss - endif - evdw1=evdw1+evdwij*sss -C -C Calculate contributions to the Cartesian gradient. -C - facvdw=-6*rrmij*(ev1+evdwij)*sss - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo - endif - enddo ! j - enddo ! i - return - end -C----------------------------------------------------------------------------- - subroutine escp_long(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) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - - if (sss.lt.1.0d0) then - - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss) - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij*(1.0d0-sss) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij*(1.0d0-sss) - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -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 -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - endif - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -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 escp_short(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) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - - if (sss.gt.0.0d0) then - - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*sss - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij*sss - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij*sss - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -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 -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - endif - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -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 diff --git a/source/unres/src_MD/energy_p_new_barrier.F b/source/unres/src_MD/energy_p_new_barrier.F index 51fbd11..85e3dbc 100644 --- a/source/unres/src_MD/energy_p_new_barrier.F +++ b/source/unres/src_MD/energy_p_new_barrier.F @@ -493,8 +493,9 @@ cMS$ATTRIBUTES C :: proc_proc #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) + write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)') + & i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3), + & (gvdwcT(j,i),j=1,3) enddo call flush(iout) #endif @@ -527,6 +528,21 @@ c enddo call flush(iout) #endif #ifdef SPLITELE +#ifdef TSCSC + do i=1,nct + do j=1,3 + gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+ + & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ + & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ + & wel_loc*gel_loc_long(j,i)+ + & wcorr*gradcorr_long(j,i)+ + & wcorr5*gradcorr5_long(j,i)+ + & wcorr6*gradcorr6_long(j,i)+ + & wturn6*gcorr6_turn_long(j,i)+ + & wstrain*ghpbc(j,i) + enddo + enddo +#else do i=1,nct do j=1,3 gradbufc(j,i)=wsc*gvdwc(j,i)+ @@ -540,6 +556,7 @@ c enddo & wstrain*ghpbc(j,i) enddo enddo +#endif #else do i=1,nct do j=1,3 @@ -571,6 +588,16 @@ c enddo 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 @@ -585,6 +612,17 @@ c time_allreduce=time_allreduce+MPI_Wtime()-time00 & " 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 @@ -623,6 +661,16 @@ c time_allreduce=time_allreduce+MPI_Wtime()-time00 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 @@ -677,11 +725,20 @@ c time_allreduce=time_allreduce+MPI_Wtime()-time00 & wsccor*gsccorc(j,i) & +wscloc*gscloc(j,i) #endif +#ifdef TSCSC + gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(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) +#else 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) +#endif enddo enddo #ifdef DEBUG @@ -764,6 +821,10 @@ c do i=1,nct gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm +#ifdef TSCSC + gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i))) + if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm +#endif 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 @@ -802,6 +863,10 @@ c 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 +#ifdef TSCSC + gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i))) + if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm +#endif 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 diff --git a/source/unres/src_MD/energy_p_new_barrier.F.org b/source/unres/src_MD/energy_p_new_barrier.F.org deleted file mode 100644 index cdaadba..0000000 --- a/source/unres/src_MD/energy_p_new_barrier.F.org +++ /dev/null @@ -1,8812 +0,0 @@ - subroutine etotal(energia) - implicit real*8 (a-h,o-z) - 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) -#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.CONTROL' - include 'COMMON.TIME1' -#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 -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) - endif - time_Bcast=time_Bcast+MPI_Wtime()-time00 - time_Bcastw=time_Bcastw+MPI_Wtime()-time00 -c call chainbuild_cart - 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 - 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) - 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 -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 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 -c write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, - & eello_turn4) - 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 print *,'Calling EHPB' - call edis(ehpb) -cd print *,'EHPB exitted succesfully.' -C -C Calculate the virtual-bond-angle energy. -C - if (wang.gt.0d0) then - call ebend(ebe) - else - ebe=0 - endif -c print *,"Processor",myrank," computed UB" -C -C Calculate the SC local energy. -C - call esc(escloc) -c print *,"Processor",myrank," computed USC" -C -C Calculate the virtual-bond torsional energy. -C -cd print *,'nterm=',nterm - if (wtor.gt.0) then - call etor(etors,edihcnstr) - else - etors=0 - edihcnstr=0 - endif -c print *,"Processor",myrank," computed Utor" -C -C 6/23/01 Calculate double-torsional energy -C - if (wtor_d.gt.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 *,"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) -cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1, -cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -cd write (iout,*) "multibody_hb ecorr",ecorr - endif -c print *,"Processor",myrank," computed Ucorr" -C -C If performing constraint dynamics, call the constraint energy -C after the equilibration time - if(usampl.and.totT.gt.eq_time) then - call EconstrQ - call Econstr_back - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -#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 -c print *," Processor",myrank," calls SUM_ENERGY" - call sum_energy(energia,.true.) -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 real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" -#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 -#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) -#ifdef SPLITELE - etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#else - etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#endif - energia(0)=etot -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 real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include 'mpif.h' - double precision gradbufc(3,maxres),gradbufx(3,maxres), - & glocbuf(4*maxres),gradbufc_sum(3,maxres) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - include 'COMMON.MAXGRAD' -#ifdef TIMING - time01=MPI_Wtime() -#endif -#ifdef DEBUG - write (iout,*) "sum_gradient gvdwc, gvdwx" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI -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 SPLITELE - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i) - enddo - enddo -#else - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+ - & wbond*gradb(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i) - enddo - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -#ifdef DEBUG - write (iout,*) "gradbufc before allreduce" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG - write (iout,*) "gradbufc_sum after allreduce" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef TIMING - time_allreduce=time_allreduce+MPI_Wtime()-time00 -#endif - do i=nnt,nres - do k=1,3 - gradbufc(k,i)=0.0d0 - enddo - enddo - do i=igrad_start,igrad_end - do j=jgrad_start(i),jgrad_end(i) - do k=1,3 - gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) - enddo - enddo - enddo - 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=nnt,nres-1 - do k=1,3 - gradbufc(k,i)=0.0d0 - enddo - do j=i+1,nres - do k=1,3 - gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) - enddo - enddo - enddo -#ifdef MPI - endif -#endif - do k=1,3 - gradbufc(k,nres)=0.0d0 - enddo - do i=1,nct - do j=1,3 -#ifdef SPLITELE - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i))+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) -#else - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i) - & wel_loc*gel_loc_long(j,i)+ - & 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) -#endif - gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*gsccorx(j,i) - & +wscloc*gsclocx(j,i) - enddo - enddo -#ifdef DEBUG - write (iout,*) "gloc before adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) - & +wcorr5*g_corr5_loc(i) - & +wcorr6*g_corr6_loc(i) - & +wturn4*gel_loc_turn4(i) - & +wturn3*gel_loc_turn3(i) - & +wturn6*gel_loc_turn6(i) - & +wel_loc*gel_loc_loc(i) - & +wsccor*gsccor_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 - 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 -#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) gcorr6_max=gradcorr6_norm - gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i), - & gcorr6_turn(1,i))) - if (gcorr6_turn_norm.gt.gcorr6_turn_max) - & gcorr6_turn_max=gcorr6_turn_norm - gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) - if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm - gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) - if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm - gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) - if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm - gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) - if (gradx_scp_norm.gt.gradx_scp_max) - & gradx_scp_max=gradx_scp_norm - ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) - if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm - gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) - if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm - gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) - if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm - gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) - if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm - enddo - if (gradout) then -#ifdef AIX - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif - write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max, - & gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max - close(istat) - if (gvdwc_max.gt.1.0d4) then - write (iout,*) "gvdwc gvdwx gradb gradbx" - do i=nnt,nct - write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i), - & gradb(j,i),gradbx(j,i),j=1,3) - enddo - call pdbout(0.0d0,'cipiszcze',iout) - call flush(iout) - endif - endif - endif -#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 real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - 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 - 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 - - return - end -C------------------------------------------------------------------------ - subroutine enerprint(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.MD' - double precision energia(0:n_ene) - etot=energia(0) - evdw=energia(1) - evdw2=energia(2) -#ifdef SCP14 - evdw2=energia(2)+energia(18) -#else - evdw2=energia(2) -#endif - ees=energia(3) -#ifdef SPLITELE - evdw1=energia(16) -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eello_turn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor, - & edihcnstr,ebr*nss, - & Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST= ',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#else - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr, - & ebr*nss,Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST=',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#endif - return - end -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 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' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - itypi1=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=itype(j) - 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 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - 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,aa(itypi,itypj), -cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo -cgrad do k=i,j-1 -cgrad do l=1,3 -cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) -cgrad enddo -cgrad enddo -C -C 12/1/95, revised on 5/20/97 -C -C Calculate the contact function. The ith column of the array JCONT will -C contain the numbers of atoms that make contacts with the atom I (of numbers -C greater than I). The arrays FACONT and GACONT will contain the values of -C the contact function and its derivative. -C -C Uncomment next line, if the correlation interactions include EVDW explicitly. -c if (j.gt.i+1 .and. evdwij.le.0.0D0) then -C Uncomment next line, if the correlation interactions are contact function only - if (j.gt.i+1.and. eps0ij.gt.0.0D0) then - rij=dsqrt(rij) - sigij=sigma(itypi,itypj) - r0ij=rs0(itypi,itypj) -C -C Check whether the SC's are not too far to make a contact. -C - rcut=1.5d0*r0ij - call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) -C Add a new contact, if the SC's are close enough, but not too close (ri' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - 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' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -cgrad if (j.lt.i) then -cd write (iout,*) 'ji' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -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' - dimension ggg(3) - ehpb=0.0D0 -cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr -cd write(iout,*)'link_start=',link_start,' link_end=',link_end - if (link_end.eq.0) return - 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 - jjj=jj-nres - else - iii=ii - jjj=jj - endif -cd write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj -C 24/11/03 AL: SS bridges handled separately because of introducing a specific -C distance and angle dependent SS bond potential. - if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then - call ssbond_ene(iii,jjj,eij) - ehpb=ehpb+2*eij -cd write (iout,*) "eij",eij - else -C Calculate the distance between the two points and its difference from the -C target distance. - dd=dist(ii,jj) - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd -cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, -cd & ' waga=',waga,' fac=',fac - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -C If this is a SC-SC distance, we need to calculate the contributions to the -C Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif -cgrad do j=iii,jjj-1 -cgrad do k=1,3 -cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k) -cgrad enddo -cgrad enddo - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - endif - enddo - ehpb=0.5D0*ehpb - 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=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=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 -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 - do i=ibondp_start,ibondp_end - diff = vbld(i)-vbldp0 -c write (iout,*) 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) - enddo - estr=0.5d0*AKP*estr -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=itype(i) - if (iti.ne.10) then - nbi=nbondterm(iti) - if (nbi.eq.1) then - diff=vbld(i+nres)-vbldsc0(1,iti) -c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, -c & 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' - 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 -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) - if (i.gt.3) 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) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) - z(1)=cos(phii1) -#else - phii1=phi(i+1) - z(1)=dcos(phii1) -#endif - z(2)=dsin(phii1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif -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) - bthetk=bthet(k,it) - thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) - enddo - dthett=thet_pred_mean*ssd - thet_pred_mean=thet_pred_mean*ss+a0thet(it) -C Derivatives of the "mean" values in gamma1 and gamma2. - dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss - dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss - if (theta(i).gt.pi-delta) then - call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, - & E_tc0) - call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) - call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, - & E_theta) - call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else if (theta(i).lt.delta) then - call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) - call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, - & E_theta) - call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) - call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else - call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, - & E_theta,E_tc) - endif - etheta=etheta+ethetai - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'ebend',i,ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 - gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) - enddo -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 distribution. - 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 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 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' - 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 - dethetai=0.0d0 - dephii=0.0d0 - dephii1=0.0d0 - theti2=0.5d0*theta(i) - ityp2=ithetyp(itype(i-1)) - do k=1,nntheterm - coskt(k)=dcos(k*theti2) - sinkt(k)=dsin(k*theti2) - enddo - if (i.gt.3) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - ityp1=ithetyp(itype(i-2)) - do k=1,nsingle - cosph1(k)=dcos(k*phii) - sinph1(k)=dsin(k*phii) - enddo - else - phii=0.0d0 - ityp1=nthetyp+1 - do k=1,nsingle - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - endif - if (i.lt.nres) 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=nthetyp+1 - do k=1,nsingle - cosph2(k)=0.0d0 - sinph2(k)=0.0d0 - enddo - endif - ethetai=aa0thet(ityp1,ityp2,ityp3) - 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)*sinkt(k) - dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3) - & *coskt(k) - if (lprn) - & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), - & " ethetai",ethetai - enddo - if (lprn) then - write (iout,*) "cosph and sinph" - do k=1,nsingle - write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) - enddo - write (iout,*) "cosph1ph2 and sinph2ph2" - do k=2,ndouble - do l=1,k-1 - write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), - & sinph1ph2(l,k),sinph1ph2(k,l) - enddo - enddo - write(iout,*) "ethetai",ethetai - endif - do m=1,ntheterm2 - do k=1,nsingle - aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k) - & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k) - & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k) - & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*aux*coskt(m) - dephii=dephii+k*sinkt(m)*( - & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- - & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) - dephii1=dephii1+k*sinkt(m)*( - & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- - & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) - if (lprn) - & write (iout,*) "m",m," k",k," bbthet", - & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", - & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", - & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", - & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai - enddo - enddo - if (lprn) - & write(iout,*) "ethetai",ethetai - do m=1,ntheterm3 - do k=2,ndouble - do l=1,k-1 - aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*coskt(m)*aux - dephii=dephii+l*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)- - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - dephii1=dephii1+(k-l)*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)- - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - if (lprn) then - write (iout,*) "m",m," k",k," l",l," ffthet", - & ffthet(l,k,m,ityp1,ityp2,ityp3), - & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", - & ggthet(l,k,m,ityp1,ityp2,ityp3), - & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai - write (iout,*) cosph1ph2(l,k)*sinkt(m), - & cosph1ph2(k,l)*sinkt(m), - & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) - endif - enddo - enddo - enddo -10 continue - if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') - & i,theta(i)*rad2deg,phii*rad2deg, - & phii1*rad2deg,ethetai - etheta=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)=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.10) goto 1 - nlobit=nlob(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,it)-0.5D0*contr(j,iii)+emin - if(adexp.ne.adexp) adexp=1.0 - expfac=dexp(adexp) -#else - expfac=dexp(bsc(j,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,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 - 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.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) - 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=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 = -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 -#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 - 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 -#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 -#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 -#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 -#endif -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)*dC_norm(j,i+nres) - dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) - enddo - - dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) - dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) - dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) -c - dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) - dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) - enddo - - do k=1,3 - dXX_Ctab(k,i)=dXX_Ci(k) - dXX_C1tab(k,i)=dXX_Ci1(k) - dYY_Ctab(k,i)=dYY_Ci(k) - dYY_C1tab(k,i)=dYY_Ci1(k) - dZZ_Ctab(k,i)=dZZ_Ci(k) - dZZ_C1tab(k,i)=dZZ_Ci1(k) - dXX_XYZtab(k,i)=dXX_XYZ(k) - dYY_XYZtab(k,i)=dYY_XYZ(k) - dZZ_XYZtab(k,i)=dZZ_XYZ(k) - enddo - - do k = 1,3 -c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", -c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) -c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", -c & dyy_ci(k)," dzz_ci",dzz_ci(k) -c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", -c & dt_dci(k) -c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", -c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) - 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,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - 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 - 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 -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 - do i=1,ndih_constr - itori=idih_constr(i) - phii=phi(itori) - difi=phii-phi0(i) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - endif -! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -! write (iout,*) 'edihcnstr',edihcnstr - return - end -c------------------------------------------------------------------------------ - subroutine etor_d(etors_d) - etors_d=0.0d0 - return - end -c---------------------------------------------------------------------------- -#else - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - 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 - 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) - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - 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) - 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) - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'etor',i,etors_ii-v0(itori,itori1) - 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 -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 -c do i=1,ndih_constr - do i=idihconstr_start,idihconstr_end - itori=idih_constr(i) - phii=phi(itori) - difi=pinorm(phii-phi0(i)) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else - difi=0.0 - endif -cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, -cd & rad2deg*phi0(i), rad2deg*drange(i), -cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -cd write (iout,*) 'edihcnstr',edihcnstr - 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 - do i=iphid_start,iphid_end - 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 -C Regular cosine and sine terms - do j=1,ntermd_1(itori,itori1,itori2) - v1cij=v1c(1,j,itori,itori1,itori2) - v1sij=v1s(1,j,itori,itori1,itori2) - v2cij=v1c(2,j,itori,itori1,itori2) - v2sij=v1s(2,j,itori,itori1,itori2) - 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) - do l=1,k-1 - v1cdij = v2c(k,l,itori,itori1,itori2) - v2cdij = v2c(l,k,itori,itori1,itori2) - v1sdij = v2s(k,l,itori,itori1,itori2) - v2sdij = v2s(l,k,itori,itori1,itori2) - 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------------------------------------------------------------------------------ - 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",iphi_start,iphi_end,nterm_sccor - esccor=0.0D0 - do i=iphi_start,iphi_end - esccor_ii=0.0D0 - itori=itype(i-2) - itori1=itype(i-1) - phii=phi(i) - gloci=0.0D0 - do j=1,nterm_sccor - v1ij=v1sccor(j,itori,itori1) - v2ij=v2sccor(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - esccor=esccor+v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - 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, - & (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6) - gsccor_loc(i-3)=gsccor_loc(i-3)+gloci - 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 real*8 (a-h,o-z) - 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 real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - 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.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 - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -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 - 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" - 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 - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 -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 - 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" - 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.CHAIN' - include 'COMMON.CONTROL' - 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 - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -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 - 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" - 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 - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 - ecorr5=0.0d0 - ecorr6=0.0d0 -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) - 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" - 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' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont_hb(jj,i) - ekl=facont_hb(kk,k) - ees0pij=ees0p(jj,i) - ees0pkl=ees0p(kk,k) - ees0mij=ees0m(jj,i) - ees0mkl=ees0m(kk,k) - ekont=eij*ekl - ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) -cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) -C Following 4 lines for diagnostics. -cd ees0pkl=0.0D0 -cd ees0pij=1.0D0 -cd ees0mkl=0.0D0 -cd ees0mij=1.0D0 -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. - 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 - ehbcorr=ekont*ees - 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 = itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - do iii=1,2 - dipi(iii,1)=Ub2(iii,i) - dipderi(iii)=Ub2der(iii,i) - dipi(iii,2)=b1(iii,iti1) - dipj(iii,1)=Ub2(iii,j) - dipderj(iii)=Ub2der(iii,j) - dipj(iii,2)=b1(iii,itj1) - enddo - kkk=0 - do iii=1,2 - call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) - do jjj=1,2 - kkk=kkk+1 - dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - do kkk=1,5 - do lll=1,3 - mmm=0 - do iii=1,2 - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), - & auxvec(1)) - do jjj=1,2 - mmm=mmm+1 - dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - enddo - enddo - call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) - call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) - do iii=1,2 - dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) - enddo - call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) - do iii=1,2 - dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) - enddo - return - end -#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.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=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itj=itortyp(itype(j)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -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)) - 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,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) -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,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - else -C Antiparallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif -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,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) -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,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -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.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)) - else - gcorr_loc(j-1)=gcorr_loc(j-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) - & -EAEAderx(2,2,lll,kkk,iii,1) -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=itortyp(itype(k)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - eello5_1=0.0d0 - eello5_2=0.0d0 - eello5_3=0.0d0 - eello5_4=0.0d0 -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,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) -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,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - else - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - endif -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,itk)) - & -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,itl),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) -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,itl)) - & -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,itl)) - & -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,itj),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) -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,itj)) - & -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,itj)) - & -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)+ghalf+ekont*derx(ll,2,2) - gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) - gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) - gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) - gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl - gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl - enddo -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 Parallel Antiparallel -C -C o o -C /l\ /j\ -C / \ / \ -C /| o | | o |\ -C \ j|/k\| / \ |/k\|l / -C \ / \ / \ / \ / -C o o o o -C i i -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - itk=itortyp(itype(k)) - s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) - vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) -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,itk)-AEAb1derg(2,2,imat)*b1(2,itk) - vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) - if (l.eq.j+1) then - g_corr6_loc(l-1)=g_corr6_loc(l-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - endif - call transpose2(EUgCder(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) - & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) - & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) - do iii=1,2 - if (swap) then - ind=3-iii - else - ind=iii - endif - do kkk=1,5 - do lll=1,3 - s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) - & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) - vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) - & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) - derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) - enddo - enddo - enddo - return - end -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(1),auxmat1(2,2) - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Parallel Antiparallel -C -C o o -C \ /l\ /j\ / -C \ / \ / \ / -C o| o | | o |o -C \ j|/k\| \ |/k\|l -C \ / \ \ / \ -C o o -C i i -C -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.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Parallel Antiparallel -C -C o o -C /l\ / \ /j\ -C / \ / \ / \ -C /| o |o o| o |\ -C j|/k\| / |/k\|l / -C / \ / / \ / -C / o / o -C i i -C -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=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -#ifdef MOMENT - s1=dip(4,jj,i)*dip(4,kk,k) -#endif - call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -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,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) -C Derivatives in gamma(l-1) - call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) -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,itk1), - & auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif -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.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 Parallel Antiparallel -C -C o o -C /l\ / \ /j\ -C / \ / \ / \ -C /| o |o o| o |\ -C \ j|/k\| \ |/k\|l -C \ / \ \ / \ -C o \ o \ -C i i -C -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=itortyp(itype(i)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - if (k.lt.nres-1) then - itk1=itortyp(itype(k+1)) - else - itk1=ntortyp+1 - endif - itl=itortyp(itype(l)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -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,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) -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,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -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,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif - endif -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,itj1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) - else - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itl1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) - endif - call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (swap) then - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s1+s2+s4) -#else - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s2+s4) -#endif - derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 - else -#ifdef MOMENT - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) -#else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) -#endif - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - else -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (l.eq.j+1) then - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - endif - endif - enddo - enddo - enddo - return - end -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=itortyp(itype(i)) - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(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,itl)) - s1 = (auxmat(1,1)+auxmat(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) - s2 = scalar2(b1(1,itk),vtemp1(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atemp(1,1)) - call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) - call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) - s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) - s12 = scalar2(Ub2(1,i+2),vtemp3(1)) -#ifdef MOMENT - call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) - call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) - call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) - ss13 = scalar2(b1(1,itk),vtemp4(1)) - s13 = (gtemp(1,1)+gtemp(2,2))*ss13 -#endif -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,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -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,itl)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d -#endif - call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) - s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) -#endif - s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -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,itl),vtemp1d(1)) - call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d -#endif -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,itl),vtemp1(1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), - & vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))* - & scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), - & auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -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,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d - derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d - enddo - enddo -#endif -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 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 - diff --git a/source/unres/src_MD/energy_split-sep.F.org b/source/unres/src_MD/energy_split-sep.F.org deleted file mode 100644 index 24ab8dd..0000000 --- a/source/unres/src_MD/energy_split-sep.F.org +++ /dev/null @@ -1,472 +0,0 @@ - subroutine etotal_long(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c -c Compute the long-range slow-varying contributions to the energy -c -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.MD' -c write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot - if (modecalc.eq.12.or.modecalc.eq.14) then -#ifdef MPI -c if (fg_rank.eq.0) call int_from_cart1(.false.) -#else - call int_from_cart1(.false.) -#endif - endif -#ifdef MPI -c write(iout,*) "ETOTAL_LONG Processor",fg_rank, -c & " absolute rank",myrank," nfgtasks",nfgtasks - call flush(iout) - 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(3,1,MPI_INTEGER,king,FG_COMM,IERROR) -c write (iout,*) "Processor",myrank," BROADCAST iorder" -c call flush(iout) -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 -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) - endif - call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 - time_Bcastw=time_Bcastw+MPI_Wtime()-time00 -c call chainbuild_cart -c call int_from_cart1(.false.) - endif -c write (iout,*) 'Processor',myrank, -c & ' calling etotal_short ipot=',ipot -c call flush(iout) -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#endif -cd print *,'nnt=',nnt,' nct=',nct -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj_long(evdw) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk_long(evdw) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp_long(evdw) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb_long(evdw) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv_long(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 - call vec_and_deriv - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#endif - call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4) - else - ees=0 - evdw1=0 - eel_loc=0 - eello_turn3=0 - eello_turn4=0 - endif - else -c write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, - & eello_turn4) - endif -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_long(evdw2,evdw2_14) - else - evdw2=0 - evdw2_14=0 - endif - else - call escp_soft_sphere(evdw2,evdw2_14) - endif -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,*) 'n_corr=',n_corr,' n_corr1=',n_corr1, -c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) - endif -C -C If performing constraint dynamics, call the constraint energy -C after the equilibration time - if(usampl.and.totT.gt.eq_time) then - call EconstrQ - call Econstr_back - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -C -C Sum the energies -C - do i=1,n_ene - energia(i)=0.0d0 - enddo - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(20)=Uconst+Uconst_back - call sum_energy(energia,.true.) -c write (iout,*) "Exit ETOTAL_LONG" - call flush(iout) - return - end -c------------------------------------------------------------------------------ - subroutine etotal_short(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -c -c Compute the short-range fast-varying contributions to the energy -c -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - -c write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot -c call flush(iout) - if (modecalc.eq.12.or.modecalc.eq.14) then -#ifdef MPI - if (fg_rank.eq.0) call int_from_cart1(.false.) -#else - call int_from_cart1(.false.) -#endif - endif -#ifdef MPI -c write(iout,*) "ETOTAL_SHORT Processor",fg_rank, -c & " absolute rank",myrank," nfgtasks",nfgtasks -c call flush(iout) - 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(2,1,MPI_INTEGER,king,FG_COMM,IERROR) -c write (iout,*) "Processor",myrank," BROADCAST iorder" -c call flush(iout) -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 -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) - endif -c write (iout,*),"Processor",myrank," BROADCAST weights" - call MPI_Bcast(c(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST c" - call MPI_Bcast(dc(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST dc" - call MPI_Bcast(dc_norm(1,1),maxres6,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST dc_norm" - call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST theta" - call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST phi" - call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST alph" - call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST omeg" - call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) -c write (iout,*) "Processor",myrank," BROADCAST vbld" - call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION, - & king,FG_COMM,IERR) - time_Bcast=time_Bcast+MPI_Wtime()-time00 -c write (iout,*) "Processor",myrank," BROADCAST vbld_inv" - endif -c write (iout,*) 'Processor',myrank, -c & ' calling etotal_short ipot=',ipot -c call flush(iout) -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#endif -c call int_from_cart1(.false.) -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj_short(evdw) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk_short(evdw) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp_short(evdw) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb_short(evdw) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv_short(evdw) - goto 107 -C Soft-sphere potential - already dealt with in the long-range part - 106 evdw=0.0d0 -c 106 call e_softsphere_short(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue -c -c Calculate the short-range part of Evdwpp -c - call evdwpp_short(evdw1) -c -c Calculate the short-range part of ESCp -c - if (ipot.lt.6) then - call escp_short(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. - call edis(ehpb) -C -C Calculate the virtual-bond-angle energy. -C - call ebend(ebe) -C -C Calculate the SC local energy. -C - call vec_and_deriv - call esc(escloc) -C -C Calculate the virtual-bond torsional energy. -C - call etor(etors,edihcnstr) -C -C 6/23/01 Calculate double-torsional energy -C - call etor_d(etors_d) -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 -C Put energy components into an array -C - do i=1,n_ene - energia(i)=0.0d0 - enddo - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(16)=evdw1 -#else - energia(3)=evdw1 -#endif - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(17)=estr - energia(19)=edihcnstr - energia(21)=esccor -c write (iout,*) "ETOTAL_SHORT before SUM_ENERGY" - call flush(iout) - call sum_energy(energia,.true.) -c write (iout,*) "Exit ETOTAL_SHORT" - call flush(iout) - return - end diff --git a/source/unres/src_MD/geomout.F b/source/unres/src_MD/geomout.F index 460b7be..69d7802 100644 --- a/source/unres/src_MD/geomout.F +++ b/source/unres/src_MD/geomout.F @@ -406,16 +406,30 @@ c----------------------------------------------------------------- #endif if (refstr) then call rms_nac_nnc(rms,frac,frac_nn,co,.false.) + if(tnp .or. tnp1 .or. tnh) then + write (line1,'(i10,f15.2,3f12.3,f12.6,f7.2,4f6.3,3f12.3,i5,$)') + & itime,totT,EK,potE,totE,hhh, + & rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me + format1="a145" + else write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)') & itime,totT,EK,potE,totE, & rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me format1="a133" + endif + else + if(tnp .or. tnp1 .or. tnh) then + write (line1,'(i10,f15.2,7f12.3,f12.6,i5,$)') + & itime,totT,EK,potE,totE,hhh, + & amax,kinetic_T,t_bath,gyrate(),me + format1="a126" else write (line1,'(i10,f15.2,7f12.3,i5,$)') & itime,totT,EK,potE,totE, & amax,kinetic_T,t_bath,gyrate(),me format1="a114" endif + endif if(usampl.and.totT.gt.eq_time) then write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back, & (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair), diff --git a/source/unres/src_MD/indexx.f b/source/unres/src_MD/indexx.f deleted file mode 100644 index b903862..0000000 --- a/source/unres/src_MD/indexx.f +++ /dev/null @@ -1,81 +0,0 @@ - SUBROUTINE indexx(n,arr,indx) - implicit real*8 (a-h,o-z) - INTEGER n,indx(n),M,NSTACK - REAL*8 arr(n) -c PARAMETER (M=7,NSTACK=50) - PARAMETER (M=7,NSTACK=500) - INTEGER i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) - REAL*8 a - do 11 j=1,n - indx(j)=j -11 continue - jstack=0 - l=1 - ir=n -1 if(ir-l.lt.M)then - do 13 j=l+1,ir - indxt=indx(j) - a=arr(indxt) - do 12 i=j-1,1,-1 - if(arr(indx(i)).le.a)goto 2 - indx(i+1)=indx(i) -12 continue - i=0 -2 indx(i+1)=indxt -13 continue - if(jstack.eq.0)return - ir=istack(jstack) - l=istack(jstack-1) - jstack=jstack-2 - else - k=(l+ir)/2 - itemp=indx(k) - indx(k)=indx(l+1) - indx(l+1)=itemp - if(arr(indx(l+1)).gt.arr(indx(ir)))then - itemp=indx(l+1) - indx(l+1)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l)).gt.arr(indx(ir)))then - itemp=indx(l) - indx(l)=indx(ir) - indx(ir)=itemp - endif - if(arr(indx(l+1)).gt.arr(indx(l)))then - itemp=indx(l+1) - indx(l+1)=indx(l) - indx(l)=itemp - endif - i=l+1 - j=ir - indxt=indx(l) - a=arr(indxt) -3 continue - i=i+1 - if(arr(indx(i)).lt.a)goto 3 -4 continue - j=j-1 - if(arr(indx(j)).gt.a)goto 4 - if(j.lt.i)goto 5 - itemp=indx(i) - indx(i)=indx(j) - indx(j)=itemp - goto 3 -5 indx(l)=indx(j) - indx(j)=indxt - jstack=jstack+2 - if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' - if(ir-i+1.ge.j-l)then - istack(jstack)=ir - istack(jstack-1)=i - ir=j-1 - else - istack(jstack)=j-1 - istack(jstack-1)=l - l=i - endif - endif - goto 1 - END -C (C) Copr. 1986-92 Numerical Recipes Software *11915aZ%. diff --git a/source/unres/src_MD/initialize_p.F b/source/unres/src_MD/initialize_p.F index a055c1d..75c98de 100644 --- a/source/unres/src_MD/initialize_p.F +++ b/source/unres/src_MD/initialize_p.F @@ -81,7 +81,9 @@ C igeom= 8 intin= 9 ithep= 11 + ithep_pdb=51 irotam=12 + irotam_pdb=52 itorp= 13 itordp= 23 ielep= 14 diff --git a/source/unres/src_MD/minim_jlee.F b/source/unres/src_MD/minim_jlee.F deleted file mode 100644 index 21a3b97..0000000 --- a/source/unres/src_MD/minim_jlee.F +++ /dev/null @@ -1,436 +0,0 @@ -#ifdef MPI - subroutine minim_jlee -c controls minimization and sorting routines - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.MINIM' - include 'COMMON.CONTROL' - include 'mpif.h' - external func,gradient,fdum - real ran1,ran2,ran3 - include 'COMMON.SETUP' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' - include 'COMMON.CHAIN' - dimension muster(mpi_status_size) - dimension var(maxvar),erg(mxch*(mxch+1)/2+1) - dimension var2(maxvar) - integer iffr(maxres),ihpbt(maxdim),jhpbt(maxdim) - double precision d(maxvar),v(1:lv+1),garbage(maxvar) - double precision energia(0:n_ene),time0s,time1s - dimension indx(9),info(12) - dimension iv(liv) - dimension idum(1),rdum(1) - dimension icont(2,maxcont) - logical check_var,fail - integer iloop(2) - common /przechowalnia/ v - data rad /1.745329252d-2/ -c receive # of start -! print *,'Processor',me,' calling MINIM_JLEE maxfun',maxfun, -! & ' maxmin',maxmin,' tolf',tolf,' rtolf',rtolf - nhpb0=nhpb - 10 continue - time0s=MPI_WTIME() -c print *, 'MINIM_JLEE: ',me,' is waiting' - call mpi_recv(info,12,mpi_integer,king,idint,CG_COMM, - * muster,ierr) - time1s=MPI_WTIME() - write (iout,'(a12,f10.4,a4)')'Waiting for ',time1s-time0s,' sec' - call flush(iout) - n=info(1) -c print *, 'MINIM_JLEE: ',me,' received: ',n - -crc if (ierr.ne.0) go to 100 -c if # = 0, return - if (n.eq.0) then - write (iout,*) 'Finishing minim_jlee - signal',n,' from master' - call flush(iout) - return - endif - - nfun=0 - IF (n.lt.0) THEN - call mpi_recv(var,nvar,mpi_double_precision, - * king,idreal,CG_COMM,muster,ierr) - call mpi_recv(iffr,nres,mpi_integer, - * king,idint,CG_COMM,muster,ierr) - call mpi_recv(var2,nvar,mpi_double_precision, - * king,idreal,CG_COMM,muster,ierr) - ELSE -c receive initial values of variables - call mpi_recv(var,nvar,mpi_double_precision, - * king,idreal,CG_COMM,muster,ierr) -crc if (ierr.ne.0) go to 100 - ENDIF - - if(vdisulf.and.info(2).ne.-1) then - if(info(4).ne.0)then - call mpi_recv(ihpbt,info(4),mpi_integer, - * king,idint,CG_COMM,muster,ierr) - call mpi_recv(jhpbt,info(4),mpi_integer, - * king,idint,CG_COMM,muster,ierr) - endif - endif - - IF (n.lt.0) THEN - n=-n - nhpb=nhpb0 - link_start=1 - link_end=nhpb - call init_int_table - call contact_cp(var,var2,iffr,nfun,n) - ENDIF - - if(vdisulf.and.info(2).ne.-1) then - nss=0 - if(info(4).ne.0)then -cd write(iout,*) 'SS=',info(4),'N=',info(1),'IT=',info(2) - call var_to_geom(nvar,var) - call chainbuild - do i=1,info(4) - if (dist(ihpbt(i),jhpbt(i)).lt.7.0) then - nss=nss+1 - ihpb(nss)=ihpbt(i) - jhpb(nss)=jhpbt(i) -cd write(iout,*) 'SS mv=',info(3), -cd & ihpb(nss)-nres,jhpb(nss)-nres, -cd & dist(ihpb(nss),jhpb(nss)) - dhpb(nss)=dbr - forcon(nss)=fbr - else -cd write(iout,*) 'rm SS mv=',info(3), -cd & ihpbt(i)-nres,jhpbt(i)-nres,dist(ihpbt(i),jhpbt(i)) - endif - enddo - endif - nhpb=nss - link_start=1 - link_end=nhpb - call init_int_table - endif - - if (info(3).eq.14) then - write(iout,*) 'calling local_move',info(7),info(8) - call local_move_init(.false.) - call var_to_geom(nvar,var) - call local_move(info(7),info(8),20d0,50d0) - call geom_to_var(nvar,var) - endif - - - if (info(3).eq.16) then - write(iout,*) 'calling beta_slide',info(7),info(8), - & info(10), info(11), info(12) - call var_to_geom(nvar,var) - call beta_slide(info(7),info(8),info(10),info(11),info(12) - & ,nfun,n) - call geom_to_var(nvar,var) - endif - - - if (info(3).eq.17) then - write(iout,*) 'calling beta_zip',info(7),info(8) - call var_to_geom(nvar,var) - call beta_zip(info(7),info(8),nfun,n) - call geom_to_var(nvar,var) - endif - - -crc overlap test - - if (overlapsc) then - - call var_to_geom(nvar,var) - call chainbuild - call etotal(energia(0)) - nfun=nfun+1 - if (energia(1).eq.1.0d20) then - info(3)=-info(3) - write (iout,'(a,1pe14.5)')'#OVERLAP evdw=1d20',energia(1) - call overlap_sc(fail) - if(.not.fail) then - call geom_to_var(nvar,var) - call etotal(energia(0)) - nfun=nfun+1 - write (iout,'(a,1pe14.5)')'#OVERLAP evdw after',energia(1) - else - v(10)=1.0d20 - iv(1)=-1 - goto 201 - endif - endif - endif - - if (searchsc) then - call var_to_geom(nvar,var) - call sc_move(2,nres-1,1,10d0,nft_sc,etot) - call geom_to_var(nvar,var) -cd write(iout,*) 'sc_move',nft_sc,etot - endif - - if (check_var(var,info)) then - v(10)=1.0d21 - iv(1)=6 - goto 201 - endif - - -crc - -! write (iout,*) 'MINIM_JLEE: Processor',me,' nvar',nvar -! write (iout,'(8f10.4)') (var(i),i=1,nvar) -! write (*,*) 'MINIM_JLEE: Processor',me,' received nvar',nvar -! write (*,'(8f10.4)') (var(i),i=1,nvar) - - do i=1,nvar - garbage(i)=var(i) - enddo - - call deflt(2,iv,liv,lv,v) -* 12 means fresh start, dont call deflt - iv(1)=12 -* max num of fun calls - if (maxfun.eq.0) maxfun=500 - iv(17)=maxfun -* max num of iterations - if (maxmin.eq.0) maxmin=1000 - iv(18)=maxmin -* controls output - iv(19)=2 -* selects output unit -cd iv(21)=iout - iv(21)=0 -* 1 means to print out result - iv(22)=0 -cd iv(22)=1 -* 1 means to print out summary stats - iv(23)=0 -* 1 means to print initial x and d - iv(24)=0 - -c if(me.eq.3.and.n.eq.255) then -c print *,' CHUJ: stoi' -c iv(21)=6 -c iv(22)=1 -c iv(23)=1 -c iv(24)=1 -c endif - -* min val for v(radfac) default is 0.1 - v(24)=0.1D0 -* max val for v(radfac) default is 4.0 - v(25)=2.0D0 -c v(25)=4.0D0 -* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) -* the sumsl default is 0.1 - v(26)=0.1D0 -* false conv if (act fnctn decrease) .lt. v(34) -* the sumsl default is 100*machep - v(34)=v(34)/100.0D0 -* absolute convergence - if (tolf.eq.0.0D0) tolf=1.0D-4 - v(31)=tolf -* relative convergence - if (rtolf.eq.0.0D0) rtolf=1.0D-4 - v(32)=rtolf -* controls initial step size - v(35)=1.0D-1 -* large vals of d correspond to small components of step - do i=1,nphi - d(i)=1.0D-1 - enddo - do i=nphi+1,nvar - d(i)=1.0D-1 - enddo -c minimize energy -! write (iout,*) 'Processor',me,' nvar',nvar -! write (iout,*) 'Variables BEFORE minimization:' -! write (iout,'(8f10.4)') (rad2deg*var(i),i=1,nvar) - -c print *, 'MINIM_JLEE: ',me,' before SUMSL ' - - call func(nvar,var,nf,eee,idum,rdum,fdum) - nfun=nfun+1 - if(eee.ge.1.0d20) then -c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' -c print *,' energy before SUMSL =',eee -c print *,' aborting local minimization' - iv(1)=-1 - v(10)=eee - go to 201 - endif - -ct time0s=MPI_WTIME() - call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) -ct write(iout,*) 'sumsl time=',MPI_WTIME()-time0s,iv(7),v(10) -c print *, 'MINIM_JLEE: ',me,' after SUMSL ' - -c find which conformation was returned from sumsl - nfun=nfun+iv(7) -! print *,'Processor',me,' iv(17)',iv(17),' iv(18)',iv(18),' nf',nf, -! & ' retcode',iv(1),' energy',v(10),' tolf',v(31),' rtolf',v(32) -c if (iv(1).ne.4 .or. nf.le.1) then -c write (*,*) 'Processor',me,' something bad in SUMSL',iv(1),nf -c write (*,*) 'Initial Variables' -c write (*,'(8f10.4)') (rad2deg*garbage(i),i=1,nvar) -c write (*,*) 'Variables' -c write (*,'(8f10.4)') (rad2deg*var(i),i=1,nvar) -c write (*,*) 'Vector d' -c write (*,'(8f10.4)') (d(i),i=1,nvar) -c write (iout,*) 'Processor',me,' something bad in SUMSL', -c & iv(1),nf -c write (iout,*) 'Initial Variables' -c write (iout,'(8f10.4)') (rad2deg*garbage(i),i=1,nvar) -c write (iout,*) 'Variables' -c write (iout,'(8f10.4)') (rad2deg*var(i),i=1,nvar) -c write (iout,*) 'Vector d' -c write (iout,'(8f10.4)') (d(i),i=1,nvar) -c endif -c if (nf.lt.iv(6)-1) then -c recalculate intra- and interchain energies -c call func(nvar,var,nf,v(10),iv,v,fdum) -c else if (nf.eq.iv(6)-1) then -c regenerate conformation -c call var_to_geom(nvar,var) -c call chainbuild -c endif -c change origin and axes to standard ECEPP format -c call var_to_geom(nvar,var) -! write (iout,*) 'MINIM_JLEE after minim: Processor',me,' nvar',nvar -! write (iout,'(8f10.4)') (var(i),i=1,nvar) -! write (iout,*) 'Energy:',v(10) -c send back output -c print *, 'MINIM_JLEE: ',me,' minimized: ',n - 201 continue - indx(1)=n -c return code: 6-gradient 9-number of ftn evaluation, etc - indx(2)=iv(1) -c total # of ftn evaluations (for iwf=0, it includes all minimizations). - indx(3)=nfun - indx(4)=info(2) - indx(5)=info(3) - indx(6)=nss - indx(7)=info(5) - indx(8)=info(6) - indx(9)=info(9) - call mpi_send(indx,9,mpi_integer,king,idint,CG_COMM, - * ierr) -c send back energies -c al & cc -c calculate contact order -#ifdef CO_BIAS - call contact(.false.,ncont,icont,co) - erg(1)=v(10)-1.0d2*co -#else - erg(1)=v(10) -#endif - j=1 - call mpi_send(erg,j,mpi_double_precision,king,idreal, - * CG_COMM,ierr) -#ifdef CO_BIAS - call mpi_send(co,j,mpi_double_precision,king,idreal, - * CG_COMM,ierr) -#endif -c send back values of variables - call mpi_send(var,nvar,mpi_double_precision, - * king,idreal,CG_COMM,ierr) -! print * , 'MINIM_JLEE: Processor',me,' send erg and var ' - - if(vdisulf.and.info(2).ne.-1.and.nss.ne.0) then -cd call intout -cd call chainbuild -cd call etotal(energia(0)) -cd etot=energia(0) -cd call enerprint(energia(0)) - call mpi_send(ihpb,nss,mpi_integer, - * king,idint,CG_COMM,ierr) - call mpi_send(jhpb,nss,mpi_integer, - * king,idint,CG_COMM,ierr) - endif - - go to 10 - 100 print *, ' error in receiving message from emperor', me - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 200 print *, ' error in sending message to emperor' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 300 print *, ' error in communicating with emperor' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 956 format (' initial energy could not be calculated',41x) - 957 format (80x) - 965 format (' convergence code ',i2,' # of function calls ', - * i4,' # of gradient calls ',i4,10x) - 975 format (' energy ',1p,e12.4,' scaled gradient ',e11.3,32x) - end -#endif - logical function check_var(var,info) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.SETUP' - dimension var(maxvar) - dimension info(3) -C AL ------- - check_var=.false. - do i=nphi+ntheta+1,nphi+ntheta+nside -! Check the side chain "valence" angles alpha - if (var(i).lt.1.0d-7) then - write (iout,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (iout,*) 'Processor',me,'received bad variables!!!!' - write (iout,*) 'Variables' - write (iout,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (iout,*) 'Continuing calculations at this point', - & ' could destroy the results obtained so far... ABORTING!!!!!!' - write (iout,'(a19,i5,f10.4,a4,2i4,a3,i3)') - & 'valence angle alpha',i-nphi-ntheta,var(i), - & 'n it',info(1),info(2),'mv ',info(3) - write (*,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (*,*) 'Processor',me,'received bad variables!!!!' - write (*,*) 'Variables' - write (*,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (*,*) 'Continuing calculations at this point', - & ' could destroy the results obtained so far... ABORTING!!!!!!' - write (*,'(a19,i5,f10.4,a4,2i4,a3,i3)') - & 'valence angle alpha',i-nphi-ntheta,var(i), - & 'n it',info(1),info(2),'mv ',info(3) - check_var=.true. - return - endif - enddo -! Check the backbone "valence" angles theta - do i=nphi+1,nphi+ntheta - if (var(i).lt.1.0d-7) then - write (iout,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (iout,*) 'Processor',me,'received bad variables!!!!' - write (iout,*) 'Variables' - write (iout,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (iout,*) 'Continuing calculations at this point', - & ' could destroy the results obtained so far... ABORTING!!!!!!' - write (iout,'(a19,i5,f10.4,a4,2i4,a3,i3)') - & 'valence angle theta',i-nphi,var(i), - & 'n it',info(1),info(2),'mv ',info(3) - write (*,*) 'CHUJ NASTAPIL ABSOLUTNY!!!!!!!!!!!!' - write (*,*) 'Processor',me,'received bad variables!!!!' - write (*,*) 'Variables' - write (*,'(8f10.4)') (rad2deg*var(j),j=1,nvar) - write (*,*) 'Continuing calculations at this point', - & ' could destroy the results obtained so far... ABORTING!!!!!!' - write (*,'(a19,i5,f10.4,a4,2i4,a3,i3)') - & 'valence angle theta',i-nphi,var(i), - & 'n it',info(1),info(2),'mv ',info(3) - check_var=.true. - return - endif - enddo - return - end diff --git a/source/unres/src_MD/minimize_p.F b/source/unres/src_MD/minimize_p.F index 902dde2..1de3824 100644 --- a/source/unres/src_MD/minimize_p.F +++ b/source/unres/src_MD/minimize_p.F @@ -24,7 +24,7 @@ external func,gradient,fdum external func_restr,grad_restr logical not_done,change,reduce - common /przechowalnia/ v +c common /przechowalnia/ v icall = 1 @@ -416,7 +416,7 @@ c---------------------------------------------------------- include 'COMMON.CHAIN' dimension iv(liv) double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) - common /przechowalnia/ v +c common /przechowalnia/ v double precision energia(0:n_ene) external func_dc,grad_dc,fdum diff --git a/source/unres/src_MD/newconf.F b/source/unres/src_MD/newconf.F deleted file mode 100644 index df93149..0000000 --- a/source/unres/src_MD/newconf.F +++ /dev/null @@ -1,2456 +0,0 @@ -#ifdef MPI -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine make_var(n,idum,iter_csa) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.INTERACT' - include 'COMMON.HAIRPIN' - include 'COMMON.VAR' - include 'COMMON.DISTFIT' - include 'COMMON.GEO' - include 'COMMON.CONTROL' - logical nicht_getan,nicht_getan1,fail,lfound - integer nharp,iharp(4,maxres/3),nconf_harp - integer iisucc(mxio) - logical ifused(mxio) - integer nhx_seed(max_seed),ihx_seed(4,maxres/3,max_seed) - integer nhx_use(max_seed),ihx_use(0:4,maxres/3,max_seed) - integer nlx_seed(max_seed),ilx_seed(2,maxres/3,max_seed), - & nlx_use(max_seed),ilx_use(maxres/3,max_seed) - real ran1,ran2 - - write (iout,*) 'make_var : nseed=',nseed,'ntry=',n - index=0 - -c----------------------------------------- - if (n7.gt.0.or.n8.gt.0.or.n9.gt.0.or.n14.gt.0.or.n15.gt.0 - & .or.n16.gt.0.or.n17.gt.0.or.n18.gt.0) - & call select_frag(n7frag,n8frag,n14frag, - & n15frag,nbefrag,iter_csa) - -c--------------------------------------------------- -c N18 - random perturbation of one phi(=gamma) angle in a loop -c - IF (n18.gt.0) THEN - nlx_tot=0 - do iters=1,nseed - i1=is(iters) - nlx_seed(iters)=0 - do i2=1,n14frag - if (lvar_frag(i2,1).eq.i1) then - nlx_seed(iters)=nlx_seed(iters)+5 - ilx_seed(1,nlx_seed(iters),iters)=lvar_frag(i2,2) - ilx_seed(2,nlx_seed(iters),iters)=lvar_frag(i2,3) - ilx_use(nlx_seed(iters),iters)=5 - endif - enddo - nlx_use(iters)=nlx_seed(iters) - nlx_tot=nlx_tot+nlx_seed(iters) - enddo - - if (nlx_tot .ge. n18*nseed) then - ntot_gen=n18*nseed - else - ntot_gen=(nlx_tot/nseed)*nseed - endif - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nlx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nlx_seed(iters)) - if (ilx_use(iih,iters).gt.0) then - nicht_getan=.false. - ilx_use(iih,iters)=ilx_use(iih,iters)-1 - nlx_use(iters)=nlx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=18 - parent(1,index)=iseed - parent(2,index)=0 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - jr=iran_num(ilx_seed(1,iih,iters),ilx_seed(2,iih,iters)) - d=ran_number(-pi,pi) - dihang_in(2,jr-2,1,index)=pinorm(dihang_in(2,jr-2,1,index)+d) - - - if (ngen.eq.ntot_gen) goto 145 - endif - enddo - enddo - 145 continue - - ENDIF - - -c----------------------------------------- -c N17 : zip a beta in a seed by forcing one additional p-p contact -c - IF (n17.gt.0) THEN - nhx_tot=0 - do iters=1,nseed - i1=is(iters) - nhx_seed(iters)=0 - nhx_use(iters)=0 - do i2=1,nbefrag - if (avar_frag(i2,1).eq.i1) then - nhx_seed(iters)=nhx_seed(iters)+1 - ihx_use(2,nhx_seed(iters),iters)=1 - if (avar_frag(i2,5)-avar_frag(i2,3).le.3.and. - & avar_frag(i2,2).gt.1.and.avar_frag(i2,4).lt.nres) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)+1 - ihx_use(0,nhx_seed(iters),iters)=1 - ihx_use(1,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - else - if (avar_frag(i2,4).gt.avar_frag(i2,5)) then - if (avar_frag(i2,2).gt.1.and. - & avar_frag(i2,4).lt.nres) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)+1 - ihx_use(0,nhx_seed(iters),iters)=1 - ihx_use(1,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - if (avar_frag(i2,3).lt.nres.and. - & avar_frag(i2,5).gt.1) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,3)+1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,5)-1 - ihx_use(0,nhx_seed(iters),iters)= - & ihx_use(0,nhx_seed(iters),iters)+1 - ihx_use(2,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - else - if (avar_frag(i2,2).gt.1.and. - & avar_frag(i2,4).gt.1) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,2)-1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,4)-1 - ihx_use(0,nhx_seed(iters),iters)=1 - ihx_use(1,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - if (avar_frag(i2,3).lt.nres.and. - & avar_frag(i2,5).lt.nres) then - ihx_seed(1,nhx_seed(iters),iters)=avar_frag(i2,3)+1 - ihx_seed(2,nhx_seed(iters),iters)=avar_frag(i2,5)+1 - ihx_use(0,nhx_seed(iters),iters)= - & ihx_use(0,nhx_seed(iters),iters)+1 - ihx_use(2,nhx_seed(iters),iters)=0 - nhx_use(iters)=nhx_use(iters)+1 - endif - endif - endif - endif - enddo - - nhx_tot=nhx_tot+nhx_use(iters) -cd write (iout,*) "debug N17",iters,nhx_seed(iters), -cd & nhx_use(iters),nhx_tot - enddo - - if (nhx_tot .ge. n17*nseed) then - ntot_gen=n17*nseed - else if (nhx_tot .ge. nseed) then - ntot_gen=(nhx_tot/nseed)*nseed - else - ntot_gen=nhx_tot - endif -cd write (iout,*) "debug N17==",ntot_gen,nhx_tot,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nhx_use(iters).gt.0) then -cd write (iout,*) "debug N17",nhx_use(iters),ngen,ntot_gen -cd write (iout,*) "debugN17^", -cd & (ihx_use(0,k,iters),k=1,nhx_use(iters)) - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nhx_seed(iters)) -cd write (iout,*) "debugN17^",iih - if (ihx_use(0,iih,iters).gt.0) then - iim=iran_num(1,2) -cd write (iout,*) "debugN17=",iih,nhx_seed(iters) -cd write (iout,*) "debugN17-",iim,'##', -cd & (ihx_use(k,iih,iters),k=0,2) -cd call flush(iout) - do while (ihx_use(iim,iih,iters).eq.1) - iim=iran_num(1,2) -cd write (iout,*) "debugN17-",iim,'##', -cd & (ihx_use(k,iih,iters),k=0,2) -cd call flush(iout) - enddo - nicht_getan=.false. - ihx_use(iim,iih,iters)=1 - ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 - nhx_use(iters)=nhx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=17 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - if (iim.eq.1) then - idata(1,index)=ihx_seed(1,iih,iters) - idata(2,index)=ihx_seed(2,iih,iters) - else - idata(1,index)=ihx_seed(3,iih,iters) - idata(2,index)=ihx_seed(4,iih,iters) - endif - - if (ngen.eq.ntot_gen) goto 115 - endif - enddo - enddo - 115 continue - write (iout,*) "N17",n17," ngen/nseed",ngen/nseed, - & ngen,nseed - - - ENDIF -c----------------------------------------- -c N16 : slide non local beta in a seed by +/- 1 or +/- 2 -c - IF (n16.gt.0) THEN - nhx_tot=0 - do iters=1,nseed - i1=is(iters) - nhx_seed(iters)=0 - do i2=1,n7frag - if (bvar_frag(i2,1).eq.i1) then - nhx_seed(iters)=nhx_seed(iters)+1 - ihx_seed(1,nhx_seed(iters),iters)=bvar_frag(i2,3) - ihx_seed(2,nhx_seed(iters),iters)=bvar_frag(i2,4) - ihx_seed(3,nhx_seed(iters),iters)=bvar_frag(i2,5) - ihx_seed(4,nhx_seed(iters),iters)=bvar_frag(i2,6) - ihx_use(0,nhx_seed(iters),iters)=4 - do i3=1,4 - ihx_use(i3,nhx_seed(iters),iters)=0 - enddo - endif - enddo - nhx_use(iters)=4*nhx_seed(iters) - nhx_tot=nhx_tot+nhx_seed(iters) -cd write (iout,*) "debug N16",iters,nhx_seed(iters) - enddo - - if (4*nhx_tot .ge. n16*nseed) then - ntot_gen=n16*nseed - else if (4*nhx_tot .ge. nseed) then - ntot_gen=(4*nhx_tot/nseed)*nseed - else - ntot_gen=4*nhx_tot - endif - write (iout,*) "debug N16",ntot_gen,4*nhx_tot,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nhx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nhx_seed(iters)) - if (ihx_use(0,iih,iters).gt.0) then - iim=iran_num(1,4) - do while (ihx_use(iim,iih,iters).eq.1) -cd write (iout,*) iim, -cd & ihx_use(0,iih,iters),ihx_use(iim,iih,iters) - iim=iran_num(1,4) - enddo - nicht_getan=.false. - ihx_use(iim,iih,iters)=1 - ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 - nhx_use(iters)=nhx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=16 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do i=1,4 - idata(i,index)=ihx_seed(i,iih,iters) - enddo - idata(5,index)=iim - - if (ngen.eq.ntot_gen) goto 116 - endif - enddo - enddo - 116 continue - write (iout,*) "N16",n16," ngen/nseed",ngen/nseed, - & ngen,nseed - ENDIF -c----------------------------------------- -c N15 : copy two 2nd structure elements from 1 or 2 conf. in bank to a seed -c - IF (n15.gt.0) THEN - - do iters=1,nseed - iseed=is(iters) - do i=1,mxio - ifused(i)=.false. - enddo - - do idummy=1,n15 - iter=0 - 84 continue - - iran=0 - iif=iran_num(1,n15frag) - do while( (ifused(iif) .or. svar_frag(iif,1).eq.iseed) .and. - & iran.le.mxio ) - iif=iran_num(1,n15frag) - iran=iran+1 - enddo - if(iran.ge.mxio) goto 811 - - iran=0 - iig=iran_num(1,n15frag) - do while( (ifused(iig) .or. svar_frag(iig,1).eq.iseed .or. - & .not.(svar_frag(iif,3).lt.svar_frag(iig,2).or. - & svar_frag(iig,3).lt.svar_frag(iif,2)) ) .and. - & iran.le.mxio ) - iig=iran_num(1,n15frag) - iran=iran+1 - enddo - if(iran.ge.mxio) goto 811 - - index=index+1 - movenx(index)=15 - parent(1,index)=iseed - parent(2,index)=svar_frag(iif,1) - parent(3,index)=svar_frag(iig,1) - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - ifused(iif)=.true. - ifused(iig)=.true. - call newconf_copy(idum,dihang_in(1,1,1,index), - & svar_frag(iif,1),svar_frag(iif,2),svar_frag(iif,3)) - - do j=svar_frag(iig,2),svar_frag(iig,3) - do i=1,4 - dihang_in(i,j,1,index)=bvar(i,j,1,svar_frag(iig,1)) - enddo - enddo - - - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) then - index=index-1 - ifused(iif)=.false. - goto 84 - endif - endif - - 811 continue - enddo - enddo - ENDIF - -c----------------------------------------- -c N14 local_move (Maurizio) for loops in a seed -c - IF (n14.gt.0) THEN - nlx_tot=0 - do iters=1,nseed - i1=is(iters) - nlx_seed(iters)=0 - do i2=1,n14frag - if (lvar_frag(i2,1).eq.i1) then - nlx_seed(iters)=nlx_seed(iters)+3 - ilx_seed(1,nlx_seed(iters),iters)=lvar_frag(i2,2) - ilx_seed(2,nlx_seed(iters),iters)=lvar_frag(i2,3) - ilx_use(nlx_seed(iters),iters)=3 - endif - enddo - nlx_use(iters)=nlx_seed(iters) - nlx_tot=nlx_tot+nlx_seed(iters) -cd write (iout,*) "debug N14",iters,nlx_seed(iters) - enddo - - if (nlx_tot .ge. n14*nseed) then - ntot_gen=n14*nseed - else - ntot_gen=(nlx_tot/nseed)*nseed - endif -cd write (iout,*) "debug N14",ntot_gen,n14frag,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nlx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nlx_seed(iters)) - if (ilx_use(iih,iters).gt.0) then - nicht_getan=.false. - ilx_use(iih,iters)=ilx_use(iih,iters)-1 - nlx_use(iters)=nlx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=14 - parent(1,index)=iseed - parent(2,index)=0 - - idata(1,index)=ilx_seed(1,iih,iters) - idata(2,index)=ilx_seed(2,iih,iters) - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - if (ngen.eq.ntot_gen) goto 131 - endif - enddo - enddo - 131 continue -cd write (iout,*) "N14",n14," ngen/nseed",ngen/nseed, -cd & ngen,nseed - - ENDIF -c----------------------------------------- -c N9 : shift a helix in a seed -c - IF (n9.gt.0) THEN - nhx_tot=0 - do iters=1,nseed - i1=is(iters) - nhx_seed(iters)=0 - do i2=1,n8frag - if (hvar_frag(i2,1).eq.i1) then - nhx_seed(iters)=nhx_seed(iters)+1 - ihx_seed(1,nhx_seed(iters),iters)=hvar_frag(i2,2) - ihx_seed(2,nhx_seed(iters),iters)=hvar_frag(i2,3) - ihx_use(0,nhx_seed(iters),iters)=4 - do i3=1,4 - ihx_use(i3,nhx_seed(iters),iters)=0 - enddo - endif - enddo - nhx_use(iters)=4*nhx_seed(iters) - nhx_tot=nhx_tot+nhx_seed(iters) -cd write (iout,*) "debug N9",iters,nhx_seed(iters) - enddo - - if (4*nhx_tot .ge. n9*nseed) then - ntot_gen=n9*nseed - else - ntot_gen=(4*nhx_tot/nseed)*nseed - endif -cd write (iout,*) "debug N9",ntot_gen,n8frag,nseed - - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) - if (nhx_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nhx_seed(iters)) - if (ihx_use(0,iih,iters).gt.0) then - iim=iran_num(1,4) - do while (ihx_use(iim,iih,iters).eq.1) -cd write (iout,*) iim, -cd & ihx_use(0,iih,iters),ihx_use(iim,iih,iters) - iim=iran_num(1,4) - enddo - nicht_getan=.false. - ihx_use(iim,iih,iters)=1 - ihx_use(0,iih,iters)=ihx_use(0,iih,iters)-1 - nhx_use(iters)=nhx_use(iters)-1 - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=9 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - jstart=max(nnt,ihx_seed(1,iih,iters)+1) - jend=min(nct,ihx_seed(2,iih,iters)) -cd write (iout,*) "debug N9",iters,iih,jstart,jend - if (iim.eq.1) then - ishift=-2 - else if (iim.eq.2) then - ishift=-1 - else if (iim.eq.3) then - ishift=1 - else if (iim.eq.4) then - ishift=2 - else - write (iout,*) 'CHUJ NASTAPIL: iim=',iim - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do j=jstart,jend - if (itype(j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (j+ishift.ge.nnt.and.j+ishift.le.nct) - & dihang_in(i,j+ishift,1,index)=bvar(i,j,1,iseed) - enddo - enddo - if (ishift.gt.0) then - do j=0,ishift-1 - if (itype(jend+j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (jend+j.ge.nnt.and.jend+j.le.nct) - & dihang_in(i,jstart+j,1,index)=bvar(i,jend+j,1,iseed) - enddo - enddo - else - do j=0,-ishift-1 - if (itype(jstart+j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (jend+j.ge.nnt.and.jend+j.le.nct) - & dihang_in(i,jend+j,1,index)=bvar(i,jstart+j,1,iseed) - enddo - enddo - endif - if (ngen.eq.ntot_gen) goto 133 - endif - enddo - enddo - 133 continue -cd write (iout,*) "N9",n9," ngen/nseed",ngen/nseed, -cd & ngen,nseed - - ENDIF -c----------------------------------------- -c N8 : copy a helix from bank to seed -c - if (n8.gt.0) then - if (n8frag.lt.n8) then - write (iout,*) "N8: only ",n8frag,'helices' - n8c=n8frag - else - n8c=n8 - endif - - do iters=1,nseed - iseed=is(iters) - do i=1,mxio - ifused(i)=.false. - enddo - - - do idummy=1,n8c - iter=0 - 94 continue - iran=0 - iif=iran_num(1,n8frag) - do while( (ifused(iif) .or. hvar_frag(iif,1).eq.iseed) .and. - & iran.le.mxio ) - iif=iran_num(1,n8frag) - iran=iran+1 - enddo - - if(iran.ge.mxio) goto 911 - - index=index+1 - movenx(index)=8 - parent(1,index)=iseed - parent(2,index)=hvar_frag(iif,1) - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - ifused(iif)=.true. - if (hvar_frag(iif,3)-hvar_frag(iif,2).le.6) then - call newconf_copy(idum,dihang_in(1,1,1,index), - & hvar_frag(iif,1),hvar_frag(iif,2),hvar_frag(iif,3)) - else - ih_start=iran_num(hvar_frag(iif,2),hvar_frag(iif,3)-6) - ih_end=iran_num(ih_start,hvar_frag(iif,3)) - call newconf_copy(idum,dihang_in(1,1,1,index), - & hvar_frag(iif,1),ih_start,ih_end) - endif - iter=iter+1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) then - index=index-1 - ifused(iif)=.false. - goto 94 - endif - endif - - - 911 continue - - enddo - enddo - - endif - -c----------------------------------------- -c N7 : copy nonlocal beta fragment from bank to seed -c - if (n7.gt.0) then - if (n7frag.lt.n7) then - write (iout,*) "N7: only ",n7frag,'nonlocal fragments' - n7c=n7frag - else - n7c=n7 - endif - - do i=1,maxres - do j=1,mxio2 - iff_in(i,j)=0 - enddo - enddo - index2=0 - do i=1,mxio - isend2(i)=0 - enddo - - do iters=1,nseed - iseed=is(iters) - do i=1,mxio - ifused(i)=.false. - enddo - - do idummy=1,n7c - iran=0 - iif=iran_num(1,n7frag) - do while( (ifused(iif) .or. bvar_frag(iif,1).eq.iseed) .and. - & iran.le.mxio ) - iif=iran_num(1,n7frag) - iran=iran+1 - enddo - -cd write (*,'(3i5,l,4i5)'),iters,idummy,iif,ifused(iif), -cd & bvar_frag(iif,1),iseed,iran,index2 - - if(iran.ge.mxio) goto 999 - if(index2.ge.mxio2) goto 999 - - index=index+1 - movenx(index)=7 - parent(1,index)=iseed - parent(2,index)=bvar_frag(iif,1) - index2=index2+1 - isend2(index)=index2 - ifused(iif)=.true. - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in2(i,j,k,index2)=bvar(i,j,k,bvar_frag(iif,1)) - enddo - enddo - enddo - - if (bvar_frag(iif,2).eq.4) then - do i=bvar_frag(iif,3),bvar_frag(iif,4) - iff_in(i,index2)=1 - enddo - if (bvar_frag(iif,5).lt.bvar_frag(iif,6)) then -cd print *,'###',bvar_frag(iif,3),bvar_frag(iif,4), -cd & bvar_frag(iif,5),bvar_frag(iif,6) - do i=bvar_frag(iif,5),bvar_frag(iif,6) - iff_in(i,index2)=1 - enddo - else -cd print *,'###',bvar_frag(iif,3),bvar_frag(iif,4), -cd & bvar_frag(iif,6),bvar_frag(iif,5) - do i=bvar_frag(iif,6),bvar_frag(iif,5) - iff_in(i,index2)=1 - enddo - endif - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - - 999 continue - - enddo - enddo - - endif -c----------------------------------------------- -c N6 : copy random continues fragment from bank to seed -c - do iters=1,nseed - iseed=is(iters) - do idummy=1,n6 - isize=(is2-is1+1)*ran1(idum)+is1 - index=index+1 - movenx(index)=6 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 104 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 104 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - parent(1,index)=iseed - parent(2,index)=i1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 104 - endif - enddo - enddo -c----------------------------------------- - if (n3.gt.0.or.n4.gt.0) call gen_hairpin - nconf_harp=0 - do iters=1,nseed - if (nharp_seed(iters).gt.0) nconf_harp=nconf_harp+1 - enddo -c----------------------------------------- -c N3 : copy hairpin from bank to seed -c - do iters=1,nseed - iseed=is(iters) - nsucc=0 - nacc=0 - do idummy=1,n3 - index=index+1 - iter=0 - 124 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 124 - do k=1,nsucc - if (i1.eq.iisucc(k).and.nsucc.lt.nconf_harp-1) goto 124 - enddo - nsucc=nsucc+1 - iisucc(nsucc)=i1 - iter=iter+1 - call newconf_residue_hairpin(idum,dihang_in(1,1,1,index), - & i1,fail) - if (fail) then - if (icycle.le.0 .and. nsucc.eq.nconf .or. - & icycle.gt.0 .and. nsucc.eq.nbank) then - index=index-1 - goto 125 - else - goto 124 - endif - endif - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 124 - endif - movenx(index)=3 - parent(1,index)=iseed - parent(2,index)=i1 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - nacc=nacc+1 - enddo -c if not enough hairpins, supplement with windows - 125 continue -cdd if (n3.ne.0) write (iout,*) "N3",n3," nsucc",nsucc," nacc",nacc - do idummy=nacc+1,n3 - isize=(is2-is1+1)*ran1(idum)+is1 - index=index+1 - movenx(index)=6 - parent(1,index)=iseed - parent(2,index)=i1 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 114 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 114 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 114 - endif - enddo - enddo -c----------------------------------------- -c N4 : shift a turn in hairpin in seed -c - IF (N4.GT.0) THEN - if (4*nharp_tot .ge. n4*nseed) then - ntot_gen=n4*nseed - else - ntot_gen=(4*nharp_tot/nseed)*nseed - endif - ngen=0 - do while (ngen.lt.ntot_gen) - do iters=1,nseed - iseed=is(iters) -c write (iout,*) 'iters',iters,' iseed',iseed,' nharp_seed', -c & nharp_seed(iters),' nharp_use',nharp_use(iters), -c & ' ntot_gen',ntot_gen -c write (iout,*) 'iharp_use(0)', -c & (iharp_use(0,k,iters),k=1,nharp_seed(iters)) - if (nharp_use(iters).gt.0) then - nicht_getan=.true. - do while (nicht_getan) - iih=iran_num(1,nharp_seed(iters)) -c write (iout,*) 'iih',iih,' iharp_use', -c & (iharp_use(k,iih,iters),k=1,4) - if (iharp_use(0,iih,iters).gt.0) then - nicht_getan1=.true. - do while (nicht_getan1) - iim=iran_num(1,4) - nicht_getan1=iharp_use(iim,iih,iters).eq.1 - enddo - nicht_getan=.false. - iharp_use(iim,iih,iters)=1 - iharp_use(0,iih,iters)=iharp_use(0,iih,iters)-1 - nharp_use(iters)=nharp_use(iters)-1 -cdd write (iout,'(a16,i3,a5,i2,a10,2i4)') -cdd & 'N4 selected hairpin',iih,' move',iim,' iharp_seed', -cdd & iharp_seed(1,iih,iters),iharp_seed(2,iih,iters) - endif - enddo - ngen=ngen+1 - index=index+1 - movenx(index)=4 - parent(1,index)=iseed - parent(2,index)=0 - - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - jstart=iharp_seed(1,iih,iters)+1 - jend=iharp_seed(2,iih,iters) - if (iim.eq.1) then - ishift=-2 - else if (iim.eq.2) then - ishift=-1 - else if (iim.eq.3) then - ishift=1 - else if (iim.eq.4) then - ishift=2 - else - write (iout,*) 'CHUJ NASTAPIL: iim=',iim - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif -c write (iout,*) 'jstart',jstart,' jend',jend,' ishift',ishift -c write (iout,*) 'Before turn shift' -c do j=2,nres-1 -c theta(j+1)=dihang_in(1,j,1,index) -c phi(j+2)=dihang_in(2,j,1,index) -c alph(j)=dihang_in(3,j,1,index) -c omeg(j)=dihang_in(4,j,1,index) -c enddo -c call intout - do j=jstart,jend - if (itype(j).eq.10) then - iang=2 - else - iang=4 - endif - do i=1,iang - if (j+ishift.ge.nnt.and.j+ishift.le.nct) - & dihang_in(i,j+ishift,1,index)=bvar(i,j,1,iseed) - enddo - enddo -c write (iout,*) 'After turn shift' -c do j=2,nres-1 -c theta(j+1)=dihang_in(1,j,1,index) -c phi(j+2)=dihang_in(2,j,1,index) -c alph(j)=dihang_in(3,j,1,index) -c omeg(j)=dihang_in(4,j,1,index) -c enddo -c call intout - if (ngen.eq.ntot_gen) goto 135 - endif - enddo - enddo -c if not enough hairpins, supplement with windows -c write (iout,*) 'end of enddo' - 135 continue -cdd write (iout,*) "N4",n4," ngen/nseed",ngen/nseed, -cdd & ngen,nseed - do iters=1,nseed - iseed=is(iters) - do idummy=ngen/nseed+1,n4 - isize=(is2-is1+1)*ran1(idum)+is1 - index=index+1 - movenx(index)=6 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - iter=0 - 134 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 134 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - parent(1,index)=iseed - parent(2,index)=i1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 134 - endif - enddo - enddo - ENDIF -c----------------------------------------- -c N5 : copy one residue from bank to seed (normally switched off - use N1) -c - do iters=1,nseed - iseed=is(iters) - isize=1 - do i=1,n5 - index=index+1 - movenx(index)=5 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - - iter=0 - 105 continue - if(icycle.le.0) then - i1=nconf* ran1(idum)+1 - i1=nbank-nconf+i1 - else - i1=nbank* ran1(idum)+1 - endif - if(i1.eq.iseed) goto 105 - iter=iter+1 - call newconf_residue(idum,dihang_in(1,1,1,index),i1,isize) - parent(1,index)=iseed - parent(2,index)=i1 - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 105 - endif - enddo - enddo -c----------------------------------------- -c N2 : copy backbone of one residue from bank or first bank to seed -c (normally switched off - use N1) -c - do iters=1,nseed - iseed=is(iters) - do i=n2,1,-1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - iseed=ran1(idum)*nconf+1 - iseed=nbank-nconf+iseed - endif - index=index+1 - movenx(index)=2 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 102 i1= ran1(idum)*nbank+1 - if(i1.eq.iseed) goto 102 - iter=iter+1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - nran=mod(i-1,nran0)+3 - call newconf1arr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=-iseed - parent(2,index)=-i1 - else if(icycle.le.0.and.iters.le.iuse) then - nran=mod(i-1,nran0)+1 - call newconf1abr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - nran=mod(i-1,nran1)+1 - if(ran1(idum).lt.0.5) then - call newconf1abr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - call newconf1abb(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=i1 - endif - endif - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 102 - endif - enddo - enddo -c----------------------------------------- -c N1 : copy backbone or sidechain of one residue from bank or -c first bank to seed -c - do iters=1,nseed - iseed=is(iters) - do i=n1,1,-1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - iseed=ran1(idum)*nconf+1 - iseed=nbank-nconf+iseed - endif - index=index+1 - movenx(index)=1 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - iter=0 - 101 i1= ran1(idum)*nbank+1 - - if(i1.eq.iseed) goto 101 - iter=iter+1 - if(icycle.le.0.and.iuse.gt.nconf-irr) then - nran=mod(i-1,nran0)+3 - call newconf1rr(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=-iseed - parent(2,index)=-i1 - else if(icycle.le.0.and.iters.le.iuse) then - nran=mod(i-1,nran0)+1 - call newconf1br(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - nran=mod(i-1,nran1)+1 - if(ran1(idum).lt.0.5) then - call newconf1br(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=-i1 - else - call newconf1bb(idum,dihang_in(1,1,1,index),nran,i1) - parent(1,index)=iseed - parent(2,index)=i1 - endif - endif - if(iter.lt.10) then - call check_old(icheck,index) - if(icheck.eq.1) goto 101 - endif - enddo - enddo -c----------------------------------------- -c N0 just all seeds -c - IF (n0.gt.0) THEN - do iters=1,nseed - iseed=is(iters) - index=index+1 - movenx(index)=0 - parent(1,index)=iseed - parent(2,index)=0 - - if (vdisulf) then - nss_in(index)=bvar_nss(iseed) - do ij=1,nss_in(index) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - endif - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - enddo - ENDIF -c----------------------------------------- - if (vdisulf) then - do iters=1,nseed - iseed=is(iters) - - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,iseed) - phi(j+2)=bvar(2,j,k,iseed) - alph(j)=bvar(3,j,k,iseed) - omeg(j)=bvar(4,j,k,iseed) - enddo - enddo - call chainbuild - -cd write(iout,*) 'makevar DYNSS',iseed,'#',bvar_ns(iseed), -cd & (bvar_s(k,iseed),k=1,bvar_ns(iseed)), -cd & bvar_nss(iseed), -cd & (bvar_ss(1,k,iseed)-nres,'-', -cd & bvar_ss(2,k,iseed)-nres,k=1,bvar_nss(iseed)) - - do i1=1,bvar_ns(iseed) -c -c N10 fussion of free halfcysteines in seed -c first select CYS with distance < 7A -c - do j1=i1+1,bvar_ns(iseed) - if (dist(bvar_s(i1,iseed)+nres,bvar_s(j1,iseed)+nres) - & .lt.7.0.and. - & iabs(bvar_s(i1,iseed)-bvar_s(j1,iseed)).gt.3) then - - index=index+1 - movenx(index)=10 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - enddo - ij=bvar_nss(iseed)+1 - nss_in(index)=ij - iss_in(ij,index)=bvar_s(i1,iseed)+nres - jss_in(ij,index)=bvar_s(j1,iseed)+nres - -cd write(iout,*) 'makevar NSS0',index, -cd & dist(bvar_s(i1,iseed)+nres,bvar_s(j1,iseed)+nres), -cd & nss_in(index),iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - enddo -c -c N11 type I transdisulfidation -c - do j1=1,bvar_nss(iseed) - if (dist(bvar_s(i1,iseed)+nres,bvar_ss(1,j1,iseed)) - & .lt.7.0.and. - & iabs(bvar_s(i1,iseed)-(bvar_ss(1,j1,iseed)-nres)) - & .gt.3) then - - index=index+1 - movenx(index)=11 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(j1,index)=bvar_s(i1,iseed)+nres - jss_in(j1,index)=bvar_ss(1,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(1,j1,iseed) - jss_in(j1,index)=bvar_s(i1,iseed)+nres - endif - -cd write(iout,*) 'makevar NSS1 #1',index, -cd & bvar_s(i1,iseed),bvar_ss(1,j1,iseed)-nres, -cd & dist(bvar_s(i1,iseed)+nres,bvar_ss(1,j1,iseed)), -cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -cd & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - endif - if (dist(bvar_s(i1,iseed)+nres,bvar_ss(2,j1,iseed)) - & .lt.7.0.and. - & iabs(bvar_s(i1,iseed)-(bvar_ss(2,j1,iseed)-nres)) - & .gt.3) then - - index=index+1 - movenx(index)=11 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(j1,index)=bvar_s(i1,iseed)+nres - jss_in(j1,index)=bvar_ss(2,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(2,j1,iseed) - jss_in(j1,index)=bvar_s(i1,iseed)+nres - endif - - -cd write(iout,*) 'makevar NSS1 #2',index, -cd & bvar_s(i1,iseed),bvar_ss(2,j1,iseed)-nres, -cd & dist(bvar_s(i1,iseed)+nres,bvar_ss(2,j1,iseed)), -cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -cd & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - enddo - enddo - -c -c N12 type II transdisulfidation -c - do i1=1,bvar_nss(iseed) - do j1=i1+1,bvar_nss(iseed) - if (dist(bvar_ss(1,i1,iseed),bvar_ss(1,j1,iseed)) - & .lt.7.0.and. - & dist(bvar_ss(2,i1,iseed),bvar_ss(2,j1,iseed)) - & .lt.7.0.and. - & iabs(bvar_ss(1,i1,iseed)-bvar_ss(1,j1,iseed)) - & .gt.3.and. - & iabs(bvar_ss(2,i1,iseed)-bvar_ss(2,j1,iseed)) - & .gt.3) then - index=index+1 - movenx(index)=12 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.i1 .and. ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(i1,index)=bvar_ss(1,i1,iseed) - jss_in(i1,index)=bvar_ss(1,j1,iseed) - if (iss_in(i1,index).gt.jss_in(i1,index)) then - iss_in(i1,index)=bvar_ss(1,j1,iseed) - jss_in(i1,index)=bvar_ss(1,i1,iseed) - endif - iss_in(j1,index)=bvar_ss(2,i1,iseed) - jss_in(j1,index)=bvar_ss(2,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(2,j1,iseed) - jss_in(j1,index)=bvar_ss(2,i1,iseed) - endif - - -cd write(iout,*) 'makevar NSS2 #1',index, -cd & bvar_ss(1,i1,iseed)-nres,bvar_ss(1,j1,iseed)-nres, -cd & dist(bvar_ss(1,i1,iseed),bvar_ss(1,j1,iseed)), -cd & bvar_ss(2,i1,iseed)-nres,bvar_ss(2,j1,iseed)-nres, -cd & dist(bvar_ss(2,i1,iseed),bvar_ss(2,j1,iseed)), -cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -cd & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - - if (dist(bvar_ss(1,i1,iseed),bvar_ss(2,j1,iseed)) - & .lt.7.0.and. - & dist(bvar_ss(2,i1,iseed),bvar_ss(1,j1,iseed)) - & .lt.7.0.and. - & iabs(bvar_ss(1,i1,iseed)-bvar_ss(2,j1,iseed)) - & .gt.3.and. - & iabs(bvar_ss(2,i1,iseed)-bvar_ss(1,j1,iseed)) - & .gt.3) then - index=index+1 - movenx(index)=12 - parent(1,index)=iseed - parent(2,index)=0 - do ij=1,bvar_nss(iseed) - if (ij.ne.i1 .and. ij.ne.j1) then - iss_in(ij,index)=bvar_ss(1,ij,iseed) - jss_in(ij,index)=bvar_ss(2,ij,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed) - iss_in(i1,index)=bvar_ss(1,i1,iseed) - jss_in(i1,index)=bvar_ss(2,j1,iseed) - if (iss_in(i1,index).gt.jss_in(i1,index)) then - iss_in(i1,index)=bvar_ss(2,j1,iseed) - jss_in(i1,index)=bvar_ss(1,i1,iseed) - endif - iss_in(j1,index)=bvar_ss(2,i1,iseed) - jss_in(j1,index)=bvar_ss(1,j1,iseed) - if (iss_in(j1,index).gt.jss_in(j1,index)) then - iss_in(j1,index)=bvar_ss(1,j1,iseed) - jss_in(j1,index)=bvar_ss(2,i1,iseed) - endif - - -cd write(iout,*) 'makevar NSS2 #2',index, -cd & bvar_ss(1,i1,iseed)-nres,bvar_ss(2,j1,iseed)-nres, -cd & dist(bvar_ss(1,i1,iseed),bvar_ss(2,j1,iseed)), -cd & bvar_ss(2,i1,iseed)-nres,bvar_ss(1,j1,iseed)-nres, -cd & dist(bvar_ss(2,i1,iseed),bvar_ss(1,j1,iseed)), -cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -cd & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - - - enddo - enddo -c -c N13 removal of disulfide bond -c - if (bvar_nss(iseed).gt.0) then - i1=bvar_nss(iseed)*ran1(idum)+1 - - index=index+1 - movenx(index)=13 - parent(1,index)=iseed - parent(2,index)=0 - ij=0 - do j1=1,bvar_nss(iseed) - if (j1.ne.i1) then - ij=ij+1 - iss_in(ij,index)=bvar_ss(1,j1,iseed) - jss_in(ij,index)=bvar_ss(2,j1,iseed) - endif - enddo - nss_in(index)=bvar_nss(iseed)-1 - -cd write(iout,*) 'NSS3',index,i1, -cd & bvar_ss(1,i1,iseed)-nres,'=',bvar_ss(2,i1,iseed)-nres,'#', -cd & (iss_in(ij,index)-nres,'-',jss_in(ij,index)-nres, -cd & ij=1,nss_in(index)) - - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - endif - - enddo - endif -c----------------------------------------- - - - - if(index.ne.n) write(iout,*)'make_var : ntry=',index - - n=index -cd do ii=1,n -cd write (istat,*) "======== ii=",ii," the dihang array" -cd do i=1,nres -cd write (istat,'(i5,4f15.5)') i,(dihang_in(k,i,1,ii)*rad2deg,k=1,4) -cd enddo -cd enddo - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine check_old(icheck,n) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - data ctdif /10./ - data ctdiff /60./ - - i1=n - do i2=1,n-1 - diff=0.d0 - do m=1,numch - do j=2,nres-1 - do i=1,4 - dif=rad2deg*dabs(dihang_in(i,j,m,i1)-dihang_in(i,j,m,i2)) - if(dif.gt.180.0) dif=360.0-dif - if(dif.gt.ctdif) goto 100 - diff=diff+dif - if(diff.gt.ctdiff) goto 100 - enddo - enddo - enddo - icheck=1 - return - 100 continue - enddo - - icheck=0 - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1rr(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=rvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=ntotgr - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1br(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=ntotgr - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - i=0 - do j=1,ndih_nconstr - if(igroup(2,1,iran).eq.idih_nconstr(j))i=j - enddo - if(i.eq.0) then - juhc=0 -4321 juhc=juhc+1 - iran= ran1(idum)*number+1 - i=0 - do j=1,ndih_nconstr - if(igroup(2,1,iran).eq.idih_nconstr(j))i=j - enddo - if(i.eq.0.or.juhc.lt.1000)goto 4321 - if(juhc.eq.1000) then - print *, 'move 6 : failed to find unconstrained group' - write(iout,*) 'move 6 : failed to find unconstrained group' - endif - endif - endif - endif - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1bb(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=ntotgr - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1arr(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=rvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=nres-2 - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1abr(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=nres-2 - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - iran=ran1(idum)*ndih_nconstr+1 - iran=idih_nconstr(iran) - endif - endif - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-rvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=rvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf1abb(idum,vvar,nran,i1) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - do index=1,nran - iold(index) = 0 - enddo - - number=nres-2 - - iter=0 - do index=1,nran - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - iran=ran1(idum)*ndih_nconstr+1 - iran=idih_nconstr(iran) - endif - endif - if(iter.gt.number) return - iter=iter+1 - if(iter.eq.1) goto 11 - do ind=1,index-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - if(iter.gt.number) goto 20 - goto 10 - 20 continue - do ind=1,ngroup(iran) - i=igroup(1,ind,iran) - j=igroup(2,ind,iran) - k=igroup(3,ind,iran) - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - iold(index)=iran - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf_residue(idum,vvar,i1,isize) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - if (iseed.gt.mxio .or. iseed.lt.1) then - write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - - k=1 - number=nres+isize-2 - iter=1 - 10 iran= ran1(idum)*number+1 - if(i2ndstr.gt.0) then - rtmp=ran1(idum) - if(rtmp.le.rdih_bias) then - iran=ran1(idum)*ndih_nconstr+1 - iran=idih_nconstr(iran) - endif - endif - istart=iran-isize+1 - iend=iran - if(istart.lt.2) istart=2 - if(iend.gt.nres-1) iend=nres-1 - - if(iter.eq.1) goto 11 - do ind=1,iter-1 - if(iran.eq.iold(ind)) goto 10 - enddo - 11 continue - - do j=istart,iend - do i=1,4 - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - enddo - iold(iter)=iran - iter=iter+1 - if(iter.gt.number) goto 20 - goto 10 - - 20 continue - do j=istart,iend - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - enddo - - return - end - -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf_copy(idum,vvar,i1,istart,iend) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - ctdif=10. - - if (iseed.gt.mxio .or. iseed.lt.1) then - write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - - - do j=istart,iend - do i=1,4 - vvar(i,j,1)=bvar(i,j,1,i1) - enddo - enddo - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine newconf_residue_hairpin(idum,vvar,i1,fail) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.VAR' - real ran1,ran2 - dimension vvar(mxang,maxres,mxch),iold(ntotal) - integer nharp,iharp(4,maxres/3),icipa(maxres/3) - logical fail,not_done - ctdif=10. - - fail=.false. - if (iseed.gt.mxio .or. iseed.lt.1) then - write (iout,*) 'Dimension ERROR in NEWCONF: ISEED',iseed - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,iseed) - enddo - enddo - enddo - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,i1) - phi(j+2)=bvar(2,j,k,i1) - alph(j)=bvar(3,j,k,i1) - omeg(j)=bvar(4,j,k,i1) - enddo - enddo -c call intout - call chainbuild - call hairpin(.false.,nharp,iharp) - - if (nharp.eq.0) then - fail=.true. - return - endif - - n_used=0 - - DO III=1,NHARP - - not_done = .true. - icount=0 - do while (not_done) - icount=icount+1 - iih=iran_num(1,nharp) - do k=1,n_used - if (iih.eq.icipa(k)) then - iih=0 - goto 22 - endif - enddo - not_done=.false. - n_used=n_used+1 - icipa(n_used)=iih - 22 continue - not_done = not_done .and. icount.le.nharp - enddo - - if (iih.eq.0) then - write (iout,*) "CHUJ NASTAPIL W NEWCONF_RESIDUE_HAIRPIN!!!!" - fail=.true. - return - endif - - istart=iharp(1,iih)+1 - iend=iharp(2,iih) - -cdd write (iout,*) "newconf_residue_hairpin: iih",iih, -cdd & " istart",istart," iend",iend - - do k=1,numch - do j=istart,iend - do i=1,4 - dif=rad2deg*dabs(vvar(i,j,k)-bvar(i,j,k,i1)) - if(dif.gt.180.) dif=360.-dif - if(dif.gt.ctdif) goto 20 - enddo - enddo - enddo - goto 10 - 20 continue - do k=1,numch - do j=istart,iend - do i=1,4 - vvar(i,j,k)=bvar(i,j,k,i1) - enddo - enddo - enddo -c do j=1,numch -c do l=2,nres-1 -c write (iout,'(4f8.3)') (rad2deg*vvar(i,l,j),i=1,4) -c enddo -c enddo - return - 10 continue - ENDDO - - fail=.true. - - return - end -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine gen_hairpin - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.HAIRPIN' - -c write (iout,*) 'Entering GEN_HAIRPIN' - do iters=1,nseed - i1=is(iters) - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,i1) - phi(j+2)=bvar(2,j,k,i1) - alph(j)=bvar(3,j,k,i1) - omeg(j)=bvar(4,j,k,i1) - enddo - enddo - call chainbuild - call hairpin(.false.,nharp_seed(iters),iharp_seed(1,1,iters)) - enddo - - nharp_tot=0 - do iters=1,nseed - nharp_tot=nharp_tot+nharp_seed(iters) - nharp_use(iters)=4*nharp_seed(iters) - do j=1,nharp_seed(iters) - iharp_use(0,j,iters)=4 - do k=1,4 - iharp_use(k,j,iters)=0 - enddo - enddo - enddo - - write (iout,*) 'GEN_HAIRPIN: nharp_tot',nharp_tot -cdd do i=1,nseed -cdd write (iout,*) 'seed',i -cdd write (iout,*) 'nharp_seed',nharp_seed(i), -cdd & ' nharp_use',nharp_use(i) -cd write (iout,*) 'iharp_seed, iharp_use' -cd do j=1,nharp_seed(i) -cd write (iout,'(7i3)') iharp_seed(1,j,i),iharp_seed(2,j,i), -cd & (iharp_use(k,j,i),k=0,4) -cd enddo -cdd enddo - return - end - -ccccccccccccccccccccccccccccccccccccccccccccccccc -ccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine select_frag(nn,nh,nl,ns,nb,i_csa) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.HAIRPIN' - include 'COMMON.DISTFIT' - character*50 linia - integer isec(maxres) - - - nn=0 - nh=0 - nl=0 - ns=0 - nb=0 -cd write (iout,*) 'Entering select_frag' - do i1=1,nbank - do i=1,nres - isec(i)=0 - enddo - do k=1,numch - do j=2,nres-1 - theta(j+1)=bvar(1,j,k,i1) - phi(j+2)=bvar(2,j,k,i1) - alph(j)=bvar(3,j,k,i1) - omeg(j)=bvar(4,j,k,i1) - enddo - enddo - call chainbuild -cd write (iout,*) ' -- ',i1,' -- ' - call secondary2(.false.) -c -c bvar_frag nn==pair of nonlocal strands in beta sheet (loop>4) -c strands > 4 residues; used by N7 and N16 -c - do j=1,nbfrag -c -Ctest 09/12/02 bfrag(2,j)-bfrag(1,j).gt.3 -c - 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 - - if ( (bfrag(3,j).lt.bfrag(4,j) .or. - & bfrag(4,j)-bfrag(2,j).gt.4) .and. - & bfrag(2,j)-bfrag(1,j).gt.4 ) then - nn=nn+1 - - - if (bfrag(3,j).lt.bfrag(4,j)) then - write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') - & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 - & ,",",bfrag(3,j)-1,"-",bfrag(4,j)-1 - else - write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') - & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 - & ,",",bfrag(4,j)-1,"-",bfrag(3,j)-1 - - endif -cd call write_pdb(i_csa*1000+nn+nh,linia,0d0) - - bvar_frag(nn,1)=i1 - bvar_frag(nn,2)=4 - do i=1,4 - bvar_frag(nn,i+2)=bfrag(i,j) - enddo - endif - enddo - -c -c hvar_frag nh==helices; used by N8 and N9 -c - do j=1,nhfrag - - do i=hfrag(1,j),hfrag(2,j) - isec(i)=2 - enddo - - if ( hfrag(2,j)-hfrag(1,j).gt.4 ) then - nh=nh+1 - -cd write(linia,'(a6,i3,a1,i3)') -cd & "select",hfrag(1,j)-1,"-",hfrag(2,j)-1 -cd call write_pdb(i_csa*1000+nn+nh,linia,0d0) - - hvar_frag(nh,1)=i1 - hvar_frag(nh,2)=hfrag(1,j) - hvar_frag(nh,3)=hfrag(2,j) - endif - enddo - - -cv write(iout,'(i4,1pe12.4,1x,1000i1)') -cv & i1,bene(i1),(isec(i),i=1,nres) -cv write(linia,'(i4,1x,1000i1)') -cv & i1,(isec(i),i=1,nres) -cv call write_pdb(i_csa*1000+i1,linia,bene(i1)) -c -c lvar_frag nl==loops; used by N14 -c - i=1 - nl1=nl - do while (i.lt.nres) - if (isec(i).eq.0) then - nl=nl+1 - lvar_frag(nl,1)=i1 - lvar_frag(nl,2)=i - i=i+1 - do while (isec(i).eq.0.and.i.le.nres) - i=i+1 - enddo - lvar_frag(nl,3)=i-1 - if (lvar_frag(nl,3)-lvar_frag(nl,2).lt.1) nl=nl-1 - endif - i=i+1 - enddo -cd write(iout,'(4i5)') (i,(lvar_frag(i,ii),ii=1,3),i=nl1+1,nl) - -c -c svar_frag ns==an secondary structure element; used by N15 -c - i=1 - ns1=ns - do while (i.lt.nres) - if (isec(i).gt.0) then - ns=ns+1 - svar_frag(ns,1)=i1 - svar_frag(ns,2)=i - i=i+1 - do while (isec(i).gt.0.and.isec(i-1).eq.isec(i) - & .and.i.le.nres) - i=i+1 - enddo - svar_frag(ns,3)=i-1 - if (svar_frag(ns,3)-svar_frag(ns,2).lt.1) ns=ns-1 - endif - if (isec(i).eq.0) i=i+1 - enddo -cd write(iout,'(4i5)') (i,(svar_frag(i,ii),ii=1,3),i=ns1+1,ns) - -c -c avar_frag nb==any pair of beta strands; used by N17 -c - do j=1,nbfrag - nb=nb+1 - avar_frag(nb,1)=i1 - do i=1,4 - avar_frag(nb,i+1)=bfrag(i,j) - enddo - enddo - - enddo - - return - end -#endif diff --git a/source/unres/src_MD/newconf.f b/source/unres/src_MD/newconf.f deleted file mode 100644 index 0b6fc2b..0000000 Binary files a/source/unres/src_MD/newconf.f and /dev/null differ diff --git a/source/unres/src_MD/objects.sizes b/source/unres/src_MD/objects.sizes deleted file mode 100644 index 862d1e3..0000000 --- a/source/unres/src_MD/objects.sizes +++ /dev/null @@ -1,168 +0,0 @@ - text data bss dec hex filename - 342 80 0 422 1a6 add.o - text data bss dec hex filename - 104 44 0 148 94 arcos.o - text data bss dec hex filename - 2316 352 0 2668 a6c banach.o - text data bss dec hex filename - 42120 5468 772 48360 bce8 bank.o - text data bss dec hex filename - 9994 764 8 10766 2a0e blas.o - text data bss dec hex filename - 5016 680 272 5968 1750 bond_move.o - text data bss dec hex filename - 4144 196 259392 263732 40634 cartder.o - text data bss dec hex filename - 1040 224 0 1264 4f0 cartprint.o - text data bss dec hex filename - 2572 404 40 3016 bc8 chainbuild.o - text data bss dec hex filename - 368 132 184 684 2ac check_bond.o - text data bss dec hex filename - 16364 2264 390656 409284 63ec4 checkder_p.o - text data bss dec hex filename - 696 236 32 964 3c4 check_sc_distr.o - text data bss dec hex filename - 2640 832 0 3472 d90 cinfo.o - text data bss dec hex filename - 6036 980 43352 50368 c4c0 compare_s1.o - text data bss dec hex filename - 5032 672 86456 92160 16800 contact.o - text data bss dec hex filename - 3576 484 43216 47276 b8ac convert.o - text data bss dec hex filename - 28680 5840 1240 35760 8bb0 cored.o - text data bss dec hex filename - 7372 1448 264 9084 237c csa.o - text data bss dec hex filename - 632 52 0 684 2ac diff12.o - text data bss dec hex filename - 5276 768 248 6292 1894 dihed_cons.o - text data bss dec hex filename - 5840 884 21744 28468 6f34 distfit.o - text data bss dec hex filename - 4276 256 1256 5788 169c djacob.o - text data bss dec hex filename - 2200 240 0 2440 988 econstr_local.o - text data bss dec hex filename - 35258 3508 320 39086 98ae eigen.o - text data bss dec hex filename - 17660 1744 191000 210404 335e4 elecont.o - text data bss dec hex filename - 150482 10704 429408 590594 90302 energy_p_new.o - text data bss dec hex filename - 44420 4204 1136 49760 c260 energy_p_new-sep.o - text data bss dec hex filename - 3276 304 600 4180 1054 energy_split-sep.o - text data bss dec hex filename - 27800 2828 86956 117584 1cb50 entmcm.o - text data bss dec hex filename - 9964 764 568 11296 2c20 fitsq.o - text data bss dec hex filename - 2604 136 0 2740 ab4 gauss.o - text data bss dec hex filename - 15888 3224 6056 25168 6250 gen_rand_conf.o - text data bss dec hex filename - 21996 2892 26120 51008 c740 geomout.o - text data bss dec hex filename - 272 156 0 428 1ac gnmr1.o - text data bss dec hex filename - 5564 464 24 6052 17a4 gradient_p.o - text data bss dec hex filename - 1202 116 2000 3318 cf6 indexx.o - text data bss dec hex filename - 9528 16928 8308 34764 87cc initialize_p.o - text data bss dec hex filename - 12732 1176 633768 647676 9e1fc intcartderiv.o - text data bss dec hex filename - 1300 192 72 1564 61c intcor.o - text data bss dec hex filename - 11628 1740 384 13752 35b8 intlocal.o - text data bss dec hex filename - 4732 180 0 4912 1330 int_to_cart.o - text data bss dec hex filename - 2116 132 48 2296 8f8 kinetic_lesyng.o - text data bss dec hex filename - 21386 2700 39369688 39393774 25919ee lagrangian_lesyng.o - text data bss dec hex filename - 12394 1692 624 14710 3976 local_move.o - text data bss dec hex filename - 3802 412 86768 90982 16366 map.o - text data bss dec hex filename - 648 60 72 780 30c matmult.o - text data bss dec hex filename - 32904 4732 218020 255656 3e6a8 mcm.o - text data bss dec hex filename - 25172 2412 130332 157916 268dc mc.o - text data bss dec hex filename - 51422 5916 865520 922858 e14ea MD_A-MTS.o - text data bss dec hex filename - 8328 764 260456 269548 41cec minimize_p.o - text data bss dec hex filename - 11376 1464 3406284 3419124 342bf4 minim_jlee.o - text data bss dec hex filename - 1384 164 86728 88276 158d4 minim_mcmf.o - text data bss dec hex filename - 5170 878 216 6264 1878 misc.o - text data bss dec hex filename - 6752 368 712 7832 1e98 moments.o - text data bss dec hex filename - 19346 3576 8716 31638 7b96 MP.o - text data bss dec hex filename - 42300 4512 14380584 14427396 dc2504 MREMD.o - text data bss dec hex filename - 8912 1368 20568 30848 7880 muca_md.o - text data bss dec hex filename - 50648 2904 24272 77824 13000 newconf.o - text data bss dec hex filename - 42598 4892 208 47698 ba52 parmread.o - text data bss dec hex filename - 124 40 0 164 a4 pinorm.o - text data bss dec hex filename - 1256 332 0 1588 634 printmat.o - text data bss dec hex filename - 1184 16588 0 17772 456c prng.o - text data bss dec hex filename - 11748 896 194728 207372 32a0c q_measure.o - text data bss dec hex filename - 2190 448 8840 11478 2cd6 randgens.o - text data bss dec hex filename - 3104 228 524 3856 f10 ran.o - text data bss dec hex filename - 23134 1992 129688 154814 25cbe rattle.o - text data bss dec hex filename - 10440 1176 896 12512 30e0 readpdb.o - text data bss dec hex filename - 114098 11732 14564 140394 2246a readrtns_CSA.o - text data bss dec hex filename - 1816 244 0 2060 80c refsys.o - text data bss dec hex filename - 3852 492 3272720 3277064 320108 regularize.o - text data bss dec hex filename - 896 140 0 1036 40c rescode.o - text data bss dec hex filename - 444 188 0 632 278 rmdd.o - text data bss dec hex filename - 4944 776 173320 179040 2bb60 rmsd.o - text data bss dec hex filename - 9152 1292 173700 184144 2cf50 sc_move.o - text data bss dec hex filename - 5960 1888 0 7848 1ea8 shift.o - text data bss dec hex filename - 5894 920 768 7582 1d9e sort.o - text data bss dec hex filename - 17784 1960 288280 308024 4b338 stochfric.o - text data bss dec hex filename - 10248 928 120 11296 2c20 sumsld.o - text data bss dec hex filename - 4894 524 67240 72658 11bd2 surfatom.o - text data bss dec hex filename - 55640 6124 8813080 8874844 876b5c test.o - text data bss dec hex filename - 16436 1876 1048 19360 4ba0 thread.o - text data bss dec hex filename - 1820 404 28 2252 8cc timing.o - text data bss dec hex filename - 31980 4560 220320 256860 3eb5c together.o - text data bss dec hex filename - 15850 3704 44640 64194 fac2 unres.o diff --git a/source/unres/src_MD/parmread.F b/source/unres/src_MD/parmread.F index b3f26b3..be5f8b8 100644 --- a/source/unres/src_MD/parmread.F +++ b/source/unres/src_MD/parmread.F @@ -276,6 +276,17 @@ C enddo call flush(iout) endif + write (2,*) "Start reading THETA_PDB" + do i=1,ntyp + read (ithep_pdb,*,err=111,end=111) a0thet(i),(athet(j,i),j=1,2), + & (bthet(j,i),j=1,2) + read (ithep_pdb,*,err=111,end=111) (polthet(j,i),j=0,3) + read (ithep_pdb,*,err=111,end=111) (gthet(j,i),j=1,3) + read (ithep_pdb,*,err=111,end=111) theta0(i),sig0(i),sigc0(i) + sigc0(i)=sigc0(i)**2 + enddo + write (2,*) "End reading THETA_PDB" + close (ithep_pdb) #endif close(ithep) #ifdef CRYST_SC @@ -363,6 +374,48 @@ C enddo endif enddo +C +C Read the parameters of the probability distribution/energy expression +C of the side chains. +C + do i=1,ntyp + read (irotam_pdb,'(3x,i3,f8.3)',end=112,err=112) nlob(i),dsc(i) + if (i.eq.10) then + dsc_inv(i)=0.0D0 + else + dsc_inv(i)=1.0D0/dsc(i) + endif + if (i.ne.10) then + do j=1,nlob(i) + do k=1,3 + do l=1,3 + blower(l,k,j)=0.0D0 + enddo + enddo + enddo + bsc(1,i)=0.0D0 + read(irotam_pdb,*,end=112,err=112)(censc(k,1,i),k=1,3), + & ((blower(k,l,1),l=1,k),k=1,3) + do j=2,nlob(i) + read (irotam_pdb,*,end=112,err=112) bsc(j,i) + read (irotam_pdb,*,end=112,err=112) (censc(k,j,i),k=1,3), + & ((blower(k,l,j),l=1,k),k=1,3) + enddo + do j=1,nlob(i) + do k=1,3 + do l=1,k + akl=0.0D0 + do m=1,3 + akl=akl+blower(k,m,j)*blower(l,m,j) + enddo + gaussc(k,l,j,i)=akl + gaussc(l,k,j,i)=akl + enddo + enddo + enddo + endif + enddo + close (irotam_pdb) #endif close(irotam) diff --git a/source/unres/src_MD/ran.f b/source/unres/src_MD/ran.f deleted file mode 100644 index dd23252..0000000 --- a/source/unres/src_MD/ran.f +++ /dev/null @@ -1,128 +0,0 @@ -ccccccccccccccccccccccccccccccccccccccccccccccccc - FUNCTION ran0(idum) - INTEGER idum,IA,IM,IQ,IR,MASK - REAL ran0,AM - PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, - *MASK=123459876) - INTEGER k - idum=ieor(idum,MASK) - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if (idum.lt.0) idum=idum+IM - ran0=AM*idum - idum=ieor(idum,MASK) - return - END -C (C) Copr. 1986-92 Numerical Recipes Software *11915 -ccccccccccccccccccccccccccccccccccccccccccccccccc - FUNCTION ran1(idum) - INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV - REAL ran1,AM,EPS,RNMX - PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, - *NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS) - INTEGER j,k,iv(NTAB),iy - SAVE iv,iy - DATA iv /NTAB*0/, iy /0/ - if (idum.le.0.or.iy.eq.0) then - idum=max(-idum,1) - do 11 j=NTAB+8,1,-1 - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if (idum.lt.0) idum=idum+IM - if (j.le.NTAB) iv(j)=idum -11 continue - iy=iv(1) - endif - k=idum/IQ - idum=IA*(idum-k*IQ)-IR*k - if (idum.lt.0) idum=idum+IM - j=1+iy/NDIV - iy=iv(j) - iv(j)=idum - ran1=min(AM*iy,RNMX) - return - END -C (C) Copr. 1986-92 Numerical Recipes Software *11915 -ccccccccccccccccccccccccccccccccccccccccccccccccc - FUNCTION ran2(idum) - INTEGER idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV - REAL ran2,AM,EPS,RNMX - PARAMETER (IM1=2147483563,IM2=2147483399,AM=1./IM1,IMM1=IM1-1, - *IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791, - *NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-7,RNMX=1.-EPS) - INTEGER idum2,j,k,iv(NTAB),iy - SAVE iv,iy,idum2 - DATA idum2/123456789/, iv/NTAB*0/, iy/0/ - if (idum.le.0) then - idum=max(-idum,1) - idum2=idum - do 11 j=NTAB+8,1,-1 - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum=idum+IM1 - if (j.le.NTAB) iv(j)=idum -11 continue - iy=iv(1) - endif - k=idum/IQ1 - idum=IA1*(idum-k*IQ1)-k*IR1 - if (idum.lt.0) idum=idum+IM1 - k=idum2/IQ2 - idum2=IA2*(idum2-k*IQ2)-k*IR2 - if (idum2.lt.0) idum2=idum2+IM2 - j=1+iy/NDIV - iy=iv(j)-idum2 - iv(j)=idum - if(iy.lt.1)iy=iy+IMM1 - ran2=min(AM*iy,RNMX) - return - END -C (C) Copr. 1986-92 Numerical Recipes Software *11915 -ccccccccccccccccccccccccccccccccccccccccccccccccc - FUNCTION ran3(idum) - INTEGER idum - INTEGER MBIG,MSEED,MZ -C REAL MBIG,MSEED,MZ - REAL ran3,FAC - PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1./MBIG) -C PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=1./MBIG) - INTEGER i,iff,ii,inext,inextp,k - INTEGER mj,mk,ma(55) -C REAL mj,mk,ma(55) - SAVE iff,inext,inextp,ma - DATA iff /0/ - if(idum.lt.0.or.iff.eq.0)then - iff=1 - mj=MSEED-iabs(idum) - mj=mod(mj,MBIG) - ma(55)=mj - mk=1 - do 11 i=1,54 - ii=mod(21*i,55) - ma(ii)=mk - mk=mj-mk - if(mk.lt.MZ)mk=mk+MBIG - mj=ma(ii) -11 continue - do 13 k=1,4 - do 12 i=1,55 - ma(i)=ma(i)-ma(1+mod(i+30,55)) - if(ma(i).lt.MZ)ma(i)=ma(i)+MBIG -12 continue -13 continue - inext=0 - inextp=31 - idum=1 - endif - inext=inext+1 - if(inext.eq.56)inext=1 - inextp=inextp+1 - if(inextp.eq.56)inextp=1 - mj=ma(inext)-ma(inextp) - if(mj.lt.MZ)mj=mj+MBIG - ma(inext)=mj - ran3=mj*FAC - return - END -C (C) Copr. 1986-92 Numerical Recipes Software *11915 -ccccccccccccccccccccccccccccccccccccccccccccccccc diff --git a/source/unres/src_MD/readrtns_CSA.F b/source/unres/src_MD/readrtns_CSA.F deleted file mode 100644 index 50f794f..0000000 --- a/source/unres/src_MD/readrtns_CSA.F +++ /dev/null @@ -1,2585 +0,0 @@ - subroutine readrtns - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.IOUNITS' - logical file_exist -C Read force-field parameters except weights - call parmread -C Read job setup parameters - call read_control -C Read control parameters for energy minimzation if required - if (minim) call read_minim -C Read MCM control parameters if required - if (modecalc.eq.3 .or. modecalc.eq.6) call mcmread -C Read MD control parameters if reqjuired - if (modecalc.eq.12) call read_MDpar -C Read MREMD control parameters if required - if (modecalc.eq.14) then - call read_MDpar - call read_REMDpar - endif -C Read MUCA control parameters if required - if (lmuca) call read_muca -C Read CSA control parameters if required (from fort.40 if exists -C otherwise from general input file) - if (modecalc.eq.8) then - inquire (file="fort.40",exist=file_exist) - if (.not.file_exist) call csaread - endif -cfmc if (modecalc.eq.10) call mcmfread -C Read molecule information, molecule geometry, energy-term weights, and -C restraints if requested - call molread -C Print restraint information -#ifdef MPI - if (.not. out1file .or. me.eq.king) then -#endif - if (nhpb.gt.nss) - &write (iout,'(a,i5,a)') "The following",nhpb-nss, - & " distance constraints have been imposed" - do i=nss+1,nhpb - write (iout,'(3i6,f10.5)') i-nss,ihpb(i),jhpb(i),forcon(i) - enddo -#ifdef MPI - endif -#endif -c print *,"Processor",myrank," leaves READRTNS" - return - end -C------------------------------------------------------------------------------- - subroutine read_control -C -C Read contorl data -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MP - include 'mpif.h' - logical OKRandom, prng_restart - real*8 r1 -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.THREAD' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.MCM' - include 'COMMON.MAP' - include 'COMMON.HEADER' - include 'COMMON.CSA' - include 'COMMON.CHAIN' - include 'COMMON.MUCA' - include 'COMMON.MD' - include 'COMMON.FFIELD' - include 'COMMON.SETUP' - COMMON /MACHSW/ KDIAG,ICORFL,IXDR - character*8 diagmeth(0:3) /'Library','EVVRSP','Givens','Jacobi'/ - character*80 ucase - character*320 controlcard - - nglob_csa=0 - eglob_csa=1d99 - nmin_csa=0 - read (INP,'(a)') titel - call card_concat(controlcard) -c out1file=index(controlcard,'OUT1FILE').gt.0 .or. fg_rank.gt.0 -c print *,"Processor",me," fg_rank",fg_rank," out1file",out1file - call reada(controlcard,'SEED',seed,0.0D0) - call random_init(seed) -C Set up the time limit (caution! The time must be input in minutes!) - read_cart=index(controlcard,'READ_CART').gt.0 - call readi(controlcard,'CONSTR_DIST',constr_dist,0) - call reada(controlcard,'TIMLIM',timlim,960.0D0) ! default 16 hours - unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0 - call reada(controlcard,'SAFETY',safety,30.0D0) ! default 30 minutes - call reada(controlcard,'RMSDBC',rmsdbc,3.0D0) - call reada(controlcard,'RMSDBC1',rmsdbc1,0.5D0) - call reada(controlcard,'RMSDBC1MAX',rmsdbc1max,1.5D0) - call reada(controlcard,'RMSDBCM',rmsdbcm,3.0D0) - call reada(controlcard,'DRMS',drms,0.1D0) - if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then - write (iout,'(a,f10.1)')'RMSDBC = ',rmsdbc - write (iout,'(a,f10.1)')'RMSDBC1 = ',rmsdbc1 - write (iout,'(a,f10.1)')'RMSDBC1MAX = ',rmsdbc1max - write (iout,'(a,f10.1)')'DRMS = ',drms - write (iout,'(a,f10.1)')'RMSDBCM = ',rmsdbcm - write (iout,'(a,f10.1)') 'Time limit (min):',timlim - endif - call readi(controlcard,'NZ_START',nz_start,0) - call readi(controlcard,'NZ_END',nz_end,0) - call readi(controlcard,'IZ_SC',iz_sc,0) - timlim=60.0D0*timlim - safety = 60.0d0*safety - timem=timlim - modecalc=0 - call reada(controlcard,"T_BATH",t_bath,300.0d0) - minim=(index(controlcard,'MINIMIZE').gt.0) - dccart=(index(controlcard,'CART').gt.0) - overlapsc=(index(controlcard,'OVERLAP').gt.0) - overlapsc=.not.overlapsc - searchsc=(index(controlcard,'NOSEARCHSC').gt.0) - searchsc=.not.searchsc - sideadd=(index(controlcard,'SIDEADD').gt.0) - energy_dec=(index(controlcard,'ENERGY_DEC').gt.0) - outpdb=(index(controlcard,'PDBOUT').gt.0) - outmol2=(index(controlcard,'MOL2OUT').gt.0) - pdbref=(index(controlcard,'PDBREF').gt.0) - refstr=pdbref .or. (index(controlcard,'REFSTR').gt.0) - indpdb=index(controlcard,'PDBSTART') - extconf=(index(controlcard,'EXTCONF').gt.0) - call readi(controlcard,'IPRINT',iprint,0) - call readi(controlcard,'MAXGEN',maxgen,10000) - call readi(controlcard,'MAXOVERLAP',maxoverlap,1000) - call readi(controlcard,"KDIAG",kdiag,0) - call readi(controlcard,"RESCALE_MODE",rescale_mode,1) - if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) - & write (iout,*) "RESCALE_MODE",rescale_mode - split_ene=index(controlcard,'SPLIT_ENE').gt.0 - if (index(controlcard,'REGULAR').gt.0.0D0) then - call reada(controlcard,'WEIDIS',weidis,0.1D0) - modecalc=1 - refstr=.true. - endif - if (index(controlcard,'CHECKGRAD').gt.0) then - modecalc=5 - if (index(controlcard,'CART').gt.0) then - icheckgrad=1 - elseif (index(controlcard,'CARINT').gt.0) then - icheckgrad=2 - else - icheckgrad=3 - endif - elseif (index(controlcard,'THREAD').gt.0) then - modecalc=2 - call readi(controlcard,'THREAD',nthread,0) - if (nthread.gt.0) then - call reada(controlcard,'WEIDIS',weidis,0.1D0) - else - if (fg_rank.eq.0) - & write (iout,'(a)')'A number has to follow the THREAD keyword.' - stop 'Error termination in Read_Control.' - endif - else if (index(controlcard,'MCMA').gt.0) then - modecalc=3 - else if (index(controlcard,'MCEE').gt.0) then - modecalc=6 - else if (index(controlcard,'MULTCONF').gt.0) then - modecalc=4 - else if (index(controlcard,'MAP').gt.0) then - modecalc=7 - call readi(controlcard,'MAP',nmap,0) - else if (index(controlcard,'CSA').gt.0) then - modecalc=8 -crc else if (index(controlcard,'ZSCORE').gt.0) then -crc -crc ZSCORE is rm from UNRES, modecalc=9 is available -crc -crc modecalc=9 -cfcm else if (index(controlcard,'MCMF').gt.0) then -cfmc modecalc=10 - else if (index(controlcard,'SOFTREG').gt.0) then - modecalc=11 - else if (index(controlcard,'CHECK_BOND').gt.0) then - modecalc=-1 - else if (index(controlcard,'TEST').gt.0) then - modecalc=-2 - else if (index(controlcard,'MD').gt.0) then - modecalc=12 - else if (index(controlcard,'RE ').gt.0) then - modecalc=14 - endif - - lmuca=index(controlcard,'MUCA').gt.0 - call readi(controlcard,'MUCADYN',mucadyn,0) - call readi(controlcard,'MUCASMOOTH',muca_smooth,0) - if (lmuca .and. (me.eq.king .or. .not.out1file )) - & then - write (iout,*) 'MUCADYN=',mucadyn - write (iout,*) 'MUCASMOOTH=',muca_smooth - endif - - iscode=index(controlcard,'ONE_LETTER') - indphi=index(controlcard,'PHI') - indback=index(controlcard,'BACK') - iranconf=index(controlcard,'RAND_CONF') - i2ndstr=index(controlcard,'USE_SEC_PRED') - gradout=index(controlcard,'GRADOUT').gt.0 - gnorm_check=index(controlcard,'GNORM_CHECK').gt.0 - - if(me.eq.king.or..not.out1file) - & write (iout,'(2a)') diagmeth(kdiag), - & ' routine used to diagonalize matrices.' - return - end -c-------------------------------------------------------------------------- - subroutine read_REMDpar -C -C Read REMD settings -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.REMD' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - character*80 ucase - character*320 controlcard - character*3200 controlcard1 - integer iremd_m_total - - if(me.eq.king.or..not.out1file) - & write (iout,*) "REMD setup" - - call card_concat(controlcard) - call readi(controlcard,"NREP",nrep,3) - call readi(controlcard,"NSTEX",nstex,1000) - call reada(controlcard,"RETMIN",retmin,10.0d0) - call reada(controlcard,"RETMAX",retmax,1000.0d0) - mremdsync=(index(controlcard,'SYNC').gt.0) - call readi(controlcard,"NSYN",i_sync_step,100) - restart1file=(index(controlcard,'REST1FILE').gt.0) - traj1file=(index(controlcard,'TRAJ1FILE').gt.0) - call readi(controlcard,"TRAJCACHE",max_cache_traj_use,1) - if(max_cache_traj_use.gt.max_cache_traj) - & max_cache_traj_use=max_cache_traj - if(me.eq.king.or..not.out1file) then -cd if (traj1file) then -crc caching is in testing - NTWX is not ignored -cd write (iout,*) "NTWX value is ignored" -cd write (iout,*) " trajectory is stored to one file by master" -cd write (iout,*) " before exchange at NSTEX intervals" -cd endif - write (iout,*) "NREP= ",nrep - write (iout,*) "NSTEX= ",nstex - write (iout,*) "SYNC= ",mremdsync - write (iout,*) "NSYN= ",i_sync_step - write (iout,*) "TRAJCACHE= ",max_cache_traj_use - endif - - t_exchange_only=(index(controlcard,'TONLY').gt.0) - call readi(controlcard,"HREMD",hremd,0) - if((me.eq.king.or..not.out1file).and.hremd.gt.0) then - write (iout,*) "Hamiltonian REMD with ",hremd," sets of weights" - endif - if(usampl.and.hremd.gt.0) then - write (iout,'(//a)') - & "========== ERROR: USAMPL and HREMD cannot be used together" -#ifdef MPI - call MPI_Abort(MPI_COMM_WORLD,IERROR,ERRCODE) -#endif - stop - endif - - - remd_tlist=.false. - if (index(controlcard,'TLIST').gt.0) then - remd_tlist=.true. - call card_concat(controlcard1) - read(controlcard1,*) (remd_t(i),i=1,nrep) - if(me.eq.king.or..not.out1file) - & write (iout,*)'tlist',(remd_t(i),i=1,nrep) - endif - remd_mlist=.false. - if (index(controlcard,'MLIST').gt.0) then - remd_mlist=.true. - call card_concat(controlcard1) - read(controlcard1,*) (remd_m(i),i=1,nrep) - if(me.eq.king.or..not.out1file) then - write (iout,*)'mlist',(remd_m(i),i=1,nrep) - iremd_m_total=0 - do i=1,nrep - iremd_m_total=iremd_m_total+remd_m(i) - enddo - if(hremd.gt.1)then - write (iout,*) 'Total number of replicas ', - & iremd_m_total*hremd - else - write (iout,*) 'Total number of replicas ',iremd_m_total - endif - endif - endif - if(me.eq.king.or..not.out1file) - & write (iout,'(/30(1h=),a,29(1h=)/)') " End of REMD run setup " - return - end -c-------------------------------------------------------------------------- - subroutine read_MDpar -C -C Read MD settings -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' -#else - include 'COMMON.LANGEVIN.lang0' -#endif - include 'COMMON.INTERACT' - include 'COMMON.NAMES' - include 'COMMON.GEO' - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.SPLITELE' - character*80 ucase - character*320 controlcard - - call card_concat(controlcard) - call readi(controlcard,"NSTEP",n_timestep,1000000) - call readi(controlcard,"NTWE",ntwe,100) - call readi(controlcard,"NTWX",ntwx,1000) - call reada(controlcard,"DT",d_time,1.0d-1) - call reada(controlcard,"DVMAX",dvmax,2.0d1) - call reada(controlcard,"DAMAX",damax,1.0d1) - call reada(controlcard,"EDRIFTMAX",edriftmax,1.0d+1) - call readi(controlcard,"LANG",lang,0) - RESPA = index(controlcard,"RESPA") .gt. 0 - call readi(controlcard,"NTIME_SPLIT",ntime_split,1) - ntime_split0=ntime_split - call readi(controlcard,"MAXTIME_SPLIT",maxtime_split,64) - ntime_split0=ntime_split - call reada(controlcard,"R_CUT",r_cut,2.0d0) - call reada(controlcard,"LAMBDA",rlamb,0.3d0) - rest = index(controlcard,"REST").gt.0 - tbf = index(controlcard,"TBF").gt.0 - tnp = index(controlcard,"NOSEPOINCARE99").gt.0 - tnp1 = index(controlcard,"NOSEPOINCARE01").gt.0 - tnh = index(controlcard,"NOSEHOOVER96").gt.0 - if (RESPA.and.tnh)then - xiresp = index(controlcard,"XIRESP").gt.0 - endif - call reada(controlcard,"Q_NP",Q_np,0.1d0) - usampl = index(controlcard,"USAMPL").gt.0 - - mdpdb = index(controlcard,"MDPDB").gt.0 - call reada(controlcard,"T_BATH",t_bath,300.0d0) - call reada(controlcard,"TAU_BATH",tau_bath,1.0d-1) - call reada(controlcard,"EQ_TIME",eq_time,1.0d+4) - call readi(controlcard,"RESET_MOMENT",count_reset_moment,1000) - if (count_reset_moment.eq.0) count_reset_moment=1000000000 - call readi(controlcard,"RESET_VEL",count_reset_vel,1000) - reset_moment=lang.eq.0 .and. tbf .and. count_reset_moment.gt.0 - reset_vel=lang.eq.0 .and. tbf .and. count_reset_vel.gt.0 - if (count_reset_vel.eq.0) count_reset_vel=1000000000 - large = index(controlcard,"LARGE").gt.0 - print_compon = index(controlcard,"PRINT_COMPON").gt.0 - rattle = index(controlcard,"RATTLE").gt.0 -c if performing umbrella sampling, fragments constrained are read from the fragment file - nset=0 - if(usampl) then - call read_fragments - endif - - if(me.eq.king.or..not.out1file) then - write (iout,*) - write (iout,'(27(1h=),a26,27(1h=))') " Parameters of the MD run " - write (iout,*) - write (iout,'(a)') "The units are:" - write (iout,'(a)') "positions: angstrom, time: 48.9 fs" - write (iout,'(2a)') "velocity: angstrom/(48.9 fs),", - & " acceleration: angstrom/(48.9 fs)**2" - write (iout,'(a)') "energy: kcal/mol, temperature: K" - write (iout,*) - write (iout,'(a60,i10)') "Number of time steps:",n_timestep - write (iout,'(a60,f10.5,a)') - & "Initial time step of numerical integration:",d_time, - & " natural units" - write (iout,'(60x,f10.5,a)') d_time*48.9," fs" - if (RESPA) then - write (iout,'(2a,i4,a)') - & "A-MTS algorithm used; initial time step for fast-varying", - & " short-range forces split into",ntime_split," steps." - write (iout,'(a,f5.2,a,f5.2)') "Short-range force cutoff", - & r_cut," lambda",rlamb - endif - write (iout,'(2a,f10.5)') - & "Maximum acceleration threshold to reduce the time step", - & "/increase split number:",damax - write (iout,'(2a,f10.5)') - & "Maximum predicted energy drift to reduce the timestep", - & "/increase split number:",edriftmax - write (iout,'(a60,f10.5)') - & "Maximum velocity threshold to reduce velocities:",dvmax - write (iout,'(a60,i10)') "Frequency of property output:",ntwe - write (iout,'(a60,i10)') "Frequency of coordinate output:",ntwx - if (rattle) write (iout,'(a60)') - & "Rattle algorithm used to constrain the virtual bonds" - endif - reset_fricmat=1000 - if (lang.gt.0) then - call reada(controlcard,"ETAWAT",etawat,0.8904d0) - call reada(controlcard,"RWAT",rwat,1.4d0) - call reada(controlcard,"SCAL_FRIC",scal_fric,2.0d-2) - surfarea=index(controlcard,"SURFAREA").gt.0 - call readi(controlcard,"RESET_FRICMAT",reset_fricmat,1000) - if(me.eq.king.or..not.out1file)then - write (iout,'(/a,$)') "Langevin dynamics calculation" - if (lang.eq.1) then - write (iout,'(a/)') - & " with direct integration of Langevin equations" - else if (lang.eq.2) then - write (iout,'(a/)') " with TINKER stochasic MD integrator" - else if (lang.eq.3) then - write (iout,'(a/)') " with Ciccotti's stochasic MD integrator" - else if (lang.eq.4) then - write (iout,'(a/)') " in overdamped mode" - else - write (iout,'(//a,i5)') - & "=========== ERROR: Unknown Langevin dynamics mode:",lang - stop - endif - write (iout,'(a60,f10.5)') "Temperature:",t_bath - write (iout,'(a60,f10.5)') "Viscosity of the solvent:",etawat - write (iout,'(a60,f10.5)') "Radius of solvent molecule:",rwat - write (iout,'(a60,f10.5)') - & "Scaling factor of the friction forces:",scal_fric - if (surfarea) write (iout,'(2a,i10,a)') - & "Friction coefficients will be scaled by solvent-accessible", - & " surface area every",reset_fricmat," steps." - endif -c Calculate friction coefficients and bounds of stochastic forces - eta=6*pi*cPoise*etawat - if(me.eq.king.or..not.out1file) - & write(iout,'(a60,f10.5)')"Eta of the solvent in natural units:" - & ,eta - gamp=scal_fric*(pstok+rwat)*eta - stdfp=dsqrt(2*Rb*t_bath/d_time) - do i=1,ntyp - gamsc(i)=scal_fric*(restok(i)+rwat)*eta - stdfsc(i)=dsqrt(2*Rb*t_bath/d_time) - enddo - if(me.eq.king.or..not.out1file)then - write (iout,'(/2a/)') - & "Radii of site types and friction coefficients and std's of", - & " stochastic forces of fully exposed sites" - write (iout,'(a5,f5.2,2f10.5)')'p',pstok,gamp,stdfp*dsqrt(gamp) - do i=1,ntyp - write (iout,'(a5,f5.2,2f10.5)') restyp(i),restok(i), - & gamsc(i),stdfsc(i)*dsqrt(gamsc(i)) - enddo - endif - else if (tbf) then - if(me.eq.king.or..not.out1file)then - write (iout,'(a)') "Berendsen bath calculation" - write (iout,'(a60,f10.5)') "Temperature:",t_bath - write (iout,'(a60,f10.5)') "Coupling constant (tau):",tau_bath - if (reset_moment) - & write (iout,'(a,i10,a)') "Momenta will be reset at zero every", - & count_reset_moment," steps" - if (reset_vel) - & write (iout,'(a,i10,a)') - & "Velocities will be reset at random every",count_reset_vel, - & " steps" - endif - else if (tnp .or. tnp1 .or. tnh) then - if (tnp .or. tnp1) then - write (iout,'(a)') "Nose-Poincare bath calculation" - if (tnp) write (iout,'(a)') - & "J.Comput.Phys. 151 114 (1999) S.D.Bond B.J.Leimkuhler B.B.Laird" - if (tnp1) write (iout,'(a)') "JPSJ 70 75 (2001) S. Nose" - else - write (iout,'(a)') "Nose-Hoover bath calculation" - write (iout,'(a)') "Mol.Phys. 87 1117 (1996) Martyna et al." - nresn=1 - nyosh=1 - nnos=1 - do i=1,nnos - qmass(i)=Q_np - xlogs(i)=1.0 - vlogs(i)=0.0 - enddo - do i=1,nyosh - WDTI(i) = 1.0*d_time/nresn - WDTI2(i)=WDTI(i)/2 - WDTI4(i)=WDTI(i)/4 - WDTI8(i)=WDTI(i)/8 - enddo - if (RESPA) then - if(xiresp) then - write (iout,'(a)') "NVT-XI-RESPA algorithm" - else - write (iout,'(a)') "NVT-XO-RESPA algorithm" - endif - do i=1,nyosh - WDTIi(i) = 1.0*d_time/nresn/ntime_split - WDTIi2(i)=WDTIi(i)/2 - WDTIi4(i)=WDTIi(i)/4 - WDTIi8(i)=WDTIi(i)/8 - enddo - endif - endif - - write (iout,'(a60,f10.5)') "Temperature:",t_bath - write (iout,'(a60,f10.5)') "Q =",Q_np - if (reset_moment) - & write (iout,'(a,i10,a)') "Momenta will be reset at zero every", - & count_reset_moment," steps" - if (reset_vel) - & write (iout,'(a,i10,a)') - & "Velocities will be reset at random every",count_reset_vel, - & " steps" - - else - if(me.eq.king.or..not.out1file) - & write (iout,'(a31)') "Microcanonical mode calculation" - endif - if(me.eq.king.or..not.out1file)then - if (rest) write (iout,'(/a/)') "===== Calculation restarted ====" - if (usampl) then - write(iout,*) "MD running with constraints." - write(iout,*) "Equilibration time ", eq_time, " mtus." - write(iout,*) "Constraining ", nfrag," fragments." - write(iout,*) "Length of each fragment, weight and q0:" - do iset=1,nset - write (iout,*) "Set of restraints #",iset - do i=1,nfrag - write(iout,'(2i5,f8.1,f7.4)') ifrag(1,i,iset), - & ifrag(2,i,iset),wfrag(i,iset),qinfrag(i,iset) - enddo - write(iout,*) "constraints between ", npair, "fragments." - write(iout,*) "constraint pairs, weights and q0:" - do i=1,npair - write(iout,'(2i5,f8.1,f7.4)') ipair(1,i,iset), - & ipair(2,i,iset),wpair(i,iset),qinpair(i,iset) - enddo - write(iout,*) "angle constraints within ", nfrag_back, - & "backbone fragments." - write(iout,*) "fragment, weights:" - do i=1,nfrag_back - write(iout,'(2i5,3f8.1)') ifrag_back(1,i,iset), - & ifrag_back(2,i,iset),wfrag_back(1,i,iset), - & wfrag_back(2,i,iset),wfrag_back(3,i,iset) - enddo - enddo - iset=mod(kolor,nset)+1 - endif - endif - if(me.eq.king.or..not.out1file) - & write (iout,'(/30(1h=),a,29(1h=)/)') " End of MD run setup " - return - end -c------------------------------------------------------------------------------ - subroutine molread -C -C Read molecular data. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - integer error_msg -#endif - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.DBASE' - include 'COMMON.THREAD' - include 'COMMON.CONTACTS' - include 'COMMON.TORCNSTR' - include 'COMMON.TIME1' - include 'COMMON.BOUNDS' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - character*4 sequence(maxres) - integer rescode - double precision x(maxvar) - character*256 pdbfile - character*320 weightcard - character*80 weightcard_t,ucase - dimension itype_pdb(maxres) - common /pizda/ itype_pdb - logical seq_comp,fail - double precision energia(0:n_ene) - integer ilen - external ilen -C -C Body -C -C Read weights of the subsequent energy terms. - if(hremd.gt.0) then - - k=0 - do il=1,hremd - do i=1,nrep - do j=1,remd_m(i) - i2set(k)=il - k=k+1 - enddo - enddo - enddo - - if(me.eq.king.or..not.out1file) then - write (iout,*) 'Reading ',hremd,' sets of weights for HREMD' - write (iout,*) 'Current weights for processor ', - & me,' set ',i2set(me) - endif - - do i=1,hremd - call card_concat(weightcard) - call reada(weightcard,'WLONG',wlong,1.0D0) - call reada(weightcard,'WSC',wsc,wlong) - call reada(weightcard,'WSCP',wscp,wlong) - call reada(weightcard,'WELEC',welec,1.0D0) - call reada(weightcard,'WVDWPP',wvdwpp,welec) - call reada(weightcard,'WEL_LOC',wel_loc,1.0D0) - call reada(weightcard,'WCORR4',wcorr4,0.0D0) - call reada(weightcard,'WCORR5',wcorr5,0.0D0) - call reada(weightcard,'WCORR6',wcorr6,0.0D0) - call reada(weightcard,'WTURN3',wturn3,1.0D0) - call reada(weightcard,'WTURN4',wturn4,1.0D0) - call reada(weightcard,'WTURN6',wturn6,1.0D0) - call reada(weightcard,'WSCCOR',wsccor,1.0D0) - call reada(weightcard,'WSTRAIN',wstrain,1.0D0) - call reada(weightcard,'WBOND',wbond,1.0D0) - call reada(weightcard,'WTOR',wtor,1.0D0) - call reada(weightcard,'WTORD',wtor_d,1.0D0) - call reada(weightcard,'WANG',wang,1.0D0) - call reada(weightcard,'WSCLOC',wscloc,1.0D0) - call reada(weightcard,'SCAL14',scal14,0.4D0) - call reada(weightcard,'SCALSCP',scalscp,1.0d0) - call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) - call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) - call reada(weightcard,'TEMP0',temp0,300.0d0) - if (index(weightcard,'SOFT').gt.0) ipot=6 -C 12/1/95 Added weight for the multi-body term WCORR - call reada(weightcard,'WCORRH',wcorr,1.0D0) - if (wcorr4.gt.0.0d0) wcorr=wcorr4 - - hweights(i,1)=wsc - hweights(i,2)=wscp - hweights(i,3)=welec - hweights(i,4)=wcorr - hweights(i,5)=wcorr5 - hweights(i,6)=wcorr6 - hweights(i,7)=wel_loc - hweights(i,8)=wturn3 - hweights(i,9)=wturn4 - hweights(i,10)=wturn6 - hweights(i,11)=wang - hweights(i,12)=wscloc - hweights(i,13)=wtor - hweights(i,14)=wtor_d - hweights(i,15)=wstrain - hweights(i,16)=wvdwpp - hweights(i,17)=wbond - hweights(i,18)=scal14 - hweights(i,21)=wsccor - - enddo - - do i=1,n_ene - weights(i)=hweights(i2set(me),i) - enddo - 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) - - - else - call card_concat(weightcard) - call reada(weightcard,'WLONG',wlong,1.0D0) - call reada(weightcard,'WSC',wsc,wlong) - call reada(weightcard,'WSCP',wscp,wlong) - call reada(weightcard,'WELEC',welec,1.0D0) - call reada(weightcard,'WVDWPP',wvdwpp,welec) - call reada(weightcard,'WEL_LOC',wel_loc,1.0D0) - call reada(weightcard,'WCORR4',wcorr4,0.0D0) - call reada(weightcard,'WCORR5',wcorr5,0.0D0) - call reada(weightcard,'WCORR6',wcorr6,0.0D0) - call reada(weightcard,'WTURN3',wturn3,1.0D0) - call reada(weightcard,'WTURN4',wturn4,1.0D0) - call reada(weightcard,'WTURN6',wturn6,1.0D0) - call reada(weightcard,'WSCCOR',wsccor,1.0D0) - call reada(weightcard,'WSTRAIN',wstrain,1.0D0) - call reada(weightcard,'WBOND',wbond,1.0D0) - call reada(weightcard,'WTOR',wtor,1.0D0) - call reada(weightcard,'WTORD',wtor_d,1.0D0) - call reada(weightcard,'WANG',wang,1.0D0) - call reada(weightcard,'WSCLOC',wscloc,1.0D0) - call reada(weightcard,'SCAL14',scal14,0.4D0) - call reada(weightcard,'SCALSCP',scalscp,1.0d0) - call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) - call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) - call reada(weightcard,'TEMP0',temp0,300.0d0) - if (index(weightcard,'SOFT').gt.0) ipot=6 -C 12/1/95 Added weight for the multi-body term WCORR - call reada(weightcard,'WCORRH',wcorr,1.0D0) - if (wcorr4.gt.0.0d0) wcorr=wcorr4 - 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 - endif - - if(me.eq.king.or..not.out1file) - & write (iout,10) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor, - & wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3, - & wturn4,wturn6 - 10 format (/'Energy-term weights (unscaled):'// - & 'WSCC= ',f10.6,' (SC-SC)'/ - & 'WSCP= ',f10.6,' (SC-p)'/ - & 'WELEC= ',f10.6,' (p-p electr)'/ - & 'WVDWPP= ',f10.6,' (p-p VDW)'/ - & 'WBOND= ',f10.6,' (stretching)'/ - & 'WANG= ',f10.6,' (bending)'/ - & 'WSCLOC= ',f10.6,' (SC local)'/ - & 'WTOR= ',f10.6,' (torsional)'/ - & 'WTORD= ',f10.6,' (double torsional)'/ - & 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ - & 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ - & 'WCORR4= ',f10.6,' (multi-body 4th order)'/ - & 'WCORR5= ',f10.6,' (multi-body 5th order)'/ - & 'WCORR6= ',f10.6,' (multi-body 6th order)'/ - & 'WSCCOR= ',f10.6,' (back-scloc correlation)'/ - & 'WTURN3= ',f10.6,' (turns, 3rd order)'/ - & 'WTURN4= ',f10.6,' (turns, 4th order)'/ - & 'WTURN6= ',f10.6,' (turns, 6th order)') - if(me.eq.king.or..not.out1file)then - if (wcorr4.gt.0.0d0) then - write (iout,'(/2a/)') 'Local-electrostatic type correlation ', - & 'between contact pairs of peptide groups' - write (iout,'(2(a,f5.3/))') - & 'Cutoff on 4-6th order correlation terms: ',cutoff_corr, - & 'Range of quenching the correlation terms:',2*delt_corr - else if (wcorr.gt.0.0d0) then - write (iout,'(/2a/)') 'Hydrogen-bonding correlation ', - & 'between contact pairs of peptide groups' - endif - write (iout,'(a,f8.3)') - & 'Scaling factor of 1,4 SC-p interactions:',scal14 - write (iout,'(a,f8.3)') - & 'General scaling factor of SC-p interactions:',scalscp - endif - r0_corr=cutoff_corr-delt_corr - do i=1,20 - aad(i,1)=scalscp*aad(i,1) - aad(i,2)=scalscp*aad(i,2) - bad(i,1)=scalscp*bad(i,1) - bad(i,2)=scalscp*bad(i,2) - enddo - call rescale_weights(t_bath) - if(me.eq.king.or..not.out1file) - & write (iout,22) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor, - & wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3, - & wturn4,wturn6 - 22 format (/'Energy-term weights (scaled):'// - & 'WSCC= ',f10.6,' (SC-SC)'/ - & 'WSCP= ',f10.6,' (SC-p)'/ - & 'WELEC= ',f10.6,' (p-p electr)'/ - & 'WVDWPP= ',f10.6,' (p-p VDW)'/ - & 'WBOND= ',f10.6,' (stretching)'/ - & 'WANG= ',f10.6,' (bending)'/ - & 'WSCLOC= ',f10.6,' (SC local)'/ - & 'WTOR= ',f10.6,' (torsional)'/ - & 'WTORD= ',f10.6,' (double torsional)'/ - & 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ - & 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ - & 'WCORR4= ',f10.6,' (multi-body 4th order)'/ - & 'WCORR5= ',f10.6,' (multi-body 5th order)'/ - & 'WCORR6= ',f10.6,' (multi-body 6th order)'/ - & 'WSCCOR= ',f10.6,' (back-scloc correlatkion)'/ - & 'WTURN3= ',f10.6,' (turns, 3rd order)'/ - & 'WTURN4= ',f10.6,' (turns, 4th order)'/ - & 'WTURN6= ',f10.6,' (turns, 6th order)') - if(me.eq.king.or..not.out1file) - & write (iout,*) "Reference temperature for weights calculation:", - & temp0 - call reada(weightcard,"D0CM",d0cm,3.78d0) - call reada(weightcard,"AKCM",akcm,15.1d0) - call reada(weightcard,"AKTH",akth,11.0d0) - call reada(weightcard,"AKCT",akct,12.0d0) - call reada(weightcard,"V1SS",v1ss,-1.08d0) - call reada(weightcard,"V2SS",v2ss,7.61d0) - call reada(weightcard,"V3SS",v3ss,13.7d0) - call reada(weightcard,"EBR",ebr,-5.50D0) - if(me.eq.king.or..not.out1file) then - write (iout,*) "Parameters of the SS-bond potential:" - write (iout,*) "D0CM",d0cm," AKCM",akcm," AKTH",akth, - & " AKCT",akct - write (iout,*) "V1SS",v1ss," V2SS",v2ss," V3SS",v3ss - write (iout,*) "EBR",ebr - print *,'indpdb=',indpdb,' pdbref=',pdbref - endif - if (indpdb.gt.0 .or. pdbref) then - read(inp,'(a)') pdbfile - if(me.eq.king.or..not.out1file) - & write (iout,'(2a)') 'PDB data will be read from file ', - & pdbfile(:ilen(pdbfile)) - open(ipdbin,file=pdbfile,status='old',err=33) - goto 34 - 33 write (iout,'(a)') 'Error opening PDB file.' - stop - 34 continue -c print *,'Begin reading pdb data' - call readpdb -c print *,'Finished reading pdb data' - if(me.eq.king.or..not.out1file) - & write (iout,'(a,i3,a,i3)')'nsup=',nsup, - & ' nstart_sup=',nstart_sup - do i=1,nres - itype_pdb(i)=itype(i) - enddo - close (ipdbin) - nnt=nstart_sup - nct=nstart_sup+nsup-1 - call contact(.false.,ncont_ref,icont_ref,co) - - if (sideadd) then - if(me.eq.king.or..not.out1file) - & write(iout,*)'Adding sidechains' - maxsi=1000 - do i=2,nres-1 - iti=itype(i) - if (iti.ne.10) then - nsi=0 - fail=.true. - do while (fail.and.nsi.le.maxsi) - call gen_side(iti,theta(i+1),alph(i),omeg(i),fail) - nsi=nsi+1 - enddo - if(fail) write(iout,*)'Adding sidechain failed for res ', - & i,' after ',nsi,' trials' - endif - enddo - endif - endif - if (indpdb.eq.0) then -C Read sequence if not taken from the pdb file. - read (inp,*) nres -c print *,'nres=',nres - if (iscode.gt.0) then - read (inp,'(80a1)') (sequence(i)(1:1),i=1,nres) - else - read (inp,'(20(1x,a3))') (sequence(i),i=1,nres) - endif -C Convert sequence to numeric code - do i=1,nres - itype(i)=rescode(i,sequence(i),iscode) - enddo -C Assign initial virtual bond lengths - do i=2,nres - vbld(i)=vbl - vbld_inv(i)=vblinv - enddo - do i=2,nres-1 - vbld(i+nres)=dsc(itype(i)) - vbld_inv(i+nres)=dsc_inv(itype(i)) -c write (iout,*) "i",i," itype",itype(i), -c & " dsc",dsc(itype(i))," vbld",vbld(i),vbld(i+nres) - enddo - endif -c print *,nres -c print '(20i4)',(itype(i),i=1,nres) - do i=1,nres -#ifdef PROCOR - if (itype(i).eq.21 .or. itype(i+1).eq.21) then -#else - if (itype(i).eq.21) then -#endif - itel(i)=0 -#ifdef PROCOR - else if (itype(i+1).ne.20) then -#else - else if (itype(i).ne.20) then -#endif - itel(i)=1 - else - itel(i)=2 - endif - enddo - if(me.eq.king.or..not.out1file)then - write (iout,*) "ITEL" - do i=1,nres-1 - write (iout,*) i,itype(i),itel(i) - enddo - print *,'Call Read_Bridge.' - endif - call read_bridge -C 8/13/98 Set limits to generating the dihedral angles - do i=1,nres - phibound(1,i)=-pi - phibound(2,i)=pi - enddo - read (inp,*) ndih_constr - if (ndih_constr.gt.0) then - read (inp,*) ftors - read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) - if(me.eq.king.or..not.out1file)then - write (iout,*) - & 'There are',ndih_constr,' constraints on phi angles.' - do i=1,ndih_constr - write (iout,'(i5,2f8.3)') idih_constr(i),phi0(i),drange(i) - enddo - endif - do i=1,ndih_constr - phi0(i)=deg2rad*phi0(i) - drange(i)=deg2rad*drange(i) - enddo - if(me.eq.king.or..not.out1file) - & write (iout,*) 'FTORS',ftors - do i=1,ndih_constr - ii = idih_constr(i) - phibound(1,ii) = phi0(i)-drange(i) - phibound(2,ii) = phi0(i)+drange(i) - enddo - endif - nnt=1 -#ifdef MPI - if (me.eq.king) then -#endif - write (iout,'(a)') 'Boundaries in phi angle sampling:' - do i=1,nres - write (iout,'(a3,i5,2f10.1)') - & restyp(itype(i)),i,phibound(1,i)*rad2deg,phibound(2,i)*rad2deg - enddo -#ifdef MP - endif -#endif - nct=nres -cd print *,'NNT=',NNT,' NCT=',NCT - if (itype(1).eq.21) nnt=2 - if (itype(nres).eq.21) nct=nct-1 - if (pdbref) then - if(me.eq.king.or..not.out1file) - & write (iout,'(a,i3)') 'nsup=',nsup - nstart_seq=nnt - if (nsup.le.(nct-nnt+1)) then - do i=0,nct-nnt+1-nsup - if (seq_comp(itype(nnt+i),itype_pdb(nstart_sup),nsup)) then - nstart_seq=nnt+i - goto 111 - endif - enddo - write (iout,'(a)') - & 'Error - sequences to be superposed do not match.' - stop - else - do i=0,nsup-(nct-nnt+1) - if (seq_comp(itype(nnt),itype_pdb(nstart_sup+i),nct-nnt+1)) - & then - nstart_sup=nstart_sup+i - nsup=nct-nnt+1 - goto 111 - endif - enddo - write (iout,'(a)') - & 'Error - sequences to be superposed do not match.' - endif - 111 continue - if (nsup.eq.0) nsup=nct-nnt - if (nstart_sup.eq.0) nstart_sup=nnt - if (nstart_seq.eq.0) nstart_seq=nnt - if(me.eq.king.or..not.out1file) - & write (iout,*) 'nsup=',nsup,' nstart_sup=',nstart_sup, - & ' nstart_seq=',nstart_seq - endif -c--- Zscore rms ------- - if (nz_start.eq.0) nz_start=nnt - if (nz_end.eq.0 .and. nsup.gt.0) then - nz_end=nnt+nsup-1 - else if (nz_end.eq.0) then - nz_end=nct - endif - if(me.eq.king.or..not.out1file)then - write (iout,*) 'NZ_START=',nz_start,' NZ_END=',nz_end - write (iout,*) 'IZ_SC=',iz_sc - endif -c---------------------- - call init_int_table - if (refstr) then - if (.not.pdbref) then - call read_angles(inp,*38) - goto 39 - 38 write (iout,'(a)') 'Error reading reference structure.' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) - stop 'Error reading reference structure' -#endif - 39 call chainbuild - call setup_var -czscore call geom_to_var(nvar,coord_exp_zs(1,1)) - nstart_sup=nnt - nstart_seq=nnt - nsup=nct-nnt+1 - do i=1,2*nres - do j=1,3 - cref(j,i)=c(j,i) - enddo - enddo - call contact(.true.,ncont_ref,icont_ref,co) - endif -c write (iout,*) "constr_dist",constr_dist,nstart_sup,nsup - call flush(iout) - if (constr_dist.gt.0) call read_dist_constr -c write (iout,*) "After read_dist_constr nhpb",nhpb - call hpb_partition - if(me.eq.king.or..not.out1file) - & write (iout,*) 'Contact order:',co - if (pdbref) then - if(me.eq.king.or..not.out1file) - & write (2,*) 'Shifting contacts:',nstart_seq,nstart_sup - do i=1,ncont_ref - do j=1,2 - icont_ref(j,i)=icont_ref(j,i)+nstart_seq-nstart_sup - enddo - if(me.eq.king.or..not.out1file) - & write (2,*) i,' ',restyp(itype(icont_ref(1,i))),' ', - & icont_ref(1,i),' ', - & restyp(itype(icont_ref(2,i))),' ',icont_ref(2,i) - enddo - endif - endif - if (indpdb.eq.0 .and. modecalc.ne.2 .and. modecalc.ne.4 - & .and. modecalc.ne.8 .and. modecalc.ne.9 .and. - & modecalc.ne.10) then -C If input structure hasn't been supplied from the PDB file read or generate -C initial geometry. - if (iranconf.eq.0 .and. .not. extconf) then - if(me.eq.king.or..not.out1file .and.fg_rank.eq.0) - & write (iout,'(a)') 'Initial geometry will be read in.' - if (read_cart) then - read(inp,'(8f10.5)',end=36,err=36) - & ((c(l,k),l=1,3),k=1,nres), - & ((c(l,k+nres),l=1,3),k=nnt,nct) - call int_from_cart1(.false.) - do i=1,nres-1 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - dc_norm(j,i)=dc_norm(j,i)*vbld_inv(i+1) - enddo - enddo - do i=nnt,nct - if (itype(i).ne.10) then - do j=1,3 - dc(j,i+nres)=c(j,i+nres)-c(j,i) - dc_norm(j,i+nres)=dc_norm(j,i+nres)*vbld_inv(i+nres) - enddo - endif - enddo - return - else - call read_angles(inp,*36) - endif - goto 37 - 36 write (iout,'(a)') 'Error reading angle file.' -#ifdef MPI - call mpi_finalize( MPI_COMM_WORLD,IERR ) -#endif - stop 'Error reading angle file.' - 37 continue - else if (extconf) then - if(me.eq.king.or..not.out1file .and. fg_rank.eq.0) - & write (iout,'(a)') 'Extended chain initial geometry.' - do i=3,nres - theta(i)=90d0*deg2rad - enddo - do i=4,nres - phi(i)=180d0*deg2rad - enddo - do i=2,nres-1 - alph(i)=110d0*deg2rad - enddo - do i=2,nres-1 - omeg(i)=-120d0*deg2rad - enddo - else - if(me.eq.king.or..not.out1file) - & write (iout,'(a)') 'Random-generated initial geometry.' - - -#ifdef MPI - if (me.eq.king .or. fg_rank.eq.0 .and. ( - & modecalc.eq.12 .or. modecalc.eq.14) ) then -#endif - do itrial=1,100 - itmp=1 - call gen_rand_conf(itmp,*30) - goto 40 - 30 write (iout,*) 'Failed to generate random conformation', - & ', itrial=',itrial - write (*,*) 'Processor:',me, - & ' Failed to generate random conformation', - & ' itrial=',itrial - call intout - -#ifdef AIX - call flush_(iout) -#else - call flush(iout) -#endif - enddo - write (iout,'(a,i3,a)') 'Processor:',me, - & ' error in generating random conformation.' - write (*,'(a,i3,a)') 'Processor:',me, - & ' error in generating random conformation.' - call flush(iout) -#ifdef MPI - call MPI_Abort(mpi_comm_world,error_msg,ierrcode) - 40 continue - endif -#else - 40 continue -#endif - endif - elseif (modecalc.eq.4) then - read (inp,'(a)') intinname - open (intin,file=intinname,status='old',err=333) - if (me.eq.king .or. .not.out1file.and.fg_rank.eq.0) - & write (iout,'(a)') 'intinname',intinname - write (*,'(a)') 'Processor',myrank,' intinname',intinname - goto 334 - 333 write (iout,'(2a)') 'Error opening angle file ',intinname -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERR) -#endif - stop 'Error opening angle file.' - 334 continue - - endif -C Generate distance constraints, if the PDB structure is to be regularized. - if (nthread.gt.0) then - call read_threadbase - endif - call setup_var - if (me.eq.king .or. .not. out1file) - & call intout - if (ns.gt.0 .and. (me.eq.king .or. .not.out1file) ) then - write (iout,'(/a,i3,a)') - & 'The chain contains',ns,' disulfide-bridging cysteines.' - write (iout,'(20i4)') (iss(i),i=1,ns) - write (iout,'(/a/)') 'Pre-formed links are:' - do i=1,nss - i1=ihpb(i)-nres - i2=jhpb(i)-nres - it1=itype(i1) - it2=itype(i2) - if (me.eq.king.or..not.out1file) - & write (iout,'(2a,i3,3a,i3,a,3f10.3)') - & restyp(it1),'(',i1,') -- ',restyp(it2),'(',i2,')',dhpb(i), - & ebr,forcon(i) - enddo - write (iout,'(a)') - endif - if (i2ndstr.gt.0) call secstrp2dihc -c call geom_to_var(nvar,x) -c call etotal(energia(0)) -c call enerprint(energia(0)) -c call briefout(0,etot) -c stop -cd write (iout,'(2(a,i3))') 'NNT',NNT,' NCT',NCT -cd write (iout,'(a)') 'Variable list:' -cd write (iout,'(i4,f10.5)') (i,rad2deg*x(i),i=1,nvar) -#ifdef MPI - if (me.eq.king .or. (fg_rank.eq.0 .and. .not.out1file)) - & write (iout,'(//80(1h*)/20x,a,i4,a/80(1h*)//)') - & 'Processor',myrank,': end reading molecular data.' -#endif - return - end -c-------------------------------------------------------------------------- - logical function seq_comp(itypea,itypeb,length) - implicit none - integer length,itypea(length),itypeb(length) - integer i - do i=1,length - if (itypea(i).ne.itypeb(i)) then - seq_comp=.false. - return - endif - enddo - seq_comp=.true. - return - end -c----------------------------------------------------------------------------- - subroutine read_bridge -C Read information about disulfide bridges. - 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.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.DBASE' - include 'COMMON.THREAD' - include 'COMMON.TIME1' - include 'COMMON.SETUP' -C Read bridging residues. - read (inp,*) ns,(iss(i),i=1,ns) - print *,'ns=',ns - if(me.eq.king.or..not.out1file) - & write (iout,*) 'ns=',ns,' iss:',(iss(i),i=1,ns) -C Check whether the specified bridging residues are cystines. - do i=1,ns - if (itype(iss(i)).ne.1) then - if (me.eq.king.or..not.out1file) write (iout,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, - & ' can form a disulfide bridge?!!!' - write (*,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, - & ' can form a disulfide bridge?!!!' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,ierror) - stop -#endif - endif - enddo -C Read preformed bridges. - if (ns.gt.0) then - read (inp,*) nss,(ihpb(i),jhpb(i),i=1,nss) - write (iout,*) 'nss=',nss,' ihpb,jhpb: ',(ihpb(i),jhpb(i),i=1,nss) - if (nss.gt.0) then - nhpb=nss -C Check if the residues involved in bridges are in the specified list of -C bridging residues. - do i=1,nss - do j=1,i-1 - if (ihpb(i).eq.ihpb(j).or.ihpb(i).eq.jhpb(j) - & .or.jhpb(i).eq.ihpb(j).or.jhpb(i).eq.jhpb(j)) then - write (iout,'(a,i3,a)') 'Disulfide pair',i, - & ' contains residues present in other pairs.' - write (*,'(a,i3,a)') 'Disulfide pair',i, - & ' contains residues present in other pairs.' -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,ierror) - stop -#endif - endif - enddo - do j=1,ns - if (ihpb(i).eq.iss(j)) goto 10 - enddo - write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' - 10 continue - do j=1,ns - if (jhpb(i).eq.iss(j)) goto 20 - enddo - write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' - 20 continue - dhpb(i)=dbr - forcon(i)=fbr - enddo - do i=1,nss - ihpb(i)=ihpb(i)+nres - jhpb(i)=jhpb(i)+nres - enddo - endif - endif - return - end -c---------------------------------------------------------------------------- - subroutine read_x(kanal,*) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' -c Read coordinates from input -c - read(kanal,'(8f10.5)',end=10,err=10) - & ((c(l,k),l=1,3),k=1,nres), - & ((c(l,k+nres),l=1,3),k=nnt,nct) - do j=1,3 - c(j,nres+1)=c(j,1) - c(j,2*nres)=c(j,nres) - enddo - call int_from_cart1(.false.) - 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=nnt,nct - if (itype(i).ne.10) then - 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 - endif - enddo - - return - 10 return1 - end -c---------------------------------------------------------------------------- - subroutine read_threadbase - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.DBASE' - include 'COMMON.THREAD' - include 'COMMON.TIME1' -C Read pattern database for threading. - read (icbase,*) nseq - do i=1,nseq - read (icbase,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i), - & nres_base(2,i),nres_base(3,i) - read (icbase,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1, - & nres_base(1,i)) -c write (iout,'(i5,2x,a8,2i4)') nres_base(1,i),str_nam(i), -c & nres_base(2,i),nres_base(3,i) -c write (iout,'(9f8.3)') ((cart_base(k,j,i),k=1,3),j=1, -c & nres_base(1,i)) - enddo - close (icbase) - if (weidis.eq.0.0D0) weidis=0.1D0 - do i=nnt,nct - do j=i+2,nct - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=weidis - enddo - enddo - read (inp,*) nexcl,(iexam(1,i),iexam(2,i),i=1,nexcl) - write (iout,'(a,i5)') 'nexcl: ',nexcl - write (iout,'(2i5)') (iexam(1,i),iexam(2,i),i=1,nexcl) - return - end -c------------------------------------------------------------------------------ - subroutine setup_var - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.DBASE' - include 'COMMON.THREAD' - include 'COMMON.TIME1' -C Set up variable list. - ntheta=nres-2 - nphi=nres-3 - nvar=ntheta+nphi - nside=0 - do i=2,nres-1 - if (itype(i).ne.10) then - nside=nside+1 - ialph(i,1)=nvar+nside - ialph(nside,2)=i - endif - enddo - if (indphi.gt.0) then - nvar=nphi - else if (indback.gt.0) then - nvar=nphi+ntheta - else - nvar=nvar+2*nside - endif -cd write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1) - return - end -c---------------------------------------------------------------------------- - subroutine gen_dist_constr -C Generate CA distance constraints. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.LOCAL' - include 'COMMON.NAMES' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.HEADER' - include 'COMMON.CONTROL' - include 'COMMON.DBASE' - include 'COMMON.THREAD' - include 'COMMON.TIME1' - dimension itype_pdb(maxres) - common /pizda/ itype_pdb - character*2 iden -cd print *,'gen_dist_constr: nnt=',nnt,' nct=',nct -cd write (2,*) 'gen_dist_constr: nnt=',nnt,' nct=',nct, -cd & ' nstart_sup',nstart_sup,' nstart_seq',nstart_seq, -cd & ' nsup',nsup - do i=nstart_sup,nstart_sup+nsup-1 -cd write (2,*) 'i',i,' seq ',restyp(itype(i+nstart_seq-nstart_sup)), -cd & ' seq_pdb', restyp(itype_pdb(i)) - do j=i+2,nstart_sup+nsup-1 - nhpb=nhpb+1 - ihpb(nhpb)=i+nstart_seq-nstart_sup - jhpb(nhpb)=j+nstart_seq-nstart_sup - forcon(nhpb)=weidis - dhpb(nhpb)=dist(i,j) - enddo - enddo -cd write (iout,'(a)') 'Distance constraints:' -cd do i=nss+1,nhpb -cd ii=ihpb(i) -cd jj=jhpb(i) -cd iden='CA' -cd if (ii.gt.nres) then -cd iden='SC' -cd ii=ii-nres -cd jj=jj-nres -cd endif -cd write (iout,'(a,1x,a,i4,3x,a,1x,a,i4,2f10.3)') -cd & restyp(itype(ii)),iden,ii,restyp(itype(jj)),iden,jj, -cd & dhpb(i),forcon(i) -cd enddo - return - end -c---------------------------------------------------------------------------- - subroutine map_read - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MAP' - include 'COMMON.IOUNITS' - character*3 angid(4) /'THE','PHI','ALP','OME'/ - character*80 mapcard,ucase - do imap=1,nmap - read (inp,'(a)') mapcard - mapcard=ucase(mapcard) - if (index(mapcard,'PHI').gt.0) then - kang(imap)=1 - else if (index(mapcard,'THE').gt.0) then - kang(imap)=2 - else if (index(mapcard,'ALP').gt.0) then - kang(imap)=3 - else if (index(mapcard,'OME').gt.0) then - kang(imap)=4 - else - write(iout,'(a)')'Error - illegal variable spec in MAP card.' - stop 'Error - illegal variable spec in MAP card.' - endif - call readi (mapcard,'RES1',res1(imap),0) - call readi (mapcard,'RES2',res2(imap),0) - if (res1(imap).eq.0) then - res1(imap)=res2(imap) - else if (res2(imap).eq.0) then - res2(imap)=res1(imap) - endif - if(res1(imap)*res2(imap).eq.0 .or. res1(imap).gt.res2(imap))then - write (iout,'(a)') - & 'Error - illegal definition of variable group in MAP.' - stop 'Error - illegal definition of variable group in MAP.' - endif - call reada(mapcard,'FROM',ang_from(imap),0.0D0) - call reada(mapcard,'TO',ang_to(imap),0.0D0) - call readi(mapcard,'NSTEP',nstep(imap),0) - if (ang_from(imap).eq.ang_to(imap) .or. nstep(imap).eq.0) then - write (iout,'(a)') - & 'Illegal boundary and/or step size specification in MAP.' - stop 'Illegal boundary and/or step size specification in MAP.' - endif - enddo ! imap - return - end -c---------------------------------------------------------------------------- - subroutine csaread - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.CONTROL' - character*80 ucase - character*620 mcmcard - call card_concat(mcmcard) - - call readi(mcmcard,'NCONF',nconf,50) - call readi(mcmcard,'NADD',nadd,0) - call readi(mcmcard,'JSTART',jstart,1) - call readi(mcmcard,'JEND',jend,1) - call readi(mcmcard,'NSTMAX',nstmax,500000) - call readi(mcmcard,'N0',n0,1) - call readi(mcmcard,'N1',n1,6) - call readi(mcmcard,'N2',n2,4) - call readi(mcmcard,'N3',n3,0) - call readi(mcmcard,'N4',n4,0) - call readi(mcmcard,'N5',n5,0) - call readi(mcmcard,'N6',n6,10) - call readi(mcmcard,'N7',n7,0) - call readi(mcmcard,'N8',n8,0) - call readi(mcmcard,'N9',n9,0) - call readi(mcmcard,'N14',n14,0) - call readi(mcmcard,'N15',n15,0) - call readi(mcmcard,'N16',n16,0) - call readi(mcmcard,'N17',n17,0) - call readi(mcmcard,'N18',n18,0) - - vdisulf=(index(mcmcard,'DYNSS').gt.0) - - call readi(mcmcard,'NDIFF',ndiff,2) - call reada(mcmcard,'DIFFCUT',diffcut,0.0d0) - call readi(mcmcard,'IS1',is1,1) - call readi(mcmcard,'IS2',is2,8) - call readi(mcmcard,'NRAN0',nran0,4) - call readi(mcmcard,'NRAN1',nran1,2) - call readi(mcmcard,'IRR',irr,1) - call readi(mcmcard,'NSEED',nseed,20) - call readi(mcmcard,'NTOTAL',ntotal,10000) - call reada(mcmcard,'CUT1',cut1,2.0d0) - call reada(mcmcard,'CUT2',cut2,5.0d0) - call reada(mcmcard,'ESTOP',estop,-3000.0d0) - call readi(mcmcard,'ICMAX',icmax,3) - call readi(mcmcard,'IRESTART',irestart,0) -c!bankt call readi(mcmcard,'NBANKTM',ntbankm,0) - ntbankm=0 -c!bankt - call reada(mcmcard,'DELE',dele,20.0d0) - call reada(mcmcard,'DIFCUT',difcut,720.0d0) - call readi(mcmcard,'IREF',iref,0) - call reada(mcmcard,'RMSCUT',rmscut,4.0d0) - call reada(mcmcard,'PNCCUT',pnccut,0.5d0) - call readi(mcmcard,'NCONF_IN',nconf_in,0) - call reada(mcmcard,'RDIH_BIAS',rdih_bias,0.5d0) - write (iout,*) "NCONF_IN",nconf_in - return - end -c---------------------------------------------------------------------------- -cfmc subroutine mcmfread -cfmc implicit real*8 (a-h,o-z) -cfmc include 'DIMENSIONS' -cfmc include 'COMMON.MCMF' -cfmc include 'COMMON.IOUNITS' -cfmc include 'COMMON.GEO' -cfmc character*80 ucase -cfmc character*620 mcmcard -cfmc call card_concat(mcmcard) -cfmc -cfmc call readi(mcmcard,'MAXRANT',maxrant,1000) -cfmc write(iout,*)'MAXRANT=',maxrant -cfmc call readi(mcmcard,'MAXFAM',maxfam,maxfam_p) -cfmc write(iout,*)'MAXFAM=',maxfam -cfmc call readi(mcmcard,'NNET1',nnet1,5) -cfmc write(iout,*)'NNET1=',nnet1 -cfmc call readi(mcmcard,'NNET2',nnet2,4) -cfmc write(iout,*)'NNET2=',nnet2 -cfmc call readi(mcmcard,'NNET3',nnet3,4) -cfmc write(iout,*)'NNET3=',nnet3 -cfmc call readi(mcmcard,'ILASTT',ilastt,0) -cfmc write(iout,*)'ILASTT=',ilastt -cfmc call readi(mcmcard,'MAXSTR',maxstr,maxstr_mcmf) -cfmc write(iout,*)'MAXSTR=',maxstr -cfmc maxstr_f=maxstr/maxfam -cfmc write(iout,*)'MAXSTR_F=',maxstr_f -cfmc call readi(mcmcard,'NMCMF',nmcmf,10) -cfmc write(iout,*)'NMCMF=',nmcmf -cfmc call readi(mcmcard,'IFOCUS',ifocus,nmcmf) -cfmc write(iout,*)'IFOCUS=',ifocus -cfmc call readi(mcmcard,'NLOCMCMF',nlocmcmf,1000) -cfmc write(iout,*)'NLOCMCMF=',nlocmcmf -cfmc call readi(mcmcard,'INTPRT',intprt,1000) -cfmc write(iout,*)'INTPRT=',intprt -cfmc call readi(mcmcard,'IPRT',iprt,100) -cfmc write(iout,*)'IPRT=',iprt -cfmc call readi(mcmcard,'IMAXTR',imaxtr,100) -cfmc write(iout,*)'IMAXTR=',imaxtr -cfmc call readi(mcmcard,'MAXEVEN',maxeven,1000) -cfmc write(iout,*)'MAXEVEN=',maxeven -cfmc call readi(mcmcard,'MAXEVEN1',maxeven1,3) -cfmc write(iout,*)'MAXEVEN1=',maxeven1 -cfmc call readi(mcmcard,'INIMIN',inimin,200) -cfmc write(iout,*)'INIMIN=',inimin -cfmc call readi(mcmcard,'NSTEPMCMF',nstepmcmf,10) -cfmc write(iout,*)'NSTEPMCMF=',nstepmcmf -cfmc call readi(mcmcard,'NTHREAD',nthread,5) -cfmc write(iout,*)'NTHREAD=',nthread -cfmc call readi(mcmcard,'MAXSTEPMCMF',maxstepmcmf,2500) -cfmc write(iout,*)'MAXSTEPMCMF=',maxstepmcmf -cfmc call readi(mcmcard,'MAXPERT',maxpert,9) -cfmc write(iout,*)'MAXPERT=',maxpert -cfmc call readi(mcmcard,'IRMSD',irmsd,1) -cfmc write(iout,*)'IRMSD=',irmsd -cfmc call reada(mcmcard,'DENEMIN',denemin,0.01D0) -cfmc write(iout,*)'DENEMIN=',denemin -cfmc call reada(mcmcard,'RCUT1S',rcut1s,3.5D0) -cfmc write(iout,*)'RCUT1S=',rcut1s -cfmc call reada(mcmcard,'RCUT1E',rcut1e,2.0D0) -cfmc write(iout,*)'RCUT1E=',rcut1e -cfmc call reada(mcmcard,'RCUT2S',rcut2s,0.5D0) -cfmc write(iout,*)'RCUT2S=',rcut2s -cfmc call reada(mcmcard,'RCUT2E',rcut2e,0.1D0) -cfmc write(iout,*)'RCUT2E=',rcut2e -cfmc call reada(mcmcard,'DPERT1',d_pert1,180.0D0) -cfmc write(iout,*)'DPERT1=',d_pert1 -cfmc call reada(mcmcard,'DPERT1A',d_pert1a,180.0D0) -cfmc write(iout,*)'DPERT1A=',d_pert1a -cfmc call reada(mcmcard,'DPERT2',d_pert2,90.0D0) -cfmc write(iout,*)'DPERT2=',d_pert2 -cfmc call reada(mcmcard,'DPERT2A',d_pert2a,45.0D0) -cfmc write(iout,*)'DPERT2A=',d_pert2a -cfmc call reada(mcmcard,'DPERT2B',d_pert2b,90.0D0) -cfmc write(iout,*)'DPERT2B=',d_pert2b -cfmc call reada(mcmcard,'DPERT2C',d_pert2c,60.0D0) -cfmc write(iout,*)'DPERT2C=',d_pert2c -cfmc d_pert1=deg2rad*d_pert1 -cfmc d_pert1a=deg2rad*d_pert1a -cfmc d_pert2=deg2rad*d_pert2 -cfmc d_pert2a=deg2rad*d_pert2a -cfmc d_pert2b=deg2rad*d_pert2b -cfmc d_pert2c=deg2rad*d_pert2c -cfmc call reada(mcmcard,'KT_MCMF1',kt_mcmf1,1.0D0) -cfmc write(iout,*)'KT_MCMF1=',kt_mcmf1 -cfmc call reada(mcmcard,'KT_MCMF2',kt_mcmf2,1.0D0) -cfmc write(iout,*)'KT_MCMF2=',kt_mcmf2 -cfmc call reada(mcmcard,'DKT_MCMF1',dkt_mcmf1,10.0D0) -cfmc write(iout,*)'DKT_MCMF1=',dkt_mcmf1 -cfmc call reada(mcmcard,'DKT_MCMF2',dkt_mcmf2,1.0D0) -cfmc write(iout,*)'DKT_MCMF2=',dkt_mcmf2 -cfmc call reada(mcmcard,'RCUTINI',rcutini,3.5D0) -cfmc write(iout,*)'RCUTINI=',rcutini -cfmc call reada(mcmcard,'GRAT',grat,0.5D0) -cfmc write(iout,*)'GRAT=',grat -cfmc call reada(mcmcard,'BIAS_MCMF',bias_mcmf,0.0D0) -cfmc write(iout,*)'BIAS_MCMF=',bias_mcmf -cfmc -cfmc return -cfmc end -c---------------------------------------------------------------------------- - subroutine mcmread - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MCM' - include 'COMMON.MCE' - include 'COMMON.IOUNITS' - character*80 ucase - character*320 mcmcard - call card_concat(mcmcard) - call readi(mcmcard,'MAXACC',maxacc,100) - call readi(mcmcard,'MAX_MCM_IT',max_mcm_it,10000) - call readi(mcmcard,'MAXTRIAL',maxtrial,100) - call readi(mcmcard,'MAXTRIAL_ITER',maxtrial_iter,1000) - call readi(mcmcard,'MAXREPM',maxrepm,200) - call reada(mcmcard,'RANFRACT',RanFract,0.5D0) - call reada(mcmcard,'POOL_FRACT',pool_fraction,0.01D0) - call reada(mcmcard,'OVERLAP',overlap_cut,1.0D3) - call reada(mcmcard,'E_UP',e_up,5.0D0) - call reada(mcmcard,'DELTE',delte,0.1D0) - call readi(mcmcard,'NSWEEP',nsweep,5) - call readi(mcmcard,'NSTEPH',nsteph,0) - call readi(mcmcard,'NSTEPC',nstepc,0) - call reada(mcmcard,'TMIN',tmin,298.0D0) - call reada(mcmcard,'TMAX',tmax,298.0D0) - call readi(mcmcard,'NWINDOW',nwindow,0) - call readi(mcmcard,'PRINT_MC',print_mc,0) - print_stat=(index(mcmcard,'NO_PRINT_STAT').le.0) - print_int=(index(mcmcard,'NO_PRINT_INT').le.0) - ent_read=(index(mcmcard,'ENT_READ').gt.0) - call readi(mcmcard,'SAVE_FREQ',save_frequency,1000) - call readi(mcmcard,'MESSAGE_FREQ',message_frequency,1000) - call readi(mcmcard,'POOL_READ_FREQ',pool_read_freq,5000) - call readi(mcmcard,'POOL_SAVE_FREQ',pool_save_freq,1000) - call readi(mcmcard,'PRINT_FREQ',print_freq,1000) - if (nwindow.gt.0) then - read (inp,*) (winstart(i),winend(i),i=1,nwindow) - do i=1,nwindow - winlen(i)=winend(i)-winstart(i)+1 - enddo - endif - if (tmax.lt.tmin) tmax=tmin - if (tmax.eq.tmin) then - nstepc=0 - nsteph=0 - endif - if (nstepc.gt.0 .and. nsteph.gt.0) then - tsteph=(tmax/tmin)**(1.0D0/(nsteph+0.0D0)) - tstepc=(tmax/tmin)**(1.0D0/(nstepc+0.0D0)) - endif -C Probabilities of different move types - sumpro_type(0)=0.0D0 - call reada(mcmcard,'MULTI_BOND',sumpro_type(1),1.0d0) - call reada(mcmcard,'ONE_ANGLE' ,sumpro_type(2),2.0d0) - sumpro_type(2)=sumpro_type(1)+sumpro_type(2) - call reada(mcmcard,'THETA' ,sumpro_type(3),0.0d0) - sumpro_type(3)=sumpro_type(2)+sumpro_type(3) - call reada(mcmcard,'SIDE_CHAIN',sumpro_type(4),0.5d0) - sumpro_type(4)=sumpro_type(3)+sumpro_type(4) - do i=1,MaxMoveType - print *,'i',i,' sumprotype',sumpro_type(i) - sumpro_type(i)=sumpro_type(i)/sumpro_type(MaxMoveType) - print *,'i',i,' sumprotype',sumpro_type(i) - enddo - return - end -c---------------------------------------------------------------------------- - subroutine read_minim - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MINIM' - include 'COMMON.IOUNITS' - character*80 ucase - character*320 minimcard - call card_concat(minimcard) - call readi(minimcard,'MAXMIN',maxmin,2000) - call readi(minimcard,'MAXFUN',maxfun,5000) - call readi(minimcard,'MINMIN',minmin,maxmin) - call readi(minimcard,'MINFUN',minfun,maxmin) - call reada(minimcard,'TOLF',tolf,1.0D-2) - call reada(minimcard,'RTOLF',rtolf,1.0D-4) - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Options in energy minimization:' - write (iout,'(4(a,i5),a,1pe14.5,a,1pe14.5)') - & 'MaxMin:',MaxMin,' MaxFun:',MaxFun, - & 'MinMin:',MinMin,' MinFun:',MinFun, - & ' TolF:',TolF,' RTolF:',RTolF - return - end -c---------------------------------------------------------------------------- - subroutine read_angles(kanal,*) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' -c Read angles from input -c - read (kanal,*,err=10,end=10) (theta(i),i=3,nres) - read (kanal,*,err=10,end=10) (phi(i),i=4,nres) - read (kanal,*,err=10,end=10) (alph(i),i=2,nres-1) - read (kanal,*,err=10,end=10) (omeg(i),i=2,nres-1) - - do i=1,nres -c 9/7/01 avoid 180 deg valence angle - if (theta(i).gt.179.99d0) theta(i)=179.99d0 -c - theta(i)=deg2rad*theta(i) - phi(i)=deg2rad*phi(i) - alph(i)=deg2rad*alph(i) - omeg(i)=deg2rad*omeg(i) - enddo - return - 10 return1 - end -c---------------------------------------------------------------------------- - subroutine reada(rekord,lancuch,wartosc,default) - implicit none - character*(*) rekord,lancuch - double precision wartosc,default - integer ilen,iread - external ilen - iread=index(rekord,lancuch) - if (iread.eq.0) then - wartosc=default - return - endif - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,err=10,end=10) wartosc - return - 10 wartosc=default - return - end -c---------------------------------------------------------------------------- - subroutine readi(rekord,lancuch,wartosc,default) - implicit none - character*(*) rekord,lancuch - integer wartosc,default - integer ilen,iread - external ilen - iread=index(rekord,lancuch) - if (iread.eq.0) then - wartosc=default - return - endif - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,err=10,end=10) wartosc - return - 10 wartosc=default - return - end -c---------------------------------------------------------------------------- - subroutine multreadi(rekord,lancuch,tablica,dim,default) - implicit none - integer dim,i - integer tablica(dim),default - character*(*) rekord,lancuch - character*80 aux - integer ilen,iread - external ilen - do i=1,dim - tablica(i)=default - enddo - iread=index(rekord,lancuch(:ilen(lancuch))//"=") - if (iread.eq.0) return - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) - 10 return - end -c---------------------------------------------------------------------------- - subroutine multreada(rekord,lancuch,tablica,dim,default) - implicit none - integer dim,i - double precision tablica(dim),default - character*(*) rekord,lancuch - character*80 aux - integer ilen,iread - external ilen - do i=1,dim - tablica(i)=default - enddo - iread=index(rekord,lancuch(:ilen(lancuch))//"=") - if (iread.eq.0) return - iread=iread+ilen(lancuch)+1 - read (rekord(iread:),*,end=10,err=10) (tablica(i),i=1,dim) - 10 return - end -c---------------------------------------------------------------------------- - subroutine openunits - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' - character*16 form,nodename - integer nodelen -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.MD' - include 'COMMON.CONTROL' - integer lenpre,lenpot,ilen,lentmp - external ilen - character*3 out1file_text,ucase - character*3 ll - external ucase -c print *,"Processor",myrank,"fg_rank",fg_rank," entered openunits" - call getenv_loc("PREFIX",prefix) - pref_orig = prefix - call getenv_loc("POT",pot) - call getenv_loc("DIRTMP",tmpdir) - call getenv_loc("CURDIR",curdir) - call getenv_loc("OUT1FILE",out1file_text) -c print *,"Processor",myrank,"fg_rank",fg_rank," did GETENV" - out1file_text=ucase(out1file_text) - if (out1file_text(1:1).eq."Y") then - out1file=.true. - else - out1file=fg_rank.gt.0 - endif - lenpre=ilen(prefix) - lenpot=ilen(pot) - lentmp=ilen(tmpdir) - if (lentmp.gt.0) then - write (*,'(80(1h!))') - write (*,'(a,19x,a,19x,a)') "!"," A T T E N T I O N ","!" - write (*,'(80(1h!))') - write (*,*)"All output files will be on node /tmp directory." -#ifdef MPI - call MPI_GET_PROCESSOR_NAME( nodename, nodelen, IERROR ) - if (me.eq.king) then - write (*,*) "The master node is ",nodename - else if (fg_rank.eq.0) then - write (*,*) "I am the CG slave node ",nodename - else - write (*,*) "I am the FG slave node ",nodename - endif -#endif - PREFIX = tmpdir(:lentmp)//'/'//prefix(:lenpre) - lenpre = lentmp+lenpre+1 - endif - entname=prefix(:lenpre)//'_'//pot(:lenpot)//'.entr' -C Get the names and open the input files -#if defined(WINIFL) || defined(WINPGI) - open(1,file=pref_orig(:ilen(pref_orig))// - & '.inp',status='old',readonly,shared) - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',readonly,shared) - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',readonly,shared) - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',readonly,shared) - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',readonly,shared) - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',readonly,shared) - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',readonly,shared) - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',readonly,shared) - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old', - & action='read') -c print *,"Processor",myrank," opened file 1" - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -c print *,"Processor",myrank," opened file 9" -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',action='read') -c print *,"Processor",myrank," opened file IBOND" - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',action='read') -c print *,"Processor",myrank," opened file ITHEP" - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',action='read') -c print *,"Processor",myrank," opened file IROTAM" - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',action='read') -c print *,"Processor",myrank," opened file ITORP" - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',action='read') -c print *,"Processor",myrank," opened file ITORDP" - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old',action='read') -c print *,"Processor",myrank," opened file ISCCOR" - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',action='read') -c print *,"Processor",myrank," opened file IFOURIER" - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',action='read') -c print *,"Processor",myrank," opened file IELEP" - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',action='read') -c print *,"Processor",myrank," opened file ISIDEP" -c print *,"Processor",myrank," opened parameter files" -#elif (defined G77) - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old') - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old') - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old') - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old') - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old') - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old') - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old') - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old') - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old') - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old') -#else - open(1,file=pref_orig(:ilen(pref_orig))//'.inp',status='old', - & readonly) - open (9,file=prefix(:ilen(prefix))//'.intin',status='unknown') -C open (18,file=prefix(:ilen(prefix))//'.entin',status='unknown') -C Get parameter filenames and open the parameter files. - call getenv_loc('BONDPAR',bondname) - open (ibond,file=bondname,status='old',readonly) - call getenv_loc('THETPAR',thetname) - open (ithep,file=thetname,status='old',readonly) - call getenv_loc('ROTPAR',rotname) - open (irotam,file=rotname,status='old',readonly) - call getenv_loc('TORPAR',torname) - open (itorp,file=torname,status='old',readonly) - call getenv_loc('TORDPAR',tordname) - open (itordp,file=tordname,status='old',readonly) - call getenv_loc('SCCORPAR',sccorname) - open (isccor,file=sccorname,status='old',readonly) - call getenv_loc('FOURIER',fouriername) - open (ifourier,file=fouriername,status='old',readonly) - call getenv_loc('ELEPAR',elename) - open (ielep,file=elename,status='old',readonly) - call getenv_loc('SIDEPAR',sidename) - open (isidep,file=sidename,status='old',readonly) -#endif -#ifndef OLDSCP -C -C 8/9/01 In the newest version SCp interaction constants are read from a file -C Use -DOLDSCP to use hard-coded constants instead. -C - call getenv_loc('SCPPAR',scpname) -#if defined(WINIFL) || defined(WINPGI) - open (iscpp,file=scpname,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open (iscpp,file=scpname,status='old',action='read') -#elif (defined G77) - open (iscpp,file=scpname,status='old') -#else - open (iscpp,file=scpname,status='old',readonly) -#endif -#endif - call getenv_loc('PATTERN',patname) -#if defined(WINIFL) || defined(WINPGI) - open (icbase,file=patname,status='old',readonly,shared) -#elif (defined CRAY) || (defined AIX) - open (icbase,file=patname,status='old',action='read') -#elif (defined G77) - open (icbase,file=patname,status='old') -#else - open (icbase,file=patname,status='old',readonly) -#endif -#ifdef MPI -C Open output file only for CG processes -c print *,"Processor",myrank," fg_rank",fg_rank - if (fg_rank.eq.0) then - - if (nodes.eq.1) then - npos=3 - else - npos = dlog10(dfloat(nodes-1))+1 - endif - if (npos.lt.3) npos=3 - write (liczba,'(i1)') npos - form = '(bz,i'//liczba(:ilen(liczba))//'.'//liczba(:ilen(liczba)) - & //')' - write (liczba,form) me - outname=prefix(:lenpre)//'.out_'//pot(:lenpot)// - & liczba(:ilen(liczba)) - intname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) - & //'.int' - pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//liczba(:ilen(liczba)) - & //'.pdb' - mol2name=prefix(:lenpre)//'_'//pot(:lenpot)// - & liczba(:ilen(liczba))//'.mol2' - statname=prefix(:lenpre)//'_'//pot(:lenpot)// - & liczba(:ilen(liczba))//'.stat' - if (lentmp.gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot) - & //liczba(:ilen(liczba))//'.stat') - rest2name=prefix(:ilen(prefix))//"_"//liczba(:ilen(liczba)) - & //'.rst' - if(usampl) then - qname=prefix(:lenpre)//'_'//pot(:lenpot)// - & liczba(:ilen(liczba))//'.const' - endif - - endif -#else - outname=prefix(:lenpre)//'.out_'//pot(:lenpot) - intname=prefix(:lenpre)//'_'//pot(:lenpot)//'.int' - pdbname=prefix(:lenpre)//'_'//pot(:lenpot)//'.pdb' - mol2name=prefix(:lenpre)//'_'//pot(:lenpot)//'.mol2' - statname=prefix(:lenpre)//'_'//pot(:lenpot)//'.stat' - if (lentmp.gt.0) - & call copy_to_tmp(pref_orig(:ilen(pref_orig))//'_'//pot(:lenpot) - & //'.stat') - rest2name=prefix(:ilen(prefix))//'.rst' - if(usampl) then - qname=prefix(:lenpre)//'_'//pot(:lenpot)//'.const' - endif -#endif -#if defined(AIX) || defined(PGI) - if (me.eq.king .or. .not. out1file) - & open(iout,file=outname,status='unknown') -#ifdef DEBUG - if (fg_rank.gt.0) then - write (liczba,'(i3.3)') myrank/nfgtasks - write (ll,'(bz,i3.3)') fg_rank - open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll, - & status='unknown') - endif -#endif - if(me.eq.king) then - open(igeom,file=intname,status='unknown',position='append') - open(ipdb,file=pdbname,status='unknown') - open(imol2,file=mol2name,status='unknown') - open(istat,file=statname,status='unknown',position='append') - else -c1out open(iout,file=outname,status='unknown') - endif -#else - if (me.eq.king .or. .not.out1file) - & open(iout,file=outname,status='unknown') -#ifdef DEBUG - if (fg_rank.gt.0) then - write (liczba,'(i3.3)') myrank/nfgtasks - write (ll,'(bz,i3.3)') fg_rank - open(iout,file="debug"//liczba(:ilen(liczba))//"."//ll, - & status='unknown') - endif -#endif - if(me.eq.king) then - open(igeom,file=intname,status='unknown',access='append') - open(ipdb,file=pdbname,status='unknown') - open(imol2,file=mol2name,status='unknown') - open(istat,file=statname,status='unknown',access='append') - else -c1out open(iout,file=outname,status='unknown') - endif -#endif - csa_rbank=prefix(:lenpre)//'.CSA.rbank' - csa_seed=prefix(:lenpre)//'.CSA.seed' - csa_history=prefix(:lenpre)//'.CSA.history' - csa_bank=prefix(:lenpre)//'.CSA.bank' - csa_bank1=prefix(:lenpre)//'.CSA.bank1' - csa_alpha=prefix(:lenpre)//'.CSA.alpha' - csa_alpha1=prefix(:lenpre)//'.CSA.alpha1' -c!bankt csa_bankt=prefix(:lenpre)//'.CSA.bankt' - csa_int=prefix(:lenpre)//'.int' - csa_bank_reminimized=prefix(:lenpre)//'.CSA.bank_reminimized' - csa_native_int=prefix(:lenpre)//'.CSA.native.int' - csa_in=prefix(:lenpre)//'.CSA.in' -c print *,"Processor",myrank,"fg_rank",fg_rank," opened files" -C Write file names - if (me.eq.king)then - write (iout,'(80(1h-))') - write (iout,'(30x,a)') "FILE ASSIGNMENT" - write (iout,'(80(1h-))') - write (iout,*) "Input file : ", - & pref_orig(:ilen(pref_orig))//'.inp' - write (iout,*) "Output file : ", - & outname(:ilen(outname)) - write (iout,*) - write (iout,*) "Sidechain potential file : ", - & sidename(:ilen(sidename)) -#ifndef OLDSCP - write (iout,*) "SCp potential file : ", - & scpname(:ilen(scpname)) -#endif - write (iout,*) "Electrostatic potential file : ", - & elename(:ilen(elename)) - write (iout,*) "Cumulant coefficient file : ", - & fouriername(:ilen(fouriername)) - write (iout,*) "Torsional parameter file : ", - & torname(:ilen(torname)) - write (iout,*) "Double torsional parameter file : ", - & tordname(:ilen(tordname)) - write (iout,*) "SCCOR parameter file : ", - & sccorname(:ilen(sccorname)) - write (iout,*) "Bond & inertia constant file : ", - & bondname(:ilen(bondname)) - write (iout,*) "Bending parameter file : ", - & thetname(:ilen(thetname)) - write (iout,*) "Rotamer parameter file : ", - & rotname(:ilen(rotname)) - write (iout,*) "Threading database : ", - & patname(:ilen(patname)) - if (lentmp.ne.0) - &write (iout,*)" DIRTMP : ", - & tmpdir(:lentmp) - write (iout,'(80(1h-))') - endif - return - end -c---------------------------------------------------------------------------- - subroutine card_concat(card) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - character*(*) card - character*80 karta,ucase - external ilen - read (inp,'(a)') karta - karta=ucase(karta) - card=' ' - do while (karta(80:80).eq.'&') - card=card(:ilen(card)+1)//karta(:79) - read (inp,'(a)') karta - karta=ucase(karta) - enddo - card=card(:ilen(card)+1)//karta - return - end -c---------------------------------------------------------------------------------- - subroutine readrst - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.MD' - open(irest2,file=rest2name,status='unknown') - read(irest2,*) totT,EK,potE,totE,t_bath - do i=1,2*nres - read(irest2,'(3e15.5)') (d_t(j,i),j=1,3) - enddo - do i=1,2*nres - read(irest2,'(3e15.5)') (dc(j,i),j=1,3) - enddo - if(usampl) then - read (irest2,*) iset - endif - close(irest2) - return - end -c--------------------------------------------------------------------------------- - subroutine read_fragments - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.MD' - include 'COMMON.CONTROL' - read(inp,*) nset,nfrag,npair,nfrag_back - if(me.eq.king.or..not.out1file) - & write(iout,*) "nset",nset," nfrag",nfrag," npair",npair, - & " nfrag_back",nfrag_back - do iset=1,nset - read(inp,*) mset(iset) - do i=1,nfrag - read(inp,*) wfrag(i,iset),ifrag(1,i,iset),ifrag(2,i,iset), - & qinfrag(i,iset) - if(me.eq.king.or..not.out1file) - & write(iout,*) "R ",i,wfrag(i,iset),ifrag(1,i,iset), - & ifrag(2,i,iset), qinfrag(i,iset) - enddo - do i=1,npair - read(inp,*) wpair(i,iset),ipair(1,i,iset),ipair(2,i,iset), - & qinpair(i,iset) - if(me.eq.king.or..not.out1file) - & write(iout,*) "R ",i,wpair(i,iset),ipair(1,i,iset), - & ipair(2,i,iset), qinpair(i,iset) - enddo - do i=1,nfrag_back - read(inp,*) wfrag_back(1,i,iset),wfrag_back(2,i,iset), - & wfrag_back(3,i,iset), - & ifrag_back(1,i,iset),ifrag_back(2,i,iset) - if(me.eq.king.or..not.out1file) - & write(iout,*) "A",i,wfrag_back(1,i,iset),wfrag_back(2,i,iset), - & wfrag_back(3,i,iset),ifrag_back(1,i,iset),ifrag_back(2,i,iset) - enddo - enddo - return - end -c------------------------------------------------------------------------------- - subroutine read_dist_constr - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SETUP' - include 'COMMON.CONTROL' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.SBRIDGE' - integer ifrag_(2,100),ipair_(2,100) - double precision wfrag_(100),wpair_(100) - character*500 controlcard -c write (iout,*) "Calling read_dist_constr" -c write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup -c call flush(iout) - call card_concat(controlcard) - call readi(controlcard,"NFRAG",nfrag_,0) - call readi(controlcard,"NPAIR",npair_,0) - call readi(controlcard,"NDIST",ndist_,0) - call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) - call multreadi(controlcard,"IFRAG",ifrag_(1,1),2*nfrag_,0) - call multreadi(controlcard,"IPAIR",ipair_(1,1),2*npair_,0) - call multreada(controlcard,"WFRAG",wfrag_(1),nfrag_,0.0d0) - call multreada(controlcard,"WPAIR",wpair_(1),npair_,0.0d0) -c write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_ -c write (iout,*) "IFRAG" -c do i=1,nfrag_ -c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) -c enddo -c write (iout,*) "IPAIR" -c do i=1,npair_ -c write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i) -c enddo - call flush(iout) - do i=1,nfrag_ - if (ifrag_(1,i).lt.nstart_sup) ifrag_(1,i)=nstart_sup - if (ifrag_(2,i).gt.nstart_sup+nsup-1) - & ifrag_(2,i)=nstart_sup+nsup-1 -c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) - call flush(iout) - if (wfrag_(i).gt.0.0d0) then - do j=ifrag_(1,i),ifrag_(2,i)-1 - do k=j+1,ifrag_(2,i) - write (iout,*) "j",j," k",k - ddjk=dist(j,k) - if (constr_dist.eq.1) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - else if (constr_dist.eq.2) then - if (ddjk.le.dist_cut) then - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i) - endif - else - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - dhpb(nhpb)=ddjk - forcon(nhpb)=wfrag_(i)*dexp(-0.5d0*(ddjk/dist_cut)**2) - endif -#ifdef MPI - if (.not.out1file .or. me.eq.king) - & write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#else - write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#endif - enddo - enddo - endif - enddo - do i=1,npair_ - if (wpair_(i).gt.0.0d0) then - ii = ipair_(1,i) - jj = ipair_(2,i) - if (ii.gt.jj) then - itemp=ii - ii=jj - jj=itemp - endif - do j=ifrag_(1,ii),ifrag_(2,ii) - do k=ifrag_(1,jj),ifrag_(2,jj) - nhpb=nhpb+1 - ihpb(nhpb)=j - jhpb(nhpb)=k - forcon(nhpb)=wpair_(i) - dhpb(nhpb)=dist(j,k) -#ifdef MPI - if (.not.out1file .or. me.eq.king) - & write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#else - write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#endif - enddo - enddo - endif - enddo - do i=1,ndist_ - read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1) - if (forcon(nhpb+1).gt.0.0d0) then - nhpb=nhpb+1 - dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) -#ifdef MPI - if (.not.out1file .or. me.eq.king) - & write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#else - write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", - & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) -#endif - endif - enddo - call flush(iout) - return - end -c------------------------------------------------------------------------------- -#ifdef WINIFL - subroutine flush(iu) - return - end -#endif -#ifdef AIX - subroutine flush(iu) - call flush_(iu) - return - end -#endif -c------------------------------------------------------------------------------ - subroutine copy_to_tmp(source) - include "DIMENSIONS" - include "COMMON.IOUNITS" - character*(*) source - character* 256 tmpfile - integer ilen - external ilen - logical ex - tmpfile=curdir(:ilen(curdir))//"/"//source(:ilen(source)) - inquire(file=tmpfile,exist=ex) - if (ex) then - write (*,*) "Copying ",tmpfile(:ilen(tmpfile)), - & " to temporary directory..." - write (*,*) "/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir - call system("/bin/cp "//tmpfile(:ilen(tmpfile))//" "//tmpdir) - endif - return - end -c------------------------------------------------------------------------------ - subroutine move_from_tmp(source) - include "DIMENSIONS" - include "COMMON.IOUNITS" - character*(*) source - integer ilen - external ilen - write (*,*) "Moving ",source(:ilen(source)), - & " from temporary directory to working directory" - write (*,*) "/bin/mv "//source(:ilen(source))//" "//curdir - call system("/bin/mv "//source(:ilen(source))//" "//curdir) - return - end -c------------------------------------------------------------------------------ - subroutine random_init(seed) -C -C Initialize random number generator -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef AMD64 - integer*8 iseedi8 -#endif -#ifdef MPI - include 'mpif.h' - logical OKRandom, prng_restart - real*8 r1 - integer iseed_array(4) -#endif - include 'COMMON.IOUNITS' - include 'COMMON.TIME1' - include 'COMMON.THREAD' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.MCM' - include 'COMMON.MAP' - include 'COMMON.HEADER' - include 'COMMON.CSA' - include 'COMMON.CHAIN' - include 'COMMON.MUCA' - include 'COMMON.MD' - include 'COMMON.FFIELD' - include 'COMMON.SETUP' - iseed=-dint(dabs(seed)) - if (iseed.eq.0) then - write (iout,'(/80(1h*)/20x,a/80(1h*))') - & 'Random seed undefined. The program will stop.' - write (*,'(/80(1h*)/20x,a/80(1h*))') - & 'Random seed undefined. The program will stop.' -#ifdef MPI - call mpi_finalize(mpi_comm_world,ierr) -#endif - stop 'Bad random seed.' - endif -#ifdef MPI - if (fg_rank.eq.0) then - seed=seed*(me+1)+1 -#ifdef AMD64 - iseedi8=dint(seed) - if(me.eq.king .or. .not. out1file) - & write (iout,*) 'MPI: node= ', me, ' iseed= ',iseedi8 - write (*,*) 'MPI: node= ', me, ' iseed= ',iseedi8 - OKRandom = prng_restart(me,iseedi8) -#else - do i=1,4 - tmp=65536.0d0**(4-i) - iseed_array(i) = dint(seed/tmp) - seed=seed-iseed_array(i)*tmp - enddo - if(me.eq.king .or. .not. out1file) - & write (iout,*) 'MPI: node= ', me, ' iseed(4)= ', - & (iseed_array(i),i=1,4) - write (*,*) 'MPI: node= ',me, ' iseed(4)= ', - & (iseed_array(i),i=1,4) - OKRandom = prng_restart(me,iseed_array) -#endif - if (OKRandom) then - r1=ran_number(0.0D0,1.0D0) - if(me.eq.king .or. .not. out1file) - & write (iout,*) 'ran_num',r1 - if (r1.lt.0.0d0) OKRandom=.false. - endif - if (.not.OKRandom) then - write (iout,*) 'PRNG IS NOT WORKING!!!' - print *,'PRNG IS NOT WORKING!!!' - if (me.eq.0) then - call flush(iout) - call mpi_abort(mpi_comm_world,error_msg,ierr) - stop - else - write (iout,*) 'too many processors for parallel prng' - write (*,*) 'too many processors for parallel prng' - call flush(iout) - stop - endif - endif - endif -#else - call vrndst(iseed) - write (iout,*) 'ran_num',ran_number(0.0d0,1.0d0) -#endif - return - end diff --git a/source/unres/src_MD/shift.F b/source/unres/src_MD/shift.F deleted file mode 100644 index 6eb9b3f..0000000 --- a/source/unres/src_MD/shift.F +++ /dev/null @@ -1,105 +0,0 @@ -c--------------------------------- - subroutine csa_read - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - - open(icsa_in,file=csa_in,status="old",err=100) - read(icsa_in,*) nconf - read(icsa_in,*) jstart,jend - read(icsa_in,*) nstmax - read(icsa_in,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 - read(icsa_in,*) nran0,nran1,irr - read(icsa_in,*) nseed - read(icsa_in,*) ntotal,cut1,cut2 - read(icsa_in,*) estop - read(icsa_in,*) icmax,irestart - read(icsa_in,*) ntbankm,dele,difcut - read(icsa_in,*) iref,rmscut,pnccut - read(icsa_in,*) ndiff - close(icsa_in) - - return - - 100 continue - return - end -c--------------------------------- - subroutine initial_write - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - - open(icsa_seed,file=csa_seed,status="unknown") - write(icsa_seed,*) "seed" - close(31) -#if defined(AIX) || defined(PGI) - open(icsa_history,file=csa_history,status="unknown", - & position="append") -#else - open(icsa_history,file=csa_history,status="unknown", - & access="append") -#endif - write(icsa_history,*) nconf - write(icsa_history,*) jstart,jend - write(icsa_history,*) nstmax - write(icsa_history,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 - write(icsa_history,*) nran0,nran1,irr - write(icsa_history,*) nseed - write(icsa_history,*) ntotal,cut1,cut2 - write(icsa_history,*) estop - write(icsa_history,*) icmax,irestart - write(icsa_history,*) ntbankm,dele,difcut - write(icsa_history,*) iref,rmscut,pnccut - write(icsa_history,*) ndiff - - write(icsa_history,*) - close(icsa_history) - - open(icsa_bank1,file=csa_bank1,status="unknown") - write(icsa_bank1,*) 0 - close(icsa_bank1) - - return - end -c--------------------------------- - subroutine restart_write - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - -#if defined(AIX) || defined(PGI) - open(icsa_history,file=csa_history,position="append") -#else - open(icsa_history,file=csa_history,access="append") -#endif - write(icsa_history,*) - write(icsa_history,*) "This is restart" - write(icsa_history,*) - write(icsa_history,*) nconf - write(icsa_history,*) jstart,jend - write(icsa_history,*) nstmax - write(icsa_history,*) n1,n2,n3,n4,n5,n6,n7,n8,is1,is2 - write(icsa_history,*) nran0,nran1,irr - write(icsa_history,*) nseed - write(icsa_history,*) ntotal,cut1,cut2 - write(icsa_history,*) estop - write(icsa_history,*) icmax,irestart - write(icsa_history,*) ntbankm,dele,difcut - write(icsa_history,*) iref,rmscut,pnccut - write(icsa_history,*) ndiff - write(icsa_history,*) - write(icsa_history,*) "irestart is: ", irestart - - write(icsa_history,*) - close(icsa_history) - - return - end -c--------------------------------- diff --git a/source/unres/src_MD/test.F b/source/unres/src_MD/test.F index 0ae6fdf..0140ee5 100644 --- a/source/unres/src_MD/test.F +++ b/source/unres/src_MD/test.F @@ -115,79 +115,6 @@ c call write_pdb(999,'full min',etot) end - subroutine test_n16 - 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.DISTFIT' - 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),var1(maxvar) - integer jdata(5) - logical debug - debug=.true. - -c - call geom_to_var(nvar,var1) - call chainbuild - call etotal(energy(0)) - etot=energy(0) - write(iout,*) nnt,nct,etot - call write_pdb(1,'first structure',etot) - call secondary2(.true.) - - do i=1,4 - jdata(i)=bfrag(i,2) - enddo - - DO ij=1,4 - ieval=0 - jdata(5)=ij - call var_to_geom(nvar,var1) - write(iout,*) 'N16 test',(jdata(i),i=1,5) - call beta_slide(jdata(1),jdata(2),jdata(3),jdata(4),jdata(5) - & ,ieval,ij) - call geom_to_var(nvar,var) - - 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(ij*100+99,'full min',etot) - endif - - - ENDDO - - return - end subroutine test_local @@ -303,1212 +230,171 @@ c-------------------------------------------------------- end -c------------------------------------------ - subroutine test11 +c------------------------------------------------- + + subroutine secondary(lprint) 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' -c - include 'COMMON.DISTFIT' - integer if(20,maxres),nif,ifa(20) - integer ibc(0:maxres,0:maxres),istrand(20) - integer ibd(maxres),ifb(10,2),nifb,lifb(10),lifb0 - integer itmp(20,maxres) - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision varia(maxvar),vorg(maxvar) -c - logical debug,ltest,usedbfrag(maxres/3) - character*50 linia -c - integer betasheet(maxres),ibetasheet(maxres),nbetasheet - integer bstrand(maxres/3,6),nbstrand + include 'COMMON.DISTFIT' -c------------------------ + integer ncont,icont(2,maxres*maxres/2),isec(maxres,3) + logical lprint,not_done + real dcont(maxres*maxres/2),d + real rcomp /7.0/ + real rbeta /5.2/ + real ralfa /5.2/ + real r310 /6.6/ + double precision xpi(3),xpj(3) - debug=.true. -c------------------------ - nbstrand=0 - nbetasheet=0 - do i=1,nres - betasheet(i)=0 - ibetasheet(i)=0 - enddo - call geom_to_var(nvar,vorg) - call secondary2(debug) - if (nbfrag.le.1) return - do i=1,nbfrag - usedbfrag(i)=.false. + call chainbuild +cd call write_pdb(99,'sec structure',0d0) + ncont=0 + nbfrag=0 + nhfrag=0 + do i=1,nres + isec(i,1)=0 + isec(i,2)=0 + isec(i,3)=0 enddo - - nbetasheet=nbetasheet+1 - nbstrand=2 - bstrand(1,1)=bfrag(1,1) - bstrand(1,2)=bfrag(2,1) - bstrand(1,3)=nbetasheet - bstrand(1,4)=1 - bstrand(1,5)=bfrag(1,1) - bstrand(1,6)=bfrag(2,1) - do i=bfrag(1,1),bfrag(2,1) - betasheet(i)=nbetasheet - ibetasheet(i)=1 - enddo -c - bstrand(2,1)=bfrag(3,1) - bstrand(2,2)=bfrag(4,1) - bstrand(2,3)=nbetasheet - bstrand(2,5)=bfrag(3,1) - bstrand(2,6)=bfrag(4,1) - - if (bfrag(3,1).le.bfrag(4,1)) then - bstrand(2,4)=2 - do i=bfrag(3,1),bfrag(4,1) - betasheet(i)=nbetasheet - ibetasheet(i)=2 + do i=2,nres-3 + do k=1,3 + xpi(k)=0.5d0*(c(k,i-1)+c(k,i)) enddo - else - bstrand(2,4)=-2 - do i=bfrag(4,1),bfrag(3,1) - betasheet(i)=nbetasheet - ibetasheet(i)=2 + do j=i+2,nres + do k=1,3 + xpj(k)=0.5d0*(c(k,j-1)+c(k,j)) + enddo +cd d = (c(1,i)-c(1,j))*(c(1,i)-c(1,j)) + +cd & (c(2,i)-c(2,j))*(c(2,i)-c(2,j)) + +cd & (c(3,i)-c(3,j))*(c(3,i)-c(3,j)) +cd print *,'CA',i,j,d + d = (xpi(1)-xpj(1))*(xpi(1)-xpj(1)) + + & (xpi(2)-xpj(2))*(xpi(2)-xpj(2)) + + & (xpi(3)-xpj(3))*(xpi(3)-xpj(3)) + if ( d.lt.rcomp*rcomp) then + ncont=ncont+1 + icont(1,ncont)=i + icont(2,ncont)=j + dcont(ncont)=sqrt(d) + endif + enddo + enddo + if (lprint) then + write (iout,*) + write (iout,'(a)') '#PP contact map distances:' + do i=1,ncont + write (iout,'(3i4,f10.5)') + & i,icont(1,i),icont(2,i),dcont(i) enddo endif - iused_nbfrag=1 - - do while (iused_nbfrag.ne.nbfrag) - - do j=2,nbfrag - - IF (.not.usedbfrag(j)) THEN - - write (*,*) j,(bfrag(i,j),i=1,4) - do jk=6,1,-1 - write (*,'(i4,a3,10i4)') jk,'B',(bstrand(i,jk),i=1,nbstrand) - enddo - write (*,*) '------------------' +c finding parallel beta +cd write (iout,*) '------- looking for parallel beta -----------' + nbeta=0 + nstrand=0 + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + if(dcont(i).le.rbeta .and. j1-i1.gt.4 .and. + & isec(i1,1).le.1.and.isec(j1,1).le.1.and. + & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. + & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. + & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. + & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) + & ) then + ii1=i1 + jj1=j1 +cd write (iout,*) i1,j1,dcont(i) + not_done=.true. + do while (not_done) + i1=i1+1 + j1=j1+1 + do j=1,ncont + if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j) + & .and. dcont(j).le.rbeta .and. + & isec(i1,1).le.1.and.isec(j1,1).le.1.and. + & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. + & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. + & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. + & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) + & ) goto 5 + enddo + not_done=.false. + 5 continue +cd write (iout,*) i1,j1,dcont(j),not_done + enddo + j1=j1-1 + i1=i1-1 + if (i1-ii1.gt.1) then + ii1=max0(ii1-1,1) + jj1=max0(jj1-1,1) + nbeta=nbeta+1 + if(lprint)write(iout,*)'parallel beta',nbeta,ii1,i1,jj1,j1 + nbfrag=nbfrag+1 + bfrag(1,nbfrag)=ii1 + bfrag(2,nbfrag)=i1 + bfrag(3,nbfrag)=jj1 + bfrag(4,nbfrag)=j1 - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - if(betasheet(i).eq.nbetasheet) then - in=ibetasheet(i) - do k=bfrag(3,j),bfrag(4,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in - enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand - enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(2,j) - bstrand(nbstrand,2)=bfrag(1,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(4,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+ - & (bstrand(in,5)-bfrag(4,j)) - endif - if(bstrand(in,2).gt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(3,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)- - & (-bstrand(in,6)+bfrag(3,j)) - endif - else - bstrand(nbstrand,1)=bfrag(1,j) - bstrand(nbstrand,2)=bfrag(2,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(3,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)- - & (-bstrand(in,5)+bfrag(3,j)) - endif - if(bstrand(in,2).lt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(4,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+ - & (bstrand(in,6)-bfrag(4,j)) - endif - endif - goto 11 - endif - if(betasheet(bfrag(1,j)+i-bfrag(3,j)).eq.nbetasheet) then - in=ibetasheet(bfrag(1,j)+i-bfrag(3,j)) - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in - enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(3,1),bfrag(4,1) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand - enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(4,j) - bstrand(nbstrand,2)=bfrag(3,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(2,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+ - & (bstrand(in,5)-bfrag(2,j)) - endif - if(bstrand(in,2).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(1,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)- - & (-bstrand(in,6)+bfrag(1,j)) - endif - else - bstrand(nbstrand,1)=bfrag(3,j) - bstrand(nbstrand,2)=bfrag(4,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(1,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)- - & (-bstrand(in,5)+bfrag(1,j)) - endif - if(bstrand(in,2).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(2,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+ - & (bstrand(in,6)-bfrag(2,j)) - endif - endif - goto 11 - endif - enddo - else - do i=bfrag(4,j),bfrag(3,j) - if(betasheet(i).eq.nbetasheet) then - in=ibetasheet(i) - do k=bfrag(4,j),bfrag(3,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in + do ij=ii1,i1 + isec(ij,1)=isec(ij,1)+1 + isec(ij,1+isec(ij,1))=nbeta enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand + do ij=jj1,j1 + isec(ij,1)=isec(ij,1)+1 + isec(ij,1+isec(ij,1))=nbeta enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(1,j) - bstrand(nbstrand,2)=bfrag(2,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(3,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)- - & (bstrand(in,5)-bfrag(3,j)) - endif - if(bstrand(in,2).gt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(4,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+ - & (-bstrand(in,6)+bfrag(4,j)) - endif + + if(lprint) then + nstrand=nstrand+1 + if (nbeta.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-1,"..",i1-1,"'" else - bstrand(nbstrand,1)=bfrag(2,j) - bstrand(nbstrand,2)=bfrag(1,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(4,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(4,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+ - & (-bstrand(in,5)+bfrag(4,j)) - endif - if(bstrand(in,2).lt.bfrag(3,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(3,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)- - & (bstrand(in,6)-bfrag(3,j)) - endif + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-1,"..",i1-1,"'" endif - goto 11 - endif - if(betasheet(bfrag(2,j)-i+bfrag(4,j)).eq.nbetasheet) then - in=ibetasheet(bfrag(2,j)-i+bfrag(4,j)) - do k=bfrag(1,j),bfrag(2,j) - betasheet(k)=nbetasheet - ibetasheet(k)=in - enddo - nbstrand=nbstrand+1 - usedbfrag(j)=.true. - iused_nbfrag=iused_nbfrag+1 - do k=bfrag(4,j),bfrag(3,j) - betasheet(k)=nbetasheet - ibetasheet(k)=nbstrand - enddo - if (bstrand(in,4).lt.0) then - bstrand(nbstrand,1)=bfrag(4,j) - bstrand(nbstrand,2)=bfrag(3,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(2,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)- - & (bstrand(in,5)-bfrag(2,j)) - endif - if(bstrand(in,2).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(1,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)+ - & (-bstrand(in,6)+bfrag(1,j)) - endif + nstrand=nstrand+1 + if (nbeta.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",jj1-1,"..",j1-1,"'" else - bstrand(nbstrand,1)=bfrag(3,j) - bstrand(nbstrand,2)=bfrag(4,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,4)=-nbstrand - bstrand(nbstrand,5)=bstrand(nbstrand,1) - bstrand(nbstrand,6)=bstrand(nbstrand,2) - if(bstrand(in,1).gt.bfrag(1,j)) then - call bgrow(bstrand,nbstrand,in,1,bfrag(1,j)) - else - bstrand(nbstrand,5)=bstrand(nbstrand,5)+ - & (-bstrand(in,5)+bfrag(1,j)) - endif - if(bstrand(in,2).lt.bfrag(2,j)) then - call bgrow(bstrand,nbstrand,in,2,bfrag(2,j)) - else - bstrand(nbstrand,6)=bstrand(nbstrand,6)- - & (bstrand(in,6)-bfrag(2,j)) - endif + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",jj1-1,"..",j1-1,"'" endif - goto 11 + write(12,'(a8,4i4)') + & "SetNeigh",ii1-1,i1-1,jj1-1,j1-1 + endif endif - enddo endif - - - - ENDIF - enddo - - j=2 - do while (usedbfrag(j)) - j=j+1 enddo - - nbstrand=nbstrand+1 - nbetasheet=nbetasheet+1 - bstrand(nbstrand,1)=bfrag(1,j) - bstrand(nbstrand,2)=bfrag(2,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,5)=bfrag(1,j) - bstrand(nbstrand,6)=bfrag(2,j) - - bstrand(nbstrand,4)=nbstrand - do i=bfrag(1,j),bfrag(2,j) - betasheet(i)=nbetasheet - ibetasheet(i)=nbstrand - enddo -c - nbstrand=nbstrand+1 - bstrand(nbstrand,1)=bfrag(3,j) - bstrand(nbstrand,2)=bfrag(4,j) - bstrand(nbstrand,3)=nbetasheet - bstrand(nbstrand,5)=bfrag(3,j) - bstrand(nbstrand,6)=bfrag(4,j) - - if (bfrag(3,j).le.bfrag(4,j)) then - bstrand(nbstrand,4)=nbstrand - do i=bfrag(3,j),bfrag(4,j) - betasheet(i)=nbetasheet - ibetasheet(i)=nbstrand - enddo - else - bstrand(nbstrand,4)=-nbstrand - do i=bfrag(4,j),bfrag(3,j) - betasheet(i)=nbetasheet - ibetasheet(i)=nbstrand - enddo - endif - - iused_nbfrag=iused_nbfrag+1 - usedbfrag(j)=.true. +c finding antiparallel beta +cd write (iout,*) '--------- looking for antiparallel beta ---------' - 11 continue - do jk=6,1,-1 - write (*,'(i4,a3,10i4)') jk,'A',(bstrand(i,jk),i=1,nbstrand) - enddo - - - enddo - - do i=1,nres - if (betasheet(i).ne.0) write(*,*) i,betasheet(i),ibetasheet(i) - enddo - write(*,*) - do j=6,1,-1 - write (*,'(i4,a3,10i4)') j,':',(bstrand(i,j),i=1,nbstrand) - enddo - -c------------------------ - nifb=0 - do i=1,nbstrand - do j=i+1,nbstrand - if(iabs(bstrand(i,5)-bstrand(j,5)).le.5 .or. - & iabs(bstrand(i,6)-bstrand(j,6)).le.5 ) then - nifb=nifb+1 - ifb(nifb,1)=bstrand(i,4) - ifb(nifb,2)=bstrand(j,4) - endif - enddo - enddo - - write(*,*) - do i=1,nifb - write (*,'(a3,20i4)') "ifb",i,ifb(i,1),ifb(i,2) - enddo - - do i=1,nbstrand - ifa(i)=bstrand(i,4) - enddo - write (*,'(a3,20i4)') "ifa",(ifa(i),i=1,nbstrand) - - nif=iabs(bstrand(1,6)-bstrand(1,5))+1 - do j=2,nbstrand - if (iabs(bstrand(j,6)-bstrand(j,5))+1.gt.nif) - & nif=iabs(bstrand(j,6)-bstrand(j,5))+1 - enddo - - write(*,*) nif - do i=1,nif - do j=1,nbstrand - if(j,i)=bstrand(j,6)+(i-1)*sign(1,bstrand(j,5)-bstrand(j,6)) - if (if(j,i).gt.0) then - if(betasheet(if(j,i)).eq.0 .or. - & ibetasheet(if(j,i)).ne.iabs(bstrand(j,4))) if(j,i)=0 - else - if(j,i)=0 - endif - enddo - write(*,'(a3,10i4)') 'if ',(if(j,i),j=1,nbstrand) - enddo - -c read (inp,*) (ifa(i),i=1,4) -c do i=1,nres -c read (inp,*,err=20,end=20) (if(j,i),j=1,4) -c enddo -c 20 nif=i-1 - stop -c------------------------ - - isa=4 - is=2*isa-1 - iconf=0 -cccccccccccccccccccccccccccccccccc - DO ig=1,is**isa-1 -cccccccccccccccccccccccccccccccccc - - ii=ig - do j=1,is - istrand(is-j+1)=int(ii/is**(is-j)) - ii=ii-istrand(is-j+1)*is**(is-j) - enddo - ltest=.true. - do k=1,isa - istrand(k)=istrand(k)+1 - if(istrand(k).gt.isa) istrand(k)=istrand(k)-2*isa-1 - enddo - do k=1,isa - do l=1,isa - if(istrand(k).eq.istrand(l).and.k.ne.l.or. - & istrand(k).eq.-istrand(l).and.k.ne.l) ltest=.false. - enddo - enddo - - lifb0=1 - do m=1,nifb - lifb(m)=0 - do k=1,isa-1 - if( - & ifb(m,1).eq.istrand(k).and.ifb(m,2).eq.istrand(k+1).or. - & ifb(m,2).eq.istrand(k).and.ifb(m,1).eq.istrand(k+1).or. - & -ifb(m,1).eq.istrand(k).and.-ifb(m,2).eq.istrand(k+1).or. - & -ifb(m,2).eq.istrand(k).and.-ifb(m,1).eq.istrand(k+1)) - & lifb(m)=1 - enddo - lifb0=lifb0*lifb(m) - enddo - - if (mod(isa,2).eq.0) then - do k=isa/2+1,isa - if (istrand(k).eq.1) ltest=.false. - enddo - else - do k=(isa+1)/2+1,isa - if (istrand(k).eq.1) ltest=.false. - enddo - endif - - IF (ltest.and.lifb0.eq.1) THEN - iconf=iconf+1 - - call var_to_geom(nvar,vorg) - - write (*,'(i5,i10,10i3)') iconf,ig,(istrand(k),k=1,isa) - write (iout,'(i5,i10,10i3)') iconf,ig,(istrand(k),k=1,isa) - write (linia,'(10i3)') (istrand(k),k=1,isa) - - do i=1,nres - do j=1,nres - ibc(i,j)=0 - enddo - enddo - - - do i=1,4 - if ( sign(1,istrand(i)).eq.sign(1,ifa(iabs(istrand(i)))) ) then - do j=1,nif - itmp(iabs(istrand(i)),j)=if(iabs(ifa(iabs(istrand(i)))),j) - enddo - else - do j=1,nif - itmp(iabs(istrand(i)),j)=if(iabs(ifa(iabs(istrand(i)))),nif-j+1) - enddo - endif - enddo - - do i=1,nif - write(*,*) (itmp(j,i),j=1,4) - enddo - - do i=1,nif -c ifa(1),ifa(2),ifa(3),ifa(4) -c if(1,i),if(2,i),if(3,i),if(4,i) - do k=1,isa-1 - ltest=.false. - do m=1,nifb - if( - & ifb(m,1).eq.istrand(k).and.ifb(m,2).eq.istrand(k+1).or. - & ifb(m,2).eq.istrand(k).and.ifb(m,1).eq.istrand(k+1).or. - & -ifb(m,1).eq.istrand(k).and.-ifb(m,2).eq.istrand(k+1).or. - & -ifb(m,2).eq.istrand(k).and.-ifb(m,1).eq.istrand(k+1)) - & then - ltest=.true. - goto 110 - endif - enddo - 110 continue - if (ltest) then - ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+1)),i))=-1 - else - ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+1)),i))=-2 - endif -c - if (k.lt.3) - & ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+2)),i))=-3 - if (k.lt.2) - & ibc(itmp(iabs(istrand(k)),i),itmp(iabs(istrand(k+3)),i))=-4 - enddo - enddo -c------------------------ - -c -c freeze sec.elements -c - do i=1,nres - mask(i)=1 - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - enddo - - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - 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) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - 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) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - enddo - mask_r=.true. - -c------------------------ -c generate constrains -c - nhpb0=nhpb - call chainbuild - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( ibc(i,j).eq.-1 .or. ibc(j,i).eq.-1) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).eq.-2 .or. ibc(j,i).eq.-2) then - d0(ind)=5.0 - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).eq.-3 .or. ibc(j,i).eq.-3) then - d0(ind)=11.0 - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).eq.-4 .or. ibc(j,i).eq.-4) then - d0(ind)=16.0 - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).gt.0 ) then - d0(ind)=DIST(i,ibc(i,j)) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(j,i).gt.0 ) then - d0(ind)=DIST(ibc(j,i),j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - dd(ind)=d0(ind) - enddo - enddo - call hpb_partition -cd-------------------------- - - write(iout,'(i3,2i4,a3,2i4,f7.2)') (i,ibc(ihpb(i),jhpb(i)), - & ibc(jhpb(i),ihpb(i)),' --', - & ihpb(i),jhpb(i),dhpb(i),i=1,nhpb) - -cd nhpb=0 -cd goto 901 -c -c - call contact_cp_min(varia,ifun,iconf,linia,debug) - if (minim) then -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,varia,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, - & '+ DIST eval',ifun -#ifdef MPI - time1=MPI_WTIME() -#else - time0=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - write (linia,'(a10,10i3)') 'full_min',(istrand(k),k=1,isa) - call var_to_geom(nvar,varia) - call chainbuild - call write_pdb(900+iconf,linia,etot) - endif - - call etotal(energy(0)) - etot=energy(0) - call enerprint(energy(0)) -cd call intout -cd call briefout(0,etot) -cd call secondary2(.true.) - - 901 CONTINUE -ctest return -cccccccccccccccccccccccccccccccccccc - ENDIF - ENDDO -cccccccccccccccccccccccccccccccccccc - - return - 10 write (iout,'(a)') 'Error reading test structure.' - return - end -c-------------------------------------------------------- - - subroutine test3 - 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' -c - include 'COMMON.DISTFIT' - integer if(3,maxres),nif - integer ibc(maxres,maxres),istrand(20) - integer ibd(maxres),ifb(10,2),nifb,lifb(10),lifb0 - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision varia(maxvar) -c - logical debug,ltest - character*50 linia -c - do i=1,nres - read (inp,*,err=20,end=20) if(1,i),if(2,i),if(3,i) - enddo - 20 nif=i-1 - write (*,'(a4,3i5)') ('if =',if(1,i),if(2,i),if(3,i), - & i=1,nif) - - -c------------------------ - call secondary2(debug) -c------------------------ - do i=1,nres - do j=1,nres - ibc(i,j)=0 - enddo - enddo - -c -c freeze sec.elements and store indexes for beta constrains -c - do i=1,nres - mask(i)=1 - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - enddo - - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - 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) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - ibc(bfrag(1,j)+i-bfrag(3,j),i)=-1 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - ibc(bfrag(2,j)-i+bfrag(4,j),i)=-1 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - enddo - mask_r=.true. - - -c ---------------- test -------------- - do i=1,nif - if (ibc(if(1,i),if(2,i)).eq.-1) then - ibc(if(1,i),if(2,i))=if(3,i) - ibc(if(1,i),if(3,i))=if(2,i) - else if (ibc(if(2,i),if(1,i)).eq.-1) then - ibc(if(2,i),if(1,i))=0 - ibc(if(1,i),if(2,i))=if(3,i) - ibc(if(1,i),if(3,i))=if(2,i) - else - ibc(if(1,i),if(2,i))=if(3,i) - ibc(if(1,i),if(3,i))=if(2,i) - endif - enddo - - do i=1,nres - do j=1,nres - if (ibc(i,j).ne.0) write(*,'(3i5)') i,j,ibc(i,j) - enddo - enddo -c------------------------ - call chainbuild - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( ibc(i,j).eq.-1 ) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(i,j).gt.0 ) then - d0(ind)=DIST(i,ibc(i,j)) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else if ( ibc(j,i).gt.0 ) then - d0(ind)=DIST(ibc(j,i),j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - enddo - enddo - call hpb_partition - -cd-------------------------- - write(*,'(i3,2i4,a3,2i4,f7.2)') (i,ibc(ihpb(i),jhpb(i)), - & ibc(jhpb(i),ihpb(i)),' --', - & ihpb(i),jhpb(i),dhpb(i),i=1,nhpb) - - - linia='dist' - debug=.true. - in_pdb=7 -c - call contact_cp_min(varia,ieval,in_pdb,linia,debug) - if (minim) then -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,varia,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, - & '+ DIST eval',ieval -#ifdef MPI - time1=MPI_WTIME() -#else - time0=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,varia) - call chainbuild - call write_pdb(999,'full min',etot) - endif - - call etotal(energy(0)) - etot=energy(0) - call enerprint(energy(0)) - call intout - call briefout(0,etot) - call secondary2(.true.) - - return - 10 write (iout,'(a)') 'Error reading test structure.' - return - end - - - - - subroutine test__ - 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' -c - include 'COMMON.DISTFIT' - integer if(2,2),ind - integer iff(maxres) - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision theta2(maxres),phi2(maxres),alph2(maxres), - & omeg2(maxres), - & theta1(maxres),phi1(maxres),alph1(maxres), - & omeg1(maxres) - double precision varia(maxvar),varia2(maxvar) -c - - - read (inp,*,err=10,end=10) if(1,1),if(1,2),if(2,1),if(2,2) - write (iout,'(a4,4i5)') 'if =',if(1,1),if(1,2),if(2,1),if(2,2) - read (inp,*,err=10,end=10) (theta2(i),i=3,nres) - read (inp,*,err=10,end=10) (phi2(i),i=4,nres) - read (inp,*,err=10,end=10) (alph2(i),i=2,nres-1) - read (inp,*,err=10,end=10) (omeg2(i),i=2,nres-1) - do i=1,nres - theta2(i)=deg2rad*theta2(i) - phi2(i)=deg2rad*phi2(i) - alph2(i)=deg2rad*alph2(i) - omeg2(i)=deg2rad*omeg2(i) - enddo - do i=1,nres - theta1(i)=theta(i) - phi1(i)=phi(i) - alph1(i)=alph(i) - omeg1(i)=omeg(i) - enddo - - do i=1,nres - mask(i)=1 - enddo - - -c------------------------ - do i=1,nres - iff(i)=0 - enddo - do j=1,2 - do i=if(j,1),if(j,2) - iff(i)=1 - enddo - enddo - - call chainbuild - call geom_to_var(nvar,varia) - call write_pdb(1,'first structure',0d0) - - call secondary(.true.) - - call secondary2(.true.) - - do j=1,nbfrag - if ( (bfrag(3,j).lt.bfrag(4,j) .or. - & bfrag(4,j)-bfrag(2,j).gt.4) .and. - & bfrag(2,j)-bfrag(1,j).gt.3 ) then - nn=nn+1 - - if (bfrag(3,j).lt.bfrag(4,j)) then - write(iout,'(a6,i3,a1,i3,a1,i3,a1,i3)') - & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 - & ,",",bfrag(3,j)-1,"-",bfrag(4,j)-1 - else - write(iout,'(a6,i3,a1,i3,a1,i3,a1,i3)') - & "select",bfrag(1,j)-1,"-",bfrag(2,j)-1 - & ,",",bfrag(4,j)-1,"-",bfrag(3,j)-1 - endif - endif - enddo - - do i=1,nres - theta(i)=theta2(i) - phi(i)=phi2(i) - alph(i)=alph2(i) - omeg(i)=omeg2(i) - enddo - - call chainbuild - call geom_to_var(nvar,varia2) - call write_pdb(2,'second structure',0d0) - - - -c------------------------------------------------------- - - ifun=-1 - call contact_cp(varia,varia2,iff,ifun,7) - if (minim) then -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,varia,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, - & '+ DIST eval',ifun -#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,varia) - call chainbuild - call write_pdb(999,'full min',etot) - endif - - call etotal(energy(0)) - etot=energy(0) - call enerprint(energy(0)) - call intout - call briefout(0,etot) - - return - 10 write (iout,'(a)') 'Error reading test structure.' - return - end - -c------------------------------------------------- -c------------------------------------------------- - - subroutine secondary(lprint) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - - integer ncont,icont(2,maxres*maxres/2),isec(maxres,3) - logical lprint,not_done - real dcont(maxres*maxres/2),d - real rcomp /7.0/ - real rbeta /5.2/ - real ralfa /5.2/ - real r310 /6.6/ - double precision xpi(3),xpj(3) - - - - call chainbuild -cd call write_pdb(99,'sec structure',0d0) - ncont=0 - nbfrag=0 - nhfrag=0 - do i=1,nres - isec(i,1)=0 - isec(i,2)=0 - isec(i,3)=0 - enddo - - do i=2,nres-3 - do k=1,3 - xpi(k)=0.5d0*(c(k,i-1)+c(k,i)) - enddo - do j=i+2,nres - do k=1,3 - xpj(k)=0.5d0*(c(k,j-1)+c(k,j)) - enddo -cd d = (c(1,i)-c(1,j))*(c(1,i)-c(1,j)) + -cd & (c(2,i)-c(2,j))*(c(2,i)-c(2,j)) + -cd & (c(3,i)-c(3,j))*(c(3,i)-c(3,j)) -cd print *,'CA',i,j,d - d = (xpi(1)-xpj(1))*(xpi(1)-xpj(1)) + - & (xpi(2)-xpj(2))*(xpi(2)-xpj(2)) + - & (xpi(3)-xpj(3))*(xpi(3)-xpj(3)) - if ( d.lt.rcomp*rcomp) then - ncont=ncont+1 - icont(1,ncont)=i - icont(2,ncont)=j - dcont(ncont)=sqrt(d) - endif - enddo - enddo - if (lprint) then - write (iout,*) - write (iout,'(a)') '#PP contact map distances:' - do i=1,ncont - write (iout,'(3i4,f10.5)') - & i,icont(1,i),icont(2,i),dcont(i) - enddo - endif - -c finding parallel beta -cd write (iout,*) '------- looking for parallel beta -----------' - nbeta=0 - nstrand=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if(dcont(i).le.rbeta .and. j1-i1.gt.4 .and. - & isec(i1,1).le.1.and.isec(j1,1).le.1.and. - & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. - & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. - & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. - & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) - & ) then - ii1=i1 - jj1=j1 -cd write (iout,*) i1,j1,dcont(i) - not_done=.true. - do while (not_done) - i1=i1+1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j) - & .and. dcont(j).le.rbeta .and. - & isec(i1,1).le.1.and.isec(j1,1).le.1.and. - & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. - & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. - & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. - & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) - & ) goto 5 - enddo - not_done=.false. - 5 continue -cd write (iout,*) i1,j1,dcont(j),not_done - enddo - j1=j1-1 - i1=i1-1 - if (i1-ii1.gt.1) then - ii1=max0(ii1-1,1) - jj1=max0(jj1-1,1) - nbeta=nbeta+1 - if(lprint)write(iout,*)'parallel beta',nbeta,ii1,i1,jj1,j1 - - nbfrag=nbfrag+1 - bfrag(1,nbfrag)=ii1 - bfrag(2,nbfrag)=i1 - bfrag(3,nbfrag)=jj1 - bfrag(4,nbfrag)=j1 - - do ij=ii1,i1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - do ij=jj1,j1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - - if(lprint) then - nstrand=nstrand+1 - if (nbeta.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-1,"..",i1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-1,"..",i1-1,"'" - endif - nstrand=nstrand+1 - if (nbeta.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",jj1-1,"..",j1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",jj1-1,"..",j1-1,"'" - endif - write(12,'(a8,4i4)') - & "SetNeigh",ii1-1,i1-1,jj1-1,j1-1 - endif - endif - endif - enddo - -c finding antiparallel beta -cd write (iout,*) '--------- looking for antiparallel beta ---------' - - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if (dcont(i).le.rbeta.and. - & isec(i1,1).le.1.and.isec(j1,1).le.1.and. - & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. - & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. - & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. - & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) - & ) then - ii1=i1 - jj1=j1 -cd write (iout,*) i1,j1,dcont(i) + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + if (dcont(i).le.rbeta.and. + & isec(i1,1).le.1.and.isec(j1,1).le.1.and. + & (isec(i1,2).ne.isec(j1,2).or.isec(i1,2)*isec(j1,2).eq.0).and. + & (isec(i1,3).ne.isec(j1,3).or.isec(i1,3)*isec(j1,3).eq.0).and. + & (isec(i1,2).ne.isec(j1,3).or.isec(i1,2)*isec(j1,3).eq.0).and. + & (isec(i1,3).ne.isec(j1,2).or.isec(i1,3)*isec(j1,2).eq.0) + & ) then + ii1=i1 + jj1=j1 +cd write (iout,*) i1,j1,dcont(i) not_done=.true. do while (not_done) @@ -1528,785 +414,178 @@ cd write (iout,*) i1,j1,dcont(i) cd write (iout,*) i1,j1,dcont(j),not_done enddo i1=i1-1 - j1=j1+1 - if (i1-ii1.gt.1) then - if(lprint)write (iout,*)'antiparallel beta', - & nbeta,ii1-1,i1,jj1,j1-1 - - nbfrag=nbfrag+1 - bfrag(1,nbfrag)=max0(ii1-1,1) - bfrag(2,nbfrag)=i1 - bfrag(3,nbfrag)=jj1 - bfrag(4,nbfrag)=max0(j1-1,1) - - nbeta=nbeta+1 - iii1=max0(ii1-1,1) - do ij=iii1,i1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - jjj1=max0(j1-1,1) - do ij=jjj1,jj1 - isec(ij,1)=isec(ij,1)+1 - isec(ij,1+isec(ij,1))=nbeta - enddo - - - if (lprint) then - nstrand=nstrand+1 - if (nstrand.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-2,"..",i1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",ii1-2,"..",i1-1,"'" - endif - nstrand=nstrand+1 - if (nstrand.le.9) then - write(12,'(a18,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",j1-2,"..",jj1-1,"'" - else - write(12,'(a18,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'strand",nstrand, - & "' 'num = ",j1-2,"..",jj1-1,"'" - endif - write(12,'(a8,4i4)') - & "SetNeigh",ii1-2,i1-1,jj1-1,j1-2 - endif - endif - endif - enddo - - if (nstrand.gt.0.and.lprint) then - write(12,'(a27,$)') "DefPropRes 'sheet' 'strand1" - do i=2,nstrand - if (i.le.9) then - write(12,'(a9,i1,$)') " | strand",i - else - write(12,'(a9,i2,$)') " | strand",i - endif - enddo - write(12,'(a1)') "'" - endif - - -c finding alpha or 310 helix - - nhelix=0 - do i=1,ncont - i1=icont(1,i) - j1=icont(2,i) - if (j1.eq.i1+3.and.dcont(i).le.r310 - & .or.j1.eq.i1+4.and.dcont(i).le.ralfa ) then -cd if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,dcont(i) -cd if (j1.eq.i1+4) write (iout,*) "found 1-5 ",i1,j1,dcont(i) - ii1=i1 - jj1=j1 - if (isec(ii1,1).eq.0) then - not_done=.true. - else - not_done=.false. - endif - do while (not_done) - i1=i1+1 - j1=j1+1 - do j=1,ncont - if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 - enddo - not_done=.false. - 10 continue -cd write (iout,*) i1,j1,not_done - enddo - j1=j1-1 - if (j1-ii1.gt.4) then - nhelix=nhelix+1 -cd write (iout,*)'helix',nhelix,ii1,j1 - - nhfrag=nhfrag+1 - hfrag(1,nhfrag)=ii1 - hfrag(2,nhfrag)=max0(j1-1,1) - - do ij=ii1,j1 - isec(ij,1)=-1 - enddo - if (lprint) then - write (iout,'(a6,i3,2i4)') "Helix",nhelix,ii1-1,j1-2 - if (nhelix.le.9) then - write(12,'(a17,i1,a9,i3,a2,i3,a1)') - & "DefPropRes 'helix",nhelix, - & "' 'num = ",ii1-1,"..",j1-2,"'" - else - write(12,'(a17,i2,a9,i3,a2,i3,a1)') - & "DefPropRes 'helix",nhelix, - & "' 'num = ",ii1-1,"..",j1-2,"'" - endif - endif - endif - endif - enddo - - if (nhelix.gt.0.and.lprint) then - write(12,'(a26,$)') "DefPropRes 'helix' 'helix1" - do i=2,nhelix - if (nhelix.le.9) then - write(12,'(a8,i1,$)') " | helix",i - else - write(12,'(a8,i2,$)') " | helix",i - endif - enddo - write(12,'(a1)') "'" - endif - - if (lprint) then - write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'" - write(12,'(a20)') "XMacStand ribbon.mac" - endif - - - 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 - -c----------------------------------------------------------- - subroutine contact_cp2(var,var2,iff,ieval,in_pdb) - 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.DISTFIT' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.MINIM' - - character*50 linia - integer nf,ij(4) - double precision var(maxvar),var2(maxvar) - double precision time0,time1 - integer iff(maxres),ieval - double precision theta1(maxres),phi1(maxres),alph1(maxres), - & omeg1(maxres) - - - 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 - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - 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 - - call var_to_geom(nvar,var2) - - 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 - - call chainbuild -cd call write_pdb(3,'combined structure',0d0) -cd time0=MPI_WTIME() - - NX=NRES-3 - NY=((NRES-4)*(NRES-5))/2 - call distfit(.true.,200) - -cd time1=MPI_WTIME() -cd write (iout,'(a,f6.2,a)') ' Time for distfit ',time1-time0,' sec' - - ipot0=ipot - maxmin0=maxmin - maxfun0=maxfun - wstrain0=wstrain + j1=j1+1 + if (i1-ii1.gt.1) then + if(lprint)write (iout,*)'antiparallel beta', + & nbeta,ii1-1,i1,jj1,j1-1 - ipot=6 - maxmin=2000 - maxfun=5000 - call geom_to_var(nvar,var) -cd time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun + nbfrag=nbfrag+1 + bfrag(1,nbfrag)=max0(ii1-1,1) + bfrag(2,nbfrag)=i1 + bfrag(3,nbfrag)=jj1 + bfrag(4,nbfrag)=max0(j1-1,1) -cd time1=MPI_WTIME() -cd write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, -cd & nfun/(time1-time0),' SOFT eval/s' - call var_to_geom(nvar,var) - call chainbuild + nbeta=nbeta+1 + iii1=max0(ii1-1,1) + do ij=iii1,i1 + isec(ij,1)=isec(ij,1)+1 + isec(ij,1+isec(ij,1))=nbeta + enddo + jjj1=max0(j1-1,1) + do ij=jjj1,jj1 + isec(ij,1)=isec(ij,1)+1 + isec(ij,1+isec(ij,1))=nbeta + enddo - iwsk=0 - nf=0 - if (iff(1).eq.1) then - iwsk=1 - nf=nf+1 - ij(nf)=0 - 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 + if (lprint) then + nstrand=nstrand+1 + if (nstrand.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-2,"..",i1-1,"'" + else + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",ii1-2,"..",i1-1,"'" + endif + nstrand=nstrand+1 + if (nstrand.le.9) then + write(12,'(a18,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",j1-2,"..",jj1-1,"'" + else + write(12,'(a18,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'strand",nstrand, + & "' 'num = ",j1-2,"..",jj1-1,"'" + endif + write(12,'(a8,4i4)') + & "SetNeigh",ii1-2,i1-1,jj1-1,j1-2 endif - enddo - if (iff(nres).eq.1) then - nf=nf+1 - ij(nf)=nres + endif endif - - -cd write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') -cd & "select",ij(1),"-",ij(2), -cd & ",",ij(3),"-",ij(4) -cd call write_pdb(in_pdb,linia,etot) - - - ipot=ipot0 - maxmin=maxmin0 - maxfun=maxfun0 -cd time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) -cd write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun - ieval=nfun - -cd time1=MPI_WTIME() -cd write (iout,'(a,f6.2,f8.2,a)')' Time for DIST min.',time1-time0, -cd & nfun/(time1-time0),' eval/s' -cd call var_to_geom(nvar,var) -cd call chainbuild -cd call write_pdb(6,'dist structure',etot) - - - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - - return - end -c----------------------------------------------------------- - 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.DISTFIT' - 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 - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - 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) - 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) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - 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) - 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 + if (nstrand.gt.0.and.lprint) then + write(12,'(a27,$)') "DefPropRes 'sheet' 'strand1" + do i=2,nstrand + if (i.le.9) then + write(12,'(a9,i1,$)') " | strand",i + else + write(12,'(a9,i2,$)') " | strand",i + 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 - + write(12,'(a1)') "'" 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.DISTFIT' - 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 - +c finding alpha or 310 helix - 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 + nhelix=0 + do i=1,ncont + i1=icont(1,i) + j1=icont(2,i) + if (j1.eq.i1+3.and.dcont(i).le.r310 + & .or.j1.eq.i1+4.and.dcont(i).le.ralfa ) then +cd if (j1.eq.i1+3) write (iout,*) "found 1-4 ",i1,j1,dcont(i) +cd if (j1.eq.i1+4) write (iout,*) "found 1-5 ",i1,j1,dcont(i) + ii1=i1 + jj1=j1 + if (isec(ii1,1).eq.0) then + not_done=.true. + else + not_done=.false. + endif + do while (not_done) + i1=i1+1 + j1=j1+1 + do j=1,ncont + if (i1.eq.icont(1,j) .and. j1.eq.icont(2,j)) goto 10 + enddo + not_done=.false. + 10 continue +cd write (iout,*) i1,j1,not_done + enddo + j1=j1-1 + if (j1-ii1.gt.4) then + nhelix=nhelix+1 +cd write (iout,*)'helix',nhelix,ii1,j1 -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) + nhfrag=nhfrag+1 + hfrag(1,nhfrag)=ii1 + hfrag(2,nhfrag)=max0(j1-1,1) - 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) + do ij=ii1,j1 + isec(ij,1)=-1 + enddo + if (lprint) then + write (iout,'(a6,i3,2i4)') "Helix",nhelix,ii1-1,j1-2 + if (nhelix.le.9) then + write(12,'(a17,i1,a9,i3,a2,i3,a1)') + & "DefPropRes 'helix",nhelix, + & "' 'num = ",ii1-1,"..",j1-2,"'" + else + write(12,'(a17,i2,a9,i3,a2,i3,a1)') + & "DefPropRes 'helix",nhelix, + & "' 'num = ",ii1-1,"..",j1-2,"'" + endif + endif + endif + endif + enddo + + if (nhelix.gt.0.and.lprint) then + write(12,'(a26,$)') "DefPropRes 'helix' 'helix1" + do i=2,nhelix + if (nhelix.le.9) then + write(12,'(a8,i1,$)') " | helix",i else - mask_r=.false. - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - return + write(12,'(a8,i2,$)') " | helix",i 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 + enddo + write(12,'(a1)') "'" + endif - call minimize(etot,var,iretcode,nfun) + if (lprint) then + write(12,'(a37)') "DefPropRes 'coil' '! (helix | sheet)'" + write(12,'(a20)') "XMacStand ribbon.mac" + endif -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) - 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 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 - return - end c-------------------------------------------------------- subroutine softreg implicit real*8 (a-h,o-z) @@ -2582,238 +861,3 @@ c 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.DISTFIT' - 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.DISTFIT' - 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 diff --git a/source/unres/src_MD/tmptmp b/source/unres/src_MD/tmptmp index 54e7a36..3efe90f 100644 --- a/source/unres/src_MD/tmptmp +++ b/source/unres/src_MD/tmptmp @@ -1 +1 @@ -adam +czarek diff --git a/source/unres/src_MD/together.F b/source/unres/src_MD/together.F deleted file mode 100644 index 5763fc0..0000000 --- a/source/unres/src_MD/together.F +++ /dev/null @@ -1,1223 +0,0 @@ -#ifdef MPI - Subroutine together -c feeds tasks for parallel processing - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - real ran1,ran2 - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.TIME1' - include 'COMMON.SETUP' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - real tcpu - double precision time_start,time_start_c,time0f,time0i - logical ovrtim,sync_iter,timeout,flag,timeout1 - dimension muster(mpi_status_size) - dimension t100(0:100),indx(mxio) - dimension xout(maxvar),eout(mxch*(mxch+1)/2+1),ind(9) - dimension cout(2) - parameter (rad=1.745329252d-2) - -cccccccccccccccccccccccccccccccccccccccccccccccc - IF (ME.EQ.KING) THEN - - time0f=MPI_WTIME() - ilastnstep=1 - sync_iter=.false. - numch=1 - nrmsdb=0 - nrmsdb1=0 - rmsdbc1c=rmsdbc1 - nstep=0 - call csa_read - call make_array - - if(iref.ne.0) call from_int(1,0,idum) - -c To minimize input conformation (bank conformation) -c Output to $mol.reminimized - if (irestart.lt.0) then - call read_bank(0,nft,cutdifr) - if (irestart.lt.-10) then - p_cut=nres*4.d0 - call prune_bank(p_cut) - return - endif - call reminimize(jlee) - return - endif - - if (irestart.eq.0) then - call initial_write - nbank=nconf - ntbank=nconf - if (ntbankm.eq.0) ntbank=0 - nstep=0 - nft=0 - do i=1,mxio - ibank(i)=0 - jbank(i)=0 - enddo - else - call restart_write -c!bankt call read_bankt(jlee,nft,cutdifr) - call read_bank(jlee,nft,cutdifr) - call read_rbank(jlee,adif) - if(iref.ne.0) call from_int(1,0,idum) - endif - - nstmax=nstmax+nstep - ntrial=n1+n2+n3+n4+n5+n6+n7+n8 - ntry=ntrial+1 - ntry=ntry*nseed - -c ntrial : number of trial conformations per seed. -c ntry : total number of trial conformations including seed conformations. - - idum2=-123 - imax=2**31-1 - ENDIF - - call mpi_bcast(jend,1,mpi_integer,0,CG_COMM,ierr) -cccccccccccccccccccccccccccccccccccccccc - do 300 jlee=1,jend -cccccccccccccccccccccccccccccccccccccccc - 331 continue - IF (ME.EQ.KING) THEN - if(sync_iter) goto 333 - idum=- ran2(idum2)*imax - if(jlee.lt.jstart) goto 300 - -C Restart the random number generator for conformation generation - - if(irestart.gt.0) then - idum2=idum2+nstep - if(idum2.le.0) idum2=-idum2+1 - idum=- ran2(idum2)*imax - endif - - idumm=idum - call vrndst(idumm) - - open(icsa_seed,file=csa_seed,status="old") - write(icsa_seed,*) "jlee : ",jlee - close(icsa_seed) - - call history_append - write(icsa_history,*) "number of procs is ",nodes - write(icsa_history,*) jlee,idum,idum2 - close(icsa_history) - -cccccccccccccccccccccccccccccccccccccccccccccccc - 333 icycle=0 - - call history_append - write(icsa_history,*) "nbank is ",nbank - close(icsa_history) - - if(irestart.eq.1) goto 111 - if(irestart.eq.2) then - icycle=0 - do i=1,nbank - ibank(i)=1 - enddo - do i=nbank+1,nbank+nconf - ibank(i)=0 - enddo - endif - -c start energy minimization - nconfr=max0(nconf+nadd,nodes-1) - if (sync_iter) nconf_in=0 -c king-emperor - feed input and sort output - write (iout,*) "NCONF_IN",nconf_in - m=0 - if (nconf_in.gt.0) then -c al 7/2/00 - added possibility to read in some of the initial conformations - do m=1,nconf_in - read (intin,'(i5)',end=11,err=12) iconf - 12 continue - write (iout,*) "write READ_ANGLES",iconf,m - call read_angles(intin,*11) - if (iref.eq.0) then - mm=m - else - mm=m+1 - endif - do j=2,nres-1 - dihang_in(1,j,1,mm)=theta(j+1) - dihang_in(2,j,1,mm)=phi(j+2) - dihang_in(3,j,1,mm)=alph(j) - dihang_in(4,j,1,mm)=omeg(j) - enddo - enddo ! m - goto 13 - 11 write (iout,*) nconf_in," conformations requested, but only", - & m-1," found in the angle file." - nconf_in=m-1 - 13 continue - m=nconf_in - write (iout,*) nconf_in, - & " initial conformations have been read in." - endif - if (iref.eq.0) then - if (nconfr.gt.nconf_in) then - call make_ranvar(nconfr,m,idum) - write (iout,*) nconfr-nconf_in, - & " conformations have been generated randomly." - endif - else - nconfr=nconfr*2 - call from_int(nconfr,m,idum) -c call from_pdb(nconfr,idum) - endif - write (iout,*) 'Exitted from make_ranvar nconfr=',nconfr - write (*,*) 'Exitted from make_ranvar nconfr=',nconfr - do m=1,nconfr - write (iout,*) 'Initial conformation',m - write(iout,'(8f10.4)') (rad2deg*dihang_in(1,j,1,m),j=2,nres-1) - write(iout,'(8f10.4)') (rad2deg*dihang_in(2,j,1,m),j=2,nres-1) - write(iout,'(8f10.4)') (rad2deg*dihang_in(3,j,1,m),j=2,nres-1) - write(iout,'(8f10.4)') (rad2deg*dihang_in(4,j,1,m),j=2,nres-1) - enddo - write(iout,*)'Calling FEEDIN NCONF',nconfr - time1i=MPI_WTIME() - call feedin(nconfr,nft) - write (iout,*) ' Time for first bank min.',MPI_WTIME()-time1i - call history_append - write(icsa_history,*) jlee,nft,nbank - write(icsa_history,851) (etot(i),i=1,nconfr) - write(icsa_history,850) (rmsn(i),i=1,nconfr) - write(icsa_history,850) (pncn(i),i=1,nconfr) - write(icsa_history,*) - close(icsa_history) - ELSE -c To minimize input conformation (bank conformation) -c Output to $mol.reminimized - if (irestart.lt.0) then - call reminimize(jlee) - return - endif - if (irestart.eq.1) goto 111 -c soldier - perform energy minimization - 334 call minim_jlee - ENDIF - -ccccccccccccccccccccccccccccccccccc -c need to syncronize all procs - call mpi_barrier(CG_COMM,ierr) - if (ierr.ne.0) then - print *, ' cannot synchronize MPI' - stop - endif -ccccccccccccccccccccccccccccccccccc - - IF (ME.EQ.KING) THEN - -c print *,"ok after minim" - nstep=nstep+nconf - if(irestart.eq.2) then - nbank=nbank+nconf -c ntbank=ntbank+nconf - if(ntbank.gt.ntbankm) ntbank=ntbankm - endif -c print *,"ok before indexx" - if(iref.eq.0) then - call indexx(nconfr,etot,indx) - else -c cc/al 7/6/00 - do k=1,nconfr - indx(k)=k - enddo - call indexx(nconfr-nconf_in,rmsn(nconf_in+1),indx(nconf_in+1)) - do k=nconf_in+1,nconfr - indx(k)=indx(k)+nconf_in - enddo -c cc/al -c call indexx(nconfr,rmsn,indx) - endif -c print *,"ok after indexx" - do im=1,nconf - m=indx(im) - if (m.gt.mxio .or. m.lt.1) then - write (iout,*) 'Dimension ERROR in TOGEHER: IM',im,' M',m - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - jbank(im+nbank-nconf)=0 - bene(im+nbank-nconf)=etot(m) - rene(im+nbank-nconf)=etot(m) -c!bankt btene(im)=etot(m) -c - brmsn(im+nbank-nconf)=rmsn(m) - bpncn(im+nbank-nconf)=pncn(m) - rrmsn(im+nbank-nconf)=rmsn(m) - rpncn(im+nbank-nconf)=pncn(m) - if (im+nbank-nconf.gt.mxio .or. im+nbank-nconf.lt.1) then - write (iout,*) 'Dimension ERROR in TOGEHER: IM',im, - & ' NBANK',nbank,' NCONF',nconf,' IM+NBANK-NCONF',im+nbank-nconf - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do k=1,numch - do j=2,nres-1 - do i=1,4 - bvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) - rvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) -c!bankt btvar(i,j,k,im)=dihang(i,j,k,m) -c - enddo - enddo - enddo - if(iref.eq.1) then - if(brmsn(im+nbank-nconf).gt.rmscut.or. - & bpncn(im+nbank-nconf).lt.pnccut) ibank(im+nbank-nconf)=9 - endif - if(vdisulf) then - bvar_ns(im+nbank-nconf)=ns-2*nss - k=0 - do i=1,ns - j=1 - do while( iss(i).ne.ihpb(j)-nres .and. - & iss(i).ne.jhpb(j)-nres .and. j.le.nss) - j=j+1 - enddo - if (j.gt.nss) then - k=k+1 - bvar_s(k,im+nbank-nconf)=iss(i) - endif - enddo - endif - bvar_nss(im+nbank-nconf)=nss - do i=1,nss - bvar_ss(1,i,im+nbank-nconf)=ihpb(i) - bvar_ss(2,i,im+nbank-nconf)=jhpb(i) - enddo - enddo - ENDIF - - 111 continue - - IF (ME.EQ.KING) THEN - - call find_max - call find_min - - call get_diff - if(nbank.eq.nconf.and.irestart.eq.0) then - adif=avedif - endif - - cutdif=adif/cut1 - ctdif1=adif/cut2 - -cd print *,"adif,xctdif,cutdifr" -cd print *,adif,xctdif,cutdifr - nst=ntotal/ntrial/nseed - xctdif=(cutdif/ctdif1)**(-1.0/nst) - if(irestart.ge.1) call estimate_cutdif(adif,xctdif,cutdifr) -c print *,"ok after estimate" - - irestart=0 - - call write_rbank(jlee,adif,nft) - call write_bank(jlee,nft) -c!bankt call write_bankt(jlee,nft) -c call write_bank1(jlee) - call history_append - write(icsa_history,*) "xctdif: ", xctdif,nst,adif/cut1,ctdif1 - write(icsa_history,851) (bene(i),i=1,nbank) - write(icsa_history,850) (brmsn(i),i=1,nbank) - write(icsa_history,850) (bpncn(i),i=1,nbank) - close(icsa_history) - 850 format(10f8.3) - 851 format(5e15.6) - - ifar=nseed/4*3+1 - ifar=nseed+1 - ENDIF - - - finished=.false. - iter = 0 - irecv = 0 - isent =0 - ifrom= 0 - time0i=MPI_WTIME() - time1i=time0i - time_start_c=time0i - if (.not.sync_iter) then - time_start=time0i - nft00=nft - else - sync_iter=.false. - endif - nft00_c=nft - nft0i=nft -ccccccccccccccccccccccccccccccccccccccc - do while (.not. finished) -ccccccccccccccccccccccccccccccccccccccc -crc print *,"iter ", iter,' isent=',isent - - IF (ME.EQ.KING) THEN -c start energy minimization - - if (isent.eq.0) then -c king-emperor - select seeds & make var & feed input -cd print *,'generating new conf',ntrial,MPI_WTIME() - call select_is(nseed,ifar,idum) - - open(icsa_seed,file=csa_seed,status="old") - write(icsa_seed,39) - & jlee,icycle,nstep,(is(i),bene(is(i)),i=1,nseed) - close(icsa_seed) - call history_append - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, - * ebmin,ebmax,nft,iuse,nbank,ntbank - close(icsa_history) - - - - call make_var(ntry,idum,iter) -cd print *,'new trial generated',ntrial,MPI_WTIME() - time2i=MPI_WTIME() - write (iout,'(a20,i4,f12.2)') - & 'Time for make trial',iter+1,time2i-time1i - endif - -crc write(iout,*)'1:Calling FEEDIN NTRY',NTRY,' ntrial',ntrial -crc call feedin(ntry,nft) - - isent=isent+1 - if (isent.ge.nodes.or.iter.gt.0) then -ct print *,'waiting ',MPI_WTIME() - irecv=irecv+1 - call recv(0,ifrom,xout,eout,ind,timeout) -ct print *,' ',irecv,' received from',ifrom,MPI_WTIME() - else - ifrom=ifrom+1 - endif - -ct print *,'sending to',ifrom,MPI_WTIME() - call send(isent,ifrom,iter) -ct print *,isent,' sent ',MPI_WTIME() - -c store results ----------------------------------------------- - if (isent.ge.nodes.or.iter.gt.0) then - nft=nft+ind(3) - movernx(irecv)=iabs(ind(5)) - call getx(ind,xout,eout,cout,rad,iw_pdb,irecv) - if(vdisulf) then - nss_out(irecv)=nss - do i=1,nss - iss_out(i,irecv)=ihpb(i) - jss_out(i,irecv)=jhpb(i) - enddo - endif - if(iw_pdb.gt.0) - & call write_csa_pdb(xout,eout,nft,irecv,iw_pdb) - endif -c-------------------------------------------------------------- - if (isent.eq.ntry) then - time1i=MPI_WTIME() - write (iout,'(a18,f12.2,a14,f10.2)') - & 'Nonsetup time ',time1i-time_start_c, - & ' sec, Eval/s =',(nft-nft00_c)/(time1i-time_start_c) - write (iout,'(a14,i4,f12.2,a14,f10.2)') - & 'Time for iter ',iter+1,time1i-time0i, - & ' sec, Eval/s =',(nft-nft0i)/(time1i-time0i) - time0i=time1i - nft0i=nft - cutdif=cutdif*xctdif - if(cutdif.lt.ctdif1) cutdif=ctdif1 - if (iter.eq.0) then - print *,'UPDATING ',ntry-nodes+1,irecv - write(iout,*) 'UPDATING ',ntry-nodes+1 - iter=iter+1 -c----------------- call update(ntry-nodes+1) ------------------- - nstep=nstep+ntry-nseed-(nodes-1) - call refresh_bank(ntry-nodes+1) -c!bankt call refresh_bankt(ntry-nodes+1) - else -c----------------- call update(ntry) --------------------------- - iter=iter+1 - print *,'UPDATING ',ntry,irecv - write(iout,*) 'UPDATING ',ntry - nstep=nstep+ntry-nseed - call refresh_bank(ntry) -c!bankt call refresh_bankt(ntry) - endif -c----------------------------------------------------------------- - - call write_bank(jlee,nft) -c!bankt call write_bankt(jlee,nft) - call find_min - - time1i=MPI_WTIME() - write (iout,'(a20,i4,f12.2)') - & 'Time for refresh ',iter,time1i-time0i - - if(ebmin.lt.estop) finished=.true. - if(icycle.gt.icmax) then - call write_bank1(jlee) - do i=1,nbank - ibank(i)=2 - ibank(i)=1 - enddo - nbank=nbank+nconf - if(nbank.gt.1000) then - finished=.true. - else -crc goto 333 - sync_iter=.true. - endif - endif - if(nstep.gt.nstmax) finished=.true. - - if(finished.or.sync_iter) then - do ij=1,nodes-1 - call recv(1,ifrom,xout,eout,ind,timeout) - if (timeout) then - nstep=nstep+ij-1 - print *,'ERROR worker is not responding' - write(iout,*) 'ERROR worker is not responding' - time1i=MPI_WTIME()-time_start_c - print *,'End of cycle, master time for ',iter,' iters ', - & time1i,'sec, Eval/s ',(nft-nft00_c)/time1i - write (iout,*) 'End of cycle, master time for ',iter, - & ' iters ',time1i,' sec' - write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i - print *,'UPDATING ',ij-1 - write(iout,*) 'UPDATING ',ij-1 - call flush(iout) - call refresh_bank(ij-1) -c!bankt call refresh_bankt(ij-1) - goto 1002 - endif -c print *,'node ',ifrom,' finished ',ij,nft - write(iout,*) 'node ',ifrom,' finished ',ij,nft - call flush(iout) - nft=nft+ind(3) - movernx(ij)=iabs(ind(5)) - call getx(ind,xout,eout,cout,rad,iw_pdb,ij) - if(vdisulf) then - nss_out(ij)=nss - do i=1,nss - iss_out(i,ij)=ihpb(i) - jss_out(i,ij)=jhpb(i) - enddo - endif - if(iw_pdb.gt.0) - & call write_csa_pdb(xout,eout,nft,ij,iw_pdb) - enddo - nstep=nstep+nodes-1 -crc print *,'---------bcast finished--------',finished - time1i=MPI_WTIME()-time_start_c - print *,'End of cycle, master time for ',iter,' iters ', - & time1i,'sec, Eval/s ',(nft-nft00_c)/time1i - write (iout,*) 'End of cycle, master time for ',iter, - & ' iters ',time1i,' sec' - write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i - -ctimeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) -ctimeout call mpi_bcast(sync_iter,1,mpi_logical,0, -ctimeout & CG_COMM,ierr) - do ij=1,nodes-1 - tstart=MPI_WTIME() - call mpi_issend(finished,1,mpi_logical,ij,idchar, - & CG_COMM,ireq,ierr) - call mpi_issend(sync_iter,1,mpi_logical,ij,idchar, - & CG_COMM,ireq2,ierr) - flag=.false. - timeout1=.false. - do while(.not. (flag .or. timeout1)) - call MPI_TEST(ireq2,flag,muster,ierr) - tend1=MPI_WTIME() - if(tend1-tstart.gt.60) then - print *,'ERROR worker ',ij,' is not responding' - write(iout,*) 'ERROR worker ',ij,' is not responding' - timeout1=.true. - endif - enddo - if(timeout1) then - write(iout,*) 'worker ',ij,' NOT OK ',tend1-tstart - timeout=.true. - else - write(iout,*) 'worker ',ij,' OK ',tend1-tstart - endif - enddo - print *,'UPDATING ',nodes-1,ij - write(iout,*) 'UPDATING ',nodes-1 - call refresh_bank(nodes-1) -c!bankt call refresh_bankt(nodes-1) - 1002 continue - call write_bank(jlee,nft) -c!bankt call write_bankt(jlee,nft) - call find_min - - do i=0,mxmv - do j=1,3 - nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) - nstatnx(i,j)=0 - enddo - enddo - - write(iout,*)'### Total stats:' - do i=0,mxmv - if(nstatnx_tot(i,1).ne.0) then - if (i.le.9) then - write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') - & '### N',i,' total=',nstatnx_tot(i,1), - & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc', - & (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) - else - write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') - & '###N',i,' total=',nstatnx_tot(i,1), - & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc', - & (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) - endif - else - if (i.le.9) then - write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') - & '### N',i,' total=',nstatnx_tot(i,1), - & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3), - & ' %acc',0.0 - else - write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') - & '###N',i,' total=',nstatnx_tot(i,1), - & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3), - & ' %acc',0.0 - endif - endif - enddo - - endif - if(sync_iter) goto 331 - - 39 format(2i3,i7,5(i4,f8.3,1x),19(/,13x,5(i4,f8.3,1x))) - 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) - 43 format(10i8) - 44 format('jlee =',i3,':',4f10.1,' E =',f8.3,i7,i10) - - isent=0 - irecv=0 - endif - ELSE -c soldier - perform energy minimization - call minim_jlee - print *,'End of minim, proc',me,'time ',MPI_WTIME()-time_start - write (iout,*) 'End of minim, proc',me,'time ', - & MPI_WTIME()-time_start - call flush(iout) -ctimeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) -ctimeout call mpi_bcast(sync_iter,1,mpi_logical,0,CG_COMM,ierr) - call mpi_recv(finished,1,mpi_logical,0,idchar, - * CG_COMM,muster,ierr) - call mpi_recv(sync_iter,1,mpi_logical,0,idchar, - * CG_COMM,muster,ierr) - if(sync_iter) goto 331 - ENDIF - -ccccccccccccccccccccccccccccccccccccccc - enddo -ccccccccccccccccccccccccccccccccccccccc - - IF (ME.EQ.KING) THEN - call history_append - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, - * ebmin,ebmax,nft,iuse,nbank,ntbank - - write(icsa_history,44) jlee,0.0,0.0,0.0, - & 0.0,ebmin,nstep,nft - write(icsa_history,*) - close(icsa_history) - - time1i=MPI_WTIME()-time_start - print *,'End of RUN, master time ', - & time1i,'sec, Eval/s ',(nft-nft00)/time1i - write (iout,*) 'End of RUN, master time ', - & time1i,' sec' - write (iout,*) 'Total eval/s ',(nft-nft00)/time1i - - if(timeout) then - write(iout,*) '!!!! ERROR worker was not responding' - write(iout,*) '!!!! cannot finish work normally' - write(iout,*) 'Processor0 is calling MPI_ABORT' - print *,'!!!! ERROR worker was not responding' - print *,'!!!! cannot finish work normally' - print *,'Processor0 is calling MPI_ABORT' - call flush(iout) - call mpi_abort(mpi_comm_world, 111, ierr) - endif - ENDIF - -cccccccccccccccccccccccccccccc - 300 continue -cccccccccccccccccccccccccccccc - - return - end -c------------------------------------------------- - subroutine feedin(nconf,nft) -c sends out starting conformations and receives results of energy minimization - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'mpif.h' - dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), - * cout(2),ind(9),info(12) - dimension muster(mpi_status_size) - include 'COMMON.SETUP' - parameter (rad=1.745329252d-2) - - print *,'FEEDIN: NCONF=',nconf - mm=0 -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - if (nconf .lt. nodes-1) then - write (*,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1', - & nconf,nodes-1 - write (iout,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1', - & nconf,nodes-1 - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif - do n=1,nconf -c pull out external and internal variables for next start - call putx(xin,n,rad) -! write (iout,*) 'XIN from FEEDIN N=',n -! write(iout,'(8f10.4)') (xin(j),j=1,nvar) - mm=mm+1 - if (mm.lt.nodes) then -c feed task to soldier -! print *, ' sending input for start # ',n - info(1)=n - info(2)=-1 - info(3)=0 - info(4)=0 - info(5)=0 - info(6)=0 - call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, - * ierr) - call mpi_send(xin,nvar,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) - else -c find an available soldier - call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, - * CG_COMM,muster,ierr) -! print *, ' receiving output from start # ',ind(1) - man=muster(mpi_source) -c receive final energies and variables - nft=nft+ind(3) - call mpi_recv(eout,1,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) -! print *,eout -#ifdef CO_BIAS - call mpi_recv(co,1,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) - write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co -#endif - call mpi_recv(xout,nvar,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) -! print *,nvar , ierr -c feed next task to soldier -! print *, ' sending input for start # ',n - info(1)=n - info(2)=-1 - info(3)=0 - info(4)=0 - info(5)=0 - info(6)=0 - info(7)=0 - info(8)=0 - info(9)=0 - call mpi_send(info,12,mpi_integer,man,idint,CG_COMM, - * ierr) - call mpi_send(xin,nvar,mpi_double_precision,man, - * idreal,CG_COMM,ierr) -c retrieve latest results - call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) - if(iw_pdb.gt.0) - & call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) - endif - enddo -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c no more input -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - do j=1,nodes-1 -c wait for a soldier - call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, - * CG_COMM,muster,ierr) -crc if (ierr.ne.0) go to 30 -! print *, ' receiving output from start # ',ind(1) - man=muster(mpi_source) -c receive final energies and variables - nft=nft+ind(3) - call mpi_recv(eout,1, - * mpi_double_precision,man,idreal, - * CG_COMM,muster,ierr) -! print *,eout -#ifdef CO_BIAS - call mpi_recv(co,1,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) - write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co -#endif -crc if (ierr.ne.0) go to 30 - call mpi_recv(xout,nvar,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) -! print *,nvar , ierr -crc if (ierr.ne.0) go to 30 -c halt soldier - info(1)=0 - info(2)=-1 - info(3)=0 - info(4)=0 - info(5)=0 - info(6)=0 - call mpi_send(info,12,mpi_integer,man,idint,CG_COMM, - * ierr) -c retrieve results - call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) - if(iw_pdb.gt.0) - & call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) - enddo -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - return - 10 print *, ' dispatching error' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 20 print *, ' communication error' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - 30 print *, ' receiving error' - call mpi_abort(mpi_comm_world,ierror,ierrcode) - return - end -cccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine getx(ind,xout,eout,cout,rad,iw_pdb,k) -c receives and stores data from soldiers - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.CONTACTS' - dimension ind(9),xout(maxvar),eout(mxch*(mxch+1)/2+1) -cjlee - double precision przes(3),obr(3,3) - logical non_conv -cjlee - iw_pdb=2 - if (k.gt.mxio .or. k.lt.1) then - write (iout,*) - & 'ERROR - dimensions of ANGMIN have been exceeded K=',k - call mpi_abort(mpi_comm_world,ierror,ierrcode) - endif -c store ind() - do j=1,9 - indb(k,j)=ind(j) - enddo -c store energies - etot(k)=eout(1) -c retrieve dihedral angles etc - call var_to_geom(nvar,xout) - do j=2,nres-1 - dihang(1,j,1,k)=theta(j+1) - dihang(2,j,1,k)=phi(j+2) - dihang(3,j,1,k)=alph(j) - dihang(4,j,1,k)=omeg(j) - enddo - dihang(2,nres-1,1,k)=0.0d0 -cjlee - if(iref.eq.0) then - iw_pdb=1 -cd write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4)') -cd & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' mv ', -cd & ind(5),ind(4) - return - endif - call chainbuild -c call dihang_to_c(dihang(1,1,1,k)) -c call fitsq(rms,c(1,1),crefjlee(1,1),nres,przes,obr,non_conv) -c call fitsq(rms,c(1,2),crefjlee(1,2),nres-1,przes,obr,non_conv) -c call fitsq(rms,c(1,nstart_seq),crefjlee(1,nstart_sup), -c & nsup,przes,obr,non_conv) -c rmsn(k)=dsqrt(rms) - - call rmsd_csa(rmsn(k)) - call contact(.false.,ncont,icont,co) - pncn(k)=contact_fract(ncont,ncont_ref,icont,icont_ref) - -cd write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a5 -cd & ,0pf5.2,a5,f5.1,a,f6.3,a4,i3,i4)') -cd & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' rms ', -cd & rmsn(k),' %NC ',pncn(k)*100,' cont.order',co,' mv ', -cd & ind(5),ind(4) - - - if (rmsn(k).gt.rmscut.or.pncn(k).lt.pnccut) iw_pdb=0 - return - end -cccccccccccccccccccccccccccccccccccccccccccccccccc - subroutine putx(xin,n,rad) -c gets starting variables - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - dimension xin(maxvar) - -c pull out starting values for variables -! write (iout,*)'PUTX: N=',n - do m=1,numch -! write (iout,'(8f10.4)') (dihang_in(1,j,m,n),j=2,nres-1) -! write (iout,'(8f10.4)') (dihang_in(2,j,m,n),j=2,nres-1) -! write (iout,'(8f10.4)') (dihang_in(3,j,m,n),j=2,nres-1) -! write (iout,'(8f10.4)') (dihang_in(4,j,m,n),j=2,nres-1) - do j=2,nres-1 - theta(j+1)=dihang_in(1,j,m,n) - phi(j+2)=dihang_in(2,j,m,n) - alph(j)=dihang_in(3,j,m,n) - omeg(j)=dihang_in(4,j,m,n) - enddo - enddo -c set up array of variables - call geom_to_var(nvar,xin) -! write (iout,*) 'xin in PUTX N=',n -! call intout -! write (iout,'(8f10.4)') (xin(i),i=1,nvar) - return - end -c-------------------------------------------------------- - subroutine putx2(xin,iff,n) -c gets starting variables - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - dimension xin(maxvar),iff(maxres) - -c pull out starting values for variables - do m=1,numch - do j=2,nres-1 - theta(j+1)=dihang_in2(1,j,m,n) - phi(j+2)=dihang_in2(2,j,m,n) - alph(j)=dihang_in2(3,j,m,n) - omeg(j)=dihang_in2(4,j,m,n) - enddo - enddo -c set up array of variables - call geom_to_var(nvar,xin) - - do i=1,nres - iff(i)=iff_in(i,n) - enddo - return - end - -c------------------------------------------------------- - subroutine prune_bank(p_cut) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.TIME1' - include 'COMMON.SETUP' -c--------------------------- -c This subroutine prunes bank conformations using p_cut -c--------------------------- - - nprune=0 - nprune=nprune+1 - m=1 - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang(i,j,k,nprune)=bvar(i,j,k,m) - enddo - enddo - enddo - bene(nprune)=bene(m) - brmsn(nprune)=brmsn(m) - bpncn(nprune)=bpncn(m) - - do m=2,nbank - ddmin=9.d190 - do ip=1,nprune - call get_diff12(dihang(1,1,1,ip),bvar(1,1,1,m),diff) - if(diff.lt.p_cut) goto 100 - if(diff.lt.ddmin) ddmin=diff - enddo - nprune=nprune+1 - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang(i,j,k,nprune)=bvar(i,j,k,m) - enddo - enddo - enddo - bene(nprune)=bene(m) - brmsn(nprune)=brmsn(m) - bpncn(nprune)=bpncn(m) - 100 continue - write (iout,*) 'Pruning :',m,nprune,p_cut,ddmin - enddo - nbank=nprune - print *, 'Pruning :',m,nprune,p_cut - call write_bank(0,0) - - return - end -c------------------------------------------------------- - - subroutine reminimize(jlee) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'mpif.h' - include 'COMMON.CSA' - include 'COMMON.BANK' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.TIME1' - include 'COMMON.SETUP' -c--------------------------- -c This subroutine re-minimizes bank conformations: -c--------------------------- - - ntry=nbank - - call find_max - call find_min - - if (me.eq.king) then - open(icsa_history,file=csa_history,status="old") - write(icsa_history,*) "Re-minimization",nodes,"nodes" - write(icsa_history,851) (bene(i),i=1,nbank) - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, - * ebmin,ebmax,nft,iuse,nbank,ntbank - close(icsa_history) - do index=1,ntry - do k=1,numch - do j=2,nres-1 - do i=1,4 - dihang_in(i,j,k,index)=bvar(i,j,k,index) - enddo - enddo - enddo - enddo - nft=0 - call feedin(ntry,nft) - else - call minim_jlee - endif - - call find_max - call find_min - - if (me.eq.king) then - do i=1,ntry - call replace_bvar(i,i) - enddo - open(icsa_history,file=csa_history,status="old") - write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, - * ebmin,ebmax,nft,iuse,nbank,ntbank - write(icsa_history,851) (bene(i),i=1,nbank) - close(icsa_history) - call write_bank_reminimized(jlee,nft) - endif - - 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) - 851 format(5e15.6) - 850 format(5e15.10) -c 850 format(10f8.3) - - return - end -c------------------------------------------------------- - subroutine send(n,mm,it) -c sends out starting conformation for minimization - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'mpif.h' - dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), - * cout(2),ind(8),xin2(maxvar),iff(maxres),info(12) - dimension muster(mpi_status_size) - include 'COMMON.SETUP' - parameter (rad=1.745329252d-2) - - if (isend2(n).eq.0) then -c pull out external and internal variables for next start - call putx(xin,n,rad) - info(1)=n - info(2)=it - info(3)=movenx(n) - info(4)=nss_in(n) - info(5)=parent(1,n) - info(6)=parent(2,n) - - if (movenx(n).eq.14.or.movenx(n).eq.17) then - info(7)=idata(1,n) - info(8)=idata(2,n) - else if (movenx(n).eq.16) then - info(7)=idata(1,n) - info(8)=idata(2,n) - info(10)=idata(3,n) - info(11)=idata(4,n) - info(12)=idata(5,n) - else - info(7)=0 - info(8)=0 - info(10)=0 - info(11)=0 - info(12)=0 - endif - - if (movenx(n).eq.15) then - info(9)=parent(3,n) - else - info(9)=0 - endif - call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, - * ierr) - call mpi_send(xin,nvar,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) - else -c distfit & minimization for n7 move - info(1)=-n - info(2)=it - info(3)=movenx(n) - info(4)=nss_in(n) - info(5)=parent(1,n) - info(6)=parent(2,n) - info(7)=0 - info(8)=0 - info(9)=0 - call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, - * ierr) - call putx2(xin,iff,isend2(n)) - call mpi_send(xin,nvar,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) - call mpi_send(iff,nres,mpi_integer,mm, - * idint,CG_COMM,ierr) - call putx(xin2,n,rad) - call mpi_send(xin2,nvar,mpi_double_precision,mm, - * idreal,CG_COMM,ierr) - endif - if (vdisulf.and.nss_in(n).ne.0) then - call mpi_send(iss_in(1,n),nss_in(n),mpi_integer,mm, - * idint,CG_COMM,ierr) - call mpi_send(jss_in(1,n),nss_in(n),mpi_integer,mm, - * idint,CG_COMM,ierr) - endif - return - end -c------------------------------------------------- - - subroutine recv(ihalt,man,xout,eout,ind,tout) -c receives results of energy minimization - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.BANK' - include 'COMMON.CHAIN' - include 'mpif.h' - dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), - * cout(2),ind(9),info(12) - dimension muster(mpi_status_size) - include 'COMMON.SETUP' - logical tout,flag - double precision twait,tstart,tend1 - parameter(twait=600.0d0) - -c find an available soldier - tout=.false. - flag=.false. - tstart=MPI_WTIME() - do while(.not. (flag .or. tout)) - call MPI_IPROBE(mpi_any_source,idint,CG_COMM,flag, - * muster,ierr) - tend1=MPI_WTIME() - if(tend1-tstart.gt.twait .and. ihalt.eq.1) tout=.true. -c_error if(tend1-tstart.gt.twait) tout=.true. - enddo - if (tout) then - write(iout,*) 'ERROR = timeout for recv ',tend1-tstart - call flush(iout) - return - endif - man=muster(mpi_source) - -ctimeout call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, -ctimeout * CG_COMM,muster,ierr) -! print *, ' receiving output from start # ',ind(1) -ct print *,'receiving ',MPI_WTIME() -ctimeout man=muster(mpi_source) - call mpi_recv(ind,9,mpi_integer,man,idint, - * CG_COMM,muster,ierr) -ctimeout -c receive final energies and variables - call mpi_recv(eout,1,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) -! print *,eout -#ifdef CO_BIAS - call mpi_recv(co,1,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) - write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co -#endif - call mpi_recv(xout,nvar,mpi_double_precision, - * man,idreal,CG_COMM,muster,ierr) -! print *,nvar , ierr - if(vdisulf) nss=ind(6) - if(vdisulf.and.nss.ne.0) then - call mpi_recv(ihpb,nss,mpi_integer, - * man,idint,CG_COMM,muster,ierr) - call mpi_recv(jhpb,nss,mpi_integer, - * man,idint,CG_COMM,muster,ierr) - endif -c halt soldier - if(ihalt.eq.1) then -c print *,'sending halt to ',man - write(iout,*) 'sending halt to ',man - info(1)=0 - call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,ierr) - endif - return - end - -c---------------------------------------------------------- - subroutine history_append - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - -#if defined(AIX) || defined(PGI) - open(icsa_history,file=csa_history,position="append") -#else - open(icsa_history,file=csa_history,access="append") -#endif - return - end -#endif diff --git a/source/unres/src_MD/unres b/source/unres/src_MD/unres deleted file mode 100644 index c64e62b..0000000 Binary files a/source/unres/src_MD/unres and /dev/null differ diff --git a/source/unres/src_MD/unres.F b/source/unres/src_MD/unres.F index 067f4d8..02f3fb6 100644 --- a/source/unres/src_MD/unres.F +++ b/source/unres/src_MD/unres.F @@ -52,7 +52,7 @@ c call memmon_print_usage() call init_task if (me.eq.king) - & write(iout,*)'### LAST MODIFIED 11/03/09 1:19PM by czarek' + & write(iout,*)'### LAST MODIFIED 03/28/12 23:29 by czarek' if (me.eq.king) call cinfo C Read force field parameters and job setup data call readrtns @@ -754,9 +754,11 @@ c--------------------------------------------------------------------------- C Conformational Space Annealling programmed by Jooyoung Lee. C This method works only with parallel machines! #ifdef MPI - call together +csa call together + write (iout,*) "CSA is not supported in this version" #else - write (iout,*) "CSA works on parallel machines only" +csa write (iout,*) "CSA works on parallel machines only" + write (iout,*) "CSA is not supported in this version" #endif return end