From: Cezary Czaplewski Date: Thu, 12 May 2016 17:40:37 +0000 (+0200) Subject: the first working version of multichain homology X-Git-Url: http://mmka.chem.univ.gda.pl/gitweb/?a=commitdiff_plain;h=7006db11d703450fb82ce20cfc53f74614334362;p=unres.git the first working version of multichain homology energy is consistend for unres, wham and cluster but is not the same as for single chain unres --- diff --git a/source/cluster/wham/src-M/CMakeLists.txt b/source/cluster/wham/src-M/CMakeLists.txt index 4c73620..a230f1e 100644 --- a/source/cluster/wham/src-M/CMakeLists.txt +++ b/source/cluster/wham/src-M/CMakeLists.txt @@ -37,6 +37,7 @@ set(UNRES_CLUSTER_WHAM_M_SRC0 rescode.f setup_var.f srtclust.f + ssMD.F timing.F track.F wrtclust.f @@ -52,6 +53,7 @@ set(UNRES_CLUSTER_WHAM_M_PP_SRC probabl.F read_coords.F readrtns.F + ssMD.F timing.F track.F work_partition.F @@ -62,7 +64,7 @@ set(UNRES_CLUSTER_WHAM_M_PP_SRC # Set comipiler flags for different sourcefiles #================================================ if (Fortran_COMPILER_NAME STREQUAL "ifort") - set(FFLAGS0 "-ip -w -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) + set(FFLAGS0 "-mcmodel=medium -shared-intel -ip -w -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) elseif (Fortran_COMPILER_NAME STREQUAL "gfortran") set(FFLAGS0 "-std=legacy -I. -I${CMAKE_CURRENT_SOURCE_DIR}/include_unres" ) else () diff --git a/source/cluster/wham/src-M/COMMON.CHAIN b/source/cluster/wham/src-M/COMMON.CHAIN index 5158330..fe0ac3d 100644 --- a/source/cluster/wham/src-M/COMMON.CHAIN +++ b/source/cluster/wham/src-M/COMMON.CHAIN @@ -1,9 +1,19 @@ integer nres,nres0,nsup,nstart_sup,nend_sup,nstart_seq, - &tabperm - double precision c,cref,dc,xloc,xrot,dc_norm,t,r,prod,rt + &tabperm,chain_length + double precision c,cref,dc,xloc,xrot,dc_norm,t,r,prod,rt, + & chain_rep,crefjlee common /chain/ c(3,maxres2+2),dc(3,maxres2),xloc(3,maxres), & xrot(3,maxres),dc_norm(3,maxres2),nres,nres0 common /rotmat/ t(3,3,maxres),r(3,3,maxres),prod(3,3,maxres), & rt(3,3,maxres) - common /refstruct/ cref(3,maxres2+2),nsup,nstart_sup,nstart_seq, - & nend_sup,tabperm(maxperm,maxsym) + common /refstruct/ cref(3,maxres2+2,maxperm), + & crefjlee(3,maxres2+2), + & chain_rep(3,maxres2+2,maxsym), nsup,nstart_sup, + & nstart_seq, + & nend_sup, chain_length,tabperm(maxperm,maxsym) + double precision boxxsize,boxysize,boxzsize,enecut,sscut,sss, + & sssgrad, + & buflipbot, bufliptop,bordlipbot,bordliptop,lipbufthick,lipthick + common /box/ boxxsize,boxysize,boxzsize,enecut,sscut,sss,sssgrad, + & buflipbot, bufliptop,bordlipbot,bordliptop,lipbufthick,lipthick + diff --git a/source/cluster/wham/src-M/COMMON.CLUSTER b/source/cluster/wham/src-M/COMMON.CLUSTER index 4477d19..4fedc52 100644 --- a/source/cluster/wham/src-M/COMMON.CLUSTER +++ b/source/cluster/wham/src-M/COMMON.CLUSTER @@ -6,12 +6,12 @@ integer ncut,ngr,licz,nconf,iass,icc,mult,list_conf, & nss_all,ihpb_all,jhpb_all,iass_tot,iscore,nprop common /clu/ diss(maxdist),energy(0:maxconf), - & enetb(max_ene,maxstr_proc),ecut, + & enetb(max_ene,maxconf),ecut, & entfac(maxconf),totfree(0:maxconf),totfree_gr(maxgr), & rcutoff(max_cut+1),ncut,min_var,tree,plot_tree,lgrp common /clu1/ ngr,licz(maxgr),nconf(maxgr,maxingr),iass(maxgr), & iass_tot(maxgr,max_cut),list_conf(maxconf) - common /alles/ allcart(3,maxres2,maxstr_proc),rmstb(maxconf), + common /alles/ allcart(3,maxres2,maxconf),rmstb(maxconf), & icc(maxconf), - & mult(maxres),nss_all(maxstr_proc),ihpb_all(maxss,maxstr_proc), - & jhpb_all(maxss,maxstr_proc),iscore(maxconf),nprop + & mult(maxres),nss_all(maxconf),ihpb_all(maxss,maxconf), + & jhpb_all(maxss,maxconf),iscore(maxconf),nprop diff --git a/source/cluster/wham/src-M/COMMON.CONTROL b/source/cluster/wham/src-M/COMMON.CONTROL index 9a2bd18..ec85f0b 100644 --- a/source/cluster/wham/src-M/COMMON.CONTROL +++ b/source/cluster/wham/src-M/COMMON.CONTROL @@ -1,7 +1,25 @@ double precision betaT - integer iscode,indpdb,outpdb,outmol2,iopt,nstart,nend,symetr + integer iscode,indpdb,outpdb,outmol2,iopt,nstart,nend,symetr, + & constr_dist,shield_mode,tor_mode, + & constr_homology,homol_nset, + & iset,ihset + real*8 waga_homology + real*8 waga_dist, waga_angle, waga_theta, waga_d, dist_cut, + & dist2_cut logical refstr,pdbref,punch_dist,print_dist,caonly,lside, - & lprint_cart,lprint_int,from_cart,efree,from_bx,from_cx + & lprint_cart,lprint_int,from_cart,efree,from_bx,from_cx, + & with_dihed_constr,with_theta_constr,out1file, + & print_homology_restraints, + & print_contact_map,print_homology_models, + & read2sigma,l_homo common /cntrl/ betaT,iscode,indpdb,refstr,pdbref,outpdb,outmol2, & punch_dist,print_dist,caonly,lside,lprint_cart,lprint_int, - & from_cart,from_bx,from_cx,efree,iopt,nstart,nend,symetr + & from_cart,from_bx,from_cx, with_dihed_constr,with_theta_constr, + & efree,iopt,nstart,nend,symetr, + & tor_mode,shield_mode, + & constr_dist,out1file, + & constr_homology,homol_nset,read2sigma + common /homol/ waga_homology(10), + & waga_dist,waga_angle,waga_theta,waga_d,dist_cut,dist2_cut, + & iset,ihset,l_homo(max_template,maxdim), + & print_homology_restraints,print_homology_models diff --git a/source/cluster/wham/src-M/COMMON.DERIV b/source/cluster/wham/src-M/COMMON.DERIV index 79f8630..4e116e1 100644 --- a/source/cluster/wham/src-M/COMMON.DERIV +++ b/source/cluster/wham/src-M/COMMON.DERIV @@ -3,13 +3,31 @@ & gradcorr5,gradcorr6,gel_loc,gcorr3_turn,gcorr4_turn,gcorr6_turn, & gel_loc_loc,gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc, & g_corr5_loc,g_corr6_loc,gradb,gradbx,gsccorc,gsccorx,gsccor_loc, - & gscloc,gsclocx + & gscloc,gsclocx,gshieldx,gradafm, + & gshieldc, gshieldc_loc, gshieldx_ec, gshieldc_ec, + & gshieldc_loc_ec, gshieldx_t3,gshieldc_t3,gshieldc_loc_t3, + & gshieldx_t4, gshieldc_t4,gshieldc_loc_t4,gshieldx_ll, + & gshieldc_ll, gshieldc_loc_ll + + integer nfl,icg logical calc_grad 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),gvdwpp(3,maxres), & gradx_scp(3,maxres), + & gliptranc(3,-1:maxres), + & gliptranx(3,-1:maxres), + & gshieldx(3,-1:maxres), gshieldc(3,-1:maxres), + & gshieldc_loc(3,-1:maxres), + & gshieldx_ec(3,-1:maxres), gshieldc_ec(3,-1:maxres), + & gshieldc_loc_ec(3,-1:maxres), + & gshieldx_t3(3,-1:maxres), gshieldc_t3(3,-1:maxres), + & gshieldc_loc_t3(3,-1:maxres), + & gshieldx_t4(3,-1:maxres), gshieldc_t4(3,-1:maxres), + & gshieldc_loc_t4(3,-1:maxres), + & gshieldx_ll(3,-1:maxres), gshieldc_ll(3,-1:maxres), + & gshieldc_loc_ll(3,-1:maxres), & gvdwc_scp(3,maxres),ghpbx(3,maxres),ghpbc(3,maxres), & gloc(maxvar,2),gradcorr(3,maxres),gradxorr(3,maxres), & gradcorr5(3,maxres),gradcorr6(3,maxres), diff --git a/source/cluster/wham/src-M/COMMON.FFIELD b/source/cluster/wham/src-M/COMMON.FFIELD index ccafd30..fa85436 100644 --- a/source/cluster/wham/src-M/COMMON.FFIELD +++ b/source/cluster/wham/src-M/COMMON.FFIELD @@ -6,11 +6,11 @@ C----------------------------------------------------------------------- double precision wsc,wscp,welec,wstrain,wtor,wtor_d,wang,wscloc, & wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4,wturn6, & wvdwpp,wbond,weights,scal14,scalscp,cutoff_corr,delt_corr, - & r0_corr + & r0_corr,wliptran integer ipot,n_ene_comp,rescale_mode common /ffield/ wsc,wscp,welec,wstrain,wtor,wtor_d,wang,wscloc, & wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4,wturn6, - & wvdwpp,wbond,weights(max_ene),scalscp, + & wvdwpp,wbond,wliptran,weights(max_ene),scalscp, & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp, & rescale_mode common /potentials/ potname(5) diff --git a/source/cluster/wham/src-M/COMMON.HOMRESTR b/source/cluster/wham/src-M/COMMON.HOMRESTR new file mode 100644 index 0000000..5c23caf --- /dev/null +++ b/source/cluster/wham/src-M/COMMON.HOMRESTR @@ -0,0 +1,39 @@ + real*8 odl(max_template,maxdim),sigma_odl(max_template,maxdim), + & dih(max_template,maxres),sigma_dih(max_template,maxres), + & sigma_odlir(max_template,maxdim) +c +c Specification of new variables used in subroutine e_modeller +c modified by FP (Nov.,2014) + real*8 xxtpl(max_template,maxres),yytpl(max_template,maxres), + & zztpl(max_template,maxres),thetatpl(max_template,maxres), + & sigma_theta(max_template,maxres), + & sigma_d(max_template,maxres) +c + + integer ires_homo(maxdim),jres_homo(maxdim) + + double precision + & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst, + & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES), + & dutheta(maxres),dugamma(maxres), + & duscdiff(3,maxres), + & duscdiffx(3,maxres), + & uconst_back + integer lim_odl,lim_dih,link_start_homo,link_end_homo, + & idihconstr_start_homo,idihconstr_end_homo +c +c FP (30/10/2014) +c +c integer ithetaconstr_start_homo,ithetaconstr_end_homo +c + integer nresn,nyosh,nnos + common /back_constr/ uconst_back,uscdiff, + & dutheta,dugamma,duscdiff,duscdiffx + common /homrestr/ odl,dih,sigma_dih,sigma_odl, + & lim_odl,lim_dih,ires_homo,jres_homo,link_start_homo, + & link_end_homo,idihconstr_start_homo,idihconstr_end_homo, +c +c FP (30/10/2014,04/03/2015) +c + & xxtpl,yytpl,zztpl,thetatpl,sigma_theta,sigma_d,sigma_odlir +c diff --git a/source/cluster/wham/src-M/COMMON.IOUNITS b/source/cluster/wham/src-M/COMMON.IOUNITS index c97090d..d171ae0 100644 --- a/source/cluster/wham/src-M/COMMON.IOUNITS +++ b/source/cluster/wham/src-M/COMMON.IOUNITS @@ -10,10 +10,12 @@ C----------------------------------------------------------------------- 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,isidep1,ibond,isccor,jrms,jplot + & ientin,ientout,isidep1,ibond,isccor,jrms,jplot, + & iliptranpar common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep, & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,icbase, - & istat,ientin,ientout,isidep1,ibond,isccor,jrms,jplot + & istat,ientin,ientout,isidep1,ibond,isccor,jrms,jplot, + & iliptranpar character*256 outname,intname,pdbname,mol2name,statname,intinname, & entname,restartname,prefix,scratchdir,sidepname,pdbfile, & sccorname,rmsname,prefintin,prefout @@ -35,9 +37,9 @@ C CSA I/O units & files & icsa_bank_reminimized,icsa_native_int,icsa_in C Parameter files character*256 bondname,thetname,rotname,torname,tordname, - & fouriername,elename,sidename,scpname,patname + & fouriername,elename,sidename,scpname,patname,liptranname common /parfiles/ thetname,rotname,torname,tordname,bondname, - & fouriername,elename,sidename,scpname,patname + & fouriername,elename,sidename,scpname,patname,liptranname character*3 pot C----------------------------------------------------------------------- C INP - main input file diff --git a/source/cluster/wham/src-M/COMMON.LOCAL b/source/cluster/wham/src-M/COMMON.LOCAL index a248d99..d92ce8e 100644 --- a/source/cluster/wham/src-M/COMMON.LOCAL +++ b/source/cluster/wham/src-M/COMMON.LOCAL @@ -4,29 +4,37 @@ integer nlob,loc_start,loc_end,ithet_start,ithet_end, & iphi_start,iphi_end,itau_start,itau_end C Parameters of the virtual-bond-angle probability distribution - common /thetas/ a0thet(ntyp),athet(2,ntyp),bthet(2,ntyp), - & polthet(0:3,ntyp),gthet(3,ntyp),theta0(ntyp),sig0(ntyp), - & sigc0(ntyp) + common /thetas/ a0thet(-ntyp:ntyp),athet(2,-ntyp:ntyp,-1:1,-1:1) + & ,bthet(2,-ntyp:ntyp,-1:1,-1:1), + & polthet(0:3,-ntyp:ntyp),gthet(3,-ntyp:ntyp),theta0(-ntyp:ntyp), + &sig0(-ntyp:ntyp), sigc0(-ntyp:ntyp) C Parameters of ab initio-derived potential of virtual-bond-angle bending integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, - & ithetyp(ntyp1),nntheterm - double precision aa0thet(maxthetyp1,maxthetyp1,maxthetyp1), - & aathet(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1), - & bbthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ccthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ddthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & eethet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ffthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1), - & ggthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1) + & ithetyp(-ntyp1:ntyp1),nntheterm + double precision aa0thet(-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & aathet(maxtheterm,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & bbthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ccthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ddthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & eethet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ffthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2), + & ggthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2) common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet, & ffthet, & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, & ndouble,nntheterm C Parameters of the side-chain probability distribution common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp), - & censc(3,maxlob,ntyp),gaussc(3,3,maxlob,ntyp),dsc0(ntyp1), + & censc(3,maxlob,-ntyp:ntyp),gaussc(3,3,maxlob,-ntyp:ntyp), + & dsc0(ntyp1), & nlob(ntyp1) C Virtual-bond lenghts common /peptbond/ vbl,vblinv,vblinv2,vbl_cis,vbl0 diff --git a/source/cluster/wham/src-M/COMMON.NAMES b/source/cluster/wham/src-M/COMMON.NAMES index d42c725..7c5b6ee 100644 --- a/source/cluster/wham/src-M/COMMON.NAMES +++ b/source/cluster/wham/src-M/COMMON.NAMES @@ -1,4 +1,4 @@ - common /names/ restyp(ntyp+1),onelet(ntyp+1) + common /names/ restyp(-ntyp1:ntyp1),onelet(-ntyp1:ntyp1) character*3 restyp character*1 onelet character*10 ename,wname diff --git a/source/cluster/wham/src-M/COMMON.SBRIDGE b/source/cluster/wham/src-M/COMMON.SBRIDGE index 92150c5..028f9ae 100644 --- a/source/cluster/wham/src-M/COMMON.SBRIDGE +++ b/source/cluster/wham/src-M/COMMON.SBRIDGE @@ -1,7 +1,20 @@ - integer ns,nss,nfree,iss,ihpb,jhpb,nhpb,link_start,link_end - double precision ebr,dbr,fbr,dhpb,forcon,weidis - common /sbridge/ ebr,dbr,fbr,ns,nss,nfree,iss(maxss) - common /links/ dhpb(maxss),forcon(maxss),ihpb(maxss), - & jhpb(maxss),nhpb + double precision ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss + integer ns,nss,nfree,iss + common /sbridge/ ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss, + & ns,nss,nfree,iss(maxss) + double precision dhpb,dhpb1,forcon,fordepth + integer ihpb,jhpb,nhpb,idssb,jdssb,ibecarb + common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim), + & fordepth(maxdim), + & ihpb(maxdim),jhpb(maxdim),nhpb + double precision weidis common /restraints/ weidis + integer link_start,link_end common /links_split/ link_start,link_end + double precision Ht,dyn_ssbond_ij,dtriss,atriss,btriss,ctriss + logical dyn_ss,dyn_ss_mask + common /dyn_ssbond/ dtriss,atriss,btriss,ctriss,Ht, + & dyn_ssbond_ij(maxres,maxres), + & idssb(maxdim),jdssb(maxdim),ibecarb(maxdim) + common /dyn_ss_logic/ + & dyn_ss,dyn_ss_mask(maxres) diff --git a/source/cluster/wham/src-M/COMMON.SCROT b/source/cluster/wham/src-M/COMMON.SCROT index 2da7b8f..a352775 100644 --- a/source/cluster/wham/src-M/COMMON.SCROT +++ b/source/cluster/wham/src-M/COMMON.SCROT @@ -1,3 +1,3 @@ C Parameters of the SC rotamers (local) term double precision sc_parmin - common/scrot/sc_parmin(maxsccoef,20) + common/scrot/sc_parmin(maxsccoef,ntyp) diff --git a/source/cluster/wham/src-M/COMMON.SHIELD b/source/cluster/wham/src-M/COMMON.SHIELD new file mode 100644 index 0000000..1f96c94 --- /dev/null +++ b/source/cluster/wham/src-M/COMMON.SHIELD @@ -0,0 +1,14 @@ + double precision VSolvSphere,VSolvSphere_div,long_r_sidechain, + & short_r_sidechain,fac_shield,grad_shield_side,grad_shield, + & buff_shield,wshield,grad_shield_loc + integer ishield_list,shield_list,ees0plist + common /shield/ VSolvSphere,VSolvSphere_div,buff_shield, + & long_r_sidechain(ntyp), + & short_r_sidechain(ntyp),fac_shield(maxres),wshield, + & grad_shield_side(3,maxcont,-1:maxres),grad_shield(3,-1:maxres), + & grad_shield_loc(3,maxcont,-1:maxres), + & ishield_list(maxres),shield_list(maxcont,maxres), + & ees0plist(maxcont,maxres) + + + diff --git a/source/cluster/wham/src-M/COMMON.TORSION b/source/cluster/wham/src-M/COMMON.TORSION index 8a12451..4da8585 100644 --- a/source/cluster/wham/src-M/COMMON.TORSION +++ b/source/cluster/wham/src-M/COMMON.TORSION @@ -1,25 +1,35 @@ C Torsional constants of the rotation about virtual-bond dihedral angles double precision v1,v2,vlor1,vlor2,vlor3,v0 integer itortyp,ntortyp,nterm,nlor,nterm_old - common/torsion/v0(maxtor,maxtor),v1(maxterm,maxtor,maxtor), - & v2(maxterm,maxtor,maxtor),vlor1(maxlor,maxtor,maxtor), + common/torsion/v0(-maxtor:maxtor,-maxtor:maxtor,2), + & v1(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & v2(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & vlor1(maxlor,maxtor,maxtor), & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor), - & itortyp(ntyp),ntortyp,nterm(maxtor,maxtor),nlor(maxtor,maxtor) + & itortyp(-ntyp:ntyp),ntortyp, + & nterm(-maxtor:maxtor,-maxtor:maxtor,2), + & nlor(-maxtor:maxtor,-maxtor:maxtor,2) & ,nterm_old C 6/23/01 - constants for double torsionals double precision v1c,v1s,v2c,v2s integer ntermd_1,ntermd_2 - common /torsiond/ v1c(2,maxtermd_1,maxtor,maxtor,maxtor), - & v1s(2,maxtermd_1,maxtor,maxtor,maxtor), - & v2c(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), - & v2s(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), - & ntermd_1(maxtor,maxtor,maxtor),ntermd_2(maxtor,maxtor,maxtor) + common /torsiond/ + &v1c(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v1s(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v2c(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + &v2s(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + & ntermd_1(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + & ntermd_2(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) C 9/18/99 - added Fourier coeffficients of the expansion of local energy C surface double precision b1,b2,cc,dd,ee,ctilde,dtilde,b1tilde integer nloctyp - common/fourier/ b1(2,maxtor),b2(2,maxtor),cc(2,2,maxtor), - & dd(2,2,maxtor),ee(2,2,maxtor),ctilde(2,2,maxtor), - & dtilde(2,2,maxtor),b1tilde(2,maxtor),nloctyp + common/fourier/ b1(2,-maxtor:maxtor),b2(2,-maxtor:maxtor), + & cc(2,2,-maxtor:maxtor), + & dd(2,2,-maxtor:maxtor),ee(2,2,-maxtor:maxtor), + & ctilde(2,2,-maxtor:maxtor), + & dtilde(2,2,-maxtor:maxtor),b1tilde(2,-maxtor:maxtor),nloctyp double precision b - common /fourier1/ b(13,maxtor) + common /fourier1/ b(13,0:maxtor) diff --git a/source/cluster/wham/src-M/COMMON.VAR b/source/cluster/wham/src-M/COMMON.VAR index 326d6ec..5141f66 100644 --- a/source/cluster/wham/src-M/COMMON.VAR +++ b/source/cluster/wham/src-M/COMMON.VAR @@ -3,12 +3,13 @@ C Store the geometric variables in the following COMMON block. double precision theta,phi,alph,omeg,vbld,vbld_ref, & theta_ref,phi_ref,alph_ref,omeg_ref, & costtab,sinttab,cost2tab,sint2tab,tauangle,omicron, - & xxtab,yytab,zztab + & xxtab,yytab,zztab, + & thetaref,phiref,xxref,yyref,zzref common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), - & vbld(2*maxres), + & vbld(2*maxres),thetaref(maxres),phiref(maxres), & costtab(maxres), sinttab(maxres), cost2tab(maxres), & sint2tab(maxres),xxtab(maxres),yytab(maxres), - & zztab(maxres), + & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar, & omicron(2,maxres),tauangle(3,maxres) C Angles from experimental structure diff --git a/source/cluster/wham/src-M/DIMENSIONS b/source/cluster/wham/src-M/DIMENSIONS index 1bcdf79..9a2e297 100644 --- a/source/cluster/wham/src-M/DIMENSIONS +++ b/source/cluster/wham/src-M/DIMENSIONS @@ -9,7 +9,7 @@ C Max. number of processors. parameter (maxprocs=16) C Max. number of AA residues integer maxres,maxres2 - parameter (maxres=650) + parameter (maxres=800) C Appr. max. number of interaction sites parameter (maxres2=2*maxres) C Max. number of variables @@ -30,7 +30,7 @@ C Max. number of contacts per residue parameter (maxconts=maxres) C Number of AA types (at present only natural AA's will be handled integer ntyp,ntyp1 - parameter (ntyp=20,ntyp1=ntyp+1) + parameter (ntyp=24,ntyp1=ntyp+1) C Max. number of types of dihedral angles & multiplicity of torsional barriers integer maxtor,maxterm,maxlor,maxtermd_1,maxtermd_2 parameter (maxtor=4,maxterm=10,maxlor=3,maxtermd_1=8,maxtermd_2=8) @@ -60,7 +60,7 @@ C Max number of symetric chains parameter (maxperm=120) C Max. number of energy components integer max_ene - parameter (max_ene=21) + parameter (max_ene=25) C Max. number of temperatures integer maxt parameter (maxT=5) @@ -70,3 +70,6 @@ C Maximum number of SC local term fitting function coefficiants C Maximum number of terms in SC bond-stretching potential integer maxbondterm parameter (maxbondterm=3) +C Maximum number of templates in homology-modeling restraints + integer max_template + parameter(max_template=25) diff --git a/source/cluster/wham/src-M/chainbuild.f b/source/cluster/wham/src-M/chainbuild.f index 5774ba6..1e72ff8 100644 --- a/source/cluster/wham/src-M/chainbuild.f +++ b/source/cluster/wham/src-M/chainbuild.f @@ -208,8 +208,8 @@ C include 'COMMON.INTERACT' dimension xx(3) - dsci=dsc(itype(i)) - dsci_inv=dsc_inv(itype(i)) + dsci=dsc(iabs(itype(i))) + dsci_inv=dsc_inv(iabs(itype(i))) alphi=alph(i) omegi=omeg(i) cosalphi=dcos(alphi) diff --git a/source/cluster/wham/src-M/contact.f b/source/cluster/wham/src-M/contact.f index b17f153..6f01564 100644 --- a/source/cluster/wham/src-M/contact.f +++ b/source/cluster/wham/src-M/contact.f @@ -12,9 +12,9 @@ kkk=3 c print *,'nnt=',nnt,' nct=',nct do i=nnt+kkk,nct - iti=itype(i) + iti=iabs(itype(i)) do j=nnt,i-kkk - itj=itype(j) + itj=iabs(itype(j)) if (ipot.ne.4) then c rcomp=sigmaii(iti,itj)+1.0D0 rcomp=facont*sigmaii(iti,itj) diff --git a/source/cluster/wham/src-M/energy_p_new.F b/source/cluster/wham/src-M/energy_p_new.F index c7c2c2f..34807fe 100644 --- a/source/cluster/wham/src-M/energy_p_new.F +++ b/source/cluster/wham/src-M/energy_p_new.F @@ -22,6 +22,8 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.INTERACT' include 'COMMON.SBRIDGE' include 'COMMON.CHAIN' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' double precision fact(6) cd write(iout, '(a,i2)')'Calling etotal ipot=',ipot cd print *,'nnt=',nnt,' nct=',nct @@ -47,7 +49,14 @@ C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). C C Calculate electrostatic (H-bonding) energy of the main chain. C - 106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) + 106 continue +C write(iout,*) "shield_mode",shield_mode,ethetacnstr + if (shield_mode.eq.1) then + call set_shield_fac + else if (shield_mode.eq.2) then + call set_shield_fac2 + endif + call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) C C Calculate excluded-volume interaction energy between peptide groups C and side chains. @@ -67,7 +76,7 @@ cd print *,'EHPB exitted succesfully.' C C Calculate the virtual-bond-angle energy. C - call ebend(ebe) + call ebend(ebe,ethetacnstr) cd print *,'Bend energy finished.' C C Calculate the SC local energy. @@ -87,6 +96,11 @@ C C 21/5/07 Calculate local sicdechain correlation energy C call eback_sc_corr(esccor) + + if (wliptran.gt.0) then + call Eliptransfer(eliptran) + endif + C C 12/1/95 Multi-body terms C @@ -98,33 +112,75 @@ c print *,"calling multibody_eello" call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) c write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1 c print *,ecorr,ecorr5,ecorr6,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) then call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) endif -c write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t + +c write(iout,*) "TEST_ENE",constr_homology + if (constr_homology.ge.1) then + call e_modeller(ehomology_constr) + else + ehomology_constr=0.0d0 + endif +c write(iout,*) "TEST_ENE",ehomology_constr + + + write (iout,*) "ft(6)",fact(6),wliptran,eliptran #ifdef SPLITELE + if (shield_mode.gt.0) then + etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2 + & +welec*fact(1)*ees + & +fact(1)*wvdwpp*evdw1 + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran + else etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees & +wvdwpp*evdw1 & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d - & +wbond*estr+wsccor*fact(1)*esccor + & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr + & +wliptran*eliptran + endif #else + if (shield_mode.gt.0) then + etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2 + & +welec*fact(1)*(ees+evdw1) + & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 + & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d + & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr + & +wliptran*eliptran + else etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2 & +welec*fact(1)*(ees+evdw1) & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d - & +wbond*estr+wsccor*fact(1)*esccor + & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr + & +wliptran*eliptran + endif #endif + energia(0)=etot energia(1)=evdw -c call enerprint(energia(0),frac) #ifdef SCP14 energia(2)=evdw2-evdw2_14 energia(17)=evdw2_14 @@ -154,7 +210,10 @@ c call enerprint(energia(0),frac) energia(18)=estr energia(19)=esccor energia(20)=edihcnstr + energia(24)=ehomology_constr energia(21)=evdw_t +c energia(24)=ethetacnstr + energia(22)=eliptran c detecting NaNQ #ifdef ISNAN #ifdef AIX @@ -181,6 +240,7 @@ C #ifdef SPLITELE do i=1,nct do j=1,3 + if (shield_mode.eq.0) then gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ & welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+ & wbond*gradb(j,i)+ @@ -193,14 +253,57 @@ C & wcorr6*fact(5)*gradcorr6(j,i)+ & wturn6*fact(5)*gcorr6_turn(j,i)+ & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) 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*fact(2)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + else + gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i) + & +fact(1)*wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+ + & wbond*gradb(j,i)+ + & wstrain*ghpbc(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) + & +welec*gshieldc(j,i) + & +welec*gshieldc_loc(j,i) + & +wcorr*gshieldc_ec(j,i) + & +wcorr*gshieldc_loc_ec(j,i) + & +wturn3*gshieldc_t3(j,i) + & +wturn3*gshieldc_loc_t3(j,i) + & +wturn4*gshieldc_t4(j,i) + & +wturn4*gshieldc_loc_t4(j,i) + & +wel_loc*gshieldc_ll(j,i) + & +wel_loc*gshieldc_loc_ll(j,i) + + gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i) + & +fact(1)*wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*fact(2)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + & +welec*gshieldx(j,i) + & +wcorr*gshieldx_ec(j,i) + & +wturn3*gshieldx_t3(j,i) + & +wturn4*gshieldx_t4(j,i) + & +wel_loc*gshieldx_ll(j,i) + + + endif enddo #else - do i=1,nct + do i=1,nct do j=1,3 + if (shield_mode.eq.0) then gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ & wbond*gradb(j,i)+ @@ -212,11 +315,34 @@ C & wcorr6*fact(5)*gradcorr6(j,i)+ & wturn6*fact(5)*gcorr6_turn(j,i)+ & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) 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*fact(1)*gsccorx(j,i) - enddo + & +wliptran*gliptranx(j,i) + else + gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+ + & fact(1)*wscp*gvdwc_scp(j,i)+ + & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ + & wbond*gradb(j,i)+ + & wcorr*fact(3)*gradcorr(j,i)+ + & wel_loc*fact(2)*gel_loc(j,i)+ + & wturn3*fact(2)*gcorr3_turn(j,i)+ + & wturn4*fact(3)*gcorr4_turn(j,i)+ + & wcorr5*fact(4)*gradcorr5(j,i)+ + & wcorr6*fact(5)*gradcorr6(j,i)+ + & wturn6*fact(5)*gcorr6_turn(j,i)+ + & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) + gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+ + & fact(1)*wscp*gradx_scp(j,i)+ + & wbond*gradbx(j,i)+ + & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ + & wsccor*fact(1)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) + endif + enddo #endif enddo @@ -229,9 +355,11 @@ C & +wturn3*fact(2)*gel_loc_turn3(i) & +wturn6*fact(5)*gel_loc_turn6(i) & +wel_loc*fact(2)*gel_loc_loc(i) - & +wsccor*fact(1)*gsccor_loc(i) +c & +wsccor*fact(1)*gsccor_loc(i) +c ROZNICA Z WHAMem enddo endif + if (dyn_ss) call dyn_set_nss return end C------------------------------------------------------------------------ @@ -269,6 +397,8 @@ C------------------------------------------------------------------------ esccor=energia(19) edihcnstr=energia(20) estr=energia(18) + ehomology_constr=energia(24) +c ethetacnstr=energia(24) #ifdef SPLITELE write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1, & wvdwpp, @@ -277,7 +407,8 @@ C------------------------------------------------------------------------ & ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), & eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2), & eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5), - & esccor,wsccor*fact(1),edihcnstr,ebr*nss,etot + & esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss, + & etot 10 format (/'Virtual-chain energies:'// & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ @@ -299,6 +430,7 @@ C------------------------------------------------------------------------ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & 'ETOT= ',1pE16.6,' (total)') #else @@ -308,7 +440,8 @@ C------------------------------------------------------------------------ & ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2), & eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3), & eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor, - & edihcnstr,ebr*nss,etot + & edihcnstr,ehomology_constr,ebr*nss, + & etot 10 format (/'Virtual-chain energies:'// & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ @@ -329,6 +462,7 @@ C------------------------------------------------------------------------ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & 'ETOT= ',1pE16.6,' (total)') #endif @@ -360,12 +494,20 @@ C integer icant external icant cd print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon +c ROZNICA DODANE Z WHAM +c do i=1,210 +c do j=1,2 +c eneps_temp(j,i)=0.0d0 +c enddo +c enddo +cROZNICA + evdw=0.0D0 evdw_t=0.0d0 do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - itypi1=itype(i+1) + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -378,8 +520,8 @@ C 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) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi @@ -389,17 +531,22 @@ C Change 12/1/95 to calculate four-body interactions 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) + e1=fac*fac*aa + e2=fac*bb evdwij=e1+e2 ij=icant(itypi,itypj) +c ROZNICA z WHAM +c eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij) +c eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij +c + 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) - if (bb(itypi,itypj).gt.0.0d0) then + if (bb.gt.0.0d0) then evdw=evdw+evdwij else evdw_t=evdw_t+evdwij @@ -528,9 +675,9 @@ c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 evdw_t=0.0d0 do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - itypi1=itype(i+1) + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -539,8 +686,8 @@ C Calculate SC interaction energy. C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi @@ -551,8 +698,8 @@ C rij=1.0D0/r_inv_ij 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) + e1=fac*fac*aa + e2=fac*bb evdwij=e_augm+e1+e2 ij=icant(itypi,itypj) cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) @@ -562,7 +709,7 @@ 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) - if (bb(itypi,itypj).gt.0.0d0) then + if (bb.gt.0.0d0) then evdw=evdw+evdwij else evdw_t=evdw_t+evdwij @@ -632,9 +779,9 @@ c else c endif ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - itypi1=itype(i+1) + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -648,8 +795,8 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle dscj_inv=vbld_inv(j+nres) chi1=chi(itypi,itypj) chi2=chi(itypj,itypi) @@ -688,23 +835,23 @@ C Calculate the angle-dependent terms of energy & contributions to derivatives. 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) + e1=fac*fac*aa + e2=fac*bb evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt evdwij=evdwij*eps2rt*eps3rt ij=icant(itypi,itypj) aux=eps1*eps2rt**2*eps3rt**2 - if (bb(itypi,itypj).gt.0.0d0) then + if (bb.gt.0.0d0) then evdw=evdw+evdwij else evdw_t=evdw_t+evdwij endif if (calc_grad) then if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) + sigm=dabs(aa/bb)**(1.0D0/6.0D0) + epsi=bb**2/aa cd write (iout,'(2(a3,i3,2x),15(0pf7.3))') cd & restyp(itypi),i,restyp(itypj),j, cd & epsi,sigm,chi1,chi2,chip1,chip2, @@ -750,10 +897,13 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include 'COMMON.SBRIDGE' logical lprn common /srutu/icall integer icant external icant + integer xshift,yshift,zshift + logical energy_dec /.false./ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 evdw_t=0.0d0 @@ -761,12 +911,40 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.gt.0) lprn=.true. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - itypi1=itype(i+1) + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) + xi=mod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=mod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=mod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize + if ((zi.gt.bordlipbot) + &.and.(zi.lt.bordliptop)) then +C the energy transfer exist + if (zi.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((zi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipi=sscalelip(fracinbuf) + ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick + elseif (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick) + sslipi=sscalelip(fracinbuf) + ssgradlipi=sscagradlip(fracinbuf)/lipbufthick + else + sslipi=1.0d0 + ssgradlipi=0.0 + endif + else + sslipi=0.0d0 + ssgradlipi=0.0 + endif dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) @@ -776,9 +954,41 @@ C Calculate SC interaction energy. C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) + IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN + +c write(iout,*) "PRZED ZWYKLE", evdwij + call dyn_ssbond_ene(i,j,evdwij) +c write(iout,*) "PO ZWYKLE", evdwij + + evdw=evdw+evdwij + if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') + & 'evdw',i,j,evdwij,' ss' +C triple bond artifac removal + do k=j+1,iend(i,iint) +C search over all next residues + if (dyn_ss_mask(k)) then +C check if they are cysteins +C write(iout,*) 'k=',k + +c write(iout,*) "PRZED TRI", evdwij + evdwij_przed_tri=evdwij + call triple_ssbond_ene(i,j,k,evdwij) +c if(evdwij_przed_tri.ne.evdwij) then +c write (iout,*) "TRI:", evdwij, evdwij_przed_tri +c endif + +c write(iout,*) "PO TRI", evdwij +C call the energy function that removes the artifical triple disulfide +C bond the soubroutine is located in ssMD.F + evdw=evdw+evdwij + if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') + & 'evdw',i,j,evdwij,'tss' + endif!dyn_ss_mask(k) + enddo! k + ELSE ind=ind+1 - itypj=itype(j) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle dscj_inv=vbld_inv(j+nres) sig0ij=sigma(itypi,itypj) chi1=chi(itypi,itypj) @@ -800,15 +1010,83 @@ c chip12=0.0D0 c alf1=0.0D0 c alf2=0.0D0 c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + if ((zj.gt.bordlipbot) + &.and.(zj.lt.bordliptop)) then +C the energy transfer exist + if (zj.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((zj-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipj=sscalelip(fracinbuf) + ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick + elseif (zj.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick) + sslipj=sscalelip(fracinbuf) + ssgradlipj=sscagradlip(fracinbuf)/lipbufthick + else + sslipj=1.0d0 + ssgradlipj=0.0 + endif + else + sslipj=0.0d0 + ssgradlipj=0.0 + endif + aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 + bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 +C write(iout,*) "czy jest 0", bb-bb_lip(itypi,itypj), +C & bb-bb_aq(itypi,itypj) + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + subchap=1 + endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif dxj=dc_norm(1,nres+j) dyj=dc_norm(2,nres+j) dzj=dc_norm(3,nres+j) c write (iout,*) i,j,xj,yj,zj rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) + sss=sscale((1.0d0/rij)/sigma(itypi,itypj)) + sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj)) + if (sss.le.0.0d0) cycle C Calculate angle-dependent terms of energy and contributions to their C derivatives. call sc_angular @@ -824,16 +1102,16 @@ C I hate to put IF's in the loops, but here don't have another choice!!!! c--------------------------------------------------------------- rij_shift=1.0D0/rij_shift fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) + e1=fac*fac*aa + e2=fac*bb evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt evdwij=evdwij*eps2rt*eps3rt - if (bb(itypi,itypj).gt.0) then - evdw=evdw+evdwij + if (bb.gt.0) then + evdw=evdw+evdwij*sss else - evdw_t=evdw_t+evdwij + evdw_t=evdw_t+evdwij*sss endif ij=icant(itypi,itypj) aux=eps1*eps2rt**2*eps3rt**2 @@ -841,15 +1119,19 @@ c write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj, c & " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)), c & aux*e2/eps(itypi,itypj) c if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -c write (iout,'(2(a3,i3,2x),17(0pf7.3))') -c & restyp(itypi),i,restyp(itypj),j, -c & epsi,sigm,chi1,chi2,chip1,chip2, -c & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, -c & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, -c & evdwij -c write (iout,*) "pratial sum", evdw,evdw_t + sigm=dabs(aa/bb)**(1.0D0/6.0D0) + epsi=bb**2/aa +C#define DEBUG +#ifdef DEBUG +C write (iout,'(2(a3,i3,2x),17(0pf7.3))') +C & restyp(itypi),i,restyp(itypj),j, +C & epsi,sigm,chi1,chi2,chip1,chip2, +C & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, +C & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, +C & evdwij + write (iout,*) "pratial sum", evdw,evdw_t,e1,e2,fac,aa +#endif +C#undef DEBUG c endif if (calc_grad) then C Calculate gradient components. @@ -857,6 +1139,13 @@ C Calculate gradient components. fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac + fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij + gg_lipi(3)=eps1*(eps2rt*eps2rt) + &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip* + & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj)) + &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))) + gg_lipj(3)=ssgradlipj*gg_lipi(3) + gg_lipi(3)=gg_lipi(3)*ssgradlipi C Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac @@ -864,6 +1153,7 @@ C Calculate the radial part of the gradient C Calculate angular part of the gradient. call sc_grad endif + ENDIF ! dyn_ss enddo ! j enddo ! iint enddo ! i @@ -900,9 +1190,9 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.gt.0) lprn=.true. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - itypi1=itype(i+1) + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -910,14 +1200,43 @@ c if (icall.gt.0) lprn=.true. dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) dsci_inv=vbld_inv(i+nres) +C returning the ith atom to box + xi=mod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=mod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=mod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize + if ((zi.gt.bordlipbot) + &.and.(zi.lt.bordliptop)) then +C the energy transfer exist + if (zi.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((zi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipi=sscalelip(fracinbuf) + ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick + elseif (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick) + sslipi=sscalelip(fracinbuf) + ssgradlipi=sscagradlip(fracinbuf)/lipbufthick + else + sslipi=1.0d0 + ssgradlipi=0.0 + endif + else + sslipi=0.0d0 + ssgradlipi=0.0 + endif 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) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle dscj_inv=vbld_inv(j+nres) sig0ij=sigma(itypi,itypj) r0ij=r0(itypi,itypj) @@ -940,9 +1259,76 @@ c chip12=0.0D0 c alf1=0.0D0 c alf2=0.0D0 c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) +C returning jth atom to box + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + if ((zj.gt.bordlipbot) + &.and.(zj.lt.bordliptop)) then +C the energy transfer exist + if (zj.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((zj-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipj=sscalelip(fracinbuf) + ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick + elseif (zj.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick) + sslipj=sscalelip(fracinbuf) + ssgradlipj=sscagradlip(fracinbuf)/lipbufthick + else + sslipj=1.0d0 + ssgradlipj=0.0 + endif + else + sslipj=0.0d0 + ssgradlipj=0.0 + endif + aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 + bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 +C write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj) +C checking the distance + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 +C finding the closest + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + subchap=1 + endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif dxj=dc_norm(1,nres+j) dyj=dc_norm(2,nres+j) dzj=dc_norm(3,nres+j) @@ -963,15 +1349,15 @@ C I hate to put IF's in the loops, but here don't have another choice!!!! c--------------------------------------------------------------- rij_shift=1.0D0/rij_shift fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) + e1=fac*fac*aa + e2=fac*bb evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt fac_augm=rrij**expon e_augm=augm(itypi,itypj)*fac_augm evdwij=evdwij*eps2rt*eps3rt - if (bb(itypi,itypj).gt.0.0d0) then + if (bb.gt.0.0d0) then evdw=evdw+evdwij+e_augm else evdw_t=evdw_t+evdwij+e_augm @@ -1077,10 +1463,10 @@ C---------------------------------------------------------------------------- gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k) enddo do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) + gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k) & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - gvdwx(k,j)=gvdwx(k,j)+gg(k) + gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipi(k) & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv enddo @@ -1089,9 +1475,12 @@ C Calculate the components of the gradient in DC and X C do k=i,j-1 do l=1,3 - gvdwc(l,k)=gvdwc(l,k)+gg(l) + gvdwc(l,k)=gvdwc(l,k)+gg(l)+gg_lipi(l) enddo enddo + do l=1,3 + gvdwc(l,j)=gvdwc(l,j)+gg_lipj(l) + enddo return end c------------------------------------------------------------------------------ @@ -1736,6 +2125,8 @@ C include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' + include 'COMMON.SHIELD' + dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), @@ -1806,7 +2197,14 @@ cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e gcorr_loc(i)=0.0d0 enddo do i=iatel_s,iatel_e - if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle + if (i.le.1) cycle + if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 + & .or. ((i+2).gt.nres) + & .or. ((i-1).le.0) + & .or. itype(i+2).eq.ntyp1 + & .or. itype(i-1).eq.ntyp1 + &) cycle +C endif if (itel(i).eq.0) goto 1215 dxi=dc(1,i) dyi=dc(2,i) @@ -1817,10 +2215,23 @@ cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi + xmedi=mod(xmedi,boxxsize) + if (xmedi.lt.0) xmedi=xmedi+boxxsize + ymedi=mod(ymedi,boxysize) + if (ymedi.lt.0) ymedi=ymedi+boxysize + zmedi=mod(zmedi,boxzsize) + if (zmedi.lt.0) zmedi=zmedi+boxzsize num_conti=0 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) do j=ielstart(i),ielend(i) - if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle + if (j.le.1) cycle + if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1 + & .or.((j+2).gt.nres) + & .or.((j-1).le.0) + & .or.itype(j+2).eq.ntyp1 + & .or.itype(j-1).eq.ntyp1 + &) cycle +C endif if (itel(j).eq.0) goto 1216 ind=ind+1 iteli=itel(i) @@ -1842,10 +2253,50 @@ C End diagnostics dx_normj=dc_norm(1,j) dy_normj=dc_norm(2,j) dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi + xj=c(1,j)+0.5D0*dxj + yj=c(2,j)+0.5D0*dyj + zj=c(3,j)+0.5D0*dzj + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + isubchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + isubchap=1 + endif + enddo + enddo + enddo + if (isubchap.eq.1) then + xj=xj_temp-xmedi + yj=yj_temp-ymedi + zj=zj_temp-zmedi + else + xj=xj_safe-xmedi + yj=yj_safe-ymedi + zj=zj_safe-zmedi + endif + rij=xj*xj+yj*yj+zj*zj + sss=sscale(sqrt(rij)) + sssgrad=sscagrad(sqrt(rij)) rrmij=1.0D0/rij rij=dsqrt(rij) rmij=1.0D0/rij @@ -1868,8 +2319,27 @@ c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions c write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij C 12/26/95 - for the evaluation of multi-body H-bonding interactions ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) + if (shield_mode.gt.0) then +C fac_shield(i)=0.4 +C fac_shield(j)=0.6 +C#define DEBUG +#ifdef DEBUG + write(iout,*) "ees_compon",i,j,el1,el2, + & fac_shield(i),fac_shield(j) +#endif +C#undef DEBUG + el1=el1*fac_shield(i)**2*fac_shield(j)**2 + el2=el2*fac_shield(i)**2*fac_shield(j)**2 + eesij=(el1+el2) + ees=ees+eesij + else + fac_shield(i)=1.0 + fac_shield(j)=1.0 + eesij=(el1+el2) ees=ees+eesij - evdw1=evdw1+evdwij + endif +C ees=ees+eesij + evdw1=evdw1+evdwij*sss cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, @@ -1878,7 +2348,7 @@ C C Calculate contributions to the Cartesian gradient. C #ifdef SPLITELE - facvdw=-6*rrmij*(ev1+evdwij) + facvdw=-6*rrmij*(ev1+evdwij)*sss facel=-3*rrmij*(el1+eesij) fac1=fac erij(1)=xj*rmij @@ -1891,6 +2361,63 @@ C ggg(1)=facel*xj ggg(2)=facel*yj ggg(3)=facel*zj + + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + & (shield_mode.gt.0)) then +C print *,i,j + do ilist=1,ishield_list(i) + iresshield=shield_list(ilist,i) + do k=1,3 + rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i) + & *2.0 + gshieldx(k,iresshield)=gshieldx(k,iresshield)+ + & rlocshield + & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 + gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield +C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield) +C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i) +C if (iresshield.gt.i) then +C do ishi=i+1,iresshield-1 +C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield +C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i) +C +C enddo +C else +C do ishi=iresshield,i +C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield +C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i) +C +C enddo +C endif +C enddo +C enddo + enddo + enddo + do ilist=1,ishield_list(j) + iresshield=shield_list(ilist,j) + do k=1,3 + rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) + & *2.0 + gshieldx(k,iresshield)=gshieldx(k,iresshield)+ + & rlocshield + & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 + gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield + enddo + enddo + + do k=1,3 + gshieldc(k,i)=gshieldc(k,i)+ + & grad_shield(k,i)*eesij/fac_shield(i)*2.0 + gshieldc(k,j)=gshieldc(k,j)+ + & grad_shield(k,j)*eesij/fac_shield(j)*2.0 + gshieldc(k,i-1)=gshieldc(k,i-1)+ + & grad_shield(k,i)*eesij/fac_shield(i)*2.0 + gshieldc(k,j-1)=gshieldc(k,j-1)+ + & grad_shield(k,j)*eesij/fac_shield(j)*2.0 + + enddo + endif + do k=1,3 ghalf=0.5D0*ggg(k) gelc(k,i)=gelc(k,i)+ghalf @@ -1904,9 +2431,18 @@ C gelc(l,k)=gelc(l,k)+ggg(l) enddo enddo - ggg(1)=facvdw*xj - ggg(2)=facvdw*yj - ggg(3)=facvdw*zj +C ggg(1)=facvdw*xj +C ggg(2)=facvdw*yj +C ggg(3)=facvdw*zj + if (sss.gt.0.0) then + ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj + ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj + ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj + else + ggg(1)=0.0 + ggg(2)=0.0 + ggg(3)=0.0 + endif do k=1,3 ghalf=0.5D0*ggg(k) gvdwpp(k,i)=gvdwpp(k,i)+ghalf @@ -1921,7 +2457,7 @@ C enddo enddo #else - facvdw=ev1+evdwij + facvdw=(ev1+evdwij)*sss facel=el1+eesij fac1=fac fac=-3*rrmij*(facvdw+facvdw+facel) @@ -1965,15 +2501,19 @@ cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), cd & (dcosg(k),k=1,3) do k=1,3 ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) + & *fac_shield(i)**2*fac_shield(j)**2 enddo do k=1,3 ghalf=0.5D0*ggg(k) gelc(k,i)=gelc(k,i)+ghalf & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + & *fac_shield(i)**2*fac_shield(j)**2 + gelc(k,j)=gelc(k,j)+ghalf & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + & *fac_shield(i)**2*fac_shield(j)**2 enddo do k=i+1,j-1 do l=1,3 @@ -2221,16 +2761,70 @@ C Contribution to the local-electrostatic energy coming from the i-j pair & +a33*muij(4) cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij cd write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) + if (shield_mode.eq.0) then + fac_shield(i)=1.0 + fac_shield(j)=1.0 +C else +C fac_shield(i)=0.4 +C fac_shield(j)=0.6 + endif + eel_loc_ij=eel_loc_ij + & *fac_shield(i)*fac_shield(j) eel_loc=eel_loc+eel_loc_ij C Partial derivatives in virtual-bond dihedral angles gamma if (calc_grad) then + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + & (shield_mode.gt.0)) then +C print *,i,j + + do ilist=1,ishield_list(i) + iresshield=shield_list(ilist,i) + do k=1,3 + rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij + & /fac_shield(i) +C & *2.0 + gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ + & rlocshield + & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i) + gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1) + & +rlocshield + enddo + enddo + do ilist=1,ishield_list(j) + iresshield=shield_list(ilist,j) + do k=1,3 + rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij + & /fac_shield(j) +C & *2.0 + gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ + & rlocshield + & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j) + gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1) + & +rlocshield + + enddo + enddo + do k=1,3 + gshieldc_ll(k,i)=gshieldc_ll(k,i)+ + & grad_shield(k,i)*eel_loc_ij/fac_shield(i) + gshieldc_ll(k,j)=gshieldc_ll(k,j)+ + & grad_shield(k,j)*eel_loc_ij/fac_shield(j) + gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ + & grad_shield(k,i)*eel_loc_ij/fac_shield(i) + gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ + & grad_shield(k,j)*eel_loc_ij/fac_shield(j) + enddo + endif if (i.gt.1) & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j) + & *fac_shield(i)*fac_shield(j) gel_loc_loc(j-1)=gel_loc_loc(j-1)+ & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j) + & *fac_shield(i)*fac_shield(j) + cd call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij) cd write(iout,*) 'agg ',agg cd write(iout,*) 'aggi ',aggi @@ -2242,6 +2836,8 @@ C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) do l=1,3 ggg(l)=agg(l,1)*muij(1)+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4) + & *fac_shield(i)*fac_shield(j) + enddo do k=i+2,j2 do l=1,3 @@ -2252,12 +2848,20 @@ C Remaining derivatives of eello do l=1,3 gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+ & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4) + & *fac_shield(i)*fac_shield(j) + gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+ & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4) + & *fac_shield(i)*fac_shield(j) + gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+ & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4) + & *fac_shield(i)*fac_shield(j) + gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+ & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4) + & *fac_shield(i)*fac_shield(j) + enddo endif ENDIF @@ -2363,9 +2967,21 @@ c fac3=dsqrt(-ael6i)/r0ij**3 fac3=dsqrt(-ael6i)*r3ij ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) + if (shield_mode.eq.0) then + fac_shield(i)=1.0d0 + fac_shield(j)=1.0d0 + else + ees0plist(num_conti,i)=j +C fac_shield(i)=0.4d0 +C fac_shield(j)=0.6d0 + endif c ees0mij=0.0D0 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) + & *fac_shield(i)*fac_shield(j) + ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) + & *fac_shield(i)*fac_shield(j) + C Diagnostics. Comment out or remove after debugging! c ees0p(num_conti,i)=0.5D0*fac3*ees0pij c ees0m(num_conti,i)=0.5D0*fac3*ees0mij @@ -2430,17 +3046,29 @@ C Derivatives due to the contact function gacontp_hb1(k,num_conti,i)=ghalfp & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + & *fac_shield(i)*fac_shield(j) + gacontp_hb2(k,num_conti,i)=ghalfp & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + & *fac_shield(i)*fac_shield(j) + gacontp_hb3(k,num_conti,i)=gggp(k) + & *fac_shield(i)*fac_shield(j) + gacontm_hb1(k,num_conti,i)=ghalfm & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + & *fac_shield(i)*fac_shield(j) + gacontm_hb2(k,num_conti,i)=ghalfm & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + & *fac_shield(i)*fac_shield(j) + gacontm_hb3(k,num_conti,i)=gggm(k) + & *fac_shield(i)*fac_shield(j) + enddo endif C Diagnostics. Comment out or remove after debugging! @@ -2486,6 +3114,9 @@ C Third- and fourth-order contributions from turns include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' + include 'COMMON.SHIELD' + include 'COMMON.CONTROL' + dimension ggg(3) double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2), & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2), @@ -2494,6 +3125,18 @@ C Third- and fourth-order contributions from turns & aggj(3,4),aggj1(3,4),a_temp(2,2) common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2 if (j.eq.i+2) then + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 +C changes suggested by Ana to avoid out of bounds +C & .or.((i+5).gt.nres) +C & .or.((i-1).le.0) +C end of changes suggested by Ana + & .or. itype(i+2).eq.ntyp1 + & .or. itype(i+3).eq.ntyp1 +C & .or. itype(i+5).eq.ntyp1 +C & .or. itype(i).eq.ntyp1 +C & .or. itype(i-1).eq.ntyp1 + & ) goto 179 + CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C Third-order contributions @@ -2508,22 +3151,80 @@ cd call checkint_turn3(i,a_temp,eello_turn3_num) call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1)) call transpose2(auxmat(1,1),auxmat1(1,1)) call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) + if (shield_mode.eq.0) then + fac_shield(i)=1.0 + fac_shield(j)=1.0 +C else +C fac_shield(i)=0.4 +C fac_shield(j)=0.6 + endif eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) + & *fac_shield(i)*fac_shield(j) + eello_t3=0.5d0*(pizda(1,1)+pizda(2,2)) + & *fac_shield(i)*fac_shield(j) + cd write (2,*) 'i,',i,' j',j,'eello_turn3', cd & 0.5d0*(pizda(1,1)+pizda(2,2)), cd & ' eello_turn3_num',4*eello_turn3_num if (calc_grad) then +C Derivatives in shield mode + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + & (shield_mode.gt.0)) then +C print *,i,j + + do ilist=1,ishield_list(i) + iresshield=shield_list(ilist,i) + do k=1,3 + rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i) +C & *2.0 + gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ + & rlocshield + & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i) + gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) + & +rlocshield + enddo + enddo + do ilist=1,ishield_list(j) + iresshield=shield_list(ilist,j) + do k=1,3 + rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j) +C & *2.0 + gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ + & rlocshield + & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j) + gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) + & +rlocshield + + enddo + enddo + + do k=1,3 + gshieldc_t3(k,i)=gshieldc_t3(k,i)+ + & grad_shield(k,i)*eello_t3/fac_shield(i) + gshieldc_t3(k,j)=gshieldc_t3(k,j)+ + & grad_shield(k,j)*eello_t3/fac_shield(j) + gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+ + & grad_shield(k,i)*eello_t3/fac_shield(i) + gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+ + & grad_shield(k,j)*eello_t3/fac_shield(j) + enddo + endif + C Derivatives in gamma(i) call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1)) call transpose2(auxmat2(1,1),pizda(1,1)) call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1)) gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2)) + & *fac_shield(i)*fac_shield(j) + C Derivatives in gamma(i+1) call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1)) call transpose2(auxmat2(1,1),pizda(1,1)) call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1)) gel_loc_turn3(i+1)=gel_loc_turn3(i+1) & +0.5d0*(pizda(1,1)+pizda(2,2)) + & *fac_shield(i)*fac_shield(j) + C Cartesian derivatives do l=1,3 a_temp(1,1)=aggi(l,1) @@ -2533,6 +3234,8 @@ C Cartesian derivatives call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) gcorr3_turn(l,i)=gcorr3_turn(l,i) & +0.5d0*(pizda(1,1)+pizda(2,2)) + & *fac_shield(i)*fac_shield(j) + a_temp(1,1)=aggi1(l,1) a_temp(1,2)=aggi1(l,2) a_temp(2,1)=aggi1(l,3) @@ -2540,6 +3243,8 @@ C Cartesian derivatives call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) & +0.5d0*(pizda(1,1)+pizda(2,2)) + & *fac_shield(i)*fac_shield(j) + a_temp(1,1)=aggj(l,1) a_temp(1,2)=aggj(l,2) a_temp(2,1)=aggj(l,3) @@ -2547,6 +3252,8 @@ C Cartesian derivatives call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) gcorr3_turn(l,j)=gcorr3_turn(l,j) & +0.5d0*(pizda(1,1)+pizda(2,2)) + & *fac_shield(i)*fac_shield(j) + a_temp(1,1)=aggj1(l,1) a_temp(1,2)=aggj1(l,2) a_temp(2,1)=aggj1(l,3) @@ -2554,9 +3261,24 @@ C Cartesian derivatives call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1)) gcorr3_turn(l,j1)=gcorr3_turn(l,j1) & +0.5d0*(pizda(1,1)+pizda(2,2)) + & *fac_shield(i)*fac_shield(j) + enddo endif - else if (j.eq.i+3 .and. itype(i+2).ne.21) then + 179 continue + else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 +C changes suggested by Ana to avoid out of bounds +C & .or.((i+5).gt.nres) +C & .or.((i-1).le.0) +C end of changes suggested by Ana + & .or. itype(i+3).eq.ntyp1 + & .or. itype(i+4).eq.ntyp1 +C & .or. itype(i+5).eq.ntyp1 + & .or. itype(i).eq.ntyp1 +C & .or. itype(i-1).eq.ntyp1 + & ) goto 178 + CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C Fourth-order contributions @@ -2584,11 +3306,64 @@ cd call checkint_turn4(i,a_temp,eello_turn4_num) call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1)) call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) + if (shield_mode.eq.0) then + fac_shield(i)=1.0 + fac_shield(j)=1.0 +C else +C fac_shield(i)=0.4 +C fac_shield(j)=0.6 + endif eello_turn4=eello_turn4-(s1+s2+s3) + & *fac_shield(i)*fac_shield(j) + eello_t4=-(s1+s2+s3) + & *fac_shield(i)*fac_shield(j) + cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3), cd & ' eello_turn4_num',8*eello_turn4_num C Derivatives in gamma(i) if (calc_grad) then + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + & (shield_mode.gt.0)) then +C print *,i,j + + do ilist=1,ishield_list(i) + iresshield=shield_list(ilist,i) + do k=1,3 + rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i) +C & *2.0 + gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ + & rlocshield + & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i) + gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) + & +rlocshield + enddo + enddo + do ilist=1,ishield_list(j) + iresshield=shield_list(ilist,j) + do k=1,3 + rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j) +C & *2.0 + gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ + & rlocshield + & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j) + gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) + & +rlocshield + + enddo + enddo + + do k=1,3 + gshieldc_t4(k,i)=gshieldc_t4(k,i)+ + & grad_shield(k,i)*eello_t4/fac_shield(i) + gshieldc_t4(k,j)=gshieldc_t4(k,j)+ + & grad_shield(k,j)*eello_t4/fac_shield(j) + gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+ + & grad_shield(k,i)*eello_t4/fac_shield(i) + gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+ + & grad_shield(k,j)*eello_t4/fac_shield(j) + enddo + endif + call transpose2(EUgder(1,1,i+1),e1tder(1,1)) call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1)) call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1)) @@ -2596,6 +3371,8 @@ C Derivatives in gamma(i) call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) + & *fac_shield(i)*fac_shield(j) + C Derivatives in gamma(i+1) call transpose2(EUgder(1,1,i+2),e2tder(1,1)) call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1)) @@ -2604,6 +3381,8 @@ C Derivatives in gamma(i+1) call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) + & *fac_shield(i)*fac_shield(j) + C Derivatives in gamma(i+2) call transpose2(EUgder(1,1,i+3),e3tder(1,1)) call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1)) @@ -2615,6 +3394,8 @@ C Derivatives in gamma(i+2) call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) + & *fac_shield(i)*fac_shield(j) + C Cartesian derivatives C Derivatives of this turn contributions in DC(i+2) if (j.lt.nres-1) then @@ -2634,6 +3415,8 @@ C Derivatives of this turn contributions in DC(i+2) s3=0.5d0*(pizda(1,1)+pizda(2,2)) ggg(l)=-(s1+s2+s3) gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3) + & *fac_shield(i)*fac_shield(j) + enddo endif C Remaining derivatives of this turn contribution @@ -2652,6 +3435,8 @@ C Remaining derivatives of this turn contribution call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) + & *fac_shield(i)*fac_shield(j) + a_temp(1,1)=aggi1(l,1) a_temp(1,2)=aggi1(l,2) a_temp(2,1)=aggi1(l,3) @@ -2666,6 +3451,8 @@ C Remaining derivatives of this turn contribution call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) + & *fac_shield(i)*fac_shield(j) + a_temp(1,1)=aggj(l,1) a_temp(1,2)=aggj(l,2) a_temp(2,1)=aggj(l,3) @@ -2680,6 +3467,8 @@ C Remaining derivatives of this turn contribution call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) + & *fac_shield(i)*fac_shield(j) + a_temp(1,1)=aggj1(l,1) a_temp(1,2)=aggj1(l,2) a_temp(2,1)=aggj1(l,3) @@ -2694,8 +3483,11 @@ C Remaining derivatives of this turn contribution call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1)) s3=0.5d0*(pizda(1,1)+pizda(2,2)) gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) + & *fac_shield(i)*fac_shield(j) + enddo endif + 178 continue endif return end @@ -2757,7 +3549,7 @@ cd print '(a)','Enter ESCP' c write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e, c & ' scal14',scal14 do i=iatscp_s,iatscp_e - if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle iteli=itel(i) c write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i), c & " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) @@ -2765,37 +3557,90 @@ c & " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) xi=0.5D0*(c(1,i)+c(1,i+1)) yi=0.5D0*(c(2,i)+c(2,i+1)) zi=0.5D0*(c(3,i)+c(3,i+1)) +C Returning the ith atom to box + xi=mod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=mod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=mod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize do iint=1,nscp_gr(i) do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle C Uncomment following three lines for SC-p interactions c xj=c(1,nres+j)-xi c yj=c(2,nres+j)-yi c zj=c(3,nres+j)-zi C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi + xj=c(1,j) + yj=c(2,j) + zj=c(3,j) +C returning the jth atom to box + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 +C Finding the closest jth atom + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + subchap=1 + endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +C sss is scaling function for smoothing the cutoff gradient otherwise +C the gradient would not be continuouse + sss=sscale(1.0d0/(dsqrt(rrij))) + if (sss.le.0.0d0) cycle + sssgrad=sscagrad(1.0d0/(dsqrt(rrij))) fac=rrij**expon2 e1=fac*fac*aad(itypj,iteli) e2=fac*bad(itypj,iteli) if (iabs(j-i) .le. 2) then e1=scal14*e1 e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 + evdw2_14=evdw2_14+(e1+e2)*sss endif evdwij=e1+e2 c write (iout,*) i,j,evdwij - evdw2=evdw2+evdwij + evdw2=evdw2+evdwij*sss if (calc_grad) then C C Calculate contributions to the gradient in the virtual-bond and SC vectors. C - fac=-(evdwij+e1)*rrij + fac=-(evdwij+e1)*rrij*sss + fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon ggg(1)=xj*fac ggg(2)=yj*fac ggg(3)=zj*fac @@ -2860,6 +3705,7 @@ C include 'COMMON.DERIV' include 'COMMON.VAR' include 'COMMON.INTERACT' + include 'COMMON.CONTROL' dimension ggg(3) ehpb=0.0D0 cd print *,'edis: nhpb=',nhpb,' fbr=',fbr @@ -2880,10 +3726,42 @@ C iii and jjj point to the residues for which the distance is assigned. endif 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 +C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. +C & iabs(itype(jjj)).eq.1) then +C call ssbond_ene(iii,jjj,eij) +C ehpb=ehpb+2*eij +C else + if (.not.dyn_ss .and. i.le.nss) then + if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. + & iabs(itype(jjj)).eq.1) then call ssbond_ene(iii,jjj,eij) ehpb=ehpb+2*eij - else + endif !ii.gt.neres + else if (ii.gt.nres .and. jj.gt.nres) then +c Restraints from contact prediction + dd=dist(ii,jj) + if (constr_dist.eq.11) then +C ehpb=ehpb+fordepth(i)**4.0d0 +C & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + ehpb=ehpb+fordepth(i)**4.0d0 + & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + fac=fordepth(i)**4.0d0 + & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd +C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, +C & ehpb,fordepth(i),dd +C print *,"TUTU" +C write(iout,*) ehpb,"atu?" +C ehpb,"tu?" +C fac=fordepth(i)**4.0d0 +C & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd + else !constr_dist.eq.11 + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "beta nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else !dhpb(i).gt.0.00 + C Calculate the distance between the two points and its difference from the C target distance. dd=dist(ii,jj) @@ -2896,6 +3774,8 @@ C C Evaluate gradient. C fac=waga*rdis/dd + endif !dhpb(i).gt.0 + endif cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, cd & ' waga=',waga,' fac=',fac do j=1,3 @@ -2910,6 +3790,53 @@ C Cartesian gradient in the SC vectors (ghpbx). ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) enddo endif + else !ii.gt.nres +C write(iout,*) "before" + dd=dist(ii,jj) +C write(iout,*) "after",dd + if (constr_dist.eq.11) then + ehpb=ehpb+fordepth(i)**4.0d0 + & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + fac=fordepth(i)**4.0d0 + & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd +C ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i)) +C fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd +C print *,ehpb,"tu?" +C write(iout,*) ehpb,"btu?", +C & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i) +C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, +C & ehpb,fordepth(i),dd + else + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "alph nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +c write (iout,*) "alpha reg",dd,waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif + endif + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo +cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) +C If this is a SC-SC distance, we need to calculate the contributions to the +C Cartesian gradient in the SC vectors (ghpbx). + if (iii.lt.ii) then + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + endif do j=iii,jjj-1 do k=1,3 ghpbc(k,j)=ghpbc(k,j)+ggg(k) @@ -2917,7 +3844,7 @@ C Cartesian gradient in the SC vectors (ghpbx). enddo endif enddo - ehpb=0.5D0*ehpb + if (constr_dist.ne.11) ehpb=0.5D0*ehpb return end C-------------------------------------------------------------------------- @@ -2940,7 +3867,7 @@ C include 'COMMON.VAR' include 'COMMON.IOUNITS' double precision erij(3),dcosom1(3),dcosom2(3),gg(3) - itypi=itype(i) + itypi=iabs(itype(i)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -2948,7 +3875,7 @@ C dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) dsci_inv=dsc_inv(itypi) - itypj=itype(j) + itypj=iabs(itype(j)) dscj_inv=dsc_inv(itypj) xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi @@ -2989,23 +3916,632 @@ c & " deltat12",deltat12," eij",eij do k=1,3 gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) enddo - do k=1,3 - ghpbx(k,i)=ghpbx(k,i)-gg(k) - & +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv - ghpbx(k,j)=ghpbx(k,j)+gg(k) - & +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv + do k=1,3 + ghpbx(k,i)=ghpbx(k,i)-gg(k) + & +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv + ghpbx(k,j)=ghpbx(k,j)+gg(k) + & +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv + enddo +C +C Calculate the components of the gradient in DC and X +C + do k=i,j-1 + do l=1,3 + ghpbc(l,k)=ghpbc(l,k)+gg(l) + enddo + enddo + return + end +C-------------------------------------------------------------------------- + + +c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA + subroutine e_modeller(ehomology_constr) + implicit real*8 (a-h,o-z) + + include 'DIMENSIONS' + + integer nnn, i, j, k, ki, irec, l + integer katy, odleglosci, test7 + real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template) + real*8 distance(max_template),distancek(max_template), + & min_odl,godl(max_template),dih_diff(max_template) + +c +c FP - 30/10/2014 Temporary specifications for homology restraints +c + double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta, + & sgtheta + double precision, dimension (maxres) :: guscdiff,usc_diff + double precision, dimension (max_template) :: + & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3, + & theta_diff + + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.HOMRESTR' +c + include 'COMMON.SETUP' + include 'COMMON.NAMES' + + do i=1,max_template + distancek(i)=9999999.9 + enddo + + odleg=0.0d0 + +c Pseudo-energy and gradient from homology restraints (MODELLER-like +c function) +C AL 5/2/14 - Introduce list of restraints +c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d +#ifdef DEBUG + write(iout,*) "------- dist restrs start -------" + write (iout,*) "link_start_homo",link_start_homo, + & " link_end_homo",link_end_homo +#endif + do ii = link_start_homo,link_end_homo + i = ires_homo(ii) + j = jres_homo(ii) + dij=dist(i,j) +c write (iout,*) "dij(",i,j,") =",dij + do k=1,constr_homology + if(.not.l_homo(k,ii)) cycle + distance(k)=odl(k,ii)-dij +c write (iout,*) "distance(",k,") =",distance(k) +c +c For Gaussian-type Urestr +c + distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument +c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii) +c write (iout,*) "distancek(",k,") =",distancek(k) +c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii) +c +c For Lorentzian-type Urestr +c + if (waga_dist.lt.0.0d0) then + sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii)) + distancek(k)=distance(k)**2/(sigma_odlir(k,ii)* + & (distance(k)**2+sigma_odlir(k,ii)**2)) + endif + enddo + +c min_odl=minval(distancek) + do kk=1,constr_homology + if(l_homo(kk,ii)) then + min_odl=distancek(kk) + exit + endif + enddo + do kk=1,constr_homology + if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl) + & min_odl=distancek(kk) + enddo +c write (iout,* )"min_odl",min_odl +#ifdef DEBUG + write (iout,*) "ij dij",i,j,dij + write (iout,*) "distance",(distance(k),k=1,constr_homology) + write (iout,*) "distancek",(distancek(k),k=1,constr_homology) + write (iout,* )"min_odl",min_odl +#endif + odleg2=0.0d0 + do k=1,constr_homology +c Nie wiem po co to liczycie jeszcze raz! +c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/ +c & (2*(sigma_odl(i,j,k))**2)) + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + godl(k)=dexp(-distancek(k)+min_odl) + odleg2=odleg2+godl(k) +c +c For Lorentzian-type Urestr +c + else + odleg2=odleg2+distancek(k) + endif + +ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3, +ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=", +ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1), +ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k) + + enddo +c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents +c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#ifdef DEBUG + write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents + write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#endif + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + odleg=odleg-dLOG(odleg2/constr_homology)+min_odl +c +c For Lorentzian-type Urestr +c + else + odleg=odleg+odleg2/constr_homology + endif +c +#ifdef GRAD +c write (iout,*) "odleg",odleg ! sum of -ln-s +c Gradient +c +c For Gaussian-type Urestr +c + if (waga_dist.ge.0.0d0) sum_godl=odleg2 + sum_sgodl=0.0d0 + do k=1,constr_homology +c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) +c & *waga_dist)+min_odl +c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist +c + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c For Gaussian-type Urestr +c + sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd +c +c For Lorentzian-type Urestr +c + else + sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ + & sigma_odlir(k,ii)**2)**2) + endif + sum_sgodl=sum_sgodl+sgodl + +c sgodl2=sgodl2+sgodl +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1" +c write(iout,*) "constr_homology=",constr_homology +c write(iout,*) i, j, k, "TEST K" + enddo + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + grad_odl3=waga_homology(iset)*waga_dist + & *sum_sgodl/(sum_godl*dij) +c +c For Lorentzian-type Urestr +c + else +c Original grad expr modified by analogy w Gaussian-type Urestr grad +c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl + grad_odl3=-waga_homology(iset)*waga_dist* + & sum_sgodl/(constr_homology*dij) + endif +c +c grad_odl3=sum_sgodl/(sum_godl*dij) + + +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2" +c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2), +c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) + +ccc write(iout,*) godl, sgodl, grad_odl3 + +c grad_odl=grad_odl+grad_odl3 + + do jik=1,3 + ggodl=grad_odl3*(c(jik,i)-c(jik,j)) +ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1)) +ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) + ghpbc(jik,i)=ghpbc(jik,i)+ggodl + ghpbc(jik,j)=ghpbc(jik,j)-ggodl +ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) +c if (i.eq.25.and.j.eq.27) then +c write(iout,*) "jik",jik,"i",i,"j",j +c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl +c write(iout,*) "grad_odl3",grad_odl3 +c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j) +c write(iout,*) "ggodl",ggodl +c write(iout,*) "ghpbc(",jik,i,")", +c & ghpbc(jik,i),"ghpbc(",jik,j,")", +c & ghpbc(jik,j) +c endif + enddo +#endif +ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=", +ccc & dLOG(odleg2),"-odleg=", -odleg + + enddo ! ii-loop for dist +#ifdef DEBUG + write(iout,*) "------- dist restrs end -------" +c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or. +c & waga_d.eq.1.0d0) call sum_gradient +#endif +c Pseudo-energy and gradient from dihedral-angle restraints from +c homology templates +c write (iout,*) "End of distance loop" +c call flush(iout) + kat=0.0d0 +c write (iout,*) idihconstr_start_homo,idihconstr_end_homo +#ifdef DEBUG + write(iout,*) "------- dih restrs start -------" + do i=idihconstr_start_homo,idihconstr_end_homo + write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg) + enddo +#endif + do i=idihconstr_start_homo,idihconstr_end_homo + kat2=0.0d0 +c betai=beta(i,i+1,i+2,i+3) + betai = phi(i+3) +c write (iout,*) "betai =",betai + do k=1,constr_homology + dih_diff(k)=pinorm(dih(k,i)-betai) +c write (iout,*) "dih_diff(",k,") =",dih_diff(k) +c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)= +c & -(6.28318-dih_diff(i,k)) +c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)= +c & 6.28318+dih_diff(i,k) + + kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument +c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i) + gdih(k)=dexp(kat3) + kat2=kat2+gdih(k) +c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3) +c write(*,*)"" + enddo +c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps +#ifdef DEBUG + write (iout,*) "i",i," betai",betai," kat2",kat2 + write (iout,*) "gdih",(gdih(k),k=1,constr_homology) +#endif + if (kat2.le.1.0d-14) cycle + kat=kat-dLOG(kat2/constr_homology) +c write (iout,*) "kat",kat ! sum of -ln-s + +ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=", +ccc & dLOG(kat2), "-kat=", -kat + +#ifdef GRAD +c ---------------------------------------------------------------------- +c Gradient +c ---------------------------------------------------------------------- + + sum_gdih=kat2 + sum_sgdih=0.0d0 + do k=1,constr_homology + sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd +c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle + sum_sgdih=sum_sgdih+sgdih + enddo +c grad_dih3=sum_sgdih/sum_gdih + grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih + +c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3 +ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + gloc(i,icg)=gloc(i,icg)+grad_dih3 +c if (i.eq.25) then +c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg) +c endif +ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) +#endif + enddo ! i-loop for dih +#ifdef DEBUG + write(iout,*) "------- dih restrs end -------" +#endif + +c Pseudo-energy and gradient for theta angle restraints from +c homology templates +c FP 01/15 - inserted from econstr_local_test.F, loop structure +c adapted + +c +c For constr_homology reference structures (FP) +c +c Uconst_back_tot=0.0d0 + Eval=0.0d0 + Erot=0.0d0 +c Econstr_back legacy +#ifdef GRAD + do i=1,nres +c do i=ithet_start,ithet_end + dutheta(i)=0.0d0 +c enddo +c do i=loc_start,loc_end + do j=1,3 + duscdiff(j,i)=0.0d0 + duscdiffx(j,i)=0.0d0 + enddo + enddo +#endif +c +c do iref=1,nref +c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +c write (iout,*) "waga_theta",waga_theta + if (waga_theta.gt.0.0d0) then +#ifdef DEBUG + write (iout,*) "usampl",usampl + write(iout,*) "------- theta restrs start -------" +c do i=ithet_start,ithet_end +c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg) +c enddo +#endif +c write (iout,*) "maxres",maxres,"nres",nres + + do i=ithet_start,ithet_end +c +c do i=1,nfrag_back +c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) +c +c Deviation of theta angles wrt constr_homology ref structures +c + utheta_i=0.0d0 ! argument of Gaussian for single k + gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop +c over residues in a fragment +c write (iout,*) "theta(",i,")=",theta(i) + do k=1,constr_homology +c +c dtheta_i=theta(j)-thetaref(j,iref) +c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing + theta_diff(k)=thetatpl(k,i)-theta(i) +c + utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument +c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta? + gtheta(k)=dexp(utheta_i) ! + min_utheta_i? + gutheta_i=gutheta_i+dexp(utheta_i) ! Sum of Gaussians (pk) +c Gradient for single Gaussian restraint in subr Econstr_back +c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) +c + enddo +c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps + +c +#ifdef GRAD +c Gradient for multiple Gaussian restraint + sum_gtheta=gutheta_i + sum_sgtheta=0.0d0 + do k=1,constr_homology +c New generalized expr for multiple Gaussian from Econstr_back + sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd +c +c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form? + sum_sgtheta=sum_sgtheta+sgtheta ! cum variable + enddo +c +c Final value of gradient using same var as in Econstr_back + dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta + & *waga_homology(iset) +c dutheta(i)=sum_sgtheta/sum_gtheta +c +c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight +#endif + Eval=Eval-dLOG(gutheta_i/constr_homology) +c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s +c Uconst_back=Uconst_back+utheta(i) + enddo ! (i-loop for theta) +#ifdef DEBUG + write(iout,*) "------- theta restrs end -------" +#endif + endif +c +c Deviation of local SC geometry +c +c Separation of two i-loops (instructed by AL - 11/3/2014) +c +c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +c write (iout,*) "waga_d",waga_d + +#ifdef DEBUG + write(iout,*) "------- SC restrs start -------" + write (iout,*) "Initial duscdiff,duscdiffx" + do i=loc_start,loc_end + write (iout,*) i,(duscdiff(jik,i),jik=1,3), + & (duscdiffx(jik,i),jik=1,3) enddo -C -C Calculate the components of the gradient in DC and X -C - do k=i,j-1 - do l=1,3 - ghpbc(l,k)=ghpbc(l,k)+gg(l) +#endif + do i=loc_start,loc_end + usc_diff_i=0.0d0 ! argument of Gaussian for single k + guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy +c write(iout,*) "xxtab, yytab, zztab" +c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i) + do k=1,constr_homology +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z +c write(iout,*) "dxx, dyy, dzz" +c write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz +c + usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument +c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d? +c uscdiffk(k)=usc_diff(i) + guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff + guscdiff(i)=guscdiff(i)+dexp(usc_diff_i) !Sum of Gaussians (pk) +c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), +c & xxref(j),yyref(j),zzref(j) + enddo +c +c Gradient +c +c Generalized expression for multiple Gaussian acc to that for a single +c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014) +c +c Original implementation +c sum_guscdiff=guscdiff(i) +c +c sum_sguscdiff=0.0d0 +c do k=1,constr_homology +c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d? +c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff +c sum_sguscdiff=sum_sguscdiff+sguscdiff +c enddo +c +c Implementation of new expressions for gradient (Jan. 2015) +c +c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !? +#ifdef GRAD + do k=1,constr_homology +c +c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong +c before. Now the drivatives should be correct +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z +c +c New implementation +c + sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong! + & sigma_d(k,i) ! for the grad wrt r' +c sum_sguscdiff=sum_sguscdiff+sum_guscdiff +c +c +c New implementation + sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff + do jik=1,3 + duscdiff(jik,i-1)=duscdiff(jik,i-1)+ + & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+ + & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i) + duscdiff(jik,i)=duscdiff(jik,i)+ + & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+ + & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i) + duscdiffx(jik,i)=duscdiffx(jik,i)+ + & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+ + & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i) +c +#ifdef DEBUG + write(iout,*) "jik",jik,"i",i + write(iout,*) "dxx, dyy, dzz" + write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz + write(iout,*) "guscdiff2(",k,")",guscdiff2(k) +c write(iout,*) "sum_sguscdiff",sum_sguscdiff +cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i) +c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i) +c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i) +c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i) +c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i) +c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i) +c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i) +c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i) +c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i) +c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1) +c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i) +c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i) +c endif +#endif + enddo + enddo +#endif +c +c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required? +c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ? +c +c write (iout,*) i," uscdiff",uscdiff(i) +c +c Put together deviations from local geometry + +c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ +c & wfrag_back(3,i,iset)*uscdiff(i) + Erot=Erot-dLOG(guscdiff(i)/constr_homology) +c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s +c Uconst_back=Uconst_back+usc_diff(i) +c +c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?) +c +c New implment: multiplied by sum_sguscdiff +c + + enddo ! (i-loop for dscdiff) + +c endif + +#ifdef DEBUG + write(iout,*) "------- SC restrs end -------" + write (iout,*) "------ After SC loop in e_modeller ------" + do i=loc_start,loc_end + write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3) + write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3) enddo + if (waga_theta.eq.1.0d0) then + write (iout,*) "in e_modeller after SC restr end: dutheta" + do i=ithet_start,ithet_end + write (iout,*) i,dutheta(i) + enddo + endif + if (waga_d.eq.1.0d0) then + write (iout,*) "e_modeller after SC loop: duscdiff/x" + do i=1,nres + write (iout,*) i,(duscdiff(j,i),j=1,3) + write (iout,*) i,(duscdiffx(j,i),j=1,3) enddo + endif +#endif + +c Total energy from homology restraints +#ifdef DEBUG + write (iout,*) "odleg",odleg," kat",kat + write (iout,*) "odleg",odleg," kat",kat + write (iout,*) "Eval",Eval," Erot",Erot + write (iout,*) "waga_homology(",iset,")",waga_homology(iset) + write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle + write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d + write (iout,*) "waga_homology(",iset,")",waga_homology(iset) +#endif +c +c Addition of energy of theta angle and SC local geom over constr_homologs ref strs +c +c ehomology_constr=odleg+kat +c +c For Lorentzian-type Urestr +c + + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + ehomology_constr=(waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) +c write (iout,*) "ehomology_constr=",ehomology_constr + else +c +c For Lorentzian-type Urestr +c + ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) +c write (iout,*) "ehomology_constr=",ehomology_constr + endif +#ifdef DEBUG + write (iout,*) "iset",iset," waga_homology",waga_homology(iset) + write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat, + & " Eval",waga_theta,Eval," Erot",waga_d,Erot + write (iout,*) "ehomology_constr",ehomology_constr +#endif return + + 748 format(a8,f12.3,a6,f12.3,a7,f12.3) + 747 format(a12,i4,i4,i4,f8.3,f8.3) + 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3) + 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3) + 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, + & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3) end C-------------------------------------------------------------------------- + +C-------------------------------------------------------------------------- subroutine ebond(estr) c c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds @@ -3026,32 +4562,39 @@ c logical energy_dec /.false./ double precision u(3),ud(3) estr=0.0d0 + estr1=0.0d0 do i=nnt+1,nct - if (itype(i-1).eq.21 .or. itype(i).eq.21) then - estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) - do j=1,3 - gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) - & *dc(j,i-1)/vbld(i) - enddo - if (energy_dec) write(iout,*) - & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax) - else + if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle +C estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) +C do j=1,3 +C gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) +C & *dc(j,i-1)/vbld(i) +C enddo +C if (energy_dec) write(iout,*) +C & "estr1",i,vbld(i),distchainmax, +C & gnmr1(vbld(i),-1.0d0,distchainmax) +C else + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then + diff = vbld(i)-vbldpDUM + else diff = vbld(i)-vbldp0 c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff + endif estr=estr+diff*diff do j=1,3 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) enddo - endif - +C endif +C write (iout,'(a7,i5,4f7.3)') +C & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff enddo estr=0.5d0*AKP*estr+estr1 c c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included c do i=nnt,nct - iti=itype(i) - if (iti.ne.10 .and. iti.ne.21) then + iti=iabs(itype(i)) + if (iti.ne.10 .and. iti.ne.ntyp1) then nbi=nbondterm(iti) if (nbi.eq.1) then diff=vbld(i+nres)-vbldsc0(1,iti) @@ -3098,7 +4641,7 @@ c & AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi) end #ifdef CRYST_THETA C-------------------------------------------------------------------------- - subroutine ebend(etheta) + subroutine ebend(etheta,ethetacnstr) C C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral C angles gamma and its derivatives in consecutive thetas and gammas. @@ -3115,27 +4658,46 @@ C include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.FFIELD' + include 'COMMON.TORCNSTR' common /calcthet/ term1,term2,termm,diffak,ratak, & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, & delthe0,sig0inv,sigtc,sigsqtc,delthec,it double precision y(2),z(2) delta=0.02d0*pi - time11=dexp(-2*time) - time12=1.0d0 +c time11=dexp(-2*time) +c time12=1.0d0 etheta=0.0D0 c write (iout,*) "nres",nres c write (*,'(a,i2)') 'EBEND ICG=',icg c write (iout,*) ithet_start,ithet_end do i=ithet_start,ithet_end - if (itype(i-1).eq.21) cycle + if (i.le.2) cycle + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle C Zero the energy function and its derivative at 0 or pi. call splinthet(theta(i),0.5d0*delta,ss,ssd) it=itype(i-1) - if (i.gt.3 .and. itype(i-2).ne.21) then + ichir1=isign(1,itype(i-2)) + ichir2=isign(1,itype(i)) + if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1)) + if (itype(i).eq.10) ichir2=isign(1,itype(i-1)) + if (itype(i-1).eq.10) then + itype1=isign(10,itype(i-2)) + ichir11=isign(1,itype(i-2)) + ichir12=isign(1,itype(i-2)) + itype2=isign(10,itype(i)) + ichir21=isign(1,itype(i)) + ichir22=isign(1,itype(i)) + endif + if (i.eq.3) then + y(1)=0.0D0 + y(2)=0.0D0 + else + if (i.gt.3 .and. itype(i-3).ne.ntyp1) then #ifdef OSF phii=phi(i) - icrc=0 - call proc_proc(phii,icrc) +c icrc=0 +c call proc_proc(phii,icrc) if (icrc.eq.1) phii=150.0 #else phii=phi(i) @@ -3146,11 +4708,12 @@ C Zero the energy function and its derivative at 0 or pi. y(1)=0.0D0 y(2)=0.0D0 endif - if (i.lt.nres .and. itype(i).ne.21) then + endif + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then #ifdef OSF phii1=phi(i+1) - icrc=0 - call proc_proc(phii1,icrc) +c icrc=0 +c call proc_proc(phii1,icrc) if (icrc.eq.1) phii1=150.0 phii1=pinorm(phii1) z(1)=cos(phii1) @@ -3168,8 +4731,12 @@ 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) + athetk=athet(k,it,ichir1,ichir2) + bthetk=bthet(k,it,ichir1,ichir2) + if (it.eq.10) then + athetk=athet(k,itype1,ichir11,ichir12) + bthetk=bthet(k,itype2,ichir21,ichir22) + endif thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) enddo c write (iout,*) "thet_pred_mean",thet_pred_mean @@ -3177,8 +4744,16 @@ c write (iout,*) "thet_pred_mean",thet_pred_mean thet_pred_mean=thet_pred_mean*ss+a0thet(it) c write (iout,*) "thet_pred_mean",thet_pred_mean 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 + dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) + &+athet(2,it,ichir1,ichir2)*y(1))*ss + dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) + & +bthet(2,it,ichir1,ichir2)*z(1))*ss + if (it.eq.10) then + dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) + &+athet(2,itype1,ichir11,ichir12)*y(1))*ss + dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) + & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss + endif if (theta(i).gt.pi-delta) then call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, & E_tc0) @@ -3206,9 +4781,37 @@ c & rad2deg*phii,rad2deg*phii1,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) - 1215 continue +c 1215 continue enddo C Ufff.... We've done all this!!! +C now constrains + ethetacnstr=0.0d0 +C print *,ithetaconstr_start,ithetaconstr_end,"TU" + do i=1,ntheta_constr + itheta=itheta_constr(i) + thetiii=theta(itheta) + difi=pinorm(thetiii-theta_constr0(i)) + if (difi.gt.theta_drange(i)) then + difi=difi-theta_drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else + difi=0.0 + endif +C if (energy_dec) then +C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", +C & i,itheta,rad2deg*thetiii, +C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), +C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, +C & gloc(itheta+nphi-2,icg) +C endif + enddo return end C--------------------------------------------------------------------------- @@ -3321,7 +4924,7 @@ C "Thank you" to MAPLE (probably spared one day of hand-differentiation). end #else C-------------------------------------------------------------------------- - subroutine ebend(etheta) + subroutine ebend(etheta,ethetacnstr) C C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral C angles gamma and its derivatives in consecutive thetas and gammas. @@ -3341,6 +4944,7 @@ C include 'COMMON.NAMES' include 'COMMON.FFIELD' include 'COMMON.CONTROL' + include 'COMMON.TORCNSTR' double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), @@ -3349,24 +4953,31 @@ C etheta=0.0D0 c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) do i=ithet_start,ithet_end - if (itype(i-1).eq.21) cycle + if (i.eq.2) cycle +c print *,i,itype(i-1),itype(i),itype(i-2) + if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1) + & .or.(itype(i).eq.ntyp1)) cycle +C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF + + if (iabs(itype(i+1)).eq.20) iblock=2 + if (iabs(itype(i+1)).ne.20) iblock=1 dethetai=0.0d0 dephii=0.0d0 dephii1=0.0d0 theti2=0.5d0*theta(i) - ityp2=ithetyp(itype(i-1)) + ityp2=ithetyp((itype(i-1))) do k=1,nntheterm coskt(k)=dcos(k*theti2) sinkt(k)=dsin(k*theti2) enddo - if (i.gt.3 .and. itype(i-2).ne.21) then + if (i.gt.3 .and. itype(i-3).ne.ntyp1) then #ifdef OSF phii=phi(i) if (phii.ne.phii) phii=150.0 #else phii=phi(i) #endif - ityp1=ithetyp(itype(i-2)) + ityp1=ithetyp((itype(i-2))) do k=1,nsingle cosph1(k)=dcos(k*phii) sinph1(k)=dsin(k*phii) @@ -3379,7 +4990,7 @@ c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) sinph1(k)=0.0d0 enddo endif - if (i.lt.nres .and. itype(i).ne.21) then + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then #ifdef OSF phii1=phi(i+1) if (phii1.ne.phii1) phii1=150.0 @@ -3387,7 +4998,7 @@ c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) #else phii1=phi(i+1) #endif - ityp3=ithetyp(itype(i)) + ityp3=ithetyp((itype(i))) do k=1,nsingle cosph2(k)=dcos(k*phii1) sinph2(k)=dsin(k*phii1) @@ -3403,7 +5014,7 @@ c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) c write (iout,*) "i",i," ityp1",itype(i-2),ityp1, c & " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3 c call flush(iout) - ethetai=aa0thet(ityp1,ityp2,ityp3) + ethetai=aa0thet(ityp1,ityp2,ityp3,iblock) do k=1,ndouble do l=1,k-1 ccl=cosph1(l)*cosph2(k-l) @@ -3425,11 +5036,12 @@ c call flush(iout) 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) + ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k) + dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) & *coskt(k) if (lprn) - & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), + & write (iout,*) "k",k," aathet", + & aathet(k,ityp1,ityp2,ityp3,iblock), & " ethetai",ethetai enddo if (lprn) then @@ -3448,24 +5060,24 @@ c call flush(iout) 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) + aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) + & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) + & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) + & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k) ethetai=ethetai+sinkt(m)*aux dethetai=dethetai+0.5d0*m*aux*coskt(m) dephii=dephii+k*sinkt(m)*( - & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- - & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) + & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- + & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)) dephii1=dephii1+k*sinkt(m)*( - & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- - & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) + & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- + & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)) if (lprn) & write (iout,*) "m",m," k",k," bbthet", - & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", - & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", - & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", - & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai + & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", + & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", + & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", + & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai enddo enddo if (lprn) @@ -3473,28 +5085,29 @@ c call flush(iout) 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) + aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l) ethetai=ethetai+sinkt(m)*aux dethetai=dethetai+0.5d0*m*coskt(m)*aux dephii=dephii+l*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*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)) + & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) dephii1=dephii1+(k-l)*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*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)) + & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) if (lprn) then write (iout,*) "m",m," k",k," l",l," ffthet", - & ffthet(l,k,m,ityp1,ityp2,ityp3), - & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", - & ggthet(l,k,m,ityp1,ityp2,ityp3), - & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai + & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock), + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet", + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock), + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock), + & " ethetai",ethetai write (iout,*) cosph1ph2(l,k)*sinkt(m), & cosph1ph2(k,l)*sinkt(m), & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) @@ -3509,7 +5122,36 @@ c call flush(iout) 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 +c gloc(nphi+i-2,icg)=wang*dethetai + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai + enddo +C now constrains + ethetacnstr=0.0d0 +C print *,ithetaconstr_start,ithetaconstr_end,"TU" + do i=1,ntheta_constr + itheta=itheta_constr(i) + thetiii=theta(itheta) + difi=pinorm(thetiii-theta_constr0(i)) + if (difi.gt.theta_drange(i)) then + difi=difi-theta_drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else + difi=0.0 + endif +C if (energy_dec) then +C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", +C & i,itheta,rad2deg*thetiii, +C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), +C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, +C & gloc(itheta+nphi-2,icg) +C endif enddo return end @@ -3540,9 +5182,9 @@ C ALPHA and OMEGA. c write (iout,'(a)') 'ESC' do i=loc_start,loc_end it=itype(i) - if (it.eq.21) cycle + if (it.eq.ntyp1) cycle if (it.eq.10) goto 1 - nlobit=nlob(it) + nlobit=nlob(iabs(it)) c print *,'i=',i,' it=',it,' nlobit=',nlobit c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad theti=theta(i+1)-pipol @@ -3697,7 +5339,7 @@ C Compute the contribution to SC energy and derivatives do iii=-1,1 do j=1,nlobit - expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) cd print *,'j=',j,' expfac=',expfac escloc_i=escloc_i+expfac do k=1,3 @@ -3778,7 +5420,7 @@ 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) + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin) escloc_i=escloc_i+expfac do k=1,2 dersc(k)=dersc(k)+Ax(k,j)*expfac @@ -3833,7 +5475,7 @@ C delta=0.02d0*pi escloc=0.0D0 do i=loc_start,loc_end - if (itype(i).eq.21) cycle + if (itype(i).eq.ntyp1) cycle costtab(i+1) =dcos(theta(i+1)) sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) @@ -3842,7 +5484,7 @@ C cosfac=dsqrt(cosfac2) sinfac2=0.5d0/(1.0d0-costtab(i+1)) sinfac=dsqrt(sinfac2) - it=itype(i) + it=iabs(itype(i)) if (it.eq.10) goto 1 c C Compute the axes of tghe local cartesian coordinates system; store in @@ -3860,7 +5502,7 @@ C & dc_norm(3,i+nres) y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac enddo do j = 1,3 - z_prime(j) = -uz(j,i-1) + z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i))) enddo c write (2,*) "i",i c write (2,*) "x_prime",(x_prime(j),j=1,3) @@ -3892,7 +5534,7 @@ C C Compute the energy of the ith side cbain C c write (2,*) "xx",xx," yy",yy," zz",zz - it=itype(i) + it=iabs(itype(i)) do j = 1,65 x(j) = sc_parmin(j,it) enddo @@ -3900,7 +5542,8 @@ c write (2,*) "xx",xx," yy",yy," zz",zz Cc diagnostics - remove later xx1 = dcos(alph(2)) yy1 = dsin(alph(2))*dcos(omeg(2)) - zz1 = -dsin(alph(2))*dsin(omeg(2)) +c zz1 = -dsin(alph(2))*dsin(omeg(2)) + zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2)) write(2,'(3f8.1,3f9.3,1x,3f9.3)') & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, & xx1,yy1,zz1 @@ -4071,8 +5714,10 @@ c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) 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) + dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) + & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) + dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) + & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) enddo dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) @@ -4224,8 +5869,8 @@ C Set lprn=.true. for debugging c lprn=.true. etors=0.0D0 do i=iphi_start,iphi_end - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21) cycle + if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1) cycle itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) phii=phi(i) @@ -4273,12 +5918,12 @@ c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) 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 + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 else if (difi.lt.-drange(i)) then difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 endif ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) @@ -4309,17 +5954,23 @@ C Set lprn=.true. for debugging c lprn=.true. etors=0.0D0 do i=iphi_start,iphi_end - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21) cycle + if (i.le.2) cycle + if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215 + if (iabs(itype(i)).eq.20) then + iblock=2 + else + iblock=1 + endif itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) phii=phi(i) gloci=0.0D0 C Regular cosine and sine terms - do j=1,nterm(itori,itori1) - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) + do j=1,nterm(itori,itori1,iblock) + v1ij=v1(j,itori,itori1,iblock) + v2ij=v2(j,itori,itori1,iblock) cosphi=dcos(j*phii) sinphi=dsin(j*phii) etors=etors+v1ij*cosphi+v2ij*sinphi @@ -4332,7 +5983,7 @@ 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) + do j=1,nlor(itori,itori1,iblock) vl1ij=vlor1(j,itori,itori1) vl2ij=vlor2(j,itori,itori1) vl3ij=vlor3(j,itori,itori1) @@ -4343,11 +5994,11 @@ C gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom enddo C Subtract the constant term - etors=etors-v0(itori,itori1) + etors=etors-v0(itori,itori1,iblock) if (lprn) & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + & (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6) gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) 1215 continue @@ -4361,14 +6012,14 @@ c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) edihi=0.0d0 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 - edihi=0.25d0*ftors*difi**4 + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + edihi=0.25d0*ftors(i)*difi**4 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 - edihi=0.25d0*ftors*difi**4 + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + edihi=0.25d0*ftors(i)*difi**4 else difi=0.0d0 endif @@ -4403,8 +6054,10 @@ C Set lprn=.true. for debugging c lprn=.true. etors_d=0.0D0 do i=iphi_start,iphi_end-1 - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle + if (i.le.3) cycle + if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or. + & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or. + & (itype(i+1).eq.ntyp1)) cycle if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0) & goto 1215 itori=itortyp(itype(i-2)) @@ -4414,12 +6067,14 @@ c lprn=.true. phii1=phi(i+1) gloci1=0.0D0 gloci2=0.0D0 + iblock=1 + if (iabs(itype(i+1)).eq.20) iblock=2 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) + do j=1,ntermd_1(itori,itori1,itori2,iblock) + v1cij=v1c(1,j,itori,itori1,itori2,iblock) + v1sij=v1s(1,j,itori,itori1,itori2,iblock) + v2cij=v1c(2,j,itori,itori1,itori2,iblock) + v2sij=v1s(2,j,itori,itori1,itori2,iblock) cosphi1=dcos(j*phii) sinphi1=dsin(j*phii) cosphi2=dcos(j*phii1) @@ -4429,12 +6084,12 @@ C Regular cosine and sine terms gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) enddo - do k=2,ntermd_2(itori,itori1,itori2) + do k=2,ntermd_2(itori,itori1,itori2,iblock) 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) + v1cdij = v2c(k,l,itori,itori1,itori2,iblock) + v2cdij = v2c(l,k,itori,itori1,itori2,iblock) + v1sdij = v2s(k,l,itori,itori1,itori2,iblock) + v2sdij = v2s(l,k,itori,itori1,itori2,iblock) cosphi1p2=dcos(l*phii+(k-l)*phii1) cosphi1m2=dcos(l*phii-(k-l)*phii1) sinphi1p2=dsin(l*phii+(k-l)*phii1) @@ -4484,7 +6139,7 @@ c lprn=.true. c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor esccor=0.0D0 do i=itau_start,itau_end - if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1) cycle + if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle esccor_ii=0.0D0 isccori=isccortyp(itype(i-2)) isccori1=isccortyp(itype(i-1)) @@ -4658,9 +6313,9 @@ c------------------------------------------------------------------------------ integer dimen1,dimen2,atom,indx double precision buffer(dimen1,dimen2) double precision zapas - common /contacts_hb/ zapas(3,20,maxres,7), - & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), - & num_cont_hb(maxres),jcont_hb(20,maxres) + common /contacts_hb/ zapas(3,ntyp,maxres,7), + & facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres), + & num_cont_hb(maxres),jcont_hb(ntyp,maxres) num_kont=buffer(1,indx+26) num_kont_old=num_cont_hb(atom) num_cont_hb(atom)=num_kont+num_kont_old @@ -5113,6 +6768,8 @@ c------------------------------------------------------------------------------ include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.SHIELD' + double precision gx(3),gx1(3) logical lprn lprn=.false. @@ -5170,7 +6827,85 @@ C Calculate multi-body contributions to the gradient. & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) enddo - enddo + enddo + if (shield_mode.gt.0) then + j=ees0plist(jj,i) + l=ees0plist(kk,k) +C print *,i,j,fac_shield(i),fac_shield(j), +C &fac_shield(k),fac_shield(l) + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then + do ilist=1,ishield_list(i) + iresshield=shield_list(ilist,i) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + &+rlocshield + enddo + enddo + do ilist=1,ishield_list(j) + iresshield=shield_list(ilist,j) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo + do ilist=1,ishield_list(k) + iresshield=shield_list(ilist,k) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo + do ilist=1,ishield_list(l) + iresshield=shield_list(ilist,l) + do m=1,3 + rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l) +C & *2.0 + gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ + & rlocshield + & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l) + gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) + & +rlocshield + enddo + enddo +C print *,gshieldx(m,iresshield) + do m=1,3 + gshieldc_ec(m,i)=gshieldc_ec(m,i)+ + & grad_shield(m,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,j)=gshieldc_ec(m,j)+ + & grad_shield(m,j)*ehbcorr/fac_shield(j) + gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+ + & grad_shield(m,i)*ehbcorr/fac_shield(i) + gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+ + & grad_shield(m,j)*ehbcorr/fac_shield(j) + + gshieldc_ec(m,k)=gshieldc_ec(m,k)+ + & grad_shield(m,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,l)=gshieldc_ec(m,l)+ + & grad_shield(m,l)*ehbcorr/fac_shield(l) + gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+ + & grad_shield(m,k)*ehbcorr/fac_shield(k) + gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+ + & grad_shield(m,l)*ehbcorr/fac_shield(l) + + enddo + endif + endif endif ehbcorr=ekont*ees return @@ -5193,7 +6928,11 @@ C--------------------------------------------------------------------------- & auxmat(2,2) iti1 = itortyp(itype(i+1)) if (j.lt.nres-1) then - itj1 = itortyp(itype(j+1)) + if (itype(j).le.ntyp) then + itj1 = itortyp(itype(j+1)) + else + itj1=ntortyp+1 + endif else itj1=ntortyp+1 endif @@ -5281,14 +7020,16 @@ cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return enddo if (l.eq.j+1) then C parallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then +c if (i.gt.1) then + if (i.gt.1 .and. itype(i).le.ntyp) 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 +c if (l.lt.nres-1) then + if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then itl1=itortyp(itype(l+1)) else itl1=ntortyp+1 @@ -5434,7 +7175,8 @@ C Calculate the Cartesian derivatives of the vectors. C End vectors else C Antiparallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then +c if (i.gt.1) then + if (i.gt.1 .and. itype(i).le.ntyp) then iti=itortyp(itype(i)) else iti=ntortyp+1 @@ -5442,7 +7184,8 @@ C Antiparallel orientation of the two CA-CA-CA frames. itk1=itortyp(itype(k+1)) itl=itortyp(itype(l)) itj=itortyp(itype(j)) - if (j.lt.nres-1) then +c if (j.lt.nres-1) then + if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then itj1=itortyp(itype(j+1)) else itj1=ntortyp+1 @@ -6600,14 +8343,16 @@ 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 +c if (j.lt.nres-1) then + if (j.lt.nres-1 .and. itype(j+1).le.ntyp) 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 +c if (l.lt.nres-1) then + if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then itl1=itortyp(itype(l+1)) else itl1=ntortyp+1 @@ -6720,13 +8465,15 @@ 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 +c if (j.lt.nres-1) then + if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then itj1=itortyp(itype(j+1)) else itj1=ntortyp+1 endif itk=itortyp(itype(k)) - if (k.lt.nres-1) then +c if (k.lt.nres-1) then + if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then itk1=itortyp(itype(k+1)) else itk1=ntortyp+1 @@ -7405,4 +9152,516 @@ C----------------------------------------------------------------------------- scalar=sc return end +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----------------------------------------------------------------------- +C----------------------------------------------------------------------- + double precision function sscagrad(r) + double precision r,gamm + include "COMMON.SPLITELE" + if(r.lt.r_cut-rlamb) then + sscagrad=0.0d0 + else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then + gamm=(r-(r_cut-rlamb))/rlamb + sscagrad=gamm*(6*gamm-6.0d0)/rlamb + else + sscagrad=0.0d0 + endif + return + end +C----------------------------------------------------------------------- +C first for shielding is setting of function of side-chains + subroutine set_shield_fac2 + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +Cif there two consequtive dummy atoms there is no peptide group between them +C the line below has to be changed for FGPROC>1 + VolumeTotal=0.0 + do k=1,nres + if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle + dist_pep_side=0.0 + dist_side_calf=0.0 + do j=1,3 +C first lets set vector conecting the ithe side-chain with kth side-chain + pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 +C pep_side(j)=2.0d0 +C and vector conecting the side-chain with its proper calfa + side_calf(j)=c(j,k+nres)-c(j,k) +C side_calf(j)=2.0d0 + pept_group(j)=c(j,i)-c(j,i+1) +C lets have their lenght + dist_pep_side=pep_side(j)**2+dist_pep_side + dist_side_calf=dist_side_calf+side_calf(j)**2 + dist_pept_group=dist_pept_group+pept_group(j)**2 + enddo + dist_pep_side=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(dist_side_calf) + do j=1,3 + pep_side_norm(j)=pep_side(j)/dist_pep_side + side_calf_norm(j)=dist_side_calf + enddo +C now sscale fraction + sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +C If we reach here it means that this side chain reaches the shielding sphere +C Lets add him to the list for gradient + ishield_list(i)=ishield_list(i)+1 +C ishield_list is a list of non 0 side-chain that contribute to factor gradient +C this list is essential otherwise problem would be O3 + shield_list(ishield_list(i),i)=k +C Lets have the sscale value + if (sh_frac_dist.gt.1.0) then + scale_fac_dist=1.0d0 + do j=1,3 + sh_frac_dist_grad(j)=0.0d0 + enddo + else + scale_fac_dist=-sh_frac_dist*sh_frac_dist + & *(2.0d0*sh_frac_dist-3.0d0) + fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) + & /dist_pep_side/buff_shield*0.5d0 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + do j=1,3 + sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) +C sh_frac_dist_grad(j)=0.0d0 +C scale_fac_dist=1.0d0 +C print *,"jestem",scale_fac_dist,fac_help_scale, +C & sh_frac_dist_grad(j) + enddo + endif +C this is what is now we have the distance scaling now volume... + short=short_r_sidechain(itype(k)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2) + sinthet=short/dist_pep_side*costhet +C now costhet_grad +C costhet=0.6d0 +C sinthet=0.8 + costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4 +C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet +C & -short/dist_pep_side**2/costhet) +C costhet_fac=0.0d0 + do j=1,3 + costhet_grad(j)=costhet_fac*pep_side(j) + enddo +C remember for the final gradient multiply costhet_grad(j) +C for side_chain by factor -2 ! +C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 +C pep_side0pept_group is vector multiplication + pep_side0pept_group=0.0d0 + do j=1,3 + pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) + enddo + cosalfa=(pep_side0pept_group/ + & (dist_pep_side*dist_side_calf)) + fac_alfa_sin=1.0d0-cosalfa**2 + fac_alfa_sin=dsqrt(fac_alfa_sin) + rkprim=fac_alfa_sin*(long-short)+short +C rkprim=short + +C now costhet_grad + cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2) +C cosphi=0.6 + cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4 + sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ + & dist_pep_side**2) +C sinphi=0.8 + do j=1,3 + cosphi_grad_long(j)=cosphi_fac*pep_side(j) + &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa/ + &((dist_pep_side*dist_side_calf))* + &((side_calf(j))-cosalfa* + &((pep_side(j)/dist_pep_side)*dist_side_calf)) +C cosphi_grad_long(j)=0.0d0 + cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa + &/((dist_pep_side*dist_side_calf))* + &(pep_side(j)- + &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) +C cosphi_grad_loc(j)=0.0d0 + enddo +C print *,sinphi,sinthet + VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) + & /VSolvSphere_div +C & *wshield +C now the gradient... + do j=1,3 + grad_shield(j,i)=grad_shield(j,i) +C gradient po skalowaniu + & +(sh_frac_dist_grad(j)*VofOverlap +C gradient po costhet + & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* + &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( + & sinphi/sinthet*costhet*costhet_grad(j) + & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) + & )*wshield +C grad_shield_side is Cbeta sidechain gradient + grad_shield_side(j,ishield_list(i),i)= + & (sh_frac_dist_grad(j)*-2.0d0 + & *VofOverlap + & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* + &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( + & sinphi/sinthet*costhet*costhet_grad(j) + & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) + & )*wshield + + grad_shield_loc(j,ishield_list(i),i)= + & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* + &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*( + & sinthet/sinphi*cosphi*cosphi_grad_loc(j) + & )) + & *wshield + enddo + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield) +C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) + enddo + return + end +C first for shielding is setting of function of side-chains + subroutine set_shield_fac + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.SHIELD' + include 'COMMON.INTERACT' +C this is the squar root 77 devided by 81 the epislion in lipid (in protein) + double precision div77_81/0.974996043d0/, + &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) + +C the vector between center of side_chain and peptide group + double precision pep_side(3),long,side_calf(3), + &pept_group(3),costhet_grad(3),cosphi_grad_long(3), + &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) +C the line belowe needs to be changed for FGPROC>1 + do i=1,nres-1 + if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle + ishield_list(i)=0 +Cif there two consequtive dummy atoms there is no peptide group between them +C the line below has to be changed for FGPROC>1 + VolumeTotal=0.0 + do k=1,nres + if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle + dist_pep_side=0.0 + dist_side_calf=0.0 + do j=1,3 +C first lets set vector conecting the ithe side-chain with kth side-chain + pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 +C pep_side(j)=2.0d0 +C and vector conecting the side-chain with its proper calfa + side_calf(j)=c(j,k+nres)-c(j,k) +C side_calf(j)=2.0d0 + pept_group(j)=c(j,i)-c(j,i+1) +C lets have their lenght + dist_pep_side=pep_side(j)**2+dist_pep_side + dist_side_calf=dist_side_calf+side_calf(j)**2 + dist_pept_group=dist_pept_group+pept_group(j)**2 + enddo + dist_pep_side=dsqrt(dist_pep_side) + dist_pept_group=dsqrt(dist_pept_group) + dist_side_calf=dsqrt(dist_side_calf) + do j=1,3 + pep_side_norm(j)=pep_side(j)/dist_pep_side + side_calf_norm(j)=dist_side_calf + enddo +C now sscale fraction + sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield +C print *,buff_shield,"buff" +C now sscale + if (sh_frac_dist.le.0.0) cycle +C If we reach here it means that this side chain reaches the shielding sphere +C Lets add him to the list for gradient + ishield_list(i)=ishield_list(i)+1 +C ishield_list is a list of non 0 side-chain that contribute to factor gradient +C this list is essential otherwise problem would be O3 + shield_list(ishield_list(i),i)=k +C Lets have the sscale value + if (sh_frac_dist.gt.1.0) then + scale_fac_dist=1.0d0 + do j=1,3 + sh_frac_dist_grad(j)=0.0d0 + enddo + else + scale_fac_dist=-sh_frac_dist*sh_frac_dist + & *(2.0*sh_frac_dist-3.0d0) + fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2) + & /dist_pep_side/buff_shield*0.5 +C remember for the final gradient multiply sh_frac_dist_grad(j) +C for side_chain by factor -2 ! + do j=1,3 + sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) +C print *,"jestem",scale_fac_dist,fac_help_scale, +C & sh_frac_dist_grad(j) + enddo + endif +C if ((i.eq.3).and.(k.eq.2)) then +C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist +C & ,"TU" +C endif + +C this is what is now we have the distance scaling now volume... + short=short_r_sidechain(itype(k)) + long=long_r_sidechain(itype(k)) + costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2) +C now costhet_grad +C costhet=0.0d0 + costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4 +C costhet_fac=0.0d0 + do j=1,3 + costhet_grad(j)=costhet_fac*pep_side(j) + enddo +C remember for the final gradient multiply costhet_grad(j) +C for side_chain by factor -2 ! +C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 +C pep_side0pept_group is vector multiplication + pep_side0pept_group=0.0 + do j=1,3 + pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) + enddo + cosalfa=(pep_side0pept_group/ + & (dist_pep_side*dist_side_calf)) + fac_alfa_sin=1.0-cosalfa**2 + fac_alfa_sin=dsqrt(fac_alfa_sin) + rkprim=fac_alfa_sin*(long-short)+short +C now costhet_grad + cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2) + cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4 + + do j=1,3 + cosphi_grad_long(j)=cosphi_fac*pep_side(j) + &+cosphi**3*0.5/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa/ + &((dist_pep_side*dist_side_calf))* + &((side_calf(j))-cosalfa* + &((pep_side(j)/dist_pep_side)*dist_side_calf)) + + cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim) + &*(long-short)/fac_alfa_sin*cosalfa + &/((dist_pep_side*dist_side_calf))* + &(pep_side(j)- + &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) + enddo + + VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi) + & /VSolvSphere_div + & *wshield +C now the gradient... +C grad_shield is gradient of Calfa for peptide groups +C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist, +C & costhet,cosphi +C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group, +C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k) + do j=1,3 + grad_shield(j,i)=grad_shield(j,i) +C gradient po skalowaniu + & +(sh_frac_dist_grad(j) +C gradient po costhet + &-scale_fac_dist*costhet_grad(j)/(1.0-costhet) + &-scale_fac_dist*(cosphi_grad_long(j)) + &/(1.0-cosphi) )*div77_81 + &*VofOverlap +C grad_shield_side is Cbeta sidechain gradient + grad_shield_side(j,ishield_list(i),i)= + & (sh_frac_dist_grad(j)*-2.0d0 + & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet) + & +scale_fac_dist*(cosphi_grad_long(j)) + & *2.0d0/(1.0-cosphi)) + & *div77_81*VofOverlap + + grad_shield_loc(j,ishield_list(i),i)= + & scale_fac_dist*cosphi_grad_loc(j) + & *2.0d0/(1.0-cosphi) + & *div77_81*VofOverlap + enddo + VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist + enddo + fac_shield(i)=VolumeTotal*div77_81+div4_81 +C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) + enddo + return + end +C-------------------------------------------------------------------------- +C----------------------------------------------------------------------- + double precision function sscalelip(r) + double precision r,gamm + include "COMMON.SPLITELE" +C if(r.lt.r_cut-rlamb) then +C sscale=1.0d0 +C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then +C gamm=(r-(r_cut-rlamb))/rlamb + sscalelip=1.0d0+r*r*(2*r-3.0d0) +C else +C sscale=0d0 +C endif + return + end +C----------------------------------------------------------------------- + double precision function sscagradlip(r) + double precision r,gamm + include "COMMON.SPLITELE" +C if(r.lt.r_cut-rlamb) then +C sscagrad=0.0d0 +C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then +C gamm=(r-(r_cut-rlamb))/rlamb + sscagradlip=r*(6*r-6.0d0) +C else +C sscagrad=0.0d0 +C endif + return + end + +C----------------------------------------------------------------------- +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + subroutine Eliptransfer(eliptran) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.LOCAL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' + include 'COMMON.CONTROL' + include 'COMMON.SPLITELE' + include 'COMMON.SBRIDGE' +C this is done by Adasko +C print *,"wchodze" +C structure of box: +C water +C--bordliptop-- buffore starts +C--bufliptop--- here true lipid starts +C lipid +C--buflipbot--- lipid ends buffore starts +C--bordlipbot--buffore ends + eliptran=0.0 + write(iout,*) "I am in?" + do i=1,nres +C do i=1,1 + if (itype(i).eq.ntyp1) cycle + positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize)) + if (positi.le.0) positi=positi+boxzsize +C print *,i +C first for peptide groups +c for each residue check if it is in lipid or lipid water border area + if ((positi.gt.bordlipbot) + &.and.(positi.lt.bordliptop)) then +C the energy transfer exist + if (positi.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslip=sscalelip(fracinbuf) + ssgradlip=-sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*pepliptran + gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 + gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 +C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran + elseif (positi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) + sslip=sscalelip(fracinbuf) + ssgradlip=sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*pepliptran + gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 + gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 +C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran +C print *, "doing sscalefor top part" +C print *,i,sslip,fracinbuf,ssgradlip + else + eliptran=eliptran+pepliptran +C print *,"I am in true lipid" + endif +C else +C eliptran=elpitran+0.0 ! I am in water + endif + enddo +C print *, "nic nie bylo w lipidzie?" +C now multiply all by the peptide group transfer factor +C eliptran=eliptran*pepliptran +C now the same for side chains +CV do i=1,1 + do i=1,nres + if (itype(i).eq.ntyp1) cycle + positi=(mod(c(3,i+nres),boxzsize)) + if (positi.le.0) positi=positi+boxzsize +C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop +c for each residue check if it is in lipid or lipid water border area +C respos=mod(c(3,i+nres),boxzsize) +C print *,positi,bordlipbot,buflipbot + if ((positi.gt.bordlipbot) + & .and.(positi.lt.bordliptop)) then +C the energy transfer exist + if (positi.lt.buflipbot) then + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslip=sscalelip(fracinbuf) + ssgradlip=-sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*liptranene(itype(i)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +C print *,"doing sccale for lower part" + elseif (positi.gt.bufliptop) then + fracinbuf=1.0d0- + &((bordliptop-positi)/lipbufthick) + sslip=sscalelip(fracinbuf) + ssgradlip=sscagradlip(fracinbuf)/lipbufthick + eliptran=eliptran+sslip*liptranene(itype(i)) + gliptranx(3,i)=gliptranx(3,i) + &+ssgradlip*liptranene(itype(i)) + gliptranc(3,i-1)= gliptranc(3,i-1) + &+ssgradlip*liptranene(itype(i)) +C print *, "doing sscalefor top part",sslip,fracinbuf + else + eliptran=eliptran+liptranene(itype(i)) +C print *,"I am in true lipid" + endif + endif ! if in lipid or buffor +C else +C eliptran=elpitran+0.0 ! I am in water + enddo + return + end +C------------------------------------------------------------------------------------- diff --git a/source/cluster/wham/src-M/geomout.F b/source/cluster/wham/src-M/geomout.F index 5a61305..4ef656f 100644 --- a/source/cluster/wham/src-M/geomout.F +++ b/source/cluster/wham/src-M/geomout.F @@ -19,7 +19,7 @@ ires=0 do i=nnt,nct iti=itype(i) - if (iti.eq.21) then + if (iti.eq.ntyp1) then ichain=ichain+1 ires=0 write (ipdb,'(a)') 'TER' @@ -38,12 +38,12 @@ enddo write (ipdb,'(a)') 'TER' do i=nnt,nct-1 - if (itype(i).eq.21) cycle - if (itype(i).eq.10 .and. itype(i+1).ne.21) then + if (itype(i).eq.ntyp1) cycle + if (itype(i).eq.10 .and. itype(i+1).ne.ntyp1) then write (ipdb,30) ica(i),ica(i+1) - else if (itype(i).ne.10 .and. itype(i+1).ne.21) then + else if (itype(i).ne.10 .and. itype(i+1).ne.ntyp1) then write (ipdb,30) ica(i),ica(i+1),ica(i)+1 - else if (itype(i).ne.10 .and. itype(i+1).eq.21) then + else if (itype(i).ne.10 .and. itype(i+1).eq.ntyp1) then write (ipdb,30) ica(i),ica(i)+1 endif enddo diff --git a/source/cluster/wham/src-M/gnmr1.f b/source/cluster/wham/src-M/gnmr1.f index 905e746..2357e6d 100644 --- a/source/cluster/wham/src-M/gnmr1.f +++ b/source/cluster/wham/src-M/gnmr1.f @@ -41,3 +41,34 @@ c------------------------------------------------------------------------------- return end c--------------------------------------------------------------------------------- +c--------------------------------------------------------------------------------- + double precision function rlornmr1(y,ymin,ymax,sigma) + implicit none + double precision y,ymin,ymax,sigma + double precision wykl /4.0d0/ + if (y.lt.ymin) then + rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl) + else if (y.gt.ymax) then + rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl) + else + rlornmr1=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function rlornmr1prim(y,ymin,ymax,sigma) + implicit none + double precision y,ymin,ymax,sigma + double precision wykl /4.0d0/ + if (y.lt.ymin) then + rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ + & ((ymin-y)**wykl+sigma**wykl)**2 + else if (y.gt.ymax) then + rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ + & ((y-ymax)**wykl+sigma**wykl)**2 + else + rlornmr1prim=0.0d0 + endif + return + end + diff --git a/source/cluster/wham/src-M/include_unres/COMMON.CALC b/source/cluster/wham/src-M/include_unres/COMMON.CALC index 67b4bb9..bf255c9 100644 --- a/source/cluster/wham/src-M/include_unres/COMMON.CALC +++ b/source/cluster/wham/src-M/include_unres/COMMON.CALC @@ -5,11 +5,11 @@ & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, - & dsci_inv,dscj_inv,gg + & dsci_inv,dscj_inv,gg,gg_lipi,gg_lipj common /calc/ erij(3),rij,xj,yj,zj,dxi,dyi,dzi,dxj,dyj,dzj, & chi1,chi2,chi12,chip1,chip2,chip12,alf1,alf2,alf12,om1,om2,om12, & om1om2,chiom1,chiom2,chiom12,chipom1,chipom2,chipom12,eps1, & faceps1,faceps1_inv,eps1_om12,facsig,sigsq,sigsq_om1,sigsq_om2, & sigsq_om12,facp,facp_inv,facp1,eps2rt,eps2rt_om1,eps2rt_om2, & eps2rt_om12,eps3rt,eom1,eom2,eom12,evdwij,eps2der,eps3der,sigder, - & dsci_inv,dscj_inv,gg(3),i,j + & dsci_inv,dscj_inv,gg(3),gg_lipi(3),gg_lipj(3),i,j diff --git a/source/cluster/wham/src-M/include_unres/COMMON.INTERACT b/source/cluster/wham/src-M/include_unres/COMMON.INTERACT index d4a58b5..1c0b8db 100644 --- a/source/cluster/wham/src-M/include_unres/COMMON.INTERACT +++ b/source/cluster/wham/src-M/include_unres/COMMON.INTERACT @@ -1,8 +1,10 @@ - double precision aa,bb,augm,aad,bad,app,bpp,ael6,ael3 + double precision aa_aq,bb_aq,augm,aad,bad,app,bpp,ael6,ael3, + & aa_lip,bb_lip integer nnt,nct,nint_gr,istart,iend,itype,itel,itypro,ielstart, & ielend,nscp_gr,iscpstart,iscpend,iatsc_s,iatsc_e,iatel_s, & iatel_e,iatscp_s,iatscp_e,ispp,iscp,expon,expon2 - common /interact/aa(ntyp,ntyp),bb(ntyp,ntyp),augm(ntyp,ntyp), + common /interact/aa_aq(ntyp,ntyp),bb_aq(ntyp,ntyp), + & augm(ntyp,ntyp),aa_lip(ntyp,ntyp),bb_lip(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, @@ -10,17 +12,25 @@ & iscpstart(maxres,maxint_gr),iscpend(maxres,maxint_gr), & iatsc_s,iatsc_e,iatel_s,iatel_e,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,chip0,alp,signa0, + double precision eps,epslip,sigma,sigmaii,rs0,chi,chip,chip0, + & alp,signa0, & sigii,sigma0,rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp, & eps_orig - common /body/eps(ntyp,ntyp),sigma(ntyp,ntyp),sigmaii(ntyp,ntyp), + common /body/eps(ntyp,ntyp),epslip(ntyp,ntyp), + & sigma(ntyp,ntyp),sigmaii(ntyp,ntyp), & rs0(ntyp,ntyp),chi(ntyp,ntyp),chip(ntyp),chip0(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),eps_orig(ntyp,ntyp) + & eps_scp(ntyp,2),rscp(ntyp,2),eps_orig(ntyp,ntyp) c 12/5/03 modified 09/18/03 Bond stretching parameters. double precision vbldp0,vbldsc0,akp,aksc,abond0,distchainmax + &,vbldpDUM integer nbondterm common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp, & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp), & distchainmax,nbondterm(ntyp) + &,vbldpDUM +C 01/29/15 Lipidic parameters + double precision pepliptran,liptranene + common /lipid/ pepliptran,liptranene(ntyp) + diff --git a/source/cluster/wham/src-M/include_unres/COMMON.LOCAL b/source/cluster/wham/src-M/include_unres/COMMON.LOCAL index 1d0f3aa..138a0b9 100644 --- a/source/cluster/wham/src-M/include_unres/COMMON.LOCAL +++ b/source/cluster/wham/src-M/include_unres/COMMON.LOCAL @@ -4,23 +4,34 @@ integer nlob,loc_start,loc_end,ithet_start,ithet_end, & iphi_start,iphi_end C Parameters of the virtual-bond-angle probability distribution - common /thetas/ a0thet(ntyp),athet(2,ntyp),bthet(2,ntyp), - & polthet(0:3,ntyp),gthet(3,ntyp),theta0(ntyp),sig0(ntyp), - & sigc0(ntyp) + common /thetas/ a0thet(-ntyp:ntyp),athet(2,-ntyp:ntyp), + & bthet(2,-ntyp:ntyp), + & polthet(0:3,-ntyp:ntyp),gthet(3,-ntyp:ntyp),theta0(-ntyp:ntyp), + & sig0(-ntyp:ntyp), + & sigc0(-ntyp:ntyp) C Parameters of ab initio-derived potential of virtual-bond-angle bending integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, - & ithetyp(ntyp1),nntheterm - double precision aa0thet(maxthetyp1,maxthetyp1,maxthetyp1), - & aathet(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1), - & bbthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ccthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ddthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & eethet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ffthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1), - & ggthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1) - common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet, + & ithetyp(-ntyp:ntyp1),nntheterm +C Parameters of ab initio-derived potential of virtual-bond-angle bending + integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, + & ithetyp(-ntyp1:ntyp1),nntheterm + double precision aa0thet(-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & aathet(maxtheterm,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & bbthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ccthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ddthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & eethet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ffthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2), + & ggthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2) + common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet, & ffthet, & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, & ndouble,nntheterm diff --git a/source/cluster/wham/src-M/include_unres/COMMON.NAMES b/source/cluster/wham/src-M/include_unres/COMMON.NAMES deleted file mode 100644 index a266339..0000000 --- a/source/cluster/wham/src-M/include_unres/COMMON.NAMES +++ /dev/null @@ -1,7 +0,0 @@ - character*3 restyp - character*1 onelet - common /names/ restyp(ntyp+1),onelet(ntyp+1) - character*10 ename,wname - integer nprint_ene,print_order - common /namterm/ ename(max_ene),wname(max_ene),nprint_ene, - & print_order(max_ene) diff --git a/source/cluster/wham/src-M/include_unres/COMMON.SCCOR b/source/cluster/wham/src-M/include_unres/COMMON.SCCOR index 5217de7..fffe09b 100644 --- a/source/cluster/wham/src-M/include_unres/COMMON.SCCOR +++ b/source/cluster/wham/src-M/include_unres/COMMON.SCCOR @@ -1,6 +1,6 @@ C Parameters of the SCCOR term double precision v1sccor,v2sccor integer nterm_sccor - common/torsion/v1sccor(maxterm_sccor,20,20), - & v2sccor(maxterm_sccor,20,20), + common/torsion/v1sccor(maxterm_sccor,ntyp,ntyp), + & v2sccor(maxterm_sccor,ntyp,ntyp), & nterm_sccor diff --git a/source/cluster/wham/src-M/include_unres/COMMON.SCROT b/source/cluster/wham/src-M/include_unres/COMMON.SCROT index 2da7b8f..a352775 100644 --- a/source/cluster/wham/src-M/include_unres/COMMON.SCROT +++ b/source/cluster/wham/src-M/include_unres/COMMON.SCROT @@ -1,3 +1,3 @@ C Parameters of the SC rotamers (local) term double precision sc_parmin - common/scrot/sc_parmin(maxsccoef,20) + common/scrot/sc_parmin(maxsccoef,ntyp) diff --git a/source/cluster/wham/src-M/include_unres/COMMON.SETUP b/source/cluster/wham/src-M/include_unres/COMMON.SETUP new file mode 100644 index 0000000..5039116 --- /dev/null +++ b/source/cluster/wham/src-M/include_unres/COMMON.SETUP @@ -0,0 +1,21 @@ + integer king,idint,idreal,idchar,is_done + parameter (king=0,idint=1105,idreal=1729,idchar=1597,is_done=1) + integer me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,kolor, + & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1),CG_COMM,FG_COMM, + & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp(0:maxprocs-1), + & kolor1,key1,nfgtasks1,MyRank, + & max_gs_size + logical yourjob, finished, cgdone + common/setup/me,MyRank,cg_rank,fg_rank,fg_rank1,nodes,Nprocs, + & nfgtasks,nfgtasks1, + & max_gs_size,kolor,koniec,WhatsUp,ifinish,CG_COMM,FG_COMM, + & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp + integer MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, + & MPI_THET,MPI_GAM, + & MPI_ROTAT1(0:1),MPI_ROTAT2(0:1),MPI_ROTAT_OLD(0:1), + & MPI_PRECOMP11(0:1),MPI_PRECOMP12(0:1),MPI_PRECOMP22(0:1), + & MPI_PRECOMP23(0:1) + common /types/ MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, + & MPI_THET,MPI_GAM, + & MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,MPI_PRECOMP11,MPI_PRECOMP12, + & MPI_PRECOMP22,MPI_PRECOMP23 diff --git a/source/cluster/wham/src-M/include_unres/COMMON.SPLITELE b/source/cluster/wham/src-M/include_unres/COMMON.SPLITELE new file mode 100644 index 0000000..a2f0447 --- /dev/null +++ b/source/cluster/wham/src-M/include_unres/COMMON.SPLITELE @@ -0,0 +1,2 @@ + double precision r_cut,rlamb + common /splitele/ r_cut,rlamb diff --git a/source/cluster/wham/src-M/include_unres/COMMON.TORCNSTR b/source/cluster/wham/src-M/include_unres/COMMON.TORCNSTR index f8fc3a1..845c44d 100644 --- a/source/cluster/wham/src-M/include_unres/COMMON.TORCNSTR +++ b/source/cluster/wham/src-M/include_unres/COMMON.TORCNSTR @@ -1,5 +1,14 @@ - integer ndih_constr,idih_constr(maxdih_constr) + integer ndih_constr,idih_constr(maxdih_constr),ntheta_constr, + & itheta_constr(maxdih_constr) integer ndih_nconstr,idih_nconstr(maxdih_constr) - double precision phi0(maxdih_constr),drange(maxdih_constr),ftors - common /torcnstr/ phi0,drange,ftors,ndih_constr,idih_constr, - & ndih_nconstr,idih_nconstr + integer idihconstr_start,idihconstr_end,ithetaconstr_start, + & ithetaconstr_end + double precision phi0(maxdih_constr),drange(maxdih_constr), + & ftors(maxdih_constr),theta_constr0(maxdih_constr), + & theta_drange(maxdih_constr),for_thet_constr(maxdih_constr) + common /torcnstr/ phi0,drange,ftors,theta_constr0,theta_drange, + & for_thet_constr, + & ndih_constr,idih_constr, + & ndih_nconstr,idih_nconstr,idihconstr_start,idihconstr_end, + & ntheta_constr,itheta_constr,ithetaconstr_start, + & ithetaconstr_end diff --git a/source/cluster/wham/src-M/include_unres/COMMON.WEIGHTS b/source/cluster/wham/src-M/include_unres/COMMON.WEIGHTS index d7e6e23..86f8d7a 100644 --- a/source/cluster/wham/src-M/include_unres/COMMON.WEIGHTS +++ b/source/cluster/wham/src-M/include_unres/COMMON.WEIGHTS @@ -10,13 +10,13 @@ & epp_low(2,2),epp_up(2,2),rpp_low(2,2),rpp_up(2,2), & elpp6_low(2,2),elpp6_up(2,2),elpp3_low(2,2),elpp3_up(2,2), & b_low(13,3),b_up(13,3),x_up(max_paropt),x_low(max_paropt), - & epscp_low(0:20,2),epscp_up(0:20,2),rscp_low(0:20,2), - & rscp_up(0:20,2),epss_low(ntyp),epss_up(ntyp),epsp_low(nntyp), + & epscp_low(0:ntyp,2),epscp_up(0:ntyp,2),rscp_low(0:ntyp,2), + & rscp_up(0:ntyp,2),epss_low(ntyp),epss_up(ntyp),epsp_low(nntyp), & epsp_up(nntyp), & xm(max_paropt,0:maxprot),xm1(max_paropt,0:maxprot), & xm2(max_paropt,0:maxprot), & imask(max_ene),nsingle_sc,npair_sc,ityp_ssc(ntyp), & ityp_psc(2,nntyp),mask_elec(2,2,4), & mask_fourier(13,3), - & mask_scp(0:20,2,2),mod_other_params,mod_fourier(0:3), + & mask_scp(0:ntyp,2,2),mod_other_params,mod_fourier(0:3), & mod_elec,mod_scp,mod_side,indz(maxbatch+1,maxprot),iw(max_ene) diff --git a/source/cluster/wham/src-M/initialize.f b/source/cluster/wham/src-M/initialize.f index 751c20e..12ea156 100644 --- a/source/cluster/wham/src-M/initialize.f +++ b/source/cluster/wham/src-M/initialize.f @@ -83,10 +83,17 @@ c------------------------------------------------------------------------- include 'COMMON.NAMES' include 'COMMON.FFIELD' data restyp / + &'DD','DAU','DAI','DDB','DSM','DPR','DLY','DAR','DHI','DAS','DGL', + & 'DSG','DGN','DSN','DTH', + &'DYY','DAL','DTY','DTR','DVA','DLE','DIL','DPN','MED','DCY','ZER', &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR', - &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/ + &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','SME','DBZ', + &'AIB','ABU','D'/ data onelet / + &'z','z','z','z','z','p','k','r','h','d','e','n','q','s','t','g', + &'a','y','w','v','l','i','f','m','c','x', &'C','M','F','I','L','V','W','Y','A','G','T', - &'S','Q','N','E','D','H','R','K','P','X'/ + &'S','Q','N','E','D','H','R','K','P','z','z','z','z','X'/ + data potname /'LJ','LJK','BP','GB','GBV'/ data potname /'LJ','LJK','BP','GB','GBV'/ end diff --git a/source/cluster/wham/src-M/initialize_p.F b/source/cluster/wham/src-M/initialize_p.F index c17f282..8b01a36 100644 --- a/source/cluster/wham/src-M/initialize_p.F +++ b/source/cluster/wham/src-M/initialize_p.F @@ -58,6 +58,7 @@ C ibond=28 isccor=29 jrms=30 + iliptran=60 C C Set default weights of the energy terms. C @@ -84,8 +85,10 @@ C enddo do i=1,ntyp do j=1,ntyp - aa(i,j)=0.0D0 - bb(i,j)=0.0D0 + aa_aq(i,j)=0.0D0 + bb_aq(i,j)=0.0D0 + aa_lip(i,j)=0.0D0 + bb_lip(i,j)=0.0D0 augm(i,j)=0.0D0 sigma(i,j)=0.0D0 r0(i,j)=0.0D0 @@ -101,8 +104,12 @@ C rr0(i)=0.0D0 a0thet(i)=0.0D0 do j=1,2 - athet(j,i)=0.0D0 - bthet(j,i)=0.0D0 + do ichir1=-1,1 + do ichir2=-1,1 + athet(j,i,ichir1,ichir2)=0.0D0 + bthet(j,i,ichir1,ichir2)=0.0D0 + enddo + enddo enddo do j=0,3 polthet(j,i)=0.0D0 @@ -128,15 +135,37 @@ C enddo nlob(ntyp1)=0 dsc(ntyp1)=0.0D0 - do i=1,maxtor + do i=-maxtor,maxtor itortyp(i)=0 - do j=1,maxtor - do k=1,maxterm - v1(k,j,i)=0.0D0 - v2(k,j,i)=0.0D0 - enddo - enddo + do iblock=1,2 + do j=-maxtor,maxtor + do k=1,maxterm + v1(k,j,i,iblock)=0.0D0 + v2(k,j,i,iblock)=0.0D0 + enddo + enddo + enddo enddo + do iblock=1,2 + do i=-maxtor,maxtor + do j=-maxtor,maxtor + do k=-maxtor,maxtor + do l=1,maxtermd_1 + v1c(1,l,i,j,k,iblock)=0.0D0 + v1s(1,l,i,j,k,iblock)=0.0D0 + v1c(2,l,i,j,k,iblock)=0.0D0 + v1s(2,l,i,j,k,iblock)=0.0D0 + enddo !l + do l=1,maxtermd_2 + do m=1,maxtermd_2 + v2c(m,l,i,j,k,iblock)=0.0D0 + v2s(m,l,i,j,k,iblock)=0.0D0 + enddo !m + enddo !l + enddo !k + enddo !j + enddo !i + enddo !iblock do i=1,maxres itype(i)=0 itel(i)=0 @@ -214,24 +243,32 @@ c------------------------------------------------------------------------- include 'COMMON.NAMES' include 'COMMON.FFIELD' data restyp / + &'DD','DAU','DAI','DDB','DSM','DPR','DLY','DAR','DHI','DAS','DGL', + & 'DSG','DGN','DSN','DTH', + &'DYY','DAL','DTY','DTR','DVA','DLE','DIL','DPN','MED','DCY','ZER', &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR', - &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/ + &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','SME','DBZ', + &'AIB','ABU','D'/ data onelet / + &'z','z','z','z','z','p','k','r','h','d','e','n','q','s','t','g', + &'a','y','w','v','l','i','f','m','c','x', &'C','M','F','I','L','V','W','Y','A','G','T', - &'S','Q','N','E','D','H','R','K','P','X'/ + &'S','Q','N','E','D','H','R','K','P','z','z','z','z','X'/ data potname /'LJ','LJK','BP','GB','GBV'/ data ename / & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ", & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ", & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB","EVDWPP", - & "ESTR","ESCCOR","EVDW2_14","","EVDW_T"/ + & "EVDW2_14","ESTR","ESCCOR","EDIHC","EVDW_T","ELIPTRAN", + & "EAFM","ETHETC"/ data wname / & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", - & "WHPB","WVDWPP","WBOND","WSCCOR","WSCP14","","WSC"/ - data nprint_ene /21/ + & "WHPB","WVDWPP","WSCP14","WBOND","WSCCOR","WDIHC","WSC", + & "WLIPTRAN","WAFM","WTHETC"/ + data nprint_ene /22/ data print_order /1,2,3,18,11,12,13,14,4,5,6,7,8,9,10,19, - & 16,15,17,20,21/ + & 16,15,17,20,21,24,22,23/ end c--------------------------------------------------------------------------- subroutine init_int_table @@ -288,6 +325,7 @@ cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', cd & (ihpb(i),jhpb(i),i=1,nss) do i=nnt,nct-1 scheck=.false. + if (dyn_ss) goto 10 do ii=1,nss if (ihpb(ii).eq.i+nres) then scheck=.true. @@ -341,7 +379,7 @@ cd write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj nint_gr(i)=1 istart(i,1)=i+1 iend(i,1)=nct - ind_scint=int_scint+nct-i + ind_scint=ind_scint+nct-i #endif endif #ifdef MPL @@ -564,3 +602,45 @@ cd & ' nhpb',nhpb,' link_start=',link_start, cd & ' link_end',link_end return end +c------------------------------------------------------------------------------ + subroutine homology_partition + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' +c include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.HOMRESTR' + write(iout,*)"homology_partition: lim_odl=",lim_odl, + & " lim_dih",lim_dih +#ifdef MPL + call int_bounds(lim_odl,link_start_homo,link_end_homo) + call int_bounds(lim_dih-nnt+1,idihconstr_start_homo, + & idihconstr_end_homo) + idihconstr_start_homo=idihconstr_start_homo+nnt-1 + idihconstr_end_homo=idihconstr_end_homo+nnt-1 + if (me.eq.king .or. .not. out1file) + & write (iout,*) 'Processor',fg_rank,' CG group',kolor, + & ' absolute rank',MyRank, + & ' lim_odl',lim_odl,' link_start=',link_start_homo, + & ' link_end',link_end_homo,' lim_dih',lim_dih, + & ' idihconstr_start_homo',idihconstr_start_homo, + & ' idihconstr_end_homo',idihconstr_end_homo +#else + link_start_homo=1 + link_end_homo=lim_odl + idihconstr_start_homo=nnt + idihconstr_end_homo=lim_dih + write (iout,*) + & ' lim_odl',lim_odl,' link_start=',link_start_homo, + & ' link_end',link_end_homo,' lim_dih',lim_dih, + & ' idihconstr_start_homo',idihconstr_start_homo, + & ' idihconstr_end_homo',idihconstr_end_homo +#endif + return + end diff --git a/source/cluster/wham/src-M/main_clust.F b/source/cluster/wham/src-M/main_clust.F index f01f859..a3f8094 100644 --- a/source/cluster/wham/src-M/main_clust.F +++ b/source/cluster/wham/src-M/main_clust.F @@ -29,12 +29,12 @@ C INTEGER IA(maxconf),IB(maxconf) INTEGER ICLASS(maxconf,maxconf-1),HVALS(maxconf-1) INTEGER IORDER(maxconf-1),HEIGHT(maxconf-1) - integer nn,ndis - real*4 DISNN + integer nn,ndis,scount_buf + real*4 DISNN, diss_buf(maxdist) DIMENSION NN(maxconf),DISNN(maxconf) LOGICAL FLAG(maxconf) integer i,j,k,l,m,n,len,lev,idum,ii,ind,ioffset,jj,icut,ncon, - & it,ncon_work,ind1 + & it,ncon_work,ind1,kkk, ijk double precision t1,t2,tcpu,difconf double precision varia(maxvar) @@ -122,7 +122,7 @@ c call flush(iout) ndis=ncon_work*(ncon_work-1)/2 call work_partition(.true.,ndis) #endif - + write(iout,*) "AFTET wort_part",NCON_work DO I=1,NCON_work ICC(I)=I ENDDO @@ -132,6 +132,8 @@ C C CALCULATE DISTANCES C call daread_ccoords(1,ncon_work) + write (iout,*) "AM I HERE" + call flush(iout) ind1=0 DO I=1,NCON_work-1 if (mod(i,100).eq.0) print *,'Calculating RMS i=',i @@ -140,9 +142,10 @@ C c(l,k)=allcart(l,k,i) enddo enddo + kkk=1 do k=1,nres do l=1,3 - cref(l,k)=c(l,k) + cref(l,k,kkk)=c(l,k) enddo enddo DO J=I+1,NCON_work @@ -164,8 +167,16 @@ c write (iout,'(2i4,i10,f10.5)') i,j,ind,DISS(IND) t1=tcpu() PRINT '(a)','End of distance computation' + scount_buf=scount(me) + + do ijk=1, ndis + diss_buf(ijk)=diss(ijk) + enddo + + #ifdef MPI - call MPI_Gatherv(diss(1),scount(me),MPI_REAL,diss(1), + WRITE (iout,*) "Wchodze do call MPI_Gatherv" + call MPI_Gatherv(diss_buf(1),scount_buf,MPI_REAL,diss(1), & scount(0),idispl(0),MPI_REAL,Master,MPI_COMM_WORLD, IERROR) if (me.eq.master) then #endif @@ -305,17 +316,17 @@ C C close(icbase,status="delete") #ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) + call MPI_Finalize(IERROR) #endif stop '********** Program terminated normally.' 20 write (iout,*) "Error reading coordinates" #ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) + call MPI_Finalize(IERROR) #endif stop 30 write (iout,*) "Error reading reference structure" #ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) + call MPI_Finalize(IERROR) #endif stop end @@ -358,7 +369,7 @@ c write (iout,*) "tutaj",zzz ibezperm=(run-1)*chalen+i do j=1,3 xx(j,ii)=allcart(j,iaperm,jcon) - yy(j,ii)=cref(j,ibezperm) + yy(j,ii)=cref(j,ibezperm,kkk) enddo enddo enddo @@ -372,7 +383,7 @@ c if (itype(i).ne.10) then ii=ii+1 do j=1,3 xx(j,ii)=allcart(j,iaperm+nres,jcon) - yy(j,ii)=cref(j,ibezperm+nres) + yy(j,ii)=cref(j,ibezperm+nres,kkk) enddo enddo c endif @@ -392,7 +403,8 @@ c do i=nnt,nct enddo enddo enddo - call fitsq(rms,c(1,nstart),cref(1,nstart),nend-nstart+1,przes, + call fitsq(rms,c(1,nstart),cref(1,nstart,kkk),nend-nstart+1, + & przes, & obrot,non_conv) endif if (rms.lt.0.0) then diff --git a/source/cluster/wham/src-M/parmread.F b/source/cluster/wham/src-M/parmread.F index 877d72b..8de6af5 100644 --- a/source/cluster/wham/src-M/parmread.F +++ b/source/cluster/wham/src-M/parmread.F @@ -18,7 +18,7 @@ C include 'COMMON.SCCOR' include 'COMMON.SCROT' character*1 t1,t2,t3 - character*1 onelett(4) /"G","A","P","D"/ + character*1 onelett(-2:2) /"p","a","G","A","P"/ logical lprint dimension blower(3,3,maxlob) double precision ip,mp @@ -34,8 +34,8 @@ C Assign virtual-bond length vblinv=1.0D0/vbl vblinv2=vblinv*vblinv #ifdef CRYST_BOND - read (ibond,*) vbldp0,akp - do i=1,ntyp + read (ibond,*) vbldp0,vbldpdum,akp + do i=1,ntyp nbondterm(i)=1 read (ibond,*) vbldsc0(1,i),aksc(1,i) dsc(i) = vbldsc0(1,i) @@ -46,7 +46,7 @@ C Assign virtual-bond length endif enddo #else - read (ibond,*) ijunk,vbldp0,akp,rjunk + read (ibond,*) ijunk,vbldp0,vbldpdum,akp,rjunk do i=1,ntyp read (ibond,*) nbondterm(i),(vbldsc0(j,i),aksc(j,i),abond0(j,i), & j=1,nbondterm(i)) @@ -72,18 +72,58 @@ C Assign virtual-bond length enddo enddo endif + read(iliptranpar,*) pepliptran + do i=1,ntyp + read(iliptranpar,*) liptranene(i) + enddo + close(iliptranpar) #ifdef CRYST_THETA C C Read the parameters of the probability distribution/energy expression C of the virtual-bond valence angles theta C do i=1,ntyp - read (ithep,*) a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) + read (ithep,*) a0thet(i),(athet(j,i,1,1),j=1,2), + & (bthet(j,i,1,1),j=1,2) read (ithep,*) (polthet(j,i),j=0,3) read (ithep,*) (gthet(j,i),j=1,3) read (ithep,*) theta0(i),sig0(i),sigc0(i) sigc0(i)=sigc0(i)**2 enddo + do i=1,ntyp + athet(1,i,1,-1)=athet(1,i,1,1) + athet(2,i,1,-1)=athet(2,i,1,1) + bthet(1,i,1,-1)=-bthet(1,i,1,1) + bthet(2,i,1,-1)=-bthet(2,i,1,1) + athet(1,i,-1,1)=-athet(1,i,1,1) + athet(2,i,-1,1)=-athet(2,i,1,1) + bthet(1,i,-1,1)=bthet(1,i,1,1) + bthet(2,i,-1,1)=bthet(2,i,1,1) + enddo + do i=-ntyp,-1 + a0thet(i)=a0thet(-i) + athet(1,i,-1,-1)=athet(1,-i,1,1) + athet(2,i,-1,-1)=-athet(2,-i,1,1) + bthet(1,i,-1,-1)=bthet(1,-i,1,1) + bthet(2,i,-1,-1)=-bthet(2,-i,1,1) + athet(1,i,-1,1)=athet(1,-i,1,1) + athet(2,i,-1,1)=-athet(2,-i,1,1) + bthet(1,i,-1,1)=-bthet(1,-i,1,1) + bthet(2,i,-1,1)=bthet(2,-i,1,1) + athet(1,i,1,-1)=-athet(1,-i,1,1) + athet(2,i,1,-1)=athet(2,-i,1,1) + bthet(1,i,1,-1)=bthet(1,-i,1,1) + bthet(2,i,1,-1)=-bthet(2,-i,1,1) + theta0(i)=theta0(-i) + sig0(i)=sig0(-i) + sigc0(i)=sigc0(-i) + do j=0,3 + polthet(j,i)=polthet(j,-i) + enddo + do j=1,3 + gthet(j,i)=gthet(j,-i) + enddo + enddo close (ithep) if (lprint) then c write (iout,'(a)') @@ -119,7 +159,8 @@ c enddo & ' b1*10^1 ',' b2*10^1 ' do i=1,ntyp write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i), - & a0thet(i),(100*athet(j,i),j=1,2),(10*bthet(j,i),j=1,2) + & a0thet(i),(100*athet(j,i,1,1),j=1,2), + & (10*bthet(j,i,1,1),j=1,2) enddo write (iout,'(/a/9x,5a/79(1h-))') & 'Parameters of the expression for sigma(theta_c):', @@ -147,46 +188,55 @@ C & ntheterm3,nsingle,ndouble nntheterm=max0(ntheterm,ntheterm2,ntheterm3) read (ithep,*) (ithetyp(i),i=1,ntyp1) - do i=1,maxthetyp - do j=1,maxthetyp - do k=1,maxthetyp - aa0thet(i,j,k)=0.0d0 + do i=-ntyp1,-1 + ithetyp(i)=-ithetyp(-i) + enddo + do iblock=1,2 + do i=-maxthetyp,maxthetyp + do j=-maxthetyp,maxthetyp + do k=-maxthetyp,maxthetyp + aa0thet(i,j,k,iblock)=0.0d0 do l=1,ntheterm - aathet(l,i,j,k)=0.0d0 + aathet(l,i,j,k,iblock)=0.0d0 enddo do l=1,ntheterm2 do m=1,nsingle - bbthet(m,l,i,j,k)=0.0d0 - ccthet(m,l,i,j,k)=0.0d0 - ddthet(m,l,i,j,k)=0.0d0 - eethet(m,l,i,j,k)=0.0d0 + bbthet(m,l,i,j,k,iblock)=0.0d0 + ccthet(m,l,i,j,k,iblock)=0.0d0 + ddthet(m,l,i,j,k,iblock)=0.0d0 + eethet(m,l,i,j,k,iblock)=0.0d0 enddo enddo do l=1,ntheterm3 do m=1,ndouble do mm=1,ndouble - ffthet(mm,m,l,i,j,k)=0.0d0 - ggthet(mm,m,l,i,j,k)=0.0d0 + ffthet(mm,m,l,i,j,k,iblock)=0.0d0 + ggthet(mm,m,l,i,j,k,iblock)=0.0d0 enddo enddo enddo enddo enddo enddo - do i=1,nthetyp - do j=1,nthetyp - do k=1,nthetyp - read (ithep,'(3a)') res1,res2,res3 - read (ithep,*) aa0thet(i,j,k) - read (ithep,*)(aathet(l,i,j,k),l=1,ntheterm) + enddo + do iblock=1,2 + do i=0,nthetyp + do j=-nthetyp,nthetyp + do k=-nthetyp,nthetyp + read (ithep,'(6a)') res1 + read (ithep,*) aa0thet(i,j,k,iblock) + read (ithep,*)(aathet(l,i,j,k,iblock),l=1,ntheterm) read (ithep,*) - & ((bbthet(lll,ll,i,j,k),lll=1,nsingle), - & (ccthet(lll,ll,i,j,k),lll=1,nsingle), - & (ddthet(lll,ll,i,j,k),lll=1,nsingle), - & (eethet(lll,ll,i,j,k),lll=1,nsingle),ll=1,ntheterm2) + & ((bbthet(lll,ll,i,j,k,iblock),lll=1,nsingle), + & (ccthet(lll,ll,i,j,k,iblock),lll=1,nsingle), + & (ddthet(lll,ll,i,j,k,iblock),lll=1,nsingle), + & (eethet(lll,ll,i,j,k,iblock),lll=1,nsingle) + & ,ll=1,ntheterm2) read (ithep,*) - & (((ffthet(llll,lll,ll,i,j,k),ffthet(lll,llll,ll,i,j,k), - & ggthet(llll,lll,ll,i,j,k),ggthet(lll,llll,ll,i,j,k), + & (((ffthet(llll,lll,ll,i,j,k,iblock), + & ffthet(lll,llll,ll,i,j,k,iblock), + & ggthet(llll,lll,ll,i,j,k,iblock), + & ggthet(lll,llll,ll,i,j,k,iblock), & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) enddo enddo @@ -198,17 +248,54 @@ C do i=1,nthetyp do j=1,nthetyp do l=1,ntheterm - aathet(l,i,j,nthetyp+1)=aathet(l,i,j,1) - aathet(l,nthetyp+1,i,j)=aathet(l,1,i,j) + aathet(l,i,j,nthetyp+1,iblock)=0.0d0 + aathet(l,nthetyp+1,i,j,iblock)=0.0d0 enddo - aa0thet(i,j,nthetyp+1)=aa0thet(i,j,1) - aa0thet(nthetyp+1,i,j)=aa0thet(1,i,j) + aa0thet(i,j,nthetyp+1,iblock)=0.0d0 + aa0thet(nthetyp+1,i,j,iblock)=0.0d0 enddo do l=1,ntheterm - aathet(l,nthetyp+1,i,nthetyp+1)=aathet(l,1,i,1) + aathet(l,nthetyp+1,i,nthetyp+1,iblock)=0.0d0 enddo - aa0thet(nthetyp+1,i,nthetyp+1)=aa0thet(1,i,1) + aa0thet(nthetyp+1,i,nthetyp+1,iblock)=0.0d0 + enddo enddo +C Substitution for D aminoacids from symmetry. + do iblock=1,2 + do i=-nthetyp,0 + do j=-nthetyp,nthetyp + do k=-nthetyp,nthetyp + aa0thet(i,j,k,iblock)=aa0thet(-i,-j,-k,iblock) + do l=1,ntheterm + aathet(l,i,j,k,iblock)=aathet(l,-i,-j,-k,iblock) + enddo + do ll=1,ntheterm2 + do lll=1,nsingle + bbthet(lll,ll,i,j,k,iblock)=bbthet(lll,ll,-i,-j,-k,iblock) + ccthet(lll,ll,i,j,k,iblock)=-ccthet(lll,ll,-i,-j,-k,iblock) + ddthet(lll,ll,i,j,k,iblock)=ddthet(lll,ll,-i,-j,-k,iblock) + eethet(lll,ll,i,j,k,iblock)=-eethet(lll,ll,-i,-j,-k,iblock) + enddo + enddo + do ll=1,ntheterm3 + do lll=2,ndouble + do llll=1,lll-1 + ffthet(llll,lll,ll,i,j,k,iblock)= + & ffthet(llll,lll,ll,-i,-j,-k,iblock) + ffthet(lll,llll,ll,i,j,k,iblock)= + & ffthet(lll,llll,ll,-i,-j,-k,iblock) + ggthet(llll,lll,ll,i,j,k,iblock)= + & -ggthet(llll,lll,ll,-i,-j,-k,iblock) + ggthet(lll,llll,ll,i,j,k,iblock)= + & -ggthet(lll,llll,ll,-i,-j,-k,iblock) + enddo !ll + enddo !lll + enddo !llll + enddo !k + enddo !j + enddo !i + enddo !iblock + C C Control printout of the coefficients of virtual-bond-angle potentials C @@ -220,16 +307,16 @@ C write (iout,'(//4a)') & 'Type ',onelett(i),onelett(j),onelett(k) write (iout,'(//a,10x,a)') " l","a[l]" - write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k) + write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k,iblock) write (iout,'(i2,1pe15.5)') - & (l,aathet(l,i,j,k),l=1,ntheterm) + & (l,aathet(l,i,j,k,iblock),l=1,ntheterm) do l=1,ntheterm2 write (iout,'(//2h m,4(9x,a,3h[m,i1,1h]))') & "b",l,"c",l,"d",l,"e",l do m=1,nsingle write (iout,'(i2,4(1pe15.5))') m, - & bbthet(m,l,i,j,k),ccthet(m,l,i,j,k), - & ddthet(m,l,i,j,k),eethet(m,l,i,j,k) + & bbthet(m,l,i,j,k,iblock),ccthet(m,l,i,j,k,iblock), + & ddthet(m,l,i,j,k,iblock),eethet(m,l,i,j,k,iblock) enddo enddo do l=1,ntheterm3 @@ -238,8 +325,10 @@ C do m=2,ndouble do n=1,m-1 write (iout,'(i1,1x,i1,4(1pe15.5))') n,m, - & ffthet(n,m,l,i,j,k),ffthet(m,n,l,i,j,k), - & ggthet(n,m,l,i,j,k),ggthet(m,n,l,i,j,k) + & ffthet(n,m,l,i,j,k,iblock), + & ffthet(m,n,l,i,j,k,iblock), + & ggthet(n,m,l,i,j,k,iblock), + & ggthet(m,n,l,i,j,k,iblock) enddo enddo enddo @@ -272,10 +361,17 @@ C enddo bsc(1,i)=0.0D0 read(irotam,*)(censc(k,1,i),k=1,3),((blower(k,l,1),l=1,k),k=1,3) + censc(1,1,-i)=censc(1,1,i) + censc(2,1,-i)=censc(2,1,i) + censc(3,1,-i)=-censc(3,1,i) do j=2,nlob(i) read (irotam,*) bsc(j,i) read (irotam,*) (censc(k,j,i),k=1,3), & ((blower(k,l,j),l=1,k),k=1,3) + censc(1,j,-i)=censc(1,j,i) + censc(2,j,-i)=censc(2,j,i) + censc(3,j,-i)=-censc(3,j,i) +C BSC is amplitude of Gaussian enddo do j=1,nlob(i) do k=1,3 @@ -286,6 +382,14 @@ C enddo gaussc(k,l,j,i)=akl gaussc(l,k,j,i)=akl + if (((k.eq.3).and.(l.ne.3)) + & .or.((l.eq.3).and.(k.ne.3))) then + gaussc(k,l,j,-i)=-akl + gaussc(l,k,j,-i)=-akl + else + gaussc(k,l,j,-i)=akl + gaussc(l,k,j,-i)=akl + endif enddo enddo enddo @@ -373,23 +477,37 @@ C read (itorp,*) ntortyp read (itorp,*) (itortyp(i),i=1,ntyp) write (iout,*) 'ntortyp',ntortyp - do i=1,ntortyp - do j=1,ntortyp - read (itorp,*) nterm(i,j),nlor(i,j) + do iblock=1,2 + do i=-ntyp,-1 + itortyp(i)=-itortyp(-i) + enddo +c write (iout,*) 'ntortyp',ntortyp + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + read (itorp,*) nterm(i,j,iblock), + & nlor(i,j,iblock) + nterm(-i,-j,iblock)=nterm(i,j,iblock) + nlor(-i,-j,iblock)=nlor(i,j,iblock) v0ij=0.0d0 si=-1.0d0 - do k=1,nterm(i,j) - read (itorp,*) kk,v1(k,i,j),v2(k,i,j) - v0ij=v0ij+si*v1(k,i,j) + do k=1,nterm(i,j,iblock) + read (itorp,*) kk,v1(k,i,j,iblock), + & v2(k,i,j,iblock) + v1(k,-i,-j,iblock)=v1(k,i,j,iblock) + v2(k,-i,-j,iblock)=-v2(k,i,j,iblock) + v0ij=v0ij+si*v1(k,i,j,iblock) si=-si enddo - do k=1,nlor(i,j) - read (itorp,*) kk,vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) + do k=1,nlor(i,j,iblock) + read (itorp,*) kk,vlor1(k,i,j), + & vlor2(k,i,j),vlor3(k,i,j) v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) enddo - v0(i,j)=v0ij + v0(i,j,iblock)=v0ij + v0(-i,-j,iblock)=v0ij enddo enddo + enddo close (itorp) if (lprint) then write (iout,'(/a/)') 'Torsional constants:' @@ -397,11 +515,12 @@ C do j=1,ntortyp write (iout,*) 'ityp',i,' jtyp',j write (iout,*) 'Fourier constants' - do k=1,nterm(i,j) - write (iout,'(2(1pe15.5))') v1(k,i,j),v2(k,i,j) + do k=1,nterm(i,j,iblock) + write (iout,'(2(1pe15.5))') v1(k,i,j,iblock), + & v2(k,i,j,iblock) enddo write (iout,*) 'Lorenz constants' - do k=1,nlor(i,j) + do k=1,nlor(i,j,iblock) write (iout,'(3(1pe15.5))') & vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) enddo @@ -411,9 +530,10 @@ C C C 6/23/01 Read parameters for double torsionals C - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp + do iblock=1,2 + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 read (itordp,'(3a1)') t1,t2,t3 if (t1.ne.onelett(i) .or. t2.ne.onelett(j) & .or. t3.ne.onelett(k)) then @@ -421,48 +541,81 @@ C & i,j,k,t1,t2,t3 stop "Error in double torsional parameter file" endif - read (itordp,*) ntermd_1(i,j,k),ntermd_2(i,j,k) - read (itordp,*) (v1c(1,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) (v1s(1,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) (v1c(2,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) (v1s(2,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) ((v2c(l,m,i,j,k),v2c(m,l,i,j,k), - & v2s(l,m,i,j,k),v2s(m,l,i,j,k),m=1,l-1),l=1,ntermd_2(i,j,k)) - enddo - enddo - enddo + read (itordp,*) ntermd_1(i,j,k,iblock), + & ntermd_2(i,j,k,iblock) + ntermd_1(-i,-j,-k,iblock)=ntermd_1(i,j,k,iblock) + ntermd_2(-i,-j,-k,iblock)=ntermd_2(i,j,k,iblock) + read (itordp,*) (v1c(1,l,i,j,k,iblock),l=1, + & ntermd_1(i,j,k,iblock)) + read (itordp,*) (v1s(1,l,i,j,k,iblock),l=1, + & ntermd_1(i,j,k,iblock)) + read (itordp,*) (v1c(2,l,i,j,k,iblock),l=1, + & ntermd_1(i,j,k,iblock)) + read (itordp,*) (v1s(2,l,i,j,k,iblock),l=1, + & ntermd_1(i,j,k,iblock)) +C Martix of D parameters for one dimesional foureir series + do l=1,ntermd_1(i,j,k,iblock) + v1c(1,l,-i,-j,-k,iblock)=v1c(1,l,i,j,k,iblock) + v1s(1,l,-i,-j,-k,iblock)=-v1s(1,l,i,j,k,iblock) + v1c(2,l,-i,-j,-k,iblock)=v1c(2,l,i,j,k,iblock) + v1s(2,l,-i,-j,-k,iblock)=-v1s(2,l,i,j,k,iblock) +c write(iout,*) "whcodze" , +c & v1s(2,l,-i,-j,-k,iblock),v1s(2,l,i,j,k,iblock) + enddo + read (itordp,*) ((v2c(l,m,i,j,k,iblock), + & v2c(m,l,i,j,k,iblock),v2s(l,m,i,j,k,iblock), + & v2s(m,l,i,j,k,iblock), + & m=1,l-1),l=1,ntermd_2(i,j,k,iblock)) +C Martix of D parameters for two dimesional fourier series + do l=1,ntermd_2(i,j,k,iblock) + do m=1,l-1 + v2c(l,m,-i,-j,-k,iblock)=v2c(l,m,i,j,k,iblock) + v2c(m,l,-i,-j,-k,iblock)=v2c(m,l,i,j,k,iblock) + v2s(l,m,-i,-j,-k,iblock)=-v2s(l,m,i,j,k,iblock) + v2s(m,l,-i,-j,-k,iblock)=-v2s(m,l,i,j,k,iblock) + enddo!m + enddo!l + enddo!k + enddo!j + enddo!i + enddo!iblock if (lprint) then write (iout,*) write (iout,*) 'Constants for double torsionals' - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp + do iblock=1,2 + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k, - & ' nsingle',ntermd_1(i,j,k),' ndouble',ntermd_2(i,j,k) + & ' nsingle',ntermd_1(i,j,k,iblock), + & ' ndouble',ntermd_2(i,j,k,iblock) write (iout,*) write (iout,*) 'Single angles:' - do l=1,ntermd_1(i,j,k) - write (iout,'(i5,2f10.5,5x,2f10.5)') l, - & v1c(1,l,i,j,k),v1s(1,l,i,j,k), - & v1c(2,l,i,j,k),v1s(2,l,i,j,k) + do l=1,ntermd_1(i,j,k,iblock) + write (iout,'(i5,2f10.5,5x,2f10.5,5x,2f10.5)') l, + & v1c(1,l,i,j,k,iblock),v1s(1,l,i,j,k,iblock), + & v1c(2,l,i,j,k,iblock),v1s(2,l,i,j,k,iblock), + & v1s(1,l,-i,-j,-k,iblock),v1s(2,l,-i,-j,-k,iblock) enddo write (iout,*) write (iout,*) 'Pairs of angles:' - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2c(l,m,i,j,k),m=1,ntermd_2(i,j,k)) + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) + do l=1,ntermd_2(i,j,k,iblock) + write (iout,'(i5,20f10.5)') + & l,(v2c(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)) enddo write (iout,*) - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2s(l,m,i,j,k),m=1,ntermd_2(i,j,k)) + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) + do l=1,ntermd_2(i,j,k,iblock) + write (iout,'(i5,20f10.5)') + & l,(v2s(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)), + & (v2s(l,m,-i,-j,-k,iblock),m=1,ntermd_2(i,j,k,iblock)) enddo write (iout,*) enddo enddo enddo + enddo endif #endif C @@ -569,7 +722,7 @@ C 9/18/99 (AL) Read coefficients of the Fourier expansion of the local C interaction energy of the Gly, Ala, and Pro prototypes. C read (ifourier,*) nloctyp - do i=1,nloctyp + do i=0,nloctyp-1 read (ifourier,*) read (ifourier,*) (b(ii,i),ii=1,13) if (lprint) then @@ -578,30 +731,56 @@ C endif B1(1,i) = b(3,i) B1(2,i) = b(5,i) + B1(1,-i) = b(3,i) + B1(2,-i) = -b(5,i) B1tilde(1,i) = b(3,i) B1tilde(2,i) =-b(5,i) + B1tilde(1,-i) =-b(3,i) + B1tilde(2,-i) =b(5,i) B2(1,i) = b(2,i) B2(2,i) = b(4,i) + B2(1,-i) =b(2,i) + B2(2,-i) =-b(4,i) CC(1,1,i)= b(7,i) CC(2,2,i)=-b(7,i) CC(2,1,i)= b(9,i) CC(1,2,i)= b(9,i) + CC(1,1,-i)= b(7,i) + CC(2,2,-i)=-b(7,i) + CC(2,1,-i)=-b(9,i) + CC(1,2,-i)=-b(9,i) Ctilde(1,1,i)=b(7,i) Ctilde(1,2,i)=b(9,i) Ctilde(2,1,i)=-b(9,i) Ctilde(2,2,i)=b(7,i) + Ctilde(1,1,-i)=b(7,i) + Ctilde(1,2,-i)=-b(9,i) + Ctilde(2,1,-i)=b(9,i) + Ctilde(2,2,-i)=b(7,i) DD(1,1,i)= b(6,i) DD(2,2,i)=-b(6,i) DD(2,1,i)= b(8,i) DD(1,2,i)= b(8,i) + DD(1,1,-i)= b(6,i) + DD(2,2,-i)=-b(6,i) + DD(2,1,-i)=-b(8,i) + DD(1,2,-i)=-b(8,i) Dtilde(1,1,i)=b(6,i) Dtilde(1,2,i)=b(8,i) Dtilde(2,1,i)=-b(8,i) Dtilde(2,2,i)=b(6,i) + Dtilde(1,1,-i)=b(6,i) + Dtilde(1,2,-i)=-b(8,i) + Dtilde(2,1,-i)=b(8,i) + Dtilde(2,2,-i)=b(6,i) EE(1,1,i)= b(10,i)+b(11,i) EE(2,2,i)=-b(10,i)+b(11,i) EE(2,1,i)= b(12,i)-b(13,i) EE(1,2,i)= b(12,i)+b(13,i) + EE(1,1,-i)= b(10,i)+b(11,i) + EE(2,2,-i)=-b(10,i)+b(11,i) + EE(2,1,-i)=-b(12,i)+b(13,i) + EE(1,2,-i)=-b(12,i)-b(13,i) enddo if (lprint) then do i=1,nloctyp @@ -688,10 +867,22 @@ C----------------------- LJK potential -------------------------------- endif goto 50 C---------------------- GB or BP potential ----------------------------- - 30 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(sigii(i),i=1,ntyp),(chip0(i),i=1,ntyp), - & (alp(i),i=1,ntyp) + 30 do i=1,ntyp + read (isidep,*)(eps(i,j),j=i,ntyp) + enddo + read (isidep,*)(sigma0(i),i=1,ntyp) + read (isidep,*)(sigii(i),i=1,ntyp) + read (isidep,*)(chip0(i),i=1,ntyp) + read (isidep,*)(alp(i),i=1,ntyp) C For the GB potential convert sigma'**2 into chi' + do i=1,ntyp + read (isidep,*)(epslip(i,j),j=i,ntyp) +C write(iout,*) "WARNING!!",i,ntyp + write(iout,*) "epslip", i, (epslip(i,j),j=i,ntyp) +C do j=1,ntyp +C epslip(i,j)=epslip(i,j)+0.05d0 +C enddo + enddo if (ipot.eq.4) then do i=1,ntyp chip(i)=(chip0(i)-1.0D0)/(chip0(i)+1.0D0) @@ -729,6 +920,7 @@ C Calculate the "working" parameters of SC interactions. do i=2,ntyp do j=1,i-1 eps(i,j)=eps(j,i) + epslip(i,j)=epslip(j,i) enddo enddo do i=1,ntyp @@ -746,6 +938,7 @@ C Calculate the "working" parameters of SC interactions. do i=1,ntyp do j=i,ntyp epsij=eps(i,j) + epsijlip=epslip(i,j) if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then rrij=sigma(i,j) else @@ -755,13 +948,19 @@ C Calculate the "working" parameters of SC interactions. r0(j,i)=rrij rrij=rrij**expon epsij=eps(i,j) - sigeps=dsign(1.0D0,epsij) - epsij=dabs(epsij) - aa(i,j)=epsij*rrij*rrij - bb(i,j)=-sigeps*epsij*rrij - aa(j,i)=aa(i,j) - bb(j,i)=bb(i,j) - if (ipot.gt.2) then + sigeps=dsign(1.0D0,epsij) + epsij=dabs(epsij) + aa_aq(i,j)=epsij*rrij*rrij + bb_aq(i,j)=-sigeps*epsij*rrij + aa_aq(j,i)=aa_aq(i,j) + bb_aq(j,i)=bb_aq(i,j) + sigeps=dsign(1.0D0,epsijlip) + epsijlip=dabs(epsijlip) + aa_lip(i,j)=epsijlip*rrij*rrij + bb_lip(i,j)=-sigeps*epsijlip*rrij + aa_lip(j,i)=aa_lip(i,j) + bb_lip(j,i)=bb_lip(i,j) + if (ipot.gt.2) then sigt1sq=sigma0(i)**2 sigt2sq=sigma0(j)**2 sigii1=sigii(i) @@ -793,7 +992,7 @@ c augm(i,j)=0.5D0**(2*expon)*aa(i,j) endif if (lprint) then write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') - & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), + & restyp(i),restyp(j),aa_aq(i,j),bb_aq(i,j),augm(i,j), & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) endif enddo @@ -855,7 +1054,7 @@ C C C Define the constants of the disulfide bridge C - ebr=-5.50D0 +C ebr=-5.50D0 c c Old arbitrary potential - commented out. c @@ -866,19 +1065,19 @@ c Constants of the disulfide-bond potential determined based on the RHF/6-31G** c energy surface of diethyl disulfide. c A. Liwo and U. Kozlowska, 11/24/03 c - D0CM = 3.78d0 - AKCM = 15.1d0 - AKTH = 11.0d0 - AKCT = 12.0d0 - V1SS =-1.08d0 - V2SS = 7.61d0 - V3SS = 13.7d0 +C D0CM = 3.78d0 +C AKCM = 15.1d0 +C AKTH = 11.0d0 +C AKCT = 12.0d0 +C V1SS =-1.08d0 +C V2SS = 7.61d0 +C V3SS = 13.7d0 - write (iout,'(/a)') "Disulfide bridge parameters:" - write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr - write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm - write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct - write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss, - & ' v3ss:',v3ss +C write (iout,'(/a)') "Disulfide bridge parameters:" +C write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr +C write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm +C write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct +C write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss, +C & ' v3ss:',v3ss return end diff --git a/source/cluster/wham/src-M/probabl.F b/source/cluster/wham/src-M/probabl.F index 293fb8f..4e5632e 100644 --- a/source/cluster/wham/src-M/probabl.F +++ b/source/cluster/wham/src-M/probabl.F @@ -27,10 +27,11 @@ character*80 bxname character*2 licz1 character*5 ctemper - integer ilen + integer ilen,ijk external ilen - real*4 Fdimless(maxconf) - double precision energia(0:max_ene) + real*4 Fdimless(maxconf), Fdimless_buf(maxconf) + double precision energia(0:max_ene), totfree_buf(0:maxconf), + & entfac_buf(maxconf) do i=1,ncon list_conf(i)=i enddo @@ -41,7 +42,8 @@ c enddo write (iout,*) me," indstart",indstart(me)," indend",indend(me) call daread_ccoords(indstart(me),indend(me)) #endif -c write (iout,*) "ncon",ncon +C write (iout,*) "ncon",ncon +C call flush(iout) temper=1.0d0/(beta_h(ib)*1.987D-3) c write (iout,*) "ib",ib," beta_h",beta_h(ib)," temper",temper c quot=1.0d0/(T0*beta_h(ib)*1.987D-3) @@ -53,6 +55,7 @@ c quotl=quotl*quot c kfacl=kfacl*kfac c fT(l)=kfacl/(kfacl-1.0d0+quotl) c enddo +C#define DEBUG if (rescale_mode.eq.1) then quot=1.0d0/(T0*beta_h(ib)*1.987D-3) quotl=1.0d0 @@ -87,8 +90,8 @@ c enddo fT(l)=1.12692801104297249644d0/ & dlog(dexp(quotl)+dexp(-quotl)) enddo -c write (iout,*) 1.0d0/(beta_h(ib)*1.987D-3),ft -c call flush(iout) + write (iout,*) 1.0d0/(beta_h(ib)*1.987D-3),ft + call flush(iout) #if defined(FUNCTH) ft(6)=(320.0d0+80.0d0*dtanh((betaT-320.0d0)/80.0d0))/ & 320.0d0 @@ -113,36 +116,47 @@ c call flush(iout) do i=1,ncon ii=i #endif -c write (iout,*) "i",i," ii",ii -c call flush(iout) +C write (iout,*) "i",i," ii",ii,"ib",ib,scount(me) + call flush(iout) if (ib.eq.1) then do j=1,nres do k=1,3 c(k,j)=allcart(k,j,i) c(k,j+nres)=allcart(k,j+nres,i) +C write(iout,*) "coord",i,j,k,allcart(k,j,i),c(k,j), +C & c(k,j+nres),allcart(k,j+nres,i) enddo enddo +C write(iout,*) "out of j loop" +C call flush(iout) do k=1,3 c(k,nres+1)=c(k,1) c(k,nres+nres)=c(k,nres) enddo +C write(iout,*) "after nres+nres",nss_all(i) +C call flush(iout) nss=nss_all(i) do j=1,nss ihpb(j)=ihpb_all(j,i) jhpb(j)=jhpb_all(j,i) enddo call int_from_cart1(.false.) +C write(iout,*) "before etotal" +C call flush(iout) call etotal(energia(0),fT) totfree(i)=energia(0) + totfree_buf(i)=totfree(i) c write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) c write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) -c call enerprint(energia(0),fT) + call enerprint(energia(0),fT) c call pdbout(totfree(i),16,i) +#define DEBUG #ifdef DEBUG - write (iout,*) i," energia",(energia(j),j=0,19) + write (iout,*) i," energia",(energia(j),j=0,max_ene) write (iout,*) "etot", etot write (iout,*) "ft(6)", ft(6) #endif +#undef DEBUG do k=1,max_ene enetb(k,i)=energia(k) enddo @@ -205,30 +219,52 @@ c#endif write (iout,*) "evdw2", wscp, evdw2 write (iout,*) "welec", ft(1),welec,ees write (iout,*) "evdw1", wvdwpp,evdw1 - write (iout,*) "ebe" ebe,wang + write (iout,*) "ebe", ebe,wang #endif Fdimless(i)=beta_h(ib)*etot+entfac(ii) + Fdimless_buf(i)=Fdimless(i) totfree(i)=etot + totfree_buf(i)=totfree(i) #ifdef DEBUG write (iout,*) "fdim calc", i,ii,ib, & 1.0d0/(1.987d-3*beta_h(ib)),totfree(i), & entfac(ii),Fdimless(i) #endif enddo ! i + + do ijk=1,maxconf + entfac_buf(ijk)=entfac(ijk) + Fdimless_buf(ijk)=Fdimless(ijk) + enddo + do ijk=0,maxconf + totfree_buf(ijk)=totfree(ijk) + enddo + + +c scount_buf=scount(me) +c scount_buf2=scount(0) + +c entfac_buf(indstart(me)+1)=entfac(indstart(me)+1) + #ifdef MPI - call MPI_Gatherv(Fdimless(1),scount(me), + WRITE (iout,*) "Wchodze do call MPI_Gatherv1 (Propabl)" + call MPI_Gatherv(Fdimless_buf(1),scount(me), & MPI_REAL,Fdimless(1), & scount(0),idispl(0),MPI_REAL,Master, & MPI_COMM_WORLD, IERROR) - call MPI_Gatherv(totfree(1),scount(me), + WRITE (iout,*) "Wchodze do call MPI_Gatherv2 (Propabl)" + call MPI_Gatherv(totfree_buf(1),scount(me), & MPI_DOUBLE_PRECISION,totfree(1), & scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master, & MPI_COMM_WORLD, IERROR) - call MPI_Gatherv(entfac(indstart(me)+1),scount(me), + WRITE (iout,*) "Wchodze do call MPI_Gatherv3 (Propabl)" + call MPI_Gatherv(entfac_buf(indstart(me)+1),scount(me), & MPI_DOUBLE_PRECISION,entfac(1), & scount(0),idispl(0),MPI_DOUBLE_PRECISION,Master, & MPI_COMM_WORLD, IERROR) + WRITE (iout,*) "Wychodze z call MPI_Gatherv (Propabl)" if (me.eq.Master) then + WRITE (iout,*) "me.eq.Master" #endif #ifdef DEBUG write (iout,*) "The FDIMLESS array before sorting" @@ -236,13 +272,16 @@ c#endif c write (iout,*) i,fdimless(i) enddo #endif + WRITE (iout,*) "Wchodze do call mysort1" call mysort1(ncon,Fdimless,list_conf) -#ifdef DEBUG + WRITE (iout,*) "Wychodze z call mysort1" +C#ifdef DEBUG write (iout,*) "The FDIMLESS array after sorting" do i=1,ncon write (iout,*) i,list_conf(i),fdimless(i) enddo -#endif +c#endif + WRITE (iout,*) "Wchodze do petli i=1,ncon totfree(i)=fdimless(i)" do i=1,ncon totfree(i)=fdimless(i) enddo @@ -257,12 +296,13 @@ c write (iout,*) "qfree",qfree write (iout,*) "ncon", ncon,maxstr_proc do i=1,min0(ncon,maxstr_proc)-1 sumprob=sumprob+exp(-fdimless(i)+fdimless(1))/qfree -#ifdef DEBUG +C#ifdef DEBUG + write (iout,*) "tu szukaj ponizej 7" write (iout,*) i,ib,beta_h(ib), & 1.0d0/(1.987d-3*beta_h(ib)),list_conf(i), & totfree(list_conf(i)), & -entfac(list_conf(i)),fdimless(i),sumprob -#endif +C#endif if (sumprob.gt.prob_limit) goto 122 c if (sumprob.gt.1.00d0) goto 122 nlist=nlist+1 diff --git a/source/cluster/wham/src-M/read_coords.F b/source/cluster/wham/src-M/read_coords.F index c34aca4..55f52e3 100644 --- a/source/cluster/wham/src-M/read_coords.F +++ b/source/cluster/wham/src-M/read_coords.F @@ -178,13 +178,13 @@ c through a ring. #endif endif -#define DEBUG +C#define DEBUG #ifdef DEBUG write (iout,*) "Opening file ",intinname(:ilen(intinname)) write (iout,*) "lenrec",lenrec_in call flush(iout) #endif -#undef DEBUG +C#undef DEBUG c write (iout,*) "maxconf",maxconf i=0 do while (.true.) @@ -218,10 +218,17 @@ c call flush(iout) call xdrfint_(ixdrf, nss, iret) if (iret.eq.0) goto 101 do j=1,nss + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j), iret) + call xdrfint(ixdrf, jdssb(j), iret) + idssb(j)=idssb(j)-nres + jdssb(j)=jdssb(j)-nres + else call xdrfint_(ixdrf, ihpb(j), iret) if (iret.eq.0) goto 101 call xdrfint_(ixdrf, jhpb(j), iret) if (iret.eq.0) goto 101 + endif enddo call xdrffloat_(ixdrf,reini,iret) if (iret.eq.0) goto 101 @@ -243,10 +250,15 @@ c write (iout,*) "nss",nss call flush(iout) if (iret.eq.0) goto 101 do k=1,nss + if (dyn_ss) then + call xdrfint(ixdrf, idssb(k), iret) + call xdrfint(ixdrf, jdssb(k), iret) + else call xdrfint(ixdrf, ihpb(k), iret) if (iret.eq.0) goto 101 call xdrfint(ixdrf, jhpb(k), iret) if (iret.eq.0) goto 101 + endif enddo call xdrffloat(ixdrf,reini,iret) if (iret.eq.0) goto 101 @@ -271,6 +283,7 @@ c write (iout,*) "nss",nss enddo enddo endif +C#define DEBUG #ifdef DEBUG write (iout,'(5hREAD ,i5,3f15.4,i10)') & jj+1,energy(jj+1),entfac(jj+1), @@ -280,6 +293,7 @@ c write (iout,*) "nss",nss write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) call flush(iout) #endif +C#undef DEBUG call add_new_cconf(jjj,jj,jj_old,icount,Next) enddo 101 continue @@ -379,7 +393,8 @@ c------------------------------------------------------------------------------ chalen=int((nct-nnt+2)/symetr) call int_from_cart1(.false.) do j=nnt+1,nct - if (vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0) then + if ((vbld(j).lt.2.0d0 .or. vbld(j).gt.6.0d0) + & .and.(itype(j).ne.ntyp1)) then if (j.gt.2) then if (itel(j).ne.0 .and. itel(j-1).ne.0) then write (iout,*) "Conformation",jjj,jj+1 @@ -404,7 +419,8 @@ c------------------------------------------------------------------------------ enddo do j=nnt,nct itj=itype(j) - if (itype(j).ne.10 .and. (vbld(nres+j)-dsc(itj)).gt.2.0d0) then + if (itype(j).ne.10 .and. (vbld(nres+j)-dsc(iabs(itj))).gt.5.0d0 + & .and. itype(j).ne.ntyp1) then write (iout,*) "Conformation",jjj,jj+1 write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j) write (iout,*) "The Cartesian geometry is:" @@ -627,10 +643,11 @@ c------------------------------------------------------------------------------ integer i,j,ij,ii,iii integer len character*16 form,acc - character*32 nam + character*80 nam c c Read conformations off a DA scratchfile. c +C#define DEBUG #ifdef DEBUG write (iout,*) "DAREAD_COORDS" write (iout,*) "istart_conf",istart_conf," iend_conf",iend_conf @@ -646,10 +663,17 @@ c write (iout,*) "Reading binary file, record",iii," ii",ii call flush(iout) #endif + if (dyn_ss) then + read(icbase,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres), + & ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres), +c & nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss), + & entfac(ii),rmstb(ii) + else read(icbase,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres), & ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres), & nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss), & entfac(ii),rmstb(ii) + endif #ifdef DEBUG write (iout,*) ii,iii,ij,entfac(ii) write (iout,'(8f10.5)') ((allcart(j,i,ij),j=1,3),i=1,nres) @@ -660,7 +684,10 @@ c & jhpb_all(i,ij),i=1,nss) call flush(iout) #endif +C#undef DEBUG enddo + write (iout,*) "just before leave" + call flush(iout) return end c------------------------------------------------------------------------------ @@ -703,10 +730,17 @@ c write (iout,*) "Writing binary file, record",iii," ii",ii call flush(iout) #endif + if (dyn_ss) then + write(unit_out,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres), + & ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres), +c & nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss_all(ij)) + & entfac(ii),rmstb(ii) + else write(unit_out,rec=iii) ((allcart(j,i,ij),j=1,3),i=1,nres), & ((allcart(j,i,ij),j=1,3),i=nnt+nres,nct+nres), & nss_all(ij),(ihpb_all(i,ij),jhpb_all(i,ij),i=1,nss_all(ij)), & entfac(ii),rmstb(ii) + endif #ifdef DEBUG write (iout,'(8f10.5)') ((allcart(j,i,ij),j=1,3),i=1,nres) write (iout,'(8f10.4)') ((allcart(j,i,ij),j=1,3),i=nnt+nres, diff --git a/source/cluster/wham/src-M/readpdb.f b/source/cluster/wham/src-M/readpdb.f index 62f3f2b..993b5c6 100644 --- a/source/cluster/wham/src-M/readpdb.f +++ b/source/cluster/wham/src-M/readpdb.f @@ -14,16 +14,18 @@ C geometry. character*80 card dimension sccor(3,20) integer rescode - call permut(symetr) +c call permut(symetr) ibeg=1 + write(iout,*) 'pdbread' do read (ipdbin,'(a80)',end=10) card if (card(:3).eq.'END') then goto 10 else if (card(:3).eq.'TER') then C End current chain - ires_old=ires+1 - itype(ires_old)=21 + ires_old=ires+2 + itype(ires_old-1)=ntyp1 + itype(ires_old)=ntyp1 ibeg=2 c write (iout,*) "Chain ended",ires,ishift,ires_old call sccenter(ires,iii,sccor) @@ -44,7 +46,7 @@ c write (iout,'(a80)') card ishift=ires-1 if (res.ne.'GLY' .and. res.ne. 'ACE') then ishift=ishift-1 - itype(1)=21 + itype(1)=ntyp1 endif c write (iout,*) "ires",ires," ibeg",ibeg," ishift",ishift ibeg=0 @@ -81,14 +83,30 @@ C system nres=ires do i=2,nres-1 c write (iout,*) i,itype(i) - if (itype(i).eq.21) then + if (itype(i).eq.ntyp1) then + if (itype(i+1).eq.ntyp1) then + c write (iout,*) "dummy",i,itype(i) - do j=1,3 - c(j,i)=((c(j,i-1)+c(j,i+1))/2+2*c(j,i-1)-c(j,i-2))/2 +C do j=1,3 +C c(j,i)=((c(j,i-1)+c(j,i+1))/2+2*c(j,i-1)-c(j,i-2))/2 c c(j,i)=(c(j,i-1)+c(j,i+1))/2 - dc(j,i)=c(j,i) - enddo - endif +C dc(j,i)=c(j,i) +C enddo + do j=1,3 + dcj=(c(j,i-2)-c(j,i-3))/2.0 + c(j,i)=c(j,i-1)+dcj + c(j,nres+i)=c(j,i) + enddo +C endif !unres_pdb + else !itype(i+1).eq.ntyp1 + do j=1,3 + dcj=(c(j,i+3)-c(j,i+2))/2.0 + c(j,i)=c(j,i+1)-dcj + c(j,nres+i)=c(j,i) + enddo +C endif !unres_pdb + endif !itype(i+1).eq.ntyp1 + endif !itype.eq.ntyp1 enddo C Calculate the CM of the last side chain. call sccenter(ires,iii,sccor) @@ -96,9 +114,9 @@ C Calculate the CM of the last side chain. nstart_sup=1 if (itype(nres).ne.10) then nres=nres+1 - itype(nres)=21 + itype(nres)=ntyp1 do j=1,3 - dcj=c(j,nres-2)-c(j,nres-3) + dcj=(c(j,nres-2)-c(j,nres-3))/2.0 c(j,nres)=c(j,nres-1)+dcj c(j,2*nres)=c(j,nres) enddo @@ -112,11 +130,11 @@ C Calculate the CM of the last side chain. c(j,nres+1)=c(j,1) c(j,2*nres)=c(j,nres) enddo - if (itype(1).eq.21) then + if (itype(1).eq.ntyp1) then nsup=nsup-1 nstart_sup=2 do j=1,3 - dcj=c(j,4)-c(j,3) + dcj=(c(j,4)-c(j,3))/2.0 c(j,1)=c(j,2)-dcj c(j,nres+1)=c(j,1) enddo @@ -127,7 +145,11 @@ C Calculate internal coordinates. & ires,itype(ires),restyp(itype(ires)),(c(j,ires),j=1,3), & (c(j,nres+ires),j=1,3) enddo + call int_from_cart1(.false.) call int_from_cart(.true.,.false.) + call sc_loc_geom(.true.) + write (iout,*) "After int_from_cart" + call flush(iout) do i=1,nres-1 do j=1,3 dc(j,i)=c(j,i+1)-c(j,i) @@ -142,13 +164,101 @@ C Calculate internal coordinates. c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3), c & vbld_inv(i+nres) enddo + do i=1,nres + thetaref(i)=theta(i) + phiref(i)=phi(i) +c + phi_ref(i)=phi(i) + theta_ref(i)=theta(i) + alph_ref(i)=alph(i) + omeg_ref(i)=omeg(i) + enddo + c call chainbuild C Copy the coordinates to reference coordinates - do i=1,2*nres +c do i=1,2*nres +c do j=1,3 +c cref(j,i)=c(j,i) +c enddo +c enddo + + kkk=1 + lll=0 + cou=1 + do i=1,nres + lll=lll+1 +cc write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) + if (i.gt.1) then + if ((itype(i-1).eq.ntyp1).and.(i.gt.2)) then + chain_length=lll-1 + kkk=kkk+1 +c write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) + lll=1 + endif + endif do j=1,3 - cref(j,i)=c(j,i) + cref(j,i,cou)=c(j,i) + cref(j,i+nres,cou)=c(j,i+nres) + if (i.le.nres) then + chain_rep(j,lll,kkk)=c(j,i) + chain_rep(j,lll+nres,kkk)=c(j,i+nres) + endif + enddo + enddo + do j=1,3 + chain_rep(j,chain_length,symetr)=chain_rep(j,chain_length,1) + chain_rep(j,chain_length+nres,symetr) + &=chain_rep(j,chain_length+nres,1) + enddo + + if (symetr.gt.1) then + call permut(symetr) + nperm=1 + do i=1,symetr + nperm=nperm*i + enddo +c do i=1,nperm +c write(iout,*) "tabperm", (tabperm(i,kkk),kkk=1,4) +c enddo + do i=1,nperm + cou=0 + do kkk=1,symetr + icha=tabperm(i,kkk) +c write (iout,*) i,icha + do lll=1,chain_length + cou=cou+1 + if (cou.le.nres) then + do j=1,3 + kupa=mod(lll,chain_length) + iprzes=(kkk-1)*chain_length+lll + if (kupa.eq.0) kupa=chain_length +c write (iout,*) "kupa", kupa + cref(j,iprzes,i)=chain_rep(j,kupa,icha) + cref(j,iprzes+nres,i)=chain_rep(j,kupa+nres,icha) + enddo + endif + enddo enddo + enddo + endif + +C-koniec robienia kopidm + nperm=0 + do kkk=1,nperm + write (iout,*) "nowa struktura", nperm + do i=1,nres + write (iout,110) restyp(itype(i)),i,cref(1,i,kkk), + &cref(2,i,kkk), + &cref(3,i,kkk),cref(1,nres+i,kkk), + &cref(2,nres+i,kkk),cref(3,nres+i,kkk) enddo + 100 format (//' alpha-carbon coordinates ', + & ' centroid coordinates'/ + 1 ' ', 6X,'X',11X,'Y',11X,'Z', + & 10X,'X',11X,'Y',11X,'Z') + 110 format (a,'(',i3,')',6f12.5) + enddo + ishift_pdb=ishift return @@ -185,7 +295,8 @@ c--------------------------------------------------------------------------- do i=nnt+1,nct iti=itype(i) c write (iout,*) i,dist(i,i-1) - if (dist(i,i-1).lt.2.0D0 .or. dist(i,i-1).gt.5.0D0) then + if ((dist(i,i-1).lt.2.0D0 .or. dist(i,i-1).gt.5.0D0) + &.and.(iti.ne.ntyp1).and.(itype(i-1).ne.ntyp1)) then write (iout,'(a,i4)') 'Bad Cartesians for residue',i stop endif @@ -217,6 +328,95 @@ c write (iout,*) i,dist(i,i-1) endif return end + +c------------------------------------------------------------------------------- + subroutine sc_loc_geom(lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + double precision x_prime(3),y_prime(3),z_prime(3) + logical lprn + do i=1,nres-1 + do j=1,3 + dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i)) + enddo + enddo + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + dc_norm(j,i+nres)=vbld_inv(i+nres)*(c(j,i+nres)-c(j,i)) + enddo + else + do j=1,3 + dc_norm(j,i+nres)=0.0d0 + enddo + endif + enddo + do i=2,nres-1 + costtab(i+1) =dcos(theta(i+1)) + sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) + cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) + sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) + cosfac2=0.5d0/(1.0d0+costtab(i+1)) + cosfac=dsqrt(cosfac2) + sinfac2=0.5d0/(1.0d0-costtab(i+1)) + sinfac=dsqrt(sinfac2) + it=itype(i) + if (it.ne.10 .and. itype(i).ne.ntyp1) then +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + call vecpr(x_prime,y_prime,z_prime) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxref(i)=xx + yyref(i)=yy + zzref(i)=zz + else + xxref(i)=0.0d0 + yyref(i)=0.0d0 + zzref(i)=0.0d0 + endif + enddo + if (lprn) then + do i=2,nres + iti=itype(i) + if(me.eq.king.or..not.out1file) + & write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i), + & yyref(i),zzref(i) + enddo + endif + return + end c--------------------------------------------------------------------------- subroutine sccenter(ires,nscat,sccor) implicit real*8 (a-h,o-z) diff --git a/source/cluster/wham/src-M/readrtns.F b/source/cluster/wham/src-M/readrtns.F index 666754f..1680dab 100644 --- a/source/cluster/wham/src-M/readrtns.F +++ b/source/cluster/wham/src-M/readrtns.F @@ -15,12 +15,14 @@ C include 'COMMON.FFIELD' include 'COMMON.FREE' include 'COMMON.INTERACT' + include "COMMON.SPLITELE" + include 'COMMON.SHIELD' character*320 controlcard,ucase #ifdef MPL include 'COMMON.INFO' #endif - integer i - + integer i,i1,i2,it1,it2 + double precision pi read (INP,'(a80)') titel call card_concat(controlcard) @@ -28,6 +30,50 @@ C call readi(controlcard,'RESCALE',rescale_mode,2) call reada(controlcard,'DISTCHAINMAX',distchainmax,50.0d0) write (iout,*) "DISTCHAINMAX",distchainmax +C Reading the dimensions of box in x,y,z coordinates + call reada(controlcard,'BOXX',boxxsize,100.0d0) + call reada(controlcard,'BOXY',boxysize,100.0d0) + call reada(controlcard,'BOXZ',boxzsize,100.0d0) +c Cutoff range for interactions + call reada(controlcard,"R_CUT",r_cut,15.0d0) + call reada(controlcard,"LAMBDA",rlamb,0.3d0) + call reada(controlcard,"LIPTHICK",lipthick,0.0d0) + call reada(controlcard,"LIPAQBUF",lipbufthick,0.0d0) + if (lipthick.gt.0.0d0) then + bordliptop=(boxzsize+lipthick)/2.0 + bordlipbot=bordliptop-lipthick +C endif + if ((bordliptop.gt.boxzsize).or.(bordlipbot.lt.0.0)) + & write(iout,*) "WARNING WRONG SIZE OF LIPIDIC PHASE" + buflipbot=bordlipbot+lipbufthick + bufliptop=bordliptop-lipbufthick + if ((lipbufthick*2.0d0).gt.lipthick) + &write(iout,*) "WARNING WRONG SIZE OF LIP AQ BUF" + endif + write(iout,*) "bordliptop=",bordliptop + write(iout,*) "bordlipbot=",bordlipbot + write(iout,*) "bufliptop=",bufliptop + write(iout,*) "buflipbot=",buflipbot +C Shielding mode + call readi(controlcard,'SHIELD',shield_mode,0) + write (iout,*) "SHIELD MODE",shield_mode + if (shield_mode.gt.0) then + pi=3.141592d0 +C VSolvSphere the volume of solving sphere +C print *,pi,"pi" +C rpp(1,1) is the energy r0 for peptide group contact and will be used for it +C there will be no distinction between proline peptide group and normal peptide +C group in case of shielding parameters + VSolvSphere=4.0/3.0*pi*rpp(1,1)**3 + VSolvSphere_div=VSolvSphere-4.0/3.0*pi*(rpp(1,1)/2.0)**3 + write (iout,*) VSolvSphere,VSolvSphere_div +C long axis of side chain + do i=1,ntyp + long_r_sidechain(i)=vbldsc0(1,i) + short_r_sidechain(i)=sigma0(i) + enddo + buff_shield=1.0d0 + endif call readi(controlcard,'PDBOUT',outpdb,0) call readi(controlcard,'MOL2OUT',outmol2,0) refstr=(index(controlcard,'REFSTR').gt.0) @@ -35,6 +81,13 @@ C pdbref=(index(controlcard,'PDBREF').gt.0) iscode=index(controlcard,'ONE_LETTER') tree=(index(controlcard,'MAKE_TREE').gt.0) + with_dihed_constr = index(controlcard,"WITH_DIHED_CONSTR").gt.0 + call readi(controlcard,'CONSTR_DIST',constr_dist,0) + write (iout,*) "with_dihed_constr ",with_dihed_constr, + & " CONSTR_DIST",constr_dist + with_theta_constr = index(controlcard,"WITH_THETA_CONSTR").gt.0 + write (iout,*) "with_theta_constr ",with_theta_constr + call flush(iout) min_var=(index(controlcard,'MINVAR').gt.0) plot_tree=(index(controlcard,'PLOT_TREE').gt.0) punch_dist=(index(controlcard,'PUNCH_DIST').gt.0) @@ -64,6 +117,14 @@ C write (iout,*) 'beta_h',(beta_h(i),i=1,nT) lprint_cart=index(controlcard,"PRINT_CART") .gt.0 lprint_int=index(controlcard,"PRINT_INT") .gt.0 + call readi(controlcard,'CONSTR_HOMOL',constr_homology,0) + write (iout,*) "with_homology_constr ",with_dihed_constr, + & " CONSTR_HOMOLOGY",constr_homology + print_homology_restraints= + & index(controlcard,"PRINT_HOMOLOGY_RESTRAINTS").gt.0 + print_contact_map=index(controlcard,"PRINT_CONTACT_MAP").gt.0 + print_homology_models= + & index(controlcard,"PRINT_HOMOLOGY_MODELS").gt.0 if (min_var) iopt=1 return end @@ -87,6 +148,8 @@ C include 'COMMON.CONTROL' include 'COMMON.CONTACTS' include 'COMMON.TIME1' + include 'COMMON.TORCNSTR' + include 'COMMON.SHIELD' #ifdef MPL include 'COMMON.INFO' #endif @@ -96,13 +159,15 @@ C double precision x(maxvar) integer itype_pdb(maxres) logical seq_comp - integer i,j + integer i,j,kkk,i1,i2,it1,it2 C C Body C C Read weights of the subsequent energy terms. call card_concat(weightcard) - call reada(weightcard,'WSC',wsc,1.0d0) + write(iout,*) weightcard +C call reada(weightcard,'WSC',wsc,1.0d0) + write(iout,*) wsc call reada(weightcard,'WLONG',wsc,wsc) call reada(weightcard,'WSCP',wscp,1.0d0) call reada(weightcard,'WELEC',welec,1.0D0) @@ -126,6 +191,54 @@ C Read weights of the subsequent energy terms. call reada(weightcard,'CUTOFF',cutoff_corr,7.0d0) call reada(weightcard,'DELT_CORR',delt_corr,0.5d0) if (index(weightcard,'SOFT').gt.0) ipot=6 + 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) + call reada(weightcard,'WSHIELD',wshield,1.0d0) + write(iout,*) 'WSHIELD',wshield + call reada(weightcard,'WLT',wliptran,0.0D0) + call reada(weightcard,"ATRISS",atriss,0.301D0) + call reada(weightcard,"BTRISS",btriss,0.021D0) + call reada(weightcard,"CTRISS",ctriss,1.001D0) + call reada(weightcard,"DTRISS",dtriss,1.001D0) + write (iout,*) "ATRISS=", atriss + write (iout,*) "BTRISS=", btriss + write (iout,*) "CTRISS=", ctriss + write (iout,*) "DTRISS=", dtriss + dyn_ss=(index(weightcard,'DYN_SS').gt.0) + do i=1,maxres + dyn_ss_mask(i)=.false. + enddo + do i=1,maxres-1 + do j=i+1,maxres + dyn_ssbond_ij(i,j)=1.0d300 + enddo + enddo + call reada(weightcard,"HT",Ht,0.0D0) + if (dyn_ss) then + ss_depth=ebr/wsc-0.25*eps(1,1) + Ht=Ht/wsc-0.25*eps(1,1) + akcm=akcm*wstrain/wsc + akth=akth*wstrain/wsc + akct=akct*wstrain/wsc + v1ss=v1ss*wstrain/wsc + v2ss=v2ss*wstrain/wsc + v3ss=v3ss*wstrain/wsc + else + ss_depth=ebr/wstrain-0.25*eps(1,1)*wsc/wstrain + endif + write (iout,'(/a)') "Disulfide bridge parameters:" + write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr + write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm + write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct + write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss, + & ' v3ss:',v3ss + 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 @@ -206,33 +319,20 @@ C Convert sequence to numeric code do i=1,nres itype(i)=rescode(i,sequence(i),iscode) enddo - if (itype(2).eq.10.and.itype(1).eq.ntyp1) then - write (iout,*) - & "Glycine is the first full residue, initial dummy deleted" - do i=1,nres - itype(i)=itype(i+1) - enddo - nres=nres-1 - endif - if (itype(nres-1).eq.10.and.itype(nres).eq.ntyp1) then - write (iout,*) - & "Glycine is the last full residue, terminal dummy deleted" - nres=nres-1 - endif print *,nres 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 + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) then #else - if (itype(i).eq.21) then + if (itype(i).eq.ntyp1) then #endif itel(i)=0 #ifdef PROCOR - else if (itype(i+1).ne.20) then + else if (iabs(itype(i+1)).ne.20) then #else - else if (itype(i).ne.20) then + else if (iabs(itype(i)).ne.20) then #endif itel(i)=1 else @@ -246,15 +346,79 @@ C Convert sequence to numeric code print *,'Call Read_Bridge.' call read_bridge +C this fragment reads diheadral constrains + if (with_dihed_constr) then + + read (inp,*) ndih_constr + if (ndih_constr.gt.0) then +C read (inp,*) ftors +C write (iout,*) 'FTORS',ftors +C ftors is the force constant for torsional quartic constrains + read (inp,*) (idih_constr(i),phi0(i),drange(i),ftors(i), + & i=1,ndih_constr) + write (iout,*) + & 'There are',ndih_constr,' constraints on phi angles.' + do i=1,ndih_constr + write (iout,'(i5,3f8.3)') idih_constr(i),phi0(i),drange(i), + & ftors(i) + enddo + do i=1,ndih_constr + phi0(i)=deg2rad*phi0(i) + drange(i)=deg2rad*drange(i) + enddo + endif ! endif ndif_constr.gt.0 + endif ! with_dihed_constr + if (with_theta_constr) then +C with_theta_constr is keyword allowing for occurance of theta constrains + read (inp,*) ntheta_constr +C ntheta_constr is the number of theta constrains + if (ntheta_constr.gt.0) then +C read (inp,*) ftors + read (inp,*) (itheta_constr(i),theta_constr0(i), + & theta_drange(i),for_thet_constr(i), + & i=1,ntheta_constr) +C the above code reads from 1 to ntheta_constr +C itheta_constr(i) residue i for which is theta_constr +C theta_constr0 the global minimum value +C theta_drange is range for which there is no energy penalty +C for_thet_constr is the force constant for quartic energy penalty +C E=k*x**4 +C if(me.eq.king.or..not.out1file)then + write (iout,*) + & 'There are',ntheta_constr,' constraints on phi angles.' + do i=1,ntheta_constr + write (iout,'(i5,3f8.3)') itheta_constr(i),theta_constr0(i), + & theta_drange(i), + & for_thet_constr(i) + enddo +C endif + do i=1,ntheta_constr + theta_constr0(i)=deg2rad*theta_constr0(i) + theta_drange(i)=deg2rad*theta_drange(i) + enddo +C if(me.eq.king.or..not.out1file) +C & write (iout,*) 'FTORS',ftors +C do i=1,ntheta_constr +C ii = itheta_constr(i) +C thetabound(1,ii) = phi0(i)-drange(i) +C thetabound(2,ii) = phi0(i)+drange(i) +C enddo + endif ! ntheta_constr.gt.0 + endif! with_theta_constr + nnt=1 nct=nres print *,'NNT=',NNT,' NCT=',NCT - if (itype(1).eq.21) nnt=2 - if (itype(nres).eq.21) nct=nct-1 + if (itype(1).eq.ntyp1) nnt=2 + if (itype(nres).eq.ntyp1) nct=nct-1 if (nstart.lt.nnt) nstart=nnt if (nend.gt.nct .or. nend.eq.0) nend=nct write (iout,*) "nstart",nstart," nend",nend nres0=nres + if (constr_homology.gt.0) then + call read_constr_homology(print_homology_restraints) + endif + c if (pdbref) then c read(inp,'(a)') pdbfile c write (iout,'(2a)') 'PDB data will be read from file ',pdbfile @@ -316,14 +480,54 @@ c endif nstart_sup=nnt nstart_seq=nnt nsup=nct-nnt+1 + kkk=1 do i=1,2*nres do j=1,3 - cref(j,i)=c(j,i) + cref(j,i,kkk)=c(j,i) enddo enddo endif call contact(.true.,ncont_ref,icont_ref) endif + if (ns.gt.0) then +C write (iout,'(/a,i3,a)') +C & 'The chain contains',ns,' disulfide-bridging cysteines.' + write (iout,'(20i4)') (iss(i),i=1,ns) + if (dyn_ss) then + write(iout,*)"Running with dynamic disulfide-bond formation" + else + 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) + 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 + endif + if (ns.gt.0.and.dyn_ss) then + do i=nss+1,nhpb + ihpb(i-nss)=ihpb(i) + jhpb(i-nss)=jhpb(i) + forcon(i-nss)=forcon(i) + dhpb(i-nss)=dhpb(i) + enddo + nhpb=nhpb-nss + nss=0 + call hpb_partition + do i=1,ns + dyn_ss_mask(iss(i))=.true. + enddo + endif +c Read distance restraints + if (constr_dist.gt.0) then + call read_dist_constr + call hpb_partition + endif return end c----------------------------------------------------------------------------- @@ -368,10 +572,12 @@ C Check whether the specified bridging residues are cystines. do i=1,ns if (itype(iss(i)).ne.1) then write (iout,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, + & 'Do you REALLY think that the residue ', + & restyp(itype(iss(i))),i, & ' can form a disulfide bridge?!!!' write (*,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, + & 'Do you REALLY think that the residue ', + & restyp(itype(iss(i))),i, & ' can form a disulfide bridge?!!!' #ifdef MPL call mp_stopall(error_msg) @@ -412,8 +618,8 @@ C bridging residues. enddo write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' 20 continue - dhpb(i)=dbr - forcon(i)=fbr +C dhpb(i)=dbr +C forcon(i)=fbr enddo do i=1,nss ihpb(i)=ihpb(i)+nres @@ -494,6 +700,25 @@ c---------------------------------------------------------------------------- read (rekord(iread:),*) wartosc 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 card_concat(card) include 'DIMENSIONS' @@ -585,6 +810,8 @@ C Get parameter filenames and open the parameter files. open (isidep1,file=sidepname,status="old") call getenv('SCCORPAR',sccorname) open (isccor,file=sccorname,status="old") + call getenv('LIPTRANPAR',liptranname) + open (iliptranpar,file=liptranname,status='old') #ifndef OLDSCP C C 8/9/01 In the newest version SCp interaction constants are read from a file @@ -595,3 +822,574 @@ C #endif return end + subroutine read_dist_constr + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + 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 + logical lprn /.true./ + write (iout,*) "Calling read_dist_constr" +C write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup +C call flush(iout) + write(iout,*) "TU sie wywalam?" + call card_concat(controlcard) + write (iout,*) controlcard + call flush(iout) + 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) + write (iout,*) "NFRAG",nfrag_," NPAIR",npair_," NDIST",ndist_ + write (iout,*) "IFRAG" + do i=1,nfrag_ + write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) + enddo + write (iout,*) "IPAIR" + do i=1,npair_ + write (iout,*) i,ipair_(1,i),ipair_(2,i),wpair_(i) + 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 + if (lprn) + & write (iout,'(a,3i5,f8.2,1pe12.2)') "+dist.constr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) + 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) + write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) + enddo + enddo + endif + enddo + do i=1,ndist_ + if (constr_dist.eq.11) then + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(i),dhpb1(i), + & ibecarb(i),forcon(nhpb+1),fordepth(nhpb+1) + fordepth(nhpb+1)=fordepth(nhpb+1)/forcon(nhpb+1) +C write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", +C & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) + else + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1) + endif + if (forcon(nhpb+1).gt.0.0d0) then + nhpb=nhpb+1 + if (ibecarb(i).gt.0) then + ihpb(i)=ihpb(i)+nres + jhpb(i)=jhpb(i)+nres + endif + if (dhpb(nhpb).eq.0.0d0) + & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) +C dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) + write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", + & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) + endif +C endif + enddo + call hpb_partition +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif + return + end + +c====------------------------------------------------------------------- + subroutine read_constr_homology(lprn) + + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.HOMRESTR' +c +c For new homol impl +c + include 'COMMON.VAR' +c include 'include_unres/COMMON.VAR' +c + +c double precision odl_temp,sigma_odl_temp,waga_theta,waga_d, +c & dist_cut +c common /przechowalnia/ odl_temp(maxres,maxres,max_template), +c & sigma_odl_temp(maxres,maxres,max_template) + character*2 kic2 + character*24 model_ki_dist, model_ki_angle + character*500 controlcard + integer ki, i, j, k, l, ii_in_use(maxdim),i_tmp,idomain_tmp + integer idomain(max_template,maxres) + integer ilen + external ilen + logical lprn + logical unres_pdb +c +c FP - Nov. 2014 Temporary specifications for new vars +c + double precision rescore_tmp,x12,y12,z12,rescore2_tmp + double precision, dimension (max_template,maxres) :: rescore + double precision, dimension (max_template,maxres) :: rescore2 + character*24 tpl_k_rescore +c ----------------------------------------------------------------- +c Reading multiple PDB ref structures and calculation of retraints +c not using pre-computed ones stored in files model_ki_{dist,angle} +c FP (Nov., 2014) +c ----------------------------------------------------------------- +c +c +c Alternative: reading from input +#ifdef DEBUG + write (iout,*) "BEGIN READ HOMOLOGY INFO" +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif +#endif + call card_concat(controlcard) + call reada(controlcard,"HOMOL_DIST",waga_dist,1.0d0) + call reada(controlcard,"HOMOL_ANGLE",waga_angle,1.0d0) + call reada(controlcard,"HOMOL_THETA",waga_theta,1.0d0) ! new + call reada(controlcard,"HOMOL_SCD",waga_d,1.0d0) ! new + call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) ! for diff ways of calc sigma + call reada(controlcard,'DIST2_CUT',dist2_cut,9999.0d0) + call readi(controlcard,"HOMOL_NSET",homol_nset,1) + read2sigma=(index(controlcard,'READ2SIGMA').gt.0) + if (homol_nset.gt.1)then + call readi(controlcard,"ISET",iset,1) + call card_concat(controlcard) + read(controlcard,*) (waga_homology(i),i=1,homol_nset) + else + iset=1 + waga_homology(1)=1.0 + endif +c +#ifdef DEBUG + write(iout,*) "read_constr_homology iset",iset + write(iout,*) "waga_homology(",iset,")",waga_homology(iset) +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif +#endif +cd write (iout,*) "nnt",nnt," nct",nct +cd call flush(iout) + + + lim_odl=0 + lim_dih=0 +c +c New +c + lim_theta=0 + lim_xx=0 +c +c Reading HM global scores (prob not required) +c + do i = nnt,nct + do k=1,constr_homology + idomain(k,i)=0 + enddo + enddo +c open (4,file="HMscore") +c do k=1,constr_homology +c read (4,*,end=521) hmscore_tmp +c hmscore(k)=hmscore_tmp ! Another transformation can be used +c write(*,*) "Model", k, ":", hmscore(k) +c enddo +c521 continue + + ii=0 + do i = nnt,nct-2 + do j=i+2,nct + ii=ii+1 + ii_in_use(ii)=0 + enddo + enddo +c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d + + write (iout,*) "CONSTR_HOMOLOGY",constr_homology + do k=1,constr_homology + + read(inp,'(a)') pdbfile +c write (iout,*) "k ",k," pdbfile ",pdbfile +c Next stament causes error upon compilation (?) +c if(me.eq.king.or. .not. out1file) +c write (iout,'(2a)') 'PDB data will be read from file ', +c & pdbfile(:ilen(pdbfile)) + write (iout,'(a,5x,a)') 'HOMOL: Opening PDB file', + & pdbfile(:ilen(pdbfile)) + open(ipdbin,file=pdbfile,status='old',err=33) + goto 34 + 33 write (iout,'(a,5x,a)') 'Error opening PDB file', + & pdbfile(:ilen(pdbfile)) + stop + 34 continue +c print *,'Begin reading pdb data' +c +c Files containing res sim or local scores (former containing sigmas) +c + + write(kic2,'(bz,i2.2)') k + + tpl_k_rescore="template"//kic2//".sco" + + unres_pdb=.false. + call readpdb + do i=1,2*nres + do j=1,3 + crefjlee(j,i)=c(j,i) + enddo + enddo +#ifdef DEBUG + do i=1,nres + write (iout,'(i5,3f8.3,5x,3f8.3)') i,(crefjlee(j,i),j=1,3), + & (crefjlee(j,i+nres),j=1,3) + enddo + write (iout,*) "READ HOMOLOGY INFO" + write (iout,*) "read_constr_homology x: after reading pdb file" + write (iout,*) "waga_homology(",iset,")",waga_homology(iset) + write (iout,*) "waga_dist",waga_dist + write (iout,*) "waga_angle",waga_angle + write (iout,*) "waga_theta",waga_theta + write (iout,*) "waga_d",waga_d + write (iout,*) "dist_cut",dist_cut +#endif +#ifdef AIX + call flush_(iout) +#else + call flush(iout) +#endif + +c +c Distance restraints +c +c ... --> odl(k,ii) +C Copy the coordinates from reference coordinates (?) + do i=1,2*nres + do j=1,3 +c c(j,i)=cref(j,i) +c write (iout,*) "c(",j,i,") =",c(j,i) + enddo + enddo +c +c From read_dist_constr (commented out 25/11/2014 <-> res sim) +c +c write(iout,*) "tpl_k_rescore - ",tpl_k_rescore + open (ientin,file=tpl_k_rescore,status='old') + if (nnt.gt.1) rescore(k,1)=0.0d0 + do irec=nnt,maxdim ! loop for reading res sim + if (read2sigma) then + read (ientin,*,end=1401) i_tmp,rescore2_tmp,rescore_tmp, + & idomain_tmp + i_tmp=i_tmp+nnt-1 + idomain(k,i_tmp)=idomain_tmp + rescore(k,i_tmp)=rescore_tmp + rescore2(k,i_tmp)=rescore2_tmp + else + idomain(k,irec)=1 + read (ientin,*,end=1401) rescore_tmp + +c rescore(k,irec)=rescore_tmp+1.0d0 ! to avoid 0 values + rescore(k,irec)=0.5d0*(rescore_tmp+0.5d0) ! alt transf to reduce scores +c write(iout,*) "rescore(",k,irec,") =",rescore(k,irec) + endif + enddo + 1401 continue + close (ientin) + if (waga_dist.ne.0.0d0) then + ii=0 + do i = nnt,nct-2 + do j=i+2,nct + + x12=c(1,i)-c(1,j) + y12=c(2,i)-c(2,j) + z12=c(3,i)-c(3,j) + distal=dsqrt(x12*x12+y12*y12+z12*z12) +c write (iout,*) k,i,j,distal,dist2_cut + + if (idomain(k,i).eq.idomain(k,j).and.idomain(k,i).ne.0 + & .and. distal.le.dist2_cut ) then + + ii=ii+1 + ii_in_use(ii)=1 + l_homo(k,ii)=.true. + +c write (iout,*) "k",k +c write (iout,*) "i",i," j",j," constr_homology", +c & constr_homology + ires_homo(ii)=i + jres_homo(ii)=j + odl(k,ii)=distal + if (read2sigma) then + sigma_odl(k,ii)=0 + do ik=i,j + sigma_odl(k,ii)=sigma_odl(k,ii)+rescore2(k,ik) + enddo + sigma_odl(k,ii)=sigma_odl(k,ii)/(j-i+1) + if (odl(k,ii).gt.dist_cut) sigma_odl(k,ii) = + & sigma_odl(k,ii)*dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) + else + if (odl(k,ii).le.dist_cut) then + sigma_odl(k,ii)=rescore(k,i)+rescore(k,j) + else +#ifdef OLDSIGMA + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2) +#else + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) +#endif + endif + endif + sigma_odl(k,ii)=1.0d0/(sigma_odl(k,ii)*sigma_odl(k,ii)) + else + ii=ii+1 + l_homo(k,ii)=.false. + endif + enddo + enddo + lim_odl=ii + endif +c +c Theta, dihedral and SC retraints +c + if (waga_angle.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_dih,status='old') +c do irec=1,maxres-3 ! loop for reading sigma_dih +c read (ientin,*,end=1402) i,j,ki,l,sigma_dih(k,i+nnt-1) ! j,ki,l what for? +c if (i+nnt-1.gt.lim_dih) lim_dih=i+nnt-1 ! right? +c sigma_dih(k,i+nnt-1)=sigma_dih(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_dih(k,i+nnt-1) +c enddo +c1402 continue +c close (ientin) + do i = nnt+3,nct + if (idomain(k,i).eq.0) then + sigma_dih(k,i)=0.0 + cycle + endif + dih(k,i)=phiref(i) ! right? +c read (ientin,*) sigma_dih(k,i) ! original variant +c write (iout,*) "dih(",k,i,") =",dih(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i), +c & "rescore(",k,i-1,") =",rescore(k,i-1), +c & "rescore(",k,i-2,") =",rescore(k,i-2), +c & "rescore(",k,i-3,") =",rescore(k,i-3) + + sigma_dih(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2)+rescore(k,i-3))/4.0 +c if (read2sigma) sigma_dih(k,i)=sigma_dih(k,i)/4.0 +c write (iout,*) "Raw sigmas for dihedral angle restraints" +c write (iout,'(i5,10(2f8.2,4x))') i,sigma_dih(k,i) +c sigma_dih(k,i)=hmscore(k)*rescore(k,i)*rescore(k,i-1)* +c rescore(k,i-2)*rescore(k,i-3) ! right expression ? +c Instead of res sim other local measure of b/b str reliability possible + sigma_dih(k,i)=1.0d0/(sigma_dih(k,i)*sigma_dih(k,i)) +c sigma_dih(k,i)=sigma_dih(k,i)*sigma_dih(k,i) + enddo + lim_dih=nct-nnt-2 + endif + + if (waga_theta.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_theta,status='old') +c do irec=1,maxres-2 ! loop for reading sigma_theta, right bounds? +c read (ientin,*,end=1403) i,j,ki,sigma_theta(k,i+nnt-1) ! j,ki what for? +c sigma_theta(k,i+nnt-1)=sigma_theta(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_theta(k,i+nnt-1) +c enddo +c1403 continue +c close (ientin) + + do i = nnt+2,nct ! right? without parallel. +c do i = i=1,nres ! alternative for bounds acc to readpdb? +c do i=ithet_start,ithet_end ! with FG parallel. + if (idomain(k,i).eq.0) then + sigma_theta(k,i)=0.0 + cycle + endif + thetatpl(k,i)=thetaref(i) +c write (iout,*) "thetatpl(",k,i,") =",thetatpl(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i), +c & "rescore(",k,i-1,") =",rescore(k,i-1), +c & "rescore(",k,i-2,") =",rescore(k,i-2) +c read (ientin,*) sigma_theta(k,i) ! 1st variant + sigma_theta(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2))/3.0 +c if (read2sigma) sigma_theta(k,i)=sigma_theta(k,i)/3.0 + sigma_theta(k,i)=1.0d0/(sigma_theta(k,i)*sigma_theta(k,i)) + +c sigma_theta(k,i)=hmscore(k)*rescore(k,i)*rescore(k,i-1)* +c rescore(k,i-2) ! right expression ? +c sigma_theta(k,i)=sigma_theta(k,i)*sigma_theta(k,i) + enddo + endif + lim_theta=nct-nnt-1 + + if (waga_d.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_d,status='old') +c do irec=1,maxres-1 ! loop for reading sigma_theta, right bounds? +c read (ientin,*,end=1404) i,j,sigma_d(k,i+nnt-1) ! j,ki what for? +c sigma_d(k,i+nnt-1)=sigma_d(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_d(k,i+nnt-1) +c enddo +c1404 continue + + do i = nnt,nct ! right? without parallel. +c do i=2,nres-1 ! alternative for bounds acc to readpdb? +c do i=loc_start,loc_end ! with FG parallel. + if (itype(i).eq.10) cycle + if (idomain(k,i).eq.0 ) then + sigma_d(k,i)=0.0 + cycle + endif + xxtpl(k,i)=xxref(i) + yytpl(k,i)=yyref(i) + zztpl(k,i)=zzref(i) +c write (iout,*) "xxtpl(",k,i,") =",xxtpl(k,i) +c write (iout,*) "yytpl(",k,i,") =",yytpl(k,i) +c write (iout,*) "zztpl(",k,i,") =",zztpl(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i) + sigma_d(k,i)=rescore(k,i) ! right expression ? + sigma_d(k,i)=1.0d0/(sigma_d(k,i)*sigma_d(k,i)) + +c sigma_d(k,i)=hmscore(k)*rescore(k,i) ! right expression ? +c sigma_d(k,i)=sigma_d(k,i)*sigma_d(k,i) +c read (ientin,*) sigma_d(k,i) ! 1st variant + if (i-nnt+1.gt.lim_xx) lim_xx=i-nnt+1 ! right? + enddo + lim_xx=nct-nnt+1 + endif + enddo +c +c remove distance restraints not used in any model from the list +c shift data in all arrays +c + if (waga_dist.ne.0.0d0) then + ii=0 + do i=nnt,nct-2 + do j=i+2,nct + ii=ii+1 + if (ii_in_use(ii).eq.0) then + do ki=ii,lim_odl-1 + ires_homo(ki)=ires_homo(ki+1) + jres_homo(ki)=jres_homo(ki+1) + ii_in_use(ki)=ii_in_use(ki+1) + do k=1,constr_homology + odl(k,ki)=odl(k,ki+1) + sigma_odl(k,ki)=sigma_odl(k,ki+1) + l_homo(k,ki)=l_homo(k,ki+1) + enddo + enddo + ii=ii-1 + lim_odl=lim_odl-1 + endif + enddo + enddo + endif + if (constr_homology.gt.0) call homology_partition + if (constr_homology.gt.0) call init_int_table +cd write (iout,*) "homology_partition: lim_theta= ",lim_theta, +cd & "lim_xx=",lim_xx +c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +c +c Print restraints +c + if (.not.lprn) return +cd write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d + if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then + write (iout,*) "Distance restraints from templates" + do ii=1,lim_odl + write(iout,'(3i5,100(2f8.2,1x,l1,4x))') + & ii,ires_homo(ii),jres_homo(ii), + & (odl(ki,ii),1.0d0/dsqrt(sigma_odl(ki,ii)),l_homo(ki,ii), + & ki=1,constr_homology) + enddo + write (iout,*) "Dihedral angle restraints from templates" + do i=nnt+3,lim_dih + write (iout,'(i5,100(2f8.2,4x))') i,(rad2deg*dih(ki,i), + & rad2deg/dsqrt(sigma_dih(ki,i)),ki=1,constr_homology) + enddo + write (iout,*) "Virtual-bond angle restraints from templates" + do i=nnt+2,lim_theta + write (iout,'(i5,100(2f8.2,4x))') i,(rad2deg*thetatpl(ki,i), + & rad2deg/dsqrt(sigma_theta(ki,i)),ki=1,constr_homology) + enddo + write (iout,*) "SC restraints from templates" + do i=nnt,lim_xx + write(iout,'(i5,100(4f8.2,4x))') i, + & (xxtpl(ki,i),yytpl(ki,i),zztpl(ki,i), + & 1.0d0/dsqrt(sigma_d(ki,i)),ki=1,constr_homology) + enddo + endif +c ----------------------------------------------------------------- + return + end diff --git a/source/cluster/wham/src-M/rescode.f b/source/cluster/wham/src-M/rescode.f index ca0305c..fb68350 100644 --- a/source/cluster/wham/src-M/rescode.f +++ b/source/cluster/wham/src-M/rescode.f @@ -6,7 +6,7 @@ if (itype.eq.0) then - do i=1,ntyp1 + do i=-ntyp1,ntyp1 if (ucase(nam).eq.restyp(i)) then rescode=i return @@ -15,7 +15,7 @@ else - do i=1,ntyp1 + do i=-ntyp1,ntyp1 if (nam(1:1).eq.onelet(i)) then rescode=i return diff --git a/source/cluster/wham/src-M/ssMD.F b/source/cluster/wham/src-M/ssMD.F new file mode 100644 index 0000000..42983f8 --- /dev/null +++ b/source/cluster/wham/src-M/ssMD.F @@ -0,0 +1,2173 @@ +c---------------------------------------------------------------------------- + subroutine check_energies +c implicit none + +c Includes + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + +c External functions + double precision ran_number + external ran_number + +c Local variables + integer i,j,k,l,lmax,p,pmax + double precision rmin,rmax + double precision eij + + double precision d + double precision wi,rij,tj,pj + + +c return + + i=5 + j=14 + + d=dsc(1) + rmin=2.0D0 + rmax=12.0D0 + + lmax=10000 + pmax=1 + + do k=1,3 + c(k,i)=0.0D0 + c(k,j)=0.0D0 + c(k,nres+i)=0.0D0 + c(k,nres+j)=0.0D0 + enddo + + do l=1,lmax + +ct wi=ran_number(0.0D0,pi) +c wi=ran_number(0.0D0,pi/6.0D0) +c wi=0.0D0 +ct tj=ran_number(0.0D0,pi) +ct pj=ran_number(0.0D0,pi) +c pj=ran_number(0.0D0,pi/6.0D0) +c pj=0.0D0 + + do p=1,pmax +ct rij=ran_number(rmin,rmax) + + c(1,j)=d*sin(pj)*cos(tj) + c(2,j)=d*sin(pj)*sin(tj) + c(3,j)=d*cos(pj) + + c(3,nres+i)=-rij + + c(1,i)=d*sin(wi) + c(3,i)=-rij-d*cos(wi) + + do k=1,3 + dc(k,nres+i)=c(k,nres+i)-c(k,i) + dc_norm(k,nres+i)=dc(k,nres+i)/d + dc(k,nres+j)=c(k,nres+j)-c(k,j) + dc_norm(k,nres+j)=dc(k,nres+j)/d + enddo + + call dyn_ssbond_ene(i,j,eij) + enddo + enddo + + call exit(1) + + return + end + +C----------------------------------------------------------------------------- + + subroutine dyn_ssbond_ene(resi,resj,eij) +c implicit none + +c Includes + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' +#ifndef CLUST +#ifndef WHAM +C include 'COMMON.MD' +#endif +#endif + +c External functions + double precision h_base + external h_base + +c Input arguments + integer resi,resj + +c Output arguments + double precision eij + +c Local variables + logical havebond +c integer itypi,itypj,k,l + double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi + double precision sig0ij,ljd,sig,fac,e1,e2 + double precision dcosom1(3),dcosom2(3),ed + double precision pom1,pom2 + double precision ljA,ljB,ljXs + double precision d_ljB(1:3) + double precision ssA,ssB,ssC,ssXs + double precision ssxm,ljxm,ssm,ljm + double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3) + double precision f1,f2,h1,h2,hd1,hd2 + double precision omega,delta_inv,deltasq_inv,fac1,fac2 +c-------FIRST METHOD + double precision xm,d_xm(1:3) +c-------END FIRST METHOD +c-------SECOND METHOD +c$$$ double precision ss,d_ss(0:3),ljf,d_ljf(0:3) +c-------END SECOND METHOD + +c-------TESTING CODE + logical checkstop,transgrad + common /sschecks/ checkstop,transgrad + + integer icheck,nicheck,jcheck,njcheck + double precision echeck(-1:1),deps,ssx0,ljx0 +c-------END TESTING CODE + + + i=resi + j=resj + + itypi=itype(i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=vbld_inv(i+nres) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + xi=dmod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=dmod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=dmod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize +C define scaling factor for lipids + +C if (positi.le.0) positi=positi+boxzsize +C print *,i +C first for peptide groups +c for each residue check if it is in lipid or lipid water border area + if ((zi.gt.bordlipbot) + &.and.(zi.lt.bordliptop)) then +C the energy transfer exist + if (zi.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipi=sscalelip(fracinbuf) + ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick + elseif (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) + sslipi=sscalelip(fracinbuf) + ssgradlipi=sscagradlip(fracinbuf)/lipbufthick + else + sslipi=1.0d0 + ssgradlipi=0.0 + endif + else + sslipi=0.0d0 + ssgradlipi=0.0 + endif + + itypj=itype(j) + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) + xj=dmod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=dmod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=dmod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + if ((zj.gt.bordlipbot) + &.and.(zj.lt.bordliptop)) then +C the energy transfer exist + if (zj.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((positi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipj=sscalelip(fracinbuf) + ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick + elseif (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) + sslipj=sscalelip(fracinbuf) + ssgradlipj=sscagradlip(fracinbuf)/lipbufthick + else + sslipj=1.0d0 + ssgradlipj=0.0 + endif + else + sslipj=0.0d0 + ssgradlipj=0.0 + endif + aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +aa_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +bb_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + subchap=1 + endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif + + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + dscj_inv=vbld_inv(j+nres) + + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse +c The following are set in sc_angular +c erij(1)=xj*rij +c erij(2)=yj*rij +c erij(3)=zj*rij +c om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) +c om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) +c om12=dxi*dxj+dyi*dyj+dzi*dzj + call sc_angular + rij=1.0D0/rij ! Reset this so it makes sense + + sig0ij=sigma(itypi,itypj) + sig=sig0ij*dsqrt(1.0D0/sigsq) + + ljXs=sig-sig0ij + ljA=eps1*eps2rt**2*eps3rt**2 + ljB=ljA*bb + ljA=ljA*aa + ljxm=ljXs+(-2.0D0*aa/bb)**(1.0D0/6.0D0) + + ssXs=d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + ssA=akcm + ssB=akct*deltat12 + ssC=ss_depth + & +akth*(deltat1*deltat1+deltat2*deltat2) + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi + ssxm=ssXs-0.5D0*ssB/ssA + +c-------TESTING CODE +c$$$c Some extra output +c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +c$$$ ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) +c$$$ ssx0=ssB*ssB-4.0d0*ssA*ssC +c$$$ if (ssx0.gt.0.0d0) then +c$$$ ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA +c$$$ else +c$$$ ssx0=ssxm +c$$$ endif +c$$$ ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ", +c$$$ & ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12 +c$$$ return +c-------END TESTING CODE + +c-------TESTING CODE +c Stop and plot energy and derivative as a function of distance + if (checkstop) then + ssm=ssC-0.25D0*ssB*ssB/ssA + ljm=-0.25D0*ljB*bb/aa + if (ssm.lt.ljm .and. + & dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then + nicheck=1000 + njcheck=1 + deps=0.5d-7 + else + checkstop=.false. + endif + endif + if (.not.checkstop) then + nicheck=0 + njcheck=-1 + endif + + do icheck=0,nicheck + do jcheck=-1,njcheck + if (checkstop) rij=(ssxm-1.0d0)+ + & ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps +c-------END TESTING CODE + + if (rij.gt.ljxm) then + havebond=.false. + ljd=rij-ljXs + fac=(1.0D0/ljd)**expon + e1=fac*fac*aa + e2=fac*bb + eij=eps1*eps2rt*eps3rt*(e1+e2) +C write(iout,*) eij,'TU?1' + eps2der=eij*eps3rt + eps3der=eij*eps2rt + eij=eij*eps2rt*eps3rt + + sigder=-sig/sigsq + e1=e1*eps1*eps2rt**2*eps3rt**2 + ed=-expon*(e1+eij)/ljd + sigder=ed*sigder + eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 + eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 + eom12=eij*eps1_om12+eps2der*eps2rt_om12 + & -2.0D0*alf12*eps3der+sigder*sigsq_om12 + else if (rij.lt.ssxm) then + havebond=.true. + ssd=rij-ssXs + eij=ssA*ssd*ssd+ssB*ssd+ssC +C write(iout,*) 'TU?2',ssc,ssd + ed=2*akcm*ssd+akct*deltat12 + pom1=akct*ssd + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + else + omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi + + d_ssxm(1)=0.5D0*akct/ssA + d_ssxm(2)=-d_ssxm(1) + d_ssxm(3)=0.0D0 + + d_ljxm(1)=sig0ij/sqrt(sigsq**3) + d_ljxm(2)=d_ljxm(1)*sigsq_om2 + d_ljxm(3)=d_ljxm(1)*sigsq_om12 + d_ljxm(1)=d_ljxm(1)*sigsq_om1 + +c-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + xm=0.5d0*(ssxm+ljxm) + do k=1,3 + d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k)) + enddo + if (rij.lt.xm) then + havebond=.true. + ssm=ssC-0.25D0*ssB*ssB/ssA + d_ssm(1)=0.5D0*akct*ssB/ssA + d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) + d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) + d_ssm(3)=omega + f1=(rij-xm)/(ssxm-xm) + f2=(rij-ssxm)/(xm-ssxm) + h1=h_base(f1,hd1) + h2=h_base(f2,hd2) + eij=ssm*h1+Ht*h2 +C write(iout,*) eij,'TU?3' + delta_inv=1.0d0/(xm-ssxm) + deltasq_inv=delta_inv*delta_inv + fac=ssm*hd1-Ht*hd2 + fac1=deltasq_inv*fac*(xm-rij) + fac2=deltasq_inv*fac*(rij-ssxm) + ed=delta_inv*(Ht*hd2-ssm*hd1) + eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1) + eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2) + eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3) + else + havebond=.false. + ljm=-0.25D0*ljB*bb/aa + d_ljm(1)=-0.5D0*bb/aa*ljB + d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt) + d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- + + alf12/eps3rt) + d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt) + f1=(rij-ljxm)/(xm-ljxm) + f2=(rij-xm)/(ljxm-xm) + h1=h_base(f1,hd1) + h2=h_base(f2,hd2) + eij=Ht*h1+ljm*h2 +C write(iout,*) 'TU?4',ssA + delta_inv=1.0d0/(ljxm-xm) + deltasq_inv=delta_inv*delta_inv + fac=Ht*hd1-ljm*hd2 + fac1=deltasq_inv*fac*(ljxm-rij) + fac2=deltasq_inv*fac*(rij-xm) + ed=delta_inv*(ljm*hd2-Ht*hd1) + eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1) + eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2) + eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3) + endif +c-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + +c-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE +c$$$ ssd=rij-ssXs +c$$$ ljd=rij-ljXs +c$$$ fac1=rij-ljxm +c$$$ fac2=rij-ssxm +c$$$ +c$$$ d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt) +c$$$ d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt) +c$$$ d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt) +c$$$ +c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +c$$$ d_ssm(1)=0.5D0*akct*ssB/ssA +c$$$ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) +c$$$ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) +c$$$ d_ssm(3)=omega +c$$$ +c$$$ ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj) +c$$$ do k=1,3 +c$$$ d_ljm(k)=ljm*d_ljB(k) +c$$$ enddo +c$$$ ljm=ljm*ljB +c$$$ +c$$$ ss=ssA*ssd*ssd+ssB*ssd+ssC +c$$$ d_ss(0)=2.0d0*ssA*ssd+ssB +c$$$ d_ss(2)=akct*ssd +c$$$ d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega +c$$$ d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega +c$$$ d_ss(3)=omega +c$$$ +c$$$ ljf=bb(itypi,itypj)/aa(itypi,itypj) +c$$$ ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0) +c$$$ d_ljf(0)=ljf*2.0d0*ljB*fac1 +c$$$ do k=1,3 +c$$$ d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1- +c$$$ & 2.0d0*ljB*fac1*d_ljxm(k)) +c$$$ enddo +c$$$ ljf=ljm+ljf*ljB*fac1*fac1 +c$$$ +c$$$ f1=(rij-ljxm)/(ssxm-ljxm) +c$$$ f2=(rij-ssxm)/(ljxm-ssxm) +c$$$ h1=h_base(f1,hd1) +c$$$ h2=h_base(f2,hd2) +c$$$ eij=ss*h1+ljf*h2 +c$$$ delta_inv=1.0d0/(ljxm-ssxm) +c$$$ deltasq_inv=delta_inv*delta_inv +c$$$ fac=ljf*hd2-ss*hd1 +c$$$ ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac +c$$$ eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(1)-fac2*(d_ljxm(1))) +c$$$ eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(2)-fac2*(d_ljxm(2))) +c$$$ eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(3)-fac2*(d_ljxm(3))) +c$$$ +c$$$ havebond=.false. +c$$$ if (ed.gt.0.0d0) havebond=.true. +c-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE + + endif +C write(iout,*) 'havebond',havebond + if (havebond) then +#ifndef CLUST +#ifndef WHAM +c if (dyn_ssbond_ij(i,j).eq.1.0d300) then +c write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_E_FORM",totT,t_bath,i,j +c endif +#endif +#endif + dyn_ssbond_ij(i,j)=eij + else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then + dyn_ssbond_ij(i,j)=1.0d300 +#ifndef CLUST +#ifndef WHAM +c write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_E_BREAK",totT,t_bath,i,j +#endif +#endif + endif + +c-------TESTING CODE + if (checkstop) then + if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') + & "CHECKSTOP",rij,eij,ed + echeck(jcheck)=eij + endif + enddo + if (checkstop) then + write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps + endif + enddo + if (checkstop) then + transgrad=.true. + checkstop=.false. + endif +c-------END TESTING CODE + + do k=1,3 + dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij + dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij + enddo + do k=1,3 + gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwx(k,j)=gvdwx(k,j)+gg(k) + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) +cgrad enddo +cgrad enddo + + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo + + return + end + +C----------------------------------------------------------------------------- + + double precision function h_base(x,deriv) +c A smooth function going 0->1 in range [0,1] +c It should NOT be called outside range [0,1], it will not work there. + implicit none + +c Input arguments + double precision x + +c Output arguments + double precision deriv + +c Local variables + double precision xsq + + +c Two parabolas put together. First derivative zero at extrema +c$$$ if (x.lt.0.5D0) then +c$$$ h_base=2.0D0*x*x +c$$$ deriv=4.0D0*x +c$$$ else +c$$$ deriv=1.0D0-x +c$$$ h_base=1.0D0-2.0D0*deriv*deriv +c$$$ deriv=4.0D0*deriv +c$$$ endif + +c Third degree polynomial. First derivative zero at extrema + h_base=x*x*(3.0d0-2.0d0*x) + deriv=6.0d0*x*(1.0d0-x) + +c Fifth degree polynomial. First and second derivatives zero at extrema +c$$$ xsq=x*x +c$$$ h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0) +c$$$ deriv=x-1.0d0 +c$$$ deriv=deriv*deriv +c$$$ deriv=30.0d0*xsq*deriv + + return + end + +c---------------------------------------------------------------------------- + + subroutine dyn_set_nss +c Adjust nss and other relevant variables based on dyn_ssbond_ij +c implicit none + +c Includes + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' +C include 'COMMON.SETUP' +#ifndef CLUST +#ifndef WHAM +C include 'COMMON.MD' +#endif +#endif + +c Local variables + double precision emin + integer i,j,imin + integer diff,allflag(maxdim),allnss, + & allihpb(maxdim),alljhpb(maxdim), + & newnss,newihpb(maxdim),newjhpb(maxdim) + logical found + integer i_newnss(1024),displ(0:1024) + integer g_newihpb(maxdim),g_newjhpb(maxdim),g_newnss + + allnss=0 + do i=1,nres-1 + do j=i+1,nres + if (dyn_ssbond_ij(i,j).lt.1.0d300) then + allnss=allnss+1 + allflag(allnss)=0 + allihpb(allnss)=i + alljhpb(allnss)=j + endif + enddo + enddo + +cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + 1 emin=1.0d300 + do i=1,allnss + if (allflag(i).eq.0 .and. + & dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then + emin=dyn_ssbond_ij(allihpb(i),alljhpb(i)) + imin=i + endif + enddo + if (emin.lt.1.0d300) then + allflag(imin)=1 + do i=1,allnss + if (allflag(i).eq.0 .and. + & (allihpb(i).eq.allihpb(imin) .or. + & alljhpb(i).eq.allihpb(imin) .or. + & allihpb(i).eq.alljhpb(imin) .or. + & alljhpb(i).eq.alljhpb(imin))) then + allflag(i)=-1 + endif + enddo + goto 1 + endif + +cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + newnss=0 + do i=1,allnss + if (allflag(i).eq.1) then + newnss=newnss+1 + newihpb(newnss)=allihpb(i) + newjhpb(newnss)=alljhpb(i) + endif + enddo + +#ifdef MPI + if (nfgtasks.gt.1)then + + call MPI_Reduce(newnss,g_newnss,1, + & MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) + call MPI_Gather(newnss,1,MPI_INTEGER, + & i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_newnss(i-1)+displ(i-1) + enddo + call MPI_Gatherv(newihpb,newnss,MPI_INTEGER, + & g_newihpb,i_newnss,displ,MPI_INTEGER, + & king,FG_COMM,IERR) + call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER, + & g_newjhpb,i_newnss,displ,MPI_INTEGER, + & king,FG_COMM,IERR) + if(fg_rank.eq.0) then +c print *,'g_newnss',g_newnss +c print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss) +c print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss) + newnss=g_newnss + do i=1,newnss + newihpb(i)=g_newihpb(i) + newjhpb(i)=g_newjhpb(i) + enddo + endif + endif +#endif + + diff=newnss-nss + +cmc write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss) + + do i=1,nss + found=.false. + do j=1,newnss + if (idssb(i).eq.newihpb(j) .and. + & jdssb(i).eq.newjhpb(j)) found=.true. + enddo +#ifndef CLUST +#ifndef WHAM +c if (.not.found.and.fg_rank.eq.0) +c & write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i) +#endif +#endif + enddo + + do i=1,newnss + found=.false. + do j=1,nss + if (newihpb(i).eq.idssb(j) .and. + & newjhpb(i).eq.jdssb(j)) found=.true. + enddo +#ifndef CLUST +#ifndef WHAM +c if (.not.found.and.fg_rank.eq.0) +c & write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i) +#endif +#endif + enddo + + nss=newnss + do i=1,nss + idssb(i)=newihpb(i) + jdssb(i)=newjhpb(i) + enddo + + return + end + + +c$$$c----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax(i_in,j_in) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c Input arguments +c$$$ integer i_in,j_in +c$$$ +c$$$c Local variables +c$$$ integer i,iretcode,nfun_sc +c$$$ logical scfail +c$$$ double precision var(maxvar),e_sc,etot +c$$$ +c$$$ +c$$$ mask_r=.true. +c$$$ do i=nnt,nct +c$$$ mask_side(i)=0 +c$$$ enddo +c$$$ mask_side(i_in)=1 +c$$$ mask_side(j_in)=1 +c$$$ +c$$$c Minimize the two selected side-chains +c$$$ call overlap_sc(scfail) ! Better not fail! +c$$$ call minimize_sc(e_sc,var,iretcode,nfun_sc) +c$$$ +c$$$ mask_r=.false. +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c------------------------------------------------------------- +c$$$ +c$$$ subroutine minimize_sc(etot_sc,iretcode,nfun) +c$$$c Minimize side-chains only, starting from geom but without modifying +c$$$c bond lengths. +c$$$c If mask_r is already set, only the selected side-chains are minimized, +c$$$c otherwise all side-chains are minimized keeping the backbone frozen. +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.MINIM' +c$$$ integer icall +c$$$ common /srutu/ icall +c$$$ +c$$$c Output arguments +c$$$ double precision etot_sc +c$$$ integer iretcode,nfun +c$$$ +c$$$c External functions/subroutines +c$$$ external func_sc,grad_sc,fdum +c$$$ +c$$$c Local variables +c$$$ integer liv,lv +c$$$ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +c$$$ integer iv(liv) +c$$$ double precision rdum(1) +c$$$ double precision d(maxvar),v(1:lv),x(maxvar),xx(maxvar) +c$$$ integer idum(1) +c$$$ integer i,nvar_restr +c$$$ +c$$$ +c$$$cmc start_minim=.true. +c$$$ call deflt(2,iv,liv,lv,v) +c$$$* 12 means fresh start, dont call deflt +c$$$ iv(1)=12 +c$$$* max num of fun calls +c$$$ if (maxfun.eq.0) maxfun=500 +c$$$ iv(17)=maxfun +c$$$* max num of iterations +c$$$ if (maxmin.eq.0) maxmin=1000 +c$$$ iv(18)=maxmin +c$$$* controls output +c$$$ iv(19)=1 +c$$$* selects output unit +c$$$ iv(21)=0 +c$$$c iv(21)=iout ! DEBUG +c$$$c iv(21)=8 ! DEBUG +c$$$* 1 means to print out result +c$$$ iv(22)=0 +c$$$c iv(22)=1 ! DEBUG +c$$$* 1 means to print out summary stats +c$$$ iv(23)=0 +c$$$c iv(23)=1 ! DEBUG +c$$$* 1 means to print initial x and d +c$$$ iv(24)=0 +c$$$c iv(24)=1 ! DEBUG +c$$$* min val for v(radfac) default is 0.1 +c$$$ v(24)=0.1D0 +c$$$* max val for v(radfac) default is 4.0 +c$$$ v(25)=2.0D0 +c$$$c v(25)=4.0D0 +c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +c$$$* the sumsl default is 0.1 +c$$$ v(26)=0.1D0 +c$$$* false conv if (act fnctn decrease) .lt. v(34) +c$$$* the sumsl default is 100*machep +c$$$ v(34)=v(34)/100.0D0 +c$$$* absolute convergence +c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 +c$$$ v(31)=tolf +c$$$* relative convergence +c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-1 +c$$$ v(32)=rtolf +c$$$* controls initial step size +c$$$ v(35)=1.0D-1 +c$$$* large vals of d correspond to small components of step +c$$$ do i=1,nphi +c$$$ d(i)=1.0D-1 +c$$$ enddo +c$$$ do i=nphi+1,nvar +c$$$ d(i)=1.0D-1 +c$$$ enddo +c$$$ +c$$$ call geom_to_var(nvar,x) +c$$$ IF (mask_r) THEN +c$$$ do i=1,nres ! Just in case... +c$$$ mask_phi(i)=0 +c$$$ mask_theta(i)=0 +c$$$ enddo +c$$$ call x2xx(x,xx,nvar_restr) +c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, +c$$$ & iv,liv,lv,v,idum,rdum,fdum) +c$$$ call xx2x(x,xx) +c$$$ ELSE +c$$$c When minimizing ALL side-chains, etotal_sc is a little +c$$$c faster if we don't set mask_r +c$$$ do i=1,nres +c$$$ mask_phi(i)=0 +c$$$ mask_theta(i)=0 +c$$$ mask_side(i)=1 +c$$$ enddo +c$$$ call x2xx(x,xx,nvar_restr) +c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, +c$$$ & iv,liv,lv,v,idum,rdum,fdum) +c$$$ call xx2x(x,xx) +c$$$ ENDIF +c$$$ call var_to_geom(nvar,x) +c$$$ call chainbuild_sc +c$$$ etot_sc=v(10) +c$$$ iretcode=iv(1) +c$$$ nfun=iv(6) +c$$$ return +c$$$ end +c$$$ +c$$$C-------------------------------------------------------------------------- +c$$$ +c$$$ subroutine chainbuild_sc +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c Local variables +c$$$ integer i +c$$$ +c$$$ +c$$$ do i=nnt,nct +c$$$ if (.not.mask_r .or. mask_side(i).eq.1) then +c$$$ call locate_side_chain(i) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C-------------------------------------------------------------------------- +c$$$ +c$$$ subroutine func_sc(n,x,nf,f,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.MINIM' +c$$$ include 'COMMON.IOUNITS' +c$$$ +c$$$c Input arguments +c$$$ integer n +c$$$ double precision x(maxvar) +c$$$ double precision ufparm +c$$$ external ufparm +c$$$ +c$$$c Input/Output arguments +c$$$ integer nf +c$$$ integer uiparm(1) +c$$$ double precision urparm(1) +c$$$ +c$$$c Output arguments +c$$$ double precision f +c$$$ +c$$$c Local variables +c$$$ double precision energia(0:n_ene) +c$$$#ifdef OSF +c$$$c Variables used to intercept NaNs +c$$$ double precision x_sum +c$$$ integer i_NAN +c$$$#endif +c$$$ +c$$$ +c$$$ nfl=nf +c$$$ icg=mod(nf,2)+1 +c$$$ +c$$$#ifdef OSF +c$$$c Intercept NaNs in the coordinates, before calling etotal_sc +c$$$ x_sum=0.D0 +c$$$ do i_NAN=1,n +c$$$ x_sum=x_sum+x(i_NAN) +c$$$ enddo +c$$$c Calculate the energy only if the coordinates are ok +c$$$ if ((.not.(x_sum.lt.0.D0)) .and. (.not.(x_sum.ge.0.D0))) then +c$$$ write(iout,*)" *** func_restr_sc : Found NaN in coordinates" +c$$$ f=1.0D+77 +c$$$ nf=0 +c$$$ else +c$$$#endif +c$$$ +c$$$ call var_to_geom_restr(n,x) +c$$$ call zerograd +c$$$ call chainbuild_sc +c$$$ call etotal_sc(energia(0)) +c$$$ f=energia(0) +c$$$ if (energia(1).eq.1.0D20 .or. energia(0).eq.1.0D99) nf=0 +c$$$ +c$$$#ifdef OSF +c$$$ endif +c$$$#endif +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c------------------------------------------------------- +c$$$ +c$$$ subroutine grad_sc(n,x,nf,g,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.MINIM' +c$$$ +c$$$c Input arguments +c$$$ integer n +c$$$ double precision x(maxvar) +c$$$ double precision ufparm +c$$$ external ufparm +c$$$ +c$$$c Input/Output arguments +c$$$ integer nf +c$$$ integer uiparm(1) +c$$$ double precision urparm(1) +c$$$ +c$$$c Output arguments +c$$$ double precision g(maxvar) +c$$$ +c$$$c Local variables +c$$$ double precision f,gphii,gthetai,galphai,gomegai +c$$$ integer ig,ind,i,j,k,igall,ij +c$$$ +c$$$ +c$$$ icg=mod(nf,2)+1 +c$$$ if (nf-nfl+1) 20,30,40 +c$$$ 20 call func_sc(n,x,nf,f,uiparm,urparm,ufparm) +c$$$c write (iout,*) 'grad 20' +c$$$ if (nf.eq.0) return +c$$$ goto 40 +c$$$ 30 call var_to_geom_restr(n,x) +c$$$ call chainbuild_sc +c$$$C +c$$$C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +c$$$C +c$$$ 40 call cartder +c$$$C +c$$$C Convert the Cartesian gradient into internal-coordinate gradient. +c$$$C +c$$$ +c$$$ ig=0 +c$$$ ind=nres-2 +c$$$ do i=2,nres-2 +c$$$ IF (mask_phi(i+2).eq.1) THEN +c$$$ gphii=0.0D0 +c$$$ do j=i+1,nres-1 +c$$$ ind=ind+1 +c$$$ do k=1,3 +c$$$ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) +c$$$ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) +c$$$ enddo +c$$$ enddo +c$$$ ig=ig+1 +c$$$ g(ig)=gphii +c$$$ ELSE +c$$$ ind=ind+nres-1-i +c$$$ ENDIF +c$$$ enddo +c$$$ +c$$$ +c$$$ ind=0 +c$$$ do i=1,nres-2 +c$$$ IF (mask_theta(i+2).eq.1) THEN +c$$$ ig=ig+1 +c$$$ gthetai=0.0D0 +c$$$ do j=i+1,nres-1 +c$$$ ind=ind+1 +c$$$ do k=1,3 +c$$$ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) +c$$$ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) +c$$$ enddo +c$$$ enddo +c$$$ g(ig)=gthetai +c$$$ ELSE +c$$$ ind=ind+nres-1-i +c$$$ ENDIF +c$$$ enddo +c$$$ +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ ig=ig+1 +c$$$ galphai=0.0D0 +c$$$ do k=1,3 +c$$$ galphai=galphai+dxds(k,i)*gradx(k,i,icg) +c$$$ enddo +c$$$ g(ig)=galphai +c$$$ ENDIF +c$$$ endif +c$$$ enddo +c$$$ +c$$$ +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ ig=ig+1 +c$$$ gomegai=0.0D0 +c$$$ do k=1,3 +c$$$ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) +c$$$ enddo +c$$$ g(ig)=gomegai +c$$$ ENDIF +c$$$ endif +c$$$ enddo +c$$$ +c$$$C +c$$$C Add the components corresponding to local energy terms. +c$$$C +c$$$ +c$$$ ig=0 +c$$$ igall=0 +c$$$ do i=4,nres +c$$$ igall=igall+1 +c$$$ if (mask_phi(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ do i=3,nres +c$$$ igall=igall+1 +c$$$ if (mask_theta(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ do ij=1,2 +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ igall=igall+1 +c$$$ if (mask_side(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ endif +c$$$ enddo +c$$$ enddo +c$$$ +c$$$cd do i=1,ig +c$$$cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +c$$$cd enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine etotal_sc(energy_sc) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.FFIELD' +c$$$ +c$$$c Output arguments +c$$$ double precision energy_sc(0:n_ene) +c$$$ +c$$$c Local variables +c$$$ double precision evdw,escloc +c$$$ integer i,j +c$$$ +c$$$ +c$$$ do i=1,n_ene +c$$$ energy_sc(i)=0.0D0 +c$$$ enddo +c$$$ +c$$$ if (mask_r) then +c$$$ call egb_sc(evdw) +c$$$ call esc_sc(escloc) +c$$$ else +c$$$ call egb(evdw) +c$$$ call esc(escloc) +c$$$ endif +c$$$ +c$$$ if (evdw.eq.1.0D20) then +c$$$ energy_sc(0)=evdw +c$$$ else +c$$$ energy_sc(0)=wsc*evdw+wscloc*escloc +c$$$ endif +c$$$ energy_sc(1)=evdw +c$$$ energy_sc(12)=escloc +c$$$ +c$$$C +c$$$C Sum up the components of the Cartesian gradient. +c$$$C +c$$$ do i=1,nct +c$$$ do j=1,3 +c$$$ gradx(j,i,icg)=wsc*gvdwx(j,i) +c$$$ enddo +c$$$ enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine egb_sc(evdw) +c$$$C +c$$$C This subroutine calculates the interaction energy of nonbonded side chains +c$$$C assuming the Gay-Berne potential of interaction. +c$$$C +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.CALC' +c$$$ include 'COMMON.CONTROL' +c$$$ logical lprn +c$$$ evdw=0.0D0 +c$$$ energy_dec=.false. +c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon +c$$$ evdw=0.0D0 +c$$$ lprn=.false. +c$$$c if (icall.eq.0) lprn=.false. +c$$$ ind=0 +c$$$ do i=iatsc_s,iatsc_e +c$$$ itypi=itype(i) +c$$$ itypi1=itype(i+1) +c$$$ xi=c(1,nres+i) +c$$$ yi=c(2,nres+i) +c$$$ zi=c(3,nres+i) +c$$$ dxi=dc_norm(1,nres+i) +c$$$ dyi=dc_norm(2,nres+i) +c$$$ dzi=dc_norm(3,nres+i) +c$$$c dsci_inv=dsc_inv(itypi) +c$$$ dsci_inv=vbld_inv(i+nres) +c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +c$$$C +c$$$C Calculate SC interaction energy. +c$$$C +c$$$ do iint=1,nint_gr(i) +c$$$ do j=istart(i,iint),iend(i,iint) +c$$$ IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN +c$$$ ind=ind+1 +c$$$ itypj=itype(j) +c$$$c dscj_inv=dsc_inv(itypj) +c$$$ dscj_inv=vbld_inv(j+nres) +c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c$$$c & 1.0d0/vbld(j+nres) +c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) +c$$$ sig0ij=sigma(itypi,itypj) +c$$$ chi1=chi(itypi,itypj) +c$$$ chi2=chi(itypj,itypi) +c$$$ chi12=chi1*chi2 +c$$$ chip1=chip(itypi) +c$$$ chip2=chip(itypj) +c$$$ chip12=chip1*chip2 +c$$$ alf1=alp(itypi) +c$$$ alf2=alp(itypj) +c$$$ alf12=0.5D0*(alf1+alf2) +c$$$C For diagnostics only!!! +c$$$c chi1=0.0D0 +c$$$c chi2=0.0D0 +c$$$c chi12=0.0D0 +c$$$c chip1=0.0D0 +c$$$c chip2=0.0D0 +c$$$c chip12=0.0D0 +c$$$c alf1=0.0D0 +c$$$c alf2=0.0D0 +c$$$c alf12=0.0D0 +c$$$ xj=c(1,nres+j)-xi +c$$$ yj=c(2,nres+j)-yi +c$$$ zj=c(3,nres+j)-zi +c$$$ dxj=dc_norm(1,nres+j) +c$$$ dyj=dc_norm(2,nres+j) +c$$$ dzj=dc_norm(3,nres+j) +c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi +c$$$c write (iout,*) "j",j," dc_norm", +c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) +c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c$$$ rij=dsqrt(rrij) +c$$$C Calculate angle-dependent terms of energy and contributions to their +c$$$C derivatives. +c$$$ call sc_angular +c$$$ sigsq=1.0D0/sigsq +c$$$ sig=sig0ij*dsqrt(sigsq) +c$$$ rij_shift=1.0D0/rij-sig+sig0ij +c$$$c for diagnostics; uncomment +c$$$c rij_shift=1.2*sig0ij +c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! +c$$$ if (rij_shift.le.0.0D0) then +c$$$ evdw=1.0D20 +c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$cd & restyp(itypi),i,restyp(itypj),j, +c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) +c$$$ return +c$$$ endif +c$$$ sigder=-sig*sigsq +c$$$c--------------------------------------------------------------- +c$$$ rij_shift=1.0D0/rij_shift +c$$$ fac=rij_shift**expon +c$$$ e1=fac*fac*aa(itypi,itypj) +c$$$ e2=fac*bb(itypi,itypj) +c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) +c$$$ eps2der=evdwij*eps3rt +c$$$ eps3der=evdwij*eps2rt +c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 +c$$$ evdwij=evdwij*eps2rt*eps3rt +c$$$ evdw=evdw+evdwij +c$$$ if (lprn) then +c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$ & restyp(itypi),i,restyp(itypj),j, +c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, +c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, +c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, +c$$$ & evdwij +c$$$ endif +c$$$ +c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') +c$$$ & 'evdw',i,j,evdwij +c$$$ +c$$$C Calculate gradient components. +c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 +c$$$ fac=-expon*(e1+evdwij)*rij_shift +c$$$ sigder=fac*sigder +c$$$ fac=rij*fac +c$$$c fac=0.0d0 +c$$$C Calculate the radial part of the gradient +c$$$ gg(1)=xj*fac +c$$$ gg(2)=yj*fac +c$$$ gg(3)=zj*fac +c$$$C Calculate angular part of the gradient. +c$$$ call sc_grad +c$$$ ENDIF +c$$$ enddo ! j +c$$$ enddo ! iint +c$$$ enddo ! i +c$$$ energy_dec=.false. +c$$$ return +c$$$ end +c$$$ +c$$$c----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine esc_sc(escloc) +c$$$C Calculate the local energy of a side chain and its derivatives in the +c$$$C corresponding virtual-bond valence angles THETA and the spherical angles +c$$$C ALPHA and OMEGA. +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.FFIELD' +c$$$ include 'COMMON.CONTROL' +c$$$ double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), +c$$$ & ddersc0(3),ddummy(3),xtemp(3),temp(3) +c$$$ common /sccalc/ time11,time12,time112,theti,it,nlobit +c$$$ delta=0.02d0*pi +c$$$ escloc=0.0D0 +c$$$c write (iout,'(a)') 'ESC' +c$$$ do i=loc_start,loc_end +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ it=itype(i) +c$$$ if (it.eq.10) goto 1 +c$$$ nlobit=nlob(it) +c$$$c print *,'i=',i,' it=',it,' nlobit=',nlobit +c$$$c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad +c$$$ theti=theta(i+1)-pipol +c$$$ x(1)=dtan(theti) +c$$$ x(2)=alph(i) +c$$$ x(3)=omeg(i) +c$$$ +c$$$ if (x(2).gt.pi-delta) then +c$$$ xtemp(1)=x(1) +c$$$ xtemp(2)=pi-delta +c$$$ xtemp(3)=x(3) +c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) +c$$$ xtemp(2)=pi +c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) +c$$$ call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), +c$$$ & escloci,dersc(2)) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), +c$$$ & ddersc0(1),dersc(1)) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), +c$$$ & ddersc0(3),dersc(3)) +c$$$ xtemp(2)=pi-delta +c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) +c$$$ xtemp(2)=pi +c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) +c$$$ call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, +c$$$ & dersc0(2),esclocbi,dersc02) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), +c$$$ & dersc12,dersc01) +c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) +c$$$ dersc0(1)=dersc01 +c$$$ dersc0(2)=dersc02 +c$$$ dersc0(3)=0.0d0 +c$$$ do k=1,3 +c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) +c$$$ enddo +c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c$$$c & esclocbi,ss,ssd +c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi +c$$$c escloci=esclocbi +c$$$c write (iout,*) escloci +c$$$ else if (x(2).lt.delta) then +c$$$ xtemp(1)=x(1) +c$$$ xtemp(2)=delta +c$$$ xtemp(3)=x(3) +c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) +c$$$ xtemp(2)=0.0d0 +c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) +c$$$ call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), +c$$$ & escloci,dersc(2)) +c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), +c$$$ & ddersc0(1),dersc(1)) +c$$$ call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), +c$$$ & ddersc0(3),dersc(3)) +c$$$ xtemp(2)=delta +c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) +c$$$ xtemp(2)=0.0d0 +c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) +c$$$ call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, +c$$$ & dersc0(2),esclocbi,dersc02) +c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), +c$$$ & dersc12,dersc01) +c$$$ dersc0(1)=dersc01 +c$$$ dersc0(2)=dersc02 +c$$$ dersc0(3)=0.0d0 +c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) +c$$$ do k=1,3 +c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) +c$$$ enddo +c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c$$$c & esclocbi,ss,ssd +c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi +c$$$c write (iout,*) escloci +c$$$ else +c$$$ call enesc(x,escloci,dersc,ddummy,.false.) +c$$$ endif +c$$$ +c$$$ escloc=escloc+escloci +c$$$ if (energy_dec) write (iout,'(a6,i,0pf7.3)') +c$$$ & 'escloc',i,escloci +c$$$c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc +c$$$ +c$$$ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ +c$$$ & wscloc*dersc(1) +c$$$ gloc(ialph(i,1),icg)=wscloc*dersc(2) +c$$$ gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) +c$$$ 1 continue +c$$$ ENDIF +c$$$ enddo +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine egb_ij(i_sc,j_sc,evdw) +c$$$C +c$$$C This subroutine calculates the interaction energy of nonbonded side chains +c$$$C assuming the Gay-Berne potential of interaction. +c$$$C +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.CALC' +c$$$ include 'COMMON.CONTROL' +c$$$ logical lprn +c$$$ evdw=0.0D0 +c$$$ energy_dec=.false. +c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon +c$$$ evdw=0.0D0 +c$$$ lprn=.false. +c$$$ ind=0 +c$$$c$$$ do i=iatsc_s,iatsc_e +c$$$ i=i_sc +c$$$ itypi=itype(i) +c$$$ itypi1=itype(i+1) +c$$$ xi=c(1,nres+i) +c$$$ yi=c(2,nres+i) +c$$$ zi=c(3,nres+i) +c$$$ dxi=dc_norm(1,nres+i) +c$$$ dyi=dc_norm(2,nres+i) +c$$$ dzi=dc_norm(3,nres+i) +c$$$c dsci_inv=dsc_inv(itypi) +c$$$ dsci_inv=vbld_inv(i+nres) +c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +c$$$C +c$$$C Calculate SC interaction energy. +c$$$C +c$$$c$$$ do iint=1,nint_gr(i) +c$$$c$$$ do j=istart(i,iint),iend(i,iint) +c$$$ j=j_sc +c$$$ ind=ind+1 +c$$$ itypj=itype(j) +c$$$c dscj_inv=dsc_inv(itypj) +c$$$ dscj_inv=vbld_inv(j+nres) +c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c$$$c & 1.0d0/vbld(j+nres) +c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) +c$$$ sig0ij=sigma(itypi,itypj) +c$$$ chi1=chi(itypi,itypj) +c$$$ chi2=chi(itypj,itypi) +c$$$ chi12=chi1*chi2 +c$$$ chip1=chip(itypi) +c$$$ chip2=chip(itypj) +c$$$ chip12=chip1*chip2 +c$$$ alf1=alp(itypi) +c$$$ alf2=alp(itypj) +c$$$ alf12=0.5D0*(alf1+alf2) +c$$$C For diagnostics only!!! +c$$$c chi1=0.0D0 +c$$$c chi2=0.0D0 +c$$$c chi12=0.0D0 +c$$$c chip1=0.0D0 +c$$$c chip2=0.0D0 +c$$$c chip12=0.0D0 +c$$$c alf1=0.0D0 +c$$$c alf2=0.0D0 +c$$$c alf12=0.0D0 +c$$$ xj=c(1,nres+j)-xi +c$$$ yj=c(2,nres+j)-yi +c$$$ zj=c(3,nres+j)-zi +c$$$ dxj=dc_norm(1,nres+j) +c$$$ dyj=dc_norm(2,nres+j) +c$$$ dzj=dc_norm(3,nres+j) +c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi +c$$$c write (iout,*) "j",j," dc_norm", +c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) +c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c$$$ rij=dsqrt(rrij) +c$$$C Calculate angle-dependent terms of energy and contributions to their +c$$$C derivatives. +c$$$ call sc_angular +c$$$ sigsq=1.0D0/sigsq +c$$$ sig=sig0ij*dsqrt(sigsq) +c$$$ rij_shift=1.0D0/rij-sig+sig0ij +c$$$c for diagnostics; uncomment +c$$$c rij_shift=1.2*sig0ij +c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! +c$$$ if (rij_shift.le.0.0D0) then +c$$$ evdw=1.0D20 +c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$cd & restyp(itypi),i,restyp(itypj),j, +c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) +c$$$ return +c$$$ endif +c$$$ sigder=-sig*sigsq +c$$$c--------------------------------------------------------------- +c$$$ rij_shift=1.0D0/rij_shift +c$$$ fac=rij_shift**expon +c$$$ e1=fac*fac*aa(itypi,itypj) +c$$$ e2=fac*bb(itypi,itypj) +c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) +c$$$ eps2der=evdwij*eps3rt +c$$$ eps3der=evdwij*eps2rt +c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 +c$$$ evdwij=evdwij*eps2rt*eps3rt +c$$$ evdw=evdw+evdwij +c$$$ if (lprn) then +c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$ & restyp(itypi),i,restyp(itypj),j, +c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, +c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, +c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, +c$$$ & evdwij +c$$$ endif +c$$$ +c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') +c$$$ & 'evdw',i,j,evdwij +c$$$ +c$$$C Calculate gradient components. +c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 +c$$$ fac=-expon*(e1+evdwij)*rij_shift +c$$$ sigder=fac*sigder +c$$$ fac=rij*fac +c$$$c fac=0.0d0 +c$$$C Calculate the radial part of the gradient +c$$$ gg(1)=xj*fac +c$$$ gg(2)=yj*fac +c$$$ gg(3)=zj*fac +c$$$C Calculate angular part of the gradient. +c$$$ call sc_grad +c$$$c$$$ enddo ! j +c$$$c$$$ enddo ! iint +c$$$c$$$ enddo ! i +c$$$ energy_dec=.false. +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine perturb_side_chain(i,angle) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.IOUNITS' +c$$$ +c$$$c External functions +c$$$ external ran_number +c$$$ double precision ran_number +c$$$ +c$$$c Input arguments +c$$$ integer i +c$$$ double precision angle ! In degrees +c$$$ +c$$$c Local variables +c$$$ integer i_sc +c$$$ double precision rad_ang,rand_v(3),length,cost,sint +c$$$ +c$$$ +c$$$ i_sc=i+nres +c$$$ rad_ang=angle*deg2rad +c$$$ +c$$$ length=0.0 +c$$$ do while (length.lt.0.01) +c$$$ rand_v(1)=ran_number(0.01D0,1.0D0) +c$$$ rand_v(2)=ran_number(0.01D0,1.0D0) +c$$$ rand_v(3)=ran_number(0.01D0,1.0D0) +c$$$ length=rand_v(1)*rand_v(1)+rand_v(2)*rand_v(2)+ +c$$$ + rand_v(3)*rand_v(3) +c$$$ length=sqrt(length) +c$$$ rand_v(1)=rand_v(1)/length +c$$$ rand_v(2)=rand_v(2)/length +c$$$ rand_v(3)=rand_v(3)/length +c$$$ cost=rand_v(1)*dc_norm(1,i_sc)+rand_v(2)*dc_norm(2,i_sc)+ +c$$$ + rand_v(3)*dc_norm(3,i_sc) +c$$$ length=1.0D0-cost*cost +c$$$ if (length.lt.0.0D0) length=0.0D0 +c$$$ length=sqrt(length) +c$$$ rand_v(1)=rand_v(1)-cost*dc_norm(1,i_sc) +c$$$ rand_v(2)=rand_v(2)-cost*dc_norm(2,i_sc) +c$$$ rand_v(3)=rand_v(3)-cost*dc_norm(3,i_sc) +c$$$ enddo +c$$$ rand_v(1)=rand_v(1)/length +c$$$ rand_v(2)=rand_v(2)/length +c$$$ rand_v(3)=rand_v(3)/length +c$$$ +c$$$ cost=dcos(rad_ang) +c$$$ sint=dsin(rad_ang) +c$$$ dc(1,i_sc)=vbld(i_sc)*(dc_norm(1,i_sc)*cost+rand_v(1)*sint) +c$$$ dc(2,i_sc)=vbld(i_sc)*(dc_norm(2,i_sc)*cost+rand_v(2)*sint) +c$$$ dc(3,i_sc)=vbld(i_sc)*(dc_norm(3,i_sc)*cost+rand_v(3)*sint) +c$$$ dc_norm(1,i_sc)=dc(1,i_sc)*vbld_inv(i_sc) +c$$$ dc_norm(2,i_sc)=dc(2,i_sc)*vbld_inv(i_sc) +c$$$ dc_norm(3,i_sc)=dc(3,i_sc)*vbld_inv(i_sc) +c$$$ c(1,i_sc)=c(1,i)+dc(1,i_sc) +c$$$ c(2,i_sc)=c(2,i)+dc(2,i_sc) +c$$$ c(3,i_sc)=c(3,i)+dc(3,i_sc) +c$$$ +c$$$ call chainbuild_cart +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c---------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax3(i_in,j_in) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c External functions +c$$$ external ran_number +c$$$ double precision ran_number +c$$$ +c$$$c Input arguments +c$$$ integer i_in,j_in +c$$$ +c$$$c Local variables +c$$$ double precision energy_sc(0:n_ene),etot +c$$$ double precision org_dc(3),org_dc_norm(3),org_c(3) +c$$$ double precision ang_pert,rand_fact,exp_fact,beta +c$$$ integer n,i_pert,i +c$$$ logical notdone +c$$$ +c$$$ +c$$$ beta=1.0D0 +c$$$ +c$$$ mask_r=.true. +c$$$ do i=nnt,nct +c$$$ mask_side(i)=0 +c$$$ enddo +c$$$ mask_side(i_in)=1 +c$$$ mask_side(j_in)=1 +c$$$ +c$$$ call etotal_sc(energy_sc) +c$$$ etot=energy_sc(0) +c$$$c write(iout,'(a,3d15.5)')" SS_MC_START ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ +c$$$ notdone=.true. +c$$$ n=0 +c$$$ do while (notdone) +c$$$ if (mod(n,2).eq.0) then +c$$$ i_pert=i_in +c$$$ else +c$$$ i_pert=j_in +c$$$ endif +c$$$ n=n+1 +c$$$ +c$$$ do i=1,3 +c$$$ org_dc(i)=dc(i,i_pert+nres) +c$$$ org_dc_norm(i)=dc_norm(i,i_pert+nres) +c$$$ org_c(i)=c(i,i_pert+nres) +c$$$ enddo +c$$$ ang_pert=ran_number(0.0D0,3.0D0) +c$$$ call perturb_side_chain(i_pert,ang_pert) +c$$$ call etotal_sc(energy_sc) +c$$$ exp_fact=exp(beta*(etot-energy_sc(0))) +c$$$ rand_fact=ran_number(0.0D0,1.0D0) +c$$$ if (rand_fact.lt.exp_fact) then +c$$$c write(iout,'(a,3d15.5)')" SS_MC_ACCEPT ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ etot=energy_sc(0) +c$$$ else +c$$$c write(iout,'(a,3d15.5)')" SS_MC_REJECT ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ do i=1,3 +c$$$ dc(i,i_pert+nres)=org_dc(i) +c$$$ dc_norm(i,i_pert+nres)=org_dc_norm(i) +c$$$ c(i,i_pert+nres)=org_c(i) +c$$$ enddo +c$$$ endif +c$$$ +c$$$ if (n.eq.10000.or.etot.lt.30.0D0) notdone=.false. +c$$$ enddo +c$$$ +c$$$ mask_r=.false. +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c---------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax2(etot,iretcode,nfun,i_in,j_in) +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ integer liv,lv +c$$$ parameter (liv=60,lv=(77+maxres6*(maxres6+17)/2)) +c$$$********************************************************************* +c$$$* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * +c$$$* the calling subprogram. * +c$$$* when d(i)=1.0, then v(35) is the length of the initial step, * +c$$$* calculated in the usual pythagorean way. * +c$$$* absolute convergence occurs when the function is within v(31) of * +c$$$* zero. unless you know the minimum value in advance, abs convg * +c$$$* is probably not useful. * +c$$$* relative convergence is when the model predicts that the function * +c$$$* will decrease by less than v(32)*abs(fun). * +c$$$********************************************************************* +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.MINIM' +c$$$ include 'COMMON.CHAIN' +c$$$ +c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist +c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), +c$$$ + orig_ss_dist(maxres2,maxres2) +c$$$ +c$$$ double precision etot +c$$$ integer iretcode,nfun,i_in,j_in +c$$$ +c$$$ external dist +c$$$ double precision dist +c$$$ external ss_func,fdum +c$$$ double precision ss_func,fdum +c$$$ +c$$$ integer iv(liv),uiparm(2) +c$$$ double precision v(lv),x(maxres6),d(maxres6),rdum +c$$$ integer i,j,k +c$$$ +c$$$ +c$$$ call deflt(2,iv,liv,lv,v) +c$$$* 12 means fresh start, dont call deflt +c$$$ iv(1)=12 +c$$$* max num of fun calls +c$$$ if (maxfun.eq.0) maxfun=500 +c$$$ iv(17)=maxfun +c$$$* max num of iterations +c$$$ if (maxmin.eq.0) maxmin=1000 +c$$$ iv(18)=maxmin +c$$$* controls output +c$$$ iv(19)=2 +c$$$* selects output unit +c$$$c iv(21)=iout +c$$$ iv(21)=0 +c$$$* 1 means to print out result +c$$$ iv(22)=0 +c$$$* 1 means to print out summary stats +c$$$ iv(23)=0 +c$$$* 1 means to print initial x and d +c$$$ iv(24)=0 +c$$$* min val for v(radfac) default is 0.1 +c$$$ v(24)=0.1D0 +c$$$* max val for v(radfac) default is 4.0 +c$$$ v(25)=2.0D0 +c$$$c v(25)=4.0D0 +c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +c$$$* the sumsl default is 0.1 +c$$$ v(26)=0.1D0 +c$$$* false conv if (act fnctn decrease) .lt. v(34) +c$$$* the sumsl default is 100*machep +c$$$ v(34)=v(34)/100.0D0 +c$$$* absolute convergence +c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 +c$$$ v(31)=tolf +c$$$ v(31)=1.0D-1 +c$$$* relative convergence +c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-4 +c$$$ v(32)=rtolf +c$$$ v(32)=1.0D-1 +c$$$* controls initial step size +c$$$ v(35)=1.0D-1 +c$$$* large vals of d correspond to small components of step +c$$$ do i=1,6*nres +c$$$ d(i)=1.0D0 +c$$$ enddo +c$$$ +c$$$ do i=0,2*nres +c$$$ do j=1,3 +c$$$ orig_ss_dc(j,i)=dc(j,i) +c$$$ enddo +c$$$ enddo +c$$$ call geom_to_var(nvar,orig_ss_var) +c$$$ +c$$$ do i=1,nres +c$$$ do j=i,nres +c$$$ orig_ss_dist(j,i)=dist(j,i) +c$$$ orig_ss_dist(j+nres,i)=dist(j+nres,i) +c$$$ orig_ss_dist(j,i+nres)=dist(j,i+nres) +c$$$ orig_ss_dist(j+nres,i+nres)=dist(j+nres,i+nres) +c$$$ enddo +c$$$ enddo +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ x(k)=dc(j,i) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ x(k)=dc(j,i+nres) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ +c$$$ uiparm(1)=i_in +c$$$ uiparm(2)=j_in +c$$$ call smsno(k,d,x,ss_func,iv,liv,lv,v,uiparm,rdum,fdum) +c$$$ etot=v(10) +c$$$ iretcode=iv(1) +c$$$ nfun=iv(6)+iv(30) +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i)=x(k) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i+nres)=x(k) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ call chainbuild_cart +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_func(n,x,nf,f,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.SBRIDGE' +c$$$ +c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist +c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), +c$$$ + orig_ss_dist(maxres2,maxres2) +c$$$ +c$$$ integer n +c$$$ double precision x(maxres6) +c$$$ integer nf +c$$$ double precision f +c$$$ integer uiparm(2) +c$$$ real*8 urparm(1) +c$$$ external ufparm +c$$$ double precision ufparm +c$$$ +c$$$ external dist +c$$$ double precision dist +c$$$ +c$$$ integer i,j,k,ss_i,ss_j +c$$$ double precision tempf,var(maxvar) +c$$$ +c$$$ +c$$$ ss_i=uiparm(1) +c$$$ ss_j=uiparm(2) +c$$$ f=0.0D0 +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i)=x(k) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i+nres)=x(k) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ call chainbuild_cart +c$$$ +c$$$ call geom_to_var(nvar,var) +c$$$ +c$$$c Constraints on all angles +c$$$ do i=1,nvar +c$$$ tempf=var(i)-orig_ss_var(i) +c$$$ f=f+tempf*tempf +c$$$ enddo +c$$$ +c$$$c Constraints on all distances +c$$$ do i=1,nres-1 +c$$$ if (i.gt.1) then +c$$$ tempf=dist(i+nres,i)-orig_ss_dist(i+nres,i) +c$$$ f=f+tempf*tempf +c$$$ endif +c$$$ do j=i+1,nres +c$$$ tempf=dist(j,i)-orig_ss_dist(j,i) +c$$$ if (tempf.lt.0.0D0 .or. j.eq.i+1) f=f+tempf*tempf +c$$$ tempf=dist(j+nres,i)-orig_ss_dist(j+nres,i) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ tempf=dist(j,i+nres)-orig_ss_dist(j,i+nres) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ tempf=dist(j+nres,i+nres)-orig_ss_dist(j+nres,i+nres) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ enddo +c$$$ enddo +c$$$ +c$$$c Constraints for the relevant CYS-CYS +c$$$ tempf=dist(nres+ss_i,nres+ss_j)-8.0D0 +c$$$ f=f+tempf*tempf +c$$$CCCCCCCCCCCCCCCCC ADD SOME ANGULAR STUFF +c$$$ +c$$$c$$$ if (nf.ne.nfl) then +c$$$c$$$ write(iout,'(a,i10,2d15.5)')"IN DIST_FUNC (NF,F,DIST)",nf, +c$$$c$$$ + f,dist(5+nres,14+nres) +c$$$c$$$ endif +c$$$ +c$$$ nfl=nf +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$C----------------------------------------------------------------------------- + subroutine triple_ssbond_ene(resi,resj,resk,eij) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' +#ifndef CLUST +#ifndef WHAM +C include 'COMMON.MD' +#endif +#endif + +c External functions + double precision h_base + external h_base + +c Input arguments + integer resi,resj,resk + +c Output arguments + double precision eij,eij1,eij2,eij3 + +c Local variables + logical havebond +c integer itypi,itypj,k,l + double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi + double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij + double precision xik,yik,zik,xjk,yjk,zjk + double precision sig0ij,ljd,sig,fac,e1,e2 + double precision dcosom1(3),dcosom2(3),ed + double precision pom1,pom2 + double precision ljA,ljB,ljXs + double precision d_ljB(1:3) + double precision ssA,ssB,ssC,ssXs + double precision ssxm,ljxm,ssm,ljm + double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3) + + i=resi + j=resj + k=resk +C write(iout,*) resi,resj,resk + itypi=itype(i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=vbld_inv(i+nres) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + + itypj=itype(j) + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) + + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + dscj_inv=vbld_inv(j+nres) + itypk=itype(k) + xk=c(1,nres+k) + yk=c(2,nres+k) + zk=c(3,nres+k) + + dxk=dc_norm(1,nres+k) + dyk=dc_norm(2,nres+k) + dzk=dc_norm(3,nres+k) + dscj_inv=vbld_inv(k+nres) + xij=xj-xi + xik=xk-xi + xjk=xk-xj + yij=yj-yi + yik=yk-yi + yjk=yk-yj + zij=zj-zi + zik=zk-zi + zjk=zk-zj + rrij=(xij*xij+yij*yij+zij*zij) + rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse + rrik=(xik*xik+yik*yik+zik*zik) + rik=dsqrt(rrik) + rrjk=(xjk*xjk+yjk*yjk+zjk*zjk) + rjk=dsqrt(rrjk) +C there are three combination of distances for each trisulfide bonds +C The first case the ith atom is the center +C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first +C distance y is second distance the a,b,c,d are parameters derived for +C this problem d parameter was set as a penalty currenlty set to 1. + eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**2+ctriss) +C second case jth atom is center + eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**2+ctriss) +C the third case kth atom is the center + eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**2+ctriss) +C eij2=0.0 +C eij3=0.0 +C eij1=0.0 + eij=eij1+eij2+eij3 +C write(iout,*)i,j,k,eij +C The energy penalty calculated now time for the gradient part +C derivative over rij + fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+2.0*btriss*(rij+rik)) + &-eij2**2/dtriss*(2.0*atriss*(rij-rjk)+2.0*btriss*(rij+rjk)) + gg(1)=xij*fac/rij + gg(2)=yij*fac/rij + gg(3)=zij*fac/rij + do m=1,3 + gvdwx(m,i)=gvdwx(m,i)-gg(m) + gvdwx(m,j)=gvdwx(m,j)+gg(m) + enddo + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo +C now derivative over rik + fac=-eij1**2/dtriss*(-2.0*atriss*(rij-rik)+2.0*btriss*(rij+rik)) + &-eij3**2/dtriss*(2.0*atriss*(rik-rjk)+2.0*btriss*(rik+rjk)) + gg(1)=xik*fac/rik + gg(2)=yik*fac/rik + gg(3)=zik*fac/rik + do m=1,3 + gvdwx(m,i)=gvdwx(m,i)-gg(m) + gvdwx(m,k)=gvdwx(m,k)+gg(m) + enddo + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo +C now derivative over rjk + fac=-eij2**2/dtriss*(-2.0*atriss*(rij-rjk)+2.0*btriss*(rij+rjk))- + &eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+2.0*btriss*(rik+rjk)) + gg(1)=xjk*fac/rjk + gg(2)=yjk*fac/rjk + gg(3)=zjk*fac/rjk + do m=1,3 + gvdwx(m,j)=gvdwx(m,j)-gg(m) + gvdwx(m,k)=gvdwx(m,k)+gg(m) + enddo + do l=1,3 + gvdwc(l,j)=gvdwc(l,j)-gg(l) + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo + return + end diff --git a/source/cluster/wham/src-M/work_partition.F b/source/cluster/wham/src-M/work_partition.F index e31db53..ba87bd2 100644 --- a/source/cluster/wham/src-M/work_partition.F +++ b/source/cluster/wham/src-M/work_partition.F @@ -74,12 +74,13 @@ c print *,"N",n," NCON_WORK",ncon_work if (lprint) then write (iout,*) "Partition of work between processors" - do i=0,nprocs-1 - write (iout,'(a,i5,a,i7,a,i7,a,i7)') - & "Processor",i," indstart",indstart(i), - & " indend",indend(i)," count",scount(i) - enddo - endif +C do i=0,nprocs-1 +C write (iout,'(a,i5,a,i7,a,i7,a,i7)') +C & "Processor",i," indstart",indstart(i), +C & " indend",indend(i)," count",scount(i) +C enddo + endif + write(iout,*) "just before leave" return end #endif diff --git a/source/wham/src-M/CMakeLists.txt b/source/wham/src-M/CMakeLists.txt index 8be0d86..45f3d94 100644 --- a/source/wham/src-M/CMakeLists.txt +++ b/source/wham/src-M/CMakeLists.txt @@ -61,6 +61,7 @@ set(UNRES_WHAM_M_SRC0 proc_cont.f define_pairs.f mysort.f + ssMD.F ) set(UNRES_WHAM_M_PP_SRC diff --git a/source/wham/src-M/COMMON.ALLPARM b/source/wham/src-M/COMMON.ALLPARM index d1ddcd6..5b6284a 100644 --- a/source/wham/src-M/COMMON.ALLPARM +++ b/source/wham/src-M/COMMON.ALLPARM @@ -3,47 +3,73 @@ & vbldsc0_all(maxbondterm,ntyp,max_parm), & aksc_all(maxbondterm,ntyp,max_parm), & abond0_all(maxbondterm,ntyp,max_parm), - & a0thet_all(ntyp,max_parm),athet_all(2,ntyp,max_parm), - & bthet_all(2,ntyp,max_parm),polthet_all(0:3,ntyp,max_parm), - & gthet_all(3,ntyp,max_parm),theta0_all(ntyp,max_parm), - & sig0_all(ntyp,max_parm),sigc0_all(ntyp,max_parm), - & aa0thet_all(maxthetyp1,maxthetyp1,maxthetyp1,max_parm), - & aathet_all(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1,max_parm), - & bbthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ccthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ddthet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & eethet_all(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ffthet_all(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), - & ggthet_all(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1,max_parm), + & a0thet_all(-ntyp:ntyp,max_parm), + & athet_all(2,-ntyp:ntyp,-1:1,-1:1,max_parm), + & bthet_all(2,-ntyp:ntyp,-1:1,-1:1,max_parm), + & polthet_all(0:3,-ntyp:ntyp,max_parm), + & gthet_all(3,-ntyp:ntyp,max_parm),theta0_all(-ntyp:ntyp,max_parm), + & sig0_all(-ntyp:ntyp,max_parm),sigc0_all(-ntyp:ntyp,max_parm), + & aa0thet_all(-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,2,max_parm), + & aathet_all(maxtheterm,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm), + & bbthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2,max_parm), + & ccthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,2,max_parm), + & ddthet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,2,max_parm), + & eethet_all(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,2,max_parm), + & ffthet_all1(maxdouble,maxdouble,maxtheterm3, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,max_parm), + & ggthet_all1(maxdouble,maxdouble,maxtheterm3, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,max_parm), + & ffthet_all2(maxdouble,maxdouble,maxtheterm3, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,max_parm), + & ggthet_all2(maxdouble,maxdouble,maxtheterm3, + & -maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1, + & -maxthetyp1:maxthetyp1,max_parm), & dsc_all(ntyp1,max_parm),bsc_all(maxlob,ntyp,max_parm), - & censc_all(3,maxlob,ntyp,max_parm), - & gaussc_all(3,3,maxlob,ntyp,max_parm),dsc0_all(ntyp1,max_parm), + & censc_all(3,maxlob,-ntyp:ntyp,max_parm), + & gaussc_all(3,3,maxlob,-ntyp:ntyp,max_parm), + & dsc0_all(ntyp1,max_parm), & sc_parmin_all(65,ntyp,max_parm), - & v0_all(maxtor,maxtor,max_parm), - & v1_all(maxterm,maxtor,maxtor,max_parm), - & v2_all(maxterm,maxtor,maxtor,max_parm), + & v0_all(-maxtor:maxtor,-maxtor:maxtor,2,max_parm), + & v1_all(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,max_parm), + & v2_all(maxterm,-maxtor:maxtor,-maxtor:maxtor,2,max_parm), & vlor1_all(maxlor,maxtor,maxtor,max_parm), & vlor2_all(maxlor,maxtor,maxtor,max_parm), & vlor3_all(maxlor,maxtor,maxtor,max_parm), - & v1c_all(2,maxtermd_1,maxtor,maxtor,maxtor,max_parm), - & v1s_all(2,maxtermd_1,maxtor,maxtor,maxtor,max_parm), - & v2c_all(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor,max_parm), - & v2s_all(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor,max_parm), - & b1_all(2,maxtor,max_parm),b2_all(2,maxtor,max_parm), - & cc_all(2,2,maxtor,max_parm),dd_all(2,2,maxtor,max_parm), - & ee_all(2,2,maxtor,max_parm),ctilde_all(2,2,maxtor,max_parm), - & dtilde_all(2,2,maxtor,max_parm),b1tilde_all(2,maxtor,max_parm), + & v1c_all(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2,max_parm), + & v1s_all(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2,max_parm), + & v2c_all(maxtermd_2,maxtermd_2,-maxtor:maxtor, + & -maxtor:maxtor,-maxtor:maxtor,2,max_parm), + & v2s_all(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2,max_parm), + & b1_all(2,-maxtor:maxtor,max_parm), + & b2_all(2,-maxtor:maxtor,max_parm), + & cc_all(2,2,-maxtor:maxtor,max_parm), + & dd_all(2,2,-maxtor:maxtor,max_parm), + & ee_all(2,2,-maxtor:maxtor,max_parm), + & ctilde_all(2,2,-maxtor:maxtor,max_parm), + & dtilde_all(2,2,-maxtor:maxtor,max_parm), + & b1tilde_all(2,-maxtor:maxtor,max_parm), & app_all(2,2,max_parm),bpp_all(2,2,max_parm), & ael6_all(2,2,max_parm),ael3_all(2,2,max_parm), & aad_all(ntyp,2,max_parm),bad_all(ntyp,2,max_parm), - & aa_all(ntyp,ntyp,max_parm),bb_all(ntyp,ntyp,max_parm), + & aa_aq_all(ntyp,ntyp,max_parm),bb_aq_all(ntyp,ntyp,max_parm), + & aa_lip_all(ntyp,ntyp,max_parm),bb_lip_all(ntyp,ntyp,max_parm), & augm_all(ntyp,ntyp,max_parm),eps_all(ntyp,ntyp,max_parm), + & epslip_all(ntyp,ntyp,max_parm), & sigma_all(ntyp,ntyp,max_parm),r0_all(ntyp,ntyp,max_parm), & chi_all(ntyp,ntyp,max_parm),chip_all(ntyp,max_parm), & alp_all(ntyp,max_parm),ebr_all(max_parm),d0cm_all(max_parm), @@ -52,28 +78,30 @@ & v1sccor_all(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,max_parm), & v2sccor_all(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp,max_parm) integer nlob_all(ntyp1,max_parm), - & nlor_all(-maxtor:maxtor,-maxtor:maxtor,max_parm), - & nterm_all(-maxtor:maxtor,-maxtor:maxtor,max_parm), + & nlor_all(-maxtor:maxtor,-maxtor:maxtor,2,max_parm), + & nterm_all(-maxtor:maxtor,-maxtor:maxtor,2,max_parm), & ntermd1_all(-maxtor:maxtor,-maxtor:maxtor, - & -maxtor:maxtor,max_parm), + & -maxtor:maxtor,2,max_parm), & ntermd2_all(-maxtor:maxtor,-maxtor:maxtor, - & -maxtor:maxtor,max_parm), + & -maxtor:maxtor,2,max_parm), & nbondterm_all(ntyp,max_parm),nthetyp_all(max_parm), - & ithetyp_all(ntyp1,max_parm),ntheterm_all(max_parm), + & ithetyp_all(-ntyp1:ntyp1,max_parm),ntheterm_all(max_parm), & ntheterm2_all(max_parm),ntheterm3_all(max_parm), & nsingle_all(max_parm),ndouble_all(max_parm), & nntheterm_all(max_parm), &nterm_sccor_all(-ntyp:ntyp,-ntyp:ntyp,max_parm) common /allparm/ ww_all,vbldp0_all,akp_all,vbldsc0_all,aksc_all, & abond0_all,aa0thet_all,aathet_all,bbthet_all,ccthet_all, - & ddthet_all,eethet_all,ffthet_all,ggthet_all, + & ddthet_all,eethet_all,ffthet_all1,ggthet_all1, + & ffthet_all2,ggthet_all2, & a0thet_all,athet_all,bthet_all,polthet_all,gthet_all,theta0_all, & sig0_all,sigc0_all,dsc_all,bsc_all,censc_all,gaussc_all,dsc0_all, & sc_parmin_all, & v0_all,v1_all,v2_all,vlor1_all,vlor2_all,vlor3_all,v1c_all, & v1s_all,v2c_all,v2s_all,b1_all,b2_all,cc_all,dd_all,ee_all, & ctilde_all,dtilde_all,b1tilde_all,app_all,bpp_all,ael6_all, - & ael3_all,aad_all,bad_all,aa_all,bb_all,augm_all, + & ael3_all,aad_all,bad_all,aa_aq_all,bb_aq_all,augm_all, + & aa_lip_all,bb_lip_all,epslip_all, & eps_all,sigma_all,r0_all,chi_all,chip_all,alp_all,ebr_all, & d0cm_all,akcm_all,akth_all,akct_all,v1ss_all,v2ss_all,v3ss_all, & v1sccor_all,v2sccor_all,nbondterm_all, diff --git a/source/wham/src-M/COMMON.CHAIN b/source/wham/src-M/COMMON.CHAIN index 8dcdd98..24b8c56 100644 --- a/source/wham/src-M/COMMON.CHAIN +++ b/source/wham/src-M/COMMON.CHAIN @@ -12,3 +12,9 @@ &nsup,nstart_sup,anatemp, &nend_sup,chain_length,tabperm(maxperm,maxsym),nperm, & nstart_seq,ishift_pdb + double precision boxxsize,boxysize,boxzsize,enecut,sscut,sss, + &sssgrad, + & buflipbot, bufliptop,bordlipbot,bordliptop,lipbufthick,lipthick + common /box/ boxxsize,boxysize,boxzsize,enecut,sscut,sss,sssgrad, + & buflipbot, bufliptop,bordlipbot,bordliptop,lipbufthick,lipthick + diff --git a/source/wham/src-M/COMMON.CONTROL b/source/wham/src-M/COMMON.CONTROL index 6c87389..4f4fb65 100644 --- a/source/wham/src-M/COMMON.CONTROL +++ b/source/wham/src-M/COMMON.CONTROL @@ -1,10 +1,23 @@ integer iscode,indpdb,outpdb,outmol2,icomparfunc,pdbint, - & ensembles,constr_dist,symetr + & ensembles,constr_dist,symetr, + & constr_homology,homol_nset, + & iset,ihset + real*8 waga_homology + real*8 waga_dist, waga_angle, waga_theta, waga_d, dist_cut, + & dist2_cut logical refstr,pdbref,punch_dist,print_rms,caonly,verbose, & merge_helices,bxfile,cxfile,histfile,entfile,zscfile, - & rmsrgymap,with_dihed_constr,check_conf,histout + & rmsrgymap,with_dihed_constr,check_conf,histout,out1file, + & read2sigma,l_homo,with_theta_constr common /cntrl/ iscode,indpdb,refstr,pdbref,outpdb,outmol2, & punch_dist,print_rms,caonly,verbose,icomparfunc,pdbint, & merge_helices,bxfile,cxfile,histfile,entfile,zscfile,rmsrgymap, - & ensembles,with_dihed_constr,constr_dist,check_conf,histout, - &symetr + & ensembles,with_dihed_constr,check_conf,histout, + & with_theta_constr, + & symetr, + & constr_dist, + & constr_homology,out1file,homol_nset,read2sigma + common /homol/ waga_homology(maxR), + & waga_dist,waga_angle,waga_theta,waga_d,dist_cut,dist2_cut, + & iset,ihset,l_homo(max_template,maxdim) + diff --git a/source/wham/src-M/COMMON.HOMRESTR b/source/wham/src-M/COMMON.HOMRESTR new file mode 100644 index 0000000..5c23caf --- /dev/null +++ b/source/wham/src-M/COMMON.HOMRESTR @@ -0,0 +1,39 @@ + real*8 odl(max_template,maxdim),sigma_odl(max_template,maxdim), + & dih(max_template,maxres),sigma_dih(max_template,maxres), + & sigma_odlir(max_template,maxdim) +c +c Specification of new variables used in subroutine e_modeller +c modified by FP (Nov.,2014) + real*8 xxtpl(max_template,maxres),yytpl(max_template,maxres), + & zztpl(max_template,maxres),thetatpl(max_template,maxres), + & sigma_theta(max_template,maxres), + & sigma_d(max_template,maxres) +c + + integer ires_homo(maxdim),jres_homo(maxdim) + + double precision + & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst, + & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES), + & dutheta(maxres),dugamma(maxres), + & duscdiff(3,maxres), + & duscdiffx(3,maxres), + & uconst_back + integer lim_odl,lim_dih,link_start_homo,link_end_homo, + & idihconstr_start_homo,idihconstr_end_homo +c +c FP (30/10/2014) +c +c integer ithetaconstr_start_homo,ithetaconstr_end_homo +c + integer nresn,nyosh,nnos + common /back_constr/ uconst_back,uscdiff, + & dutheta,dugamma,duscdiff,duscdiffx + common /homrestr/ odl,dih,sigma_dih,sigma_odl, + & lim_odl,lim_dih,ires_homo,jres_homo,link_start_homo, + & link_end_homo,idihconstr_start_homo,idihconstr_end_homo, +c +c FP (30/10/2014,04/03/2015) +c + & xxtpl,yytpl,zztpl,thetatpl,sigma_theta,sigma_d,sigma_odlir +c diff --git a/source/wham/src-M/COMMON.IOUNITS b/source/wham/src-M/COMMON.IOUNITS index 23783bb..188d55e 100644 --- a/source/wham/src-M/COMMON.IOUNITS +++ b/source/wham/src-M/COMMON.IOUNITS @@ -10,11 +10,12 @@ C----------------------------------------------------------------------- C General I/O units & files integer inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep,irotam, & itorp,itordp,ifourier,ielep,isidep,iscpp,isccor,icbase, - & istat,ientin,ientout,isidep1,ibond,ihist,izsc,idistr + & istat,ientin,ientout,isidep1,ibond,ihist,izsc,idistr, + & iliptranpar common /iounits/ inp,iout,igeom,intin,ipdb,imol2,ipdbin,ithep, & irotam,itorp,itordp,ifourier,ielep,isidep,iscpp,isccor, & icbase,istat,ientin,ientout,isidep1,ibond,ihist,izsc, - & idistr + & idistr,iliptranpar character*256 outname,intname,pdbname,mol2name,statname,intinname, & entname,restartname,prefix,scratchdir,sidepname,pdbfile, & histname,zscname @@ -23,9 +24,11 @@ C General I/O units & files & sidepname,pdbfile,histname,zscname C Parameter files character*256 bondname,thetname,rotname,torname,tordname, - & fouriername,elename,sidename,scpname,sccorname,patname + & fouriername,elename,sidename,scpname,sccorname,patname, + & liptranname common /parfiles/ thetname,rotname,torname,tordname,bondname, - & fouriername,elename,sidename,scpname,sccorname,patname + & fouriername,elename,sidename,scpname,sccorname,patname, + & liptranname character*3 pot C----------------------------------------------------------------------- C INP - main input file diff --git a/source/wham/src-M/COMMON.SPLITELE b/source/wham/src-M/COMMON.SPLITELE new file mode 100644 index 0000000..a2f0447 --- /dev/null +++ b/source/wham/src-M/COMMON.SPLITELE @@ -0,0 +1,2 @@ + double precision r_cut,rlamb + common /splitele/ r_cut,rlamb diff --git a/source/wham/src-M/COMMON.VAR b/source/wham/src-M/COMMON.VAR index 326d6ec..5141f66 100644 --- a/source/wham/src-M/COMMON.VAR +++ b/source/wham/src-M/COMMON.VAR @@ -3,12 +3,13 @@ C Store the geometric variables in the following COMMON block. double precision theta,phi,alph,omeg,vbld,vbld_ref, & theta_ref,phi_ref,alph_ref,omeg_ref, & costtab,sinttab,cost2tab,sint2tab,tauangle,omicron, - & xxtab,yytab,zztab + & xxtab,yytab,zztab, + & thetaref,phiref,xxref,yyref,zzref common /var/ theta(maxres),phi(maxres),alph(maxres),omeg(maxres), - & vbld(2*maxres), + & vbld(2*maxres),thetaref(maxres),phiref(maxres), & costtab(maxres), sinttab(maxres), cost2tab(maxres), & sint2tab(maxres),xxtab(maxres),yytab(maxres), - & zztab(maxres), + & zztab(maxres),xxref(maxres),yyref(maxres),zzref(maxres), & ialph(maxres,2),ivar(4*maxres2),ntheta,nphi,nside,nvar, & omicron(2,maxres),tauangle(3,maxres) C Angles from experimental structure diff --git a/source/wham/src-M/DIMENSIONS b/source/wham/src-M/DIMENSIONS index 00fa77f..dcb64c3 100644 --- a/source/wham/src-M/DIMENSIONS +++ b/source/wham/src-M/DIMENSIONS @@ -14,7 +14,7 @@ c parameter (max_cg_procs=maxprocs) C Max. number of AA residues integer maxres c parameter (maxres=250) - parameter (maxres=100) + parameter (maxres=800) C Appr. max. number of interaction sites integer maxres2 parameter (maxres2=2*maxres) @@ -39,7 +39,7 @@ C Max. number of contacts per residue parameter (maxconts=maxres) C Number of AA types (at present only natural AA's will be handled integer ntyp,ntyp1 - parameter (ntyp=20,ntyp1=ntyp+1) + parameter (ntyp=24,ntyp1=ntyp+1) integer nntyp parameter (nntyp=ntyp*(ntyp+1)/2) C Max. number of types of dihedral angles & multiplicity of torsional barriers @@ -143,3 +143,6 @@ C Maximum number of SC local term fitting function coefficiants C Maximum number of terms in SC bond-stretching potential integer maxbondterm parameter (maxbondterm=3) +C Maximum number of templates in homology-modeling restraints + integer max_template + parameter(max_template=25) diff --git a/source/wham/src-M/DIMENSIONS.FREE b/source/wham/src-M/DIMENSIONS.FREE index 691d9b2..e9ebe0e 100644 --- a/source/wham/src-M/DIMENSIONS.FREE +++ b/source/wham/src-M/DIMENSIONS.FREE @@ -3,8 +3,8 @@ integer MaxR,MaxT_h integer MaxSlice parameter (Max_Parm=1) - parameter (MaxQ=1,MaxQ1=MaxQ+2) - parameter(MaxR=1,MaxT_h=32) + parameter (MaxQ=4,MaxQ1=MaxQ+2) + parameter(MaxR=1,MaxT_h=36) parameter(MaxSlice=40) integer MaxN parameter (MaxN=100) diff --git a/source/wham/src-M/DIMENSIONS.ZSCOPT b/source/wham/src-M/DIMENSIONS.ZSCOPT index 2f5ee76..6519938 100644 --- a/source/wham/src-M/DIMENSIONS.ZSCOPT +++ b/source/wham/src-M/DIMENSIONS.ZSCOPT @@ -3,7 +3,7 @@ c Maximum number of structures in the database, energy components, proteins, c and structural classes c#ifdef JUBL - parameter (maxstr=200000,max_ene=21,maxprot=7,maxclass=5000) + parameter (maxstr=200000,max_ene=25,maxprot=7,maxclass=5000) parameter (maxclass1=10) c Maximum number of structures to be dealt with by one processor parameter (maxstr_proc=10000) @@ -25,7 +25,7 @@ c Maximum number of grid points in energy map evaluation parameter (max_x=200,max_y=200,max_minim=1000) c Maximum number of processors integer MaxProcs - parameter (MaxProcs = 2048) + parameter (MaxProcs = 128) c Maximum number of optimizable parameters integer max_paropt parameter (max_paropt=500) diff --git a/source/wham/src-M/cartder.f b/source/wham/src-M/cartder.f index ed14f18..693fd60 100644 --- a/source/wham/src-M/cartder.f +++ b/source/wham/src-M/cartder.f @@ -263,7 +263,7 @@ cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) * Derivatives in alpha and omega: * do i=2,nres-1 - dsci=dsc(itype(i)) + dsci=dsc(iabs(itype(i))) alphi=alph(i) omegi=omeg(i) cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi diff --git a/source/wham/src-M/contact.f b/source/wham/src-M/contact.f index 40ed61d..e481284 100644 --- a/source/wham/src-M/contact.f +++ b/source/wham/src-M/contact.f @@ -2,6 +2,7 @@ implicit none include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' include 'COMMON.CONTROL' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' @@ -29,10 +30,10 @@ endif 110 format (a,'(',i3,')',9f8.3) do i=ist,ien-kkk - iti=itype(i) + iti=iabs(itype(i)) if (iti.le.0 .or. iti.gt.ntyp) cycle do j=i+kkk,ien - itj=itype(j) + itj=iabs(itype(j)) if (itj.le.0 .or. itj.gt.ntyp) cycle itypi=iti itypj=itj @@ -94,7 +95,7 @@ c & csc it2=itype(i2) write (iout,'(i3,2x,a,i4,2x,a,i4,5f8.3,3f10.5)') & i,restyp(it1),i1,restyp(it2),i2,cscore(i), - & sc_cutoff(it1,it2),ddsc(i),ddla(i),ddlb(i), + & sc_cutoff(iabs(it1),iabs(it2)),ddsc(i),ddla(i),ddlb(i), & omt1(i),omt2(i),omt12(i) enddo endif diff --git a/source/wham/src-M/cxread.F b/source/wham/src-M/cxread.F index 7bb2f6a..c4cc7bb 100644 --- a/source/wham/src-M/cxread.F +++ b/source/wham/src-M/cxread.F @@ -63,8 +63,15 @@ c write (iout,*) "rpotE",rpotE," iret",iret call xdrffloat_(ixdrf, rt_bath, iret) call xdrfint_(ixdrf, nss, iret) do j=1,nss - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j), iret) + call xdrfint(ixdrf, jdssb(j), iret) + idssb(j)=idssb(j)-nres + jdssb(j)=jdssb(j)-nres + else + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + endif enddo call xdrfint_(ixdrf, nprop, iret) if (umbrella(iparm) .or. read_iset(iparm) .or. hamil_rep) @@ -81,8 +88,13 @@ c write (iout,*) "rpotE",rpotE," iret",iret call xdrffloat(ixdrf, rt_bath, iret) call xdrfint(ixdrf, nss, iret) do j=1,nss - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j), iret) + call xdrfint(ixdrf, jdssb(j), iret) + else + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + endif enddo call xdrfint(ixdrf, nprop, iret) c write (iout,*) "nprop",nprop diff --git a/source/wham/src-M/define_pairs.f b/source/wham/src-M/define_pairs.f index 00866a8..789575b 100644 --- a/source/wham/src-M/define_pairs.f +++ b/source/wham/src-M/define_pairs.f @@ -3,6 +3,7 @@ include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' include 'COMMON.IOUNITS' include 'COMMON.TIME1' include 'COMMON.SBRIDGE' diff --git a/source/wham/src-M/enecalc1.F b/source/wham/src-M/enecalc1.F index 880664c..a2347d3 100644 --- a/source/wham/src-M/enecalc1.F +++ b/source/wham/src-M/enecalc1.F @@ -47,6 +47,7 @@ integer snk_p(MaxR,MaxT_h,Max_parm) logical lerr character*64 bprotfile_temp + integer scount_t(0:maxprocs-1) call opentmp(islice,ientout,bprotfile_temp) iii=0 ii=0 @@ -60,6 +61,8 @@ enddo enddo enddo + write (iout,*) "indstart(me1),indend(me1)" + &,indstart(me1),indend(me1) do i=indstart(me1),indend(me1) #else do iparm=1,nParmSet @@ -155,13 +158,17 @@ c & " kfac",kfac,"quot",quot," fT",fT & wtor_d,wsccor,wbond #endif call etotal(energia(0),fT) + if (constr_homology.gt.0) energia(0)=energia(0)+ + & waga_homology(iset)*energia(22) +c write (iout,*) "constr_homology",constr_homology," iset",iset, +c & " waga_homology",waga_homology(iset) #ifdef DEBUG write (iout,*) "Conformation",i write (iout,'(8f10.5)') ((c(l,k),l=1,3),k=1,nres) write (iout,'(8f10.5)') ((c(l,k+nres),l=1,3),k=nnt,nct) call enerprint(energia(0),fT) write (iout,'(2i5,21f8.2)') i,iparm,(energia(k),k=1,21) - write (iout,*) "ftors",ftors + write (iout,*) "ftors(1)",ftors(1) call briefout(i,energia(0)) temp=1.0d0/(beta_h(ib,ipar)*1.987D-3) write (iout,*) "temp", temp @@ -220,7 +227,7 @@ c call pdbout(ii+1,beta_h(ib,ipar),efree,energia(0),0.0d0,rmsdev) endif endif potE(iii+1,iparm)=energia(0) - do k=1,21 + do k=1,22 enetb(k,iii+1,iparm)=energia(k) enddo #ifdef DEBUG @@ -273,8 +280,11 @@ c & " snk",snk_p(iR,ib,ipar) write (iout,*) "Me",me," scount",scount(me) call flush(iout) c Master gathers updated numbers of conformations written by all procs. - call MPI_AllGather( scount(me), 1, MPI_INTEGER, scount(0), 1, + call MPI_AllGather( scount(me), 1, MPI_INTEGER, scount_t(0), 1, & MPI_INTEGER, WHAM_COMM, IERROR) + do k=0,nprocs-1 + scount(k) = scount_t(k) + enddo indstart(0)=1 indend(0)=scount(0) do i=1, Nprocs-1 @@ -346,6 +356,7 @@ c------------------------------------------------------------------------------ include "COMMON.ENERGIES" include "COMMON.COMPAR" include "COMMON.PROT" + include "COMMON.CONTACTS1" character*64 nazwa character*80 bxname,cxname character*64 bprotfile_temp @@ -359,7 +370,8 @@ c------------------------------------------------------------------------------ double precision energ integer ilen,iroof external ilen,iroof - integer ir,ib,iparm + integer ir,ib,iparm, scount_buff(0:99) + integer isecstr(maxres) write (licz2,'(bz,i2.2)') islice call opentmp(islice,ientout,bprotfile_temp) write (iout,*) "bprotfile_temp ",bprotfile_temp @@ -458,8 +470,12 @@ c write (iout,*) iR,ib,iparm,eini,efree iscore=0 c write (iout,*) "Calling conf_compar",i c call flush(iout) + anatemp= 1.0d0/(beta_h(ib,iparm)*1.987D-3) if (indpdb.gt.0) then call conf_compar(i,.false.,.true.) +c else +c call elecont(.false.,ncont,icont,nnt,nct) +c call secondary2(.false.,.false.,ncont,icont,isecstr) endif c write (iout,*) "Exit conf_compar",i c call flush(iout) @@ -659,8 +675,13 @@ c write (iout,*) "xdrf3dfcoord" c call flush(iout) call xdrfint_(ixdrf, nss, iret) do j=1,nss - call xdrfint_(ixdrf, ihpb(j), iret) - call xdrfint_(ixdrf, jhpb(j), iret) + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j)+nres, iret) + call xdrfint(ixdrf, jdssb(j)+nres, iret) + else + call xdrfint_(ixdrf, ihpb(j), iret) + call xdrfint_(ixdrf, jhpb(j), iret) + endif enddo call xdrffloat_(ixdrf,real(eini),iret) call xdrffloat_(ixdrf,real(efree),iret) @@ -671,8 +692,13 @@ c call flush(iout) call xdrfint(ixdrf, nss, iret) do j=1,nss - call xdrfint(ixdrf, ihpb(j), iret) - call xdrfint(ixdrf, jhpb(j), iret) + if (dyn_ss) then + call xdrfint(ixdrf, idssb(j)+nres, iret) + call xdrfint(ixdrf, jdssb(j)+nres, iret) + else + call xdrfint(ixdrf, ihpb(j), iret) + call xdrfint(ixdrf, jhpb(j), iret) + endif enddo call xdrffloat(ixdrf,real(eini),iret) call xdrffloat(ixdrf,real(efree),iret) @@ -716,8 +742,8 @@ c------------------------------------------------------------------------------ endif call int_from_cart1(.false.) do j=nnt+1,nct - if (itype(j-1).ne.21 .and. itype(j).ne.21 .and. - & (vbld(j).lt.2.0d0 .or. vbld(j).gt.5.0d0)) then + if (itype(j-1).ne.ntyp1 .and. itype(j).ne.ntyp1 .and. + & (vbld(j).lt.2.0d0 .or. vbld(j).gt.6.0d0)) then if (iprint.gt.0) & write (iout,*) "Bad CA-CA bond length",j," ",vbld(j), & " for conformation",ii @@ -741,8 +767,8 @@ c------------------------------------------------------------------------------ enddo do j=nnt,nct itj=itype(j) - if (itype(j).ne.10 .and.itype(j).ne.21 .and. - & (vbld(nres+j)-dsc(itj)).gt.2.0d0) then + if (itype(j).ne.10 .and.itype(j).ne.ntyp1 .and. + & (vbld(nres+j)-dsc(iabs(itj))).gt.5.0d0) then if (iprint.gt.0) & write (iout,*) "Bad CA-SC bond length",j," ",vbld(nres+j), & " for conformation",ii diff --git a/source/wham/src-M/energy_p_new.F b/source/wham/src-M/energy_p_new.F index af921d0..d0775ad 100644 --- a/source/wham/src-M/energy_p_new.F +++ b/source/wham/src-M/energy_p_new.F @@ -2,6 +2,7 @@ implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' #ifndef ISNAN external proc_proc @@ -22,6 +23,7 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.INTERACT' include 'COMMON.SBRIDGE' include 'COMMON.CHAIN' + include 'COMMON.CONTROL' double precision fact(6) cd write(iout, '(a,i2)')'Calling etotal ipot=',ipot cd print *,'nnt=',nnt,' nct=',nct @@ -98,16 +100,29 @@ c print *,"calling multibody_eello" call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) c write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1 c print *,ecorr,ecorr5,ecorr6,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) then call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) endif +c write(iout,*) "TEST_ENE1 constr_homology=",constr_homology + if (constr_homology.ge.1) then + call e_modeller(ehomology_constr) + else + ehomology_constr=0.0d0 + endif + +c write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr c write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t #ifdef SPLITELE etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees & +wvdwpp*evdw1 & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d @@ -116,7 +131,7 @@ c write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2 & +welec*fact(1)*(ees+evdw1) & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc - & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d @@ -154,6 +169,7 @@ c write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t energia(19)=esccor energia(20)=edihcnstr energia(21)=evdw_t + energia(22)=ehomology_constr c detecting NaNQ #ifdef ISNAN #ifdef AIX @@ -173,6 +189,11 @@ c detecting NaNQ #ifdef MPL c endif #endif +#define DEBUG +#ifdef DEBUG + call enerprint(energia,fact) +#endif +#undef DEBUG if (calc_grad) then C C Sum up the components of the Cartesian gradient. @@ -192,6 +213,7 @@ C & wcorr6*fact(5)*gradcorr6(j,i)+ & wturn6*fact(5)*gcorr6_turn(j,i)+ & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) 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)+ @@ -211,10 +233,12 @@ C & wcorr6*fact(5)*gradcorr6(j,i)+ & wturn6*fact(5)*gcorr6_turn(j,i)+ & wsccor*fact(2)*gsccorc(j,i) + & +wliptran*gliptranc(j,i) 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*fact(1)*gsccorx(j,i) + & +wliptran*gliptranx(j,i) enddo #endif enddo @@ -228,8 +252,11 @@ C & +wturn3*fact(2)*gel_loc_turn3(i) & +wturn6*fact(5)*gel_loc_turn6(i) & +wel_loc*fact(2)*gel_loc_loc(i) +c & +wsccor*fact(1)*gsccor_loc(i) +c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA enddo endif + if (dyn_ss) call dyn_set_nss return end C------------------------------------------------------------------------ @@ -267,6 +294,7 @@ C------------------------------------------------------------------------ esccor=energia(19) edihcnstr=energia(20) estr=energia(18) + ehomology_constr=energia(22) #ifdef SPLITELE write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1, & wvdwpp, @@ -275,7 +303,7 @@ C------------------------------------------------------------------------ & ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), & eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2), & eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5), - & esccor,wsccor*fact(1),edihcnstr,ebr*nss,etot + & esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,etot 10 format (/'Virtual-chain energies:'// & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ @@ -297,6 +325,7 @@ C------------------------------------------------------------------------ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & 'ETOT= ',1pE16.6,' (total)') #else @@ -306,7 +335,8 @@ C------------------------------------------------------------------------ & ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2), & eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3), & eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor, - & edihcnstr,ebr*nss,etot + & edihcnstr,ehomology_constr,ebr*nss, + & etot 10 format (/'Virtual-chain energies:'// & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ @@ -327,6 +357,7 @@ C------------------------------------------------------------------------ & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ + & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/ & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ & 'ETOT= ',1pE16.6,' (total)') #endif @@ -367,9 +398,9 @@ cd print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 evdw_t=0.0d0 do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - itypi1=itype(i+1) + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -382,8 +413,8 @@ C 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) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi @@ -393,8 +424,8 @@ C Change 12/1/95 to calculate four-body interactions 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) + e1=fac*fac*aa + e2=fac*bb evdwij=e1+e2 ij=icant(itypi,itypj) eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij) @@ -405,7 +436,7 @@ 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) - if (bb(itypi,itypj).gt.0.0d0) then + if (bb.gt.0.0d0) then evdw=evdw+evdwij else evdw_t=evdw_t+evdwij @@ -540,9 +571,9 @@ c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 evdw_t=0.0d0 do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - itypi1=itype(i+1) + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -551,8 +582,8 @@ C Calculate SC interaction energy. C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi @@ -563,8 +594,8 @@ C rij=1.0D0/r_inv_ij 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) + e1=fac*fac*aa + e2=fac*bb evdwij=e_augm+e1+e2 ij=icant(itypi,itypj) eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm) @@ -577,7 +608,7 @@ 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) - if (bb(itypi,itypj).gt.0.0d0) then + if (bb.gt.0.0d0) then evdw=evdw+evdwij else evdw_t=evdw_t+evdwij @@ -653,9 +684,9 @@ c else c endif ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - itypi1=itype(i+1) + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -669,8 +700,8 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle dscj_inv=vbld_inv(j+nres) chi1=chi(itypi,itypj) chi2=chi(itypj,itypi) @@ -709,8 +740,8 @@ C Calculate the angle-dependent terms of energy & contributions to derivatives. 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) + e1=fac*fac*aa + e2=fac*bb evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt @@ -720,15 +751,15 @@ C to its derivatives eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux & /dabs(eps(itypi,itypj)) eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj) - if (bb(itypi,itypj).gt.0.0d0) then + if (bb.gt.0.0d0) then evdw=evdw+evdwij else evdw_t=evdw_t+evdwij endif if (calc_grad) then if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) + sigm=dabs(aa/bb)**(1.0D0/6.0D0) + epsi=bb**2/aa write (iout,'(2(a3,i3,2x),15(0pf7.3))') & restyp(itypi),i,restyp(itypj),j, & epsi,sigm,chi1,chi2,chip1,chip2, @@ -775,9 +806,10 @@ C include 'COMMON.ENEPS' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include 'COMMON.SBRIDGE' logical lprn common /srutu/icall - integer icant + integer icant,xshift,yshift,zshift external icant do i=1,210 do j=1,2 @@ -791,12 +823,42 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.gt.0) lprn=.true. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - itypi1=itype(i+1) + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) +C returning the ith atom to box + xi=mod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=mod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=mod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize + if ((zi.gt.bordlipbot) + &.and.(zi.lt.bordliptop)) then +C the energy transfer exist + if (zi.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((zi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipi=sscalelip(fracinbuf) + ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick + elseif (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick) + sslipi=sscalelip(fracinbuf) + ssgradlipi=sscagradlip(fracinbuf)/lipbufthick + else + sslipi=1.0d0 + ssgradlipi=0.0 + endif + else + sslipi=0.0d0 + ssgradlipi=0.0 + endif + dxi=dc_norm(1,nres+i) dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) @@ -806,9 +868,29 @@ C Calculate SC interaction energy. C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) + IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN + call dyn_ssbond_ene(i,j,evdwij) + evdw=evdw+evdwij +C write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)') +C & 'evdw',i,j,evdwij,' ss',evdw,evdw_t +C triple bond artifac removal + do k=j+1,iend(i,iint) +C search over all next residues + if (dyn_ss_mask(k)) then +C check if they are cysteins +C write(iout,*) 'k=',k + call triple_ssbond_ene(i,j,k,evdwij) +C call the energy function that removes the artifical triple disulfide +C bond the soubroutine is located in ssMD.F + evdw=evdw+evdwij +C write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)') +C & 'evdw',i,j,evdwij,'tss',evdw,evdw_t + endif!dyn_ss_mask(k) + enddo! k + ELSE ind=ind+1 - itypj=itype(j) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle dscj_inv=vbld_inv(j+nres) sig0ij=sigma(itypi,itypj) chi1=chi(itypi,itypj) @@ -830,17 +912,96 @@ c chip12=0.0D0 c alf1=0.0D0 c alf2=0.0D0 c alf12=0.0D0 - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) +C returning jth atom to box + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + if ((zj.gt.bordlipbot) + &.and.(zj.lt.bordliptop)) then +C the energy transfer exist + if (zj.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((zj-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipj=sscalelip(fracinbuf) + ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick + elseif (zj.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick) + sslipj=sscalelip(fracinbuf) + ssgradlipj=sscagradlip(fracinbuf)/lipbufthick + else + sslipj=1.0d0 + ssgradlipj=0.0 + endif + else + sslipj=0.0d0 + ssgradlipj=0.0 + endif + aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 + bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 +C if (aa.ne.aa_aq(itypi,itypj)) then + +C write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa, +C & bb_aq(itypi,itypj)-bb, +C & sslipi,sslipj +C endif + +C write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj) +C checking the distance + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 +C finding the closest + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + subchap=1 + endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif + dxj=dc_norm(1,nres+j) dyj=dc_norm(2,nres+j) dzj=dc_norm(3,nres+j) c write (iout,*) i,j,xj,yj,zj rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) + sss=sscale((1.0d0/rij)/sigma(itypi,itypj)) + sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj)) + if (sss.le.0.0) cycle C Calculate angle-dependent terms of energy and contributions to their C derivatives. + call sc_angular sigsq=1.0D0/sigsq sig=sig0ij*dsqrt(sigsq) @@ -854,16 +1015,16 @@ C I hate to put IF's in the loops, but here don't have another choice!!!! c--------------------------------------------------------------- rij_shift=1.0D0/rij_shift fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) + e1=fac*fac*aa + e2=fac*bb evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt evdwij=evdwij*eps2rt*eps3rt - if (bb(itypi,itypj).gt.0) then - evdw=evdw+evdwij + if (bb.gt.0) then + evdw=evdw+evdwij*sss else - evdw_t=evdw_t+evdwij + evdw_t=evdw_t+evdwij*sss endif ij=icant(itypi,itypj) aux=eps1*eps2rt**2*eps3rt**2 @@ -874,8 +1035,9 @@ c write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj, c & " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)), c & aux*e2/eps(itypi,itypj) c if (lprn) then - sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) - epsi=bb(itypi,itypj)**2/aa(itypi,itypj) + sigm=dabs(aa/bb)**(1.0D0/6.0D0) + epsi=bb**2/aa +C#define DEBUG #ifdef DEBUG write (iout,'(2(a3,i3,2x),17(0pf7.3))') & restyp(itypi),i,restyp(itypj),j, @@ -885,6 +1047,7 @@ c if (lprn) then & evdwij write (iout,*) "partial sum", evdw, evdw_t #endif +C#undef DEBUG c endif if (calc_grad) then C Calculate gradient components. @@ -892,6 +1055,7 @@ C Calculate gradient components. fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac + fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij C Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac @@ -899,6 +1063,8 @@ C Calculate the radial part of the gradient C Calculate angular part of the gradient. call sc_grad endif +C write(iout,*) "partial sum", evdw, evdw_t + ENDIF ! dyn_ss enddo ! j enddo ! iint enddo ! i @@ -941,9 +1107,9 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.gt.0) lprn=.true. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - itypi1=itype(i+1) + itypi=iabs(itype(i)) + if (itypi.eq.ntyp1) cycle + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -957,8 +1123,8 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle dscj_inv=vbld_inv(j+nres) sig0ij=sigma(itypi,itypj) r0ij=r0(itypi,itypj) @@ -1004,15 +1170,15 @@ C I hate to put IF's in the loops, but here don't have another choice!!!! c--------------------------------------------------------------- rij_shift=1.0D0/rij_shift fac=rij_shift**expon - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) + e1=fac*fac*aa + e2=fac*bb evdwij=eps1*eps2rt*eps3rt*(e1+e2) eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt fac_augm=rrij**expon e_augm=augm(itypi,itypj)*fac_augm evdwij=evdwij*eps2rt*eps3rt - if (bb(itypi,itypj).gt.0.0d0) then + if (bb.gt.0.0d0) then evdw=evdw+evdwij+e_augm else evdw_t=evdw_t+evdwij+e_augm @@ -1770,6 +1936,7 @@ C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' include 'COMMON.CONTROL' include 'COMMON.IOUNITS' include 'COMMON.GEO' @@ -1852,7 +2019,14 @@ cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e gcorr_loc(i)=0.0d0 enddo do i=iatel_s,iatel_e - if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle + if (i.le.1) cycle + if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1 + & .or. ((i+2).gt.nres) + & .or. ((i-1).le.0) + & .or. itype(i+2).eq.ntyp1 + & .or. itype(i-1).eq.ntyp1 + &) cycle +C endif if (itel(i).eq.0) goto 1215 dxi=dc(1,i) dyi=dc(2,i) @@ -1863,10 +2037,22 @@ cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi + xmedi=mod(xmedi,boxxsize) + if (xmedi.lt.0) xmedi=xmedi+boxxsize + ymedi=mod(ymedi,boxysize) + if (ymedi.lt.0) ymedi=ymedi+boxysize + zmedi=mod(zmedi,boxzsize) + if (zmedi.lt.0) zmedi=zmedi+boxzsize num_conti=0 -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) +C write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) do j=ielstart(i),ielend(i) - if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle + if (j.le.1) cycle + if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1 + & .or.((j+2).gt.nres) + & .or.((j-1).le.0) + & .or.itype(j+2).eq.ntyp1 + & .or.itype(j-1).eq.ntyp1 + &) cycle if (itel(j).eq.0) goto 1216 ind=ind+1 iteli=itel(i) @@ -1888,10 +2074,49 @@ C End diagnostics dx_normj=dc_norm(1,j) dy_normj=dc_norm(2,j) dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj-xmedi - yj=c(2,j)+0.5D0*dyj-ymedi - zj=c(3,j)+0.5D0*dzj-zmedi + xj=c(1,j)+0.5D0*dxj + yj=c(2,j)+0.5D0*dyj + zj=c(3,j)+0.5D0*dzj + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + isubchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + isubchap=1 + endif + enddo + enddo + enddo + if (isubchap.eq.1) then + xj=xj_temp-xmedi + yj=yj_temp-ymedi + zj=zj_temp-zmedi + else + xj=xj_safe-xmedi + yj=yj_safe-ymedi + zj=zj_safe-zmedi + endif rij=xj*xj+yj*yj+zj*zj + sss=sscale(sqrt(rij)) + sssgrad=sscagrad(sqrt(rij)) rrmij=1.0D0/rij rij=dsqrt(rij) rmij=1.0D0/rij @@ -1915,7 +2140,7 @@ c write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij 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 + evdw1=evdw1+evdwij*sss cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, @@ -1924,7 +2149,7 @@ C C Calculate contributions to the Cartesian gradient. C #ifdef SPLITELE - facvdw=-6*rrmij*(ev1+evdwij) + facvdw=-6*rrmij*(ev1+evdwij)*sss facel=-3*rrmij*(el1+eesij) fac1=fac erij(1)=xj*rmij @@ -2540,6 +2765,18 @@ C Third- and fourth-order contributions from turns & aggj(3,4),aggj1(3,4),a_temp(2,2) common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2 if (j.eq.i+2) then + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 +C changes suggested by Ana to avoid out of bounds +C & .or.((i+5).gt.nres) +C & .or.((i-1).le.0) +C end of changes suggested by Ana + & .or. itype(i+2).eq.ntyp1 + & .or. itype(i+3).eq.ntyp1 +C & .or. itype(i+5).eq.ntyp1 +C & .or. itype(i).eq.ntyp1 +C & .or. itype(i-1).eq.ntyp1 + & ) goto 179 + CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C Third-order contributions @@ -2602,7 +2839,19 @@ C Cartesian derivatives & +0.5d0*(pizda(1,1)+pizda(2,2)) enddo endif - else if (j.eq.i+3 .and. itype(i+2).ne.21) then + 179 continue + else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 +C changes suggested by Ana to avoid out of bounds +C & .or.((i+5).gt.nres) +C & .or.((i-1).le.0) +C end of changes suggested by Ana + & .or. itype(i+3).eq.ntyp1 + & .or. itype(i+4).eq.ntyp1 +C & .or. itype(i+5).eq.ntyp1 + & .or. itype(i).eq.ntyp1 +C & .or. itype(i-1).eq.ntyp1 + & ) goto 178 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C Fourth-order contributions @@ -2742,6 +2991,7 @@ C Remaining derivatives of this turn contribution gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) enddo endif + 178 continue endif return end @@ -2803,7 +3053,7 @@ cd print '(a)','Enter ESCP' c write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e, c & ' scal14',scal14 do i=iatscp_s,iatscp_e - if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle iteli=itel(i) c write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i), c & " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) @@ -2811,37 +3061,90 @@ c & " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i)) xi=0.5D0*(c(1,i)+c(1,i+1)) yi=0.5D0*(c(2,i)+c(2,i+1)) zi=0.5D0*(c(3,i)+c(3,i+1)) - +C Returning the ith atom to box + xi=mod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=mod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=mod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize do iint=1,nscp_gr(i) do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) - if (itypj.eq.21) cycle + itypj=iabs(itype(j)) + if (itypj.eq.ntyp1) cycle C Uncomment following three lines for SC-p interactions c xj=c(1,nres+j)-xi c yj=c(2,nres+j)-yi c zj=c(3,nres+j)-zi C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi + xj=c(1,j) + yj=c(2,j) + zj=c(3,j) +C returning the jth atom to box + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 +C Finding the closest jth atom + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + subchap=1 + endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +C sss is scaling function for smoothing the cutoff gradient otherwise +C the gradient would not be continuouse + sss=sscale(1.0d0/(dsqrt(rrij))) + if (sss.le.0.0d0) cycle + sssgrad=sscagrad(1.0d0/(dsqrt(rrij))) fac=rrij**expon2 e1=fac*fac*aad(itypj,iteli) e2=fac*bad(itypj,iteli) if (iabs(j-i) .le. 2) then e1=scal14*e1 e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 + evdw2_14=evdw2_14+(e1+e2)*sss endif evdwij=e1+e2 -c write (iout,*) i,j,evdwij - evdw2=evdw2+evdwij +c write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') +c & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli), +c & bad(itypj,iteli) + evdw2=evdw2+evdwij*sss if (calc_grad) then C C Calculate contributions to the gradient in the virtual-bond and SC vectors. C - fac=-(evdwij+e1)*rrij + fac=-(evdwij+e1)*rrij*sss + fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon ggg(1)=xj*fac ggg(2)=yj*fac ggg(3)=zj*fac @@ -2901,15 +3204,19 @@ C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' include 'COMMON.SBRIDGE' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.VAR' include 'COMMON.INTERACT' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' dimension ggg(3) ehpb=0.0D0 cd print *,'edis: nhpb=',nhpb,' fbr=',fbr cd print *,'link_start=',link_start,' link_end=',link_end +C write(iout,*) 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 @@ -2926,24 +3233,98 @@ C iii and jjj point to the residues for which the distance is assigned. endif 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 +C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. +C & iabs(itype(jjj)).eq.1) then +C write(iout,*) constr_dist,"const" + if (.not.dyn_ss .and. i.le.nss) then + if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. + & iabs(itype(jjj)).eq.1) then call ssbond_ene(iii,jjj,eij) ehpb=ehpb+2*eij - 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) + endif !ii.gt.neres + else if (ii.gt.nres .and. jj.gt.nres) then +c Restraints from contact prediction + dd=dist(ii,jj) + if (constr_dist.eq.11) then +C ehpb=ehpb+fordepth(i)**4.0d0 +C & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + ehpb=ehpb+fordepth(i)**4.0d0 + & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + fac=fordepth(i)**4.0d0 + & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd +C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, +C & ehpb,fordepth(i),dd +C write(iout,*) ehpb,"atu?" +C ehpb,"tu?" +C fac=fordepth(i)**4.0d0 +C & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd + else + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "beta nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else + dd=dist(ii,jj) + rdis=dd-dhpb(i) +C Get the force constant corresponding to this distance. + waga=forcon(i) +C Calculate the contribution to energy. + ehpb=ehpb+waga*rdis*rdis +c write (iout,*) "beta reg",dd,waga*rdis*rdis +C +C Evaluate gradient. +C + fac=waga*rdis/dd + endif !end dhpb1(i).gt.0 + endif !end const_dist=11 + do j=1,3 + ggg(j)=fac*(c(j,jj)-c(j,ii)) + enddo + do j=1,3 + ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) + ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) + enddo + do k=1,3 + ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) + ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) + enddo + else !ii.gt.nres +C write(iout,*) "before" + dd=dist(ii,jj) +C write(iout,*) "after",dd + if (constr_dist.eq.11) then + ehpb=ehpb+fordepth(i)**4.0d0 + & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) + fac=fordepth(i)**4.0d0 + & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd +C ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i)) +C fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd +C print *,ehpb,"tu?" +C write(iout,*) ehpb,"btu?", +C & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i) +C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, +C & ehpb,fordepth(i),dd + else + if (dhpb1(i).gt.0.0d0) then + ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd +c write (iout,*) "alph nmr", +c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) + else + rdis=dd-dhpb(i) C Get the force constant corresponding to this distance. - waga=forcon(i) + waga=forcon(i) C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis + ehpb=ehpb+waga*rdis*rdis +c write (iout,*) "alpha reg",dd,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 + fac=waga*rdis/dd + endif + endif + do j=1,3 ggg(j)=fac*(c(j,jj)-c(j,ii)) enddo @@ -2963,7 +3344,7 @@ C Cartesian gradient in the SC vectors (ghpbx). enddo endif enddo - ehpb=0.5D0*ehpb + if (constr_dist.ne.11) ehpb=0.5D0*ehpb return end C-------------------------------------------------------------------------- @@ -2986,7 +3367,7 @@ C include 'COMMON.VAR' include 'COMMON.IOUNITS' double precision erij(3),dcosom1(3),dcosom2(3),gg(3) - itypi=itype(i) + itypi=iabs(itype(i)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -2994,7 +3375,7 @@ C dyi=dc_norm(2,nres+i) dzi=dc_norm(3,nres+i) dsci_inv=dsc_inv(itypi) - itypj=itype(j) + itypj=iabs(itype(j)) dscj_inv=dsc_inv(itypj) xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi @@ -3052,6 +3433,612 @@ C return end C-------------------------------------------------------------------------- +c MODELLER restraint function + subroutine e_modeller(ehomology_constr) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + integer nnn, i, j, k, ki, irec, l + integer katy, odleglosci, test7 + real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template) + real*8 distance(max_template),distancek(max_template), + & min_odl,godl(max_template),dih_diff(max_template) + +c +c FP - 30/10/2014 Temporary specifications for homology restraints +c + double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta, + & sgtheta + double precision, dimension (maxres) :: guscdiff,usc_diff + double precision, dimension (max_template) :: + & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3, + & theta_diff + + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' + include 'COMMON.HOMRESTR' +c + include 'COMMON.SETUP' + include 'COMMON.NAMES' + + do i=1,max_template + distancek(i)=9999999.9 + enddo + + odleg=0.0d0 + +c Pseudo-energy and gradient from homology restraints (MODELLER-like +c function) +C AL 5/2/14 - Introduce list of restraints +c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d +#ifdef DEBUG + write(iout,*) "------- dist restrs start -------" +#endif + do ii = link_start_homo,link_end_homo + i = ires_homo(ii) + j = jres_homo(ii) + dij=dist(i,j) +c write (iout,*) "dij(",i,j,") =",dij + do k=1,constr_homology + if(.not.l_homo(k,ii)) cycle + distance(k)=odl(k,ii)-dij +c write (iout,*) "distance(",k,") =",distance(k) +c +c For Gaussian-type Urestr +c + distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument +c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii) +c write (iout,*) "distancek(",k,") =",distancek(k) +c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii) +c +c For Lorentzian-type Urestr +c + if (waga_dist.lt.0.0d0) then + sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii)) + distancek(k)=distance(k)**2/(sigma_odlir(k,ii)* + & (distance(k)**2+sigma_odlir(k,ii)**2)) + endif + enddo + +c min_odl=minval(distancek) + do kk=1,constr_homology + if(l_homo(kk,ii)) then + min_odl=distancek(kk) + exit + endif + enddo + do kk=1,constr_homology + if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl) + & min_odl=distancek(kk) + enddo +c write (iout,* )"min_odl",min_odl +#ifdef DEBUG + write (iout,*) "ij dij",i,j,dij + write (iout,*) "distance",(distance(k),k=1,constr_homology) + write (iout,*) "distancek",(distancek(k),k=1,constr_homology) + write (iout,* )"min_odl",min_odl +#endif + odleg2=0.0d0 + do k=1,constr_homology +c Nie wiem po co to liczycie jeszcze raz! +c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/ +c & (2*(sigma_odl(i,j,k))**2)) + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + godl(k)=dexp(-distancek(k)+min_odl) + odleg2=odleg2+godl(k) +c +c For Lorentzian-type Urestr +c + else + odleg2=odleg2+distancek(k) + endif + +ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3, +ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=", +ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1), +ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k) + + enddo +c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents +c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#ifdef DEBUG + write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents + write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps +#endif + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + odleg=odleg-dLOG(odleg2/constr_homology)+min_odl +c +c For Lorentzian-type Urestr +c + else + odleg=odleg+odleg2/constr_homology + endif +c +#ifdef GRAD +c write (iout,*) "odleg",odleg ! sum of -ln-s +c Gradient +c +c For Gaussian-type Urestr +c + if (waga_dist.ge.0.0d0) sum_godl=odleg2 + sum_sgodl=0.0d0 + do k=1,constr_homology +c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) +c & *waga_dist)+min_odl +c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist +c + if(.not.l_homo(k,ii)) cycle + if (waga_dist.ge.0.0d0) then +c For Gaussian-type Urestr +c + sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd +c +c For Lorentzian-type Urestr +c + else + sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ + & sigma_odlir(k,ii)**2)**2) + endif + sum_sgodl=sum_sgodl+sgodl + +c sgodl2=sgodl2+sgodl +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1" +c write(iout,*) "constr_homology=",constr_homology +c write(iout,*) i, j, k, "TEST K" + enddo + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c + grad_odl3=waga_homology(iset)*waga_dist + & *sum_sgodl/(sum_godl*dij) +c +c For Lorentzian-type Urestr +c + else +c Original grad expr modified by analogy w Gaussian-type Urestr grad +c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl + grad_odl3=-waga_homology(iset)*waga_dist* + & sum_sgodl/(constr_homology*dij) + endif +c +c grad_odl3=sum_sgodl/(sum_godl*dij) + + +c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2" +c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2), +c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2)) + +ccc write(iout,*) godl, sgodl, grad_odl3 + +c grad_odl=grad_odl+grad_odl3 + + do jik=1,3 + ggodl=grad_odl3*(c(jik,i)-c(jik,j)) +ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1)) +ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) + ghpbc(jik,i)=ghpbc(jik,i)+ggodl + ghpbc(jik,j)=ghpbc(jik,j)-ggodl +ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl, +ccc & ghpbc(jik,i+1), ghpbc(jik,j+1) +c if (i.eq.25.and.j.eq.27) then +c write(iout,*) "jik",jik,"i",i,"j",j +c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl +c write(iout,*) "grad_odl3",grad_odl3 +c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j) +c write(iout,*) "ggodl",ggodl +c write(iout,*) "ghpbc(",jik,i,")", +c & ghpbc(jik,i),"ghpbc(",jik,j,")", +c & ghpbc(jik,j) +c endif + enddo +#endif +ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=", +ccc & dLOG(odleg2),"-odleg=", -odleg + + enddo ! ii-loop for dist +#ifdef DEBUG + write(iout,*) "------- dist restrs end -------" +c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or. +c & waga_d.eq.1.0d0) call sum_gradient +#endif +c Pseudo-energy and gradient from dihedral-angle restraints from +c homology templates +c write (iout,*) "End of distance loop" +c call flush(iout) + kat=0.0d0 +c write (iout,*) idihconstr_start_homo,idihconstr_end_homo +#ifdef DEBUG + write(iout,*) "------- dih restrs start -------" + do i=idihconstr_start_homo,idihconstr_end_homo + write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg) + enddo +#endif + do i=idihconstr_start_homo,idihconstr_end_homo + kat2=0.0d0 +c betai=beta(i,i+1,i+2,i+3) + betai = phi(i+3) +c write (iout,*) "betai =",betai + do k=1,constr_homology + dih_diff(k)=pinorm(dih(k,i)-betai) +c write (iout,*) "dih_diff(",k,") =",dih_diff(k) +c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)= +c & -(6.28318-dih_diff(i,k)) +c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)= +c & 6.28318+dih_diff(i,k) + + kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument +c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i) + gdih(k)=dexp(kat3) + kat2=kat2+gdih(k) +c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3) +c write(*,*)"" + enddo +c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps +#ifdef DEBUG + write (iout,*) "i",i," betai",betai," kat2",kat2 + write (iout,*) "gdih",(gdih(k),k=1,constr_homology) +#endif + if (kat2.le.1.0d-14) cycle + kat=kat-dLOG(kat2/constr_homology) +c write (iout,*) "kat",kat ! sum of -ln-s + +ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=", +ccc & dLOG(kat2), "-kat=", -kat + +#ifdef GRAD +c ---------------------------------------------------------------------- +c Gradient +c ---------------------------------------------------------------------- + + sum_gdih=kat2 + sum_sgdih=0.0d0 + do k=1,constr_homology + sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd +c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle + sum_sgdih=sum_sgdih+sgdih + enddo +c grad_dih3=sum_sgdih/sum_gdih + grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih + +c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3 +ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) + gloc(i,icg)=gloc(i,icg)+grad_dih3 +c if (i.eq.25) then +c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg) +c endif +ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3, +ccc & gloc(nphi+i-3,icg) +#endif + enddo ! i-loop for dih +#ifdef DEBUG + write(iout,*) "------- dih restrs end -------" +#endif + +c Pseudo-energy and gradient for theta angle restraints from +c homology templates +c FP 01/15 - inserted from econstr_local_test.F, loop structure +c adapted + +c +c For constr_homology reference structures (FP) +c +c Uconst_back_tot=0.0d0 + Eval=0.0d0 + Erot=0.0d0 +c Econstr_back legacy +#ifdef GRAD + do i=1,nres +c do i=ithet_start,ithet_end + dutheta(i)=0.0d0 +c enddo +c do i=loc_start,loc_end + do j=1,3 + duscdiff(j,i)=0.0d0 + duscdiffx(j,i)=0.0d0 + enddo + enddo +#endif +c +c do iref=1,nref +c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +c write (iout,*) "waga_theta",waga_theta + if (waga_theta.gt.0.0d0) then +#ifdef DEBUG + write (iout,*) "usampl",usampl + write(iout,*) "------- theta restrs start -------" +c do i=ithet_start,ithet_end +c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg) +c enddo +#endif +c write (iout,*) "maxres",maxres,"nres",nres + + do i=ithet_start,ithet_end +c +c do i=1,nfrag_back +c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset) +c +c Deviation of theta angles wrt constr_homology ref structures +c + utheta_i=0.0d0 ! argument of Gaussian for single k + gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop +c over residues in a fragment +c write (iout,*) "theta(",i,")=",theta(i) + do k=1,constr_homology +c +c dtheta_i=theta(j)-thetaref(j,iref) +c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing + theta_diff(k)=thetatpl(k,i)-theta(i) +c + utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument +c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta? + gtheta(k)=dexp(utheta_i) ! + min_utheta_i? + gutheta_i=gutheta_i+dexp(utheta_i) ! Sum of Gaussians (pk) +c Gradient for single Gaussian restraint in subr Econstr_back +c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1) +c + enddo +c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps +c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps + +c +#ifdef GRAD +c Gradient for multiple Gaussian restraint + sum_gtheta=gutheta_i + sum_sgtheta=0.0d0 + do k=1,constr_homology +c New generalized expr for multiple Gaussian from Econstr_back + sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd +c +c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form? + sum_sgtheta=sum_sgtheta+sgtheta ! cum variable + enddo +c +c Final value of gradient using same var as in Econstr_back + dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta + & *waga_homology(iset) +c dutheta(i)=sum_sgtheta/sum_gtheta +c +c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight +#endif + Eval=Eval-dLOG(gutheta_i/constr_homology) +c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s +c Uconst_back=Uconst_back+utheta(i) + enddo ! (i-loop for theta) +#ifdef DEBUG + write(iout,*) "------- theta restrs end -------" +#endif + endif +c +c Deviation of local SC geometry +c +c Separation of two i-loops (instructed by AL - 11/3/2014) +c +c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +c write (iout,*) "waga_d",waga_d + +#ifdef DEBUG + write(iout,*) "------- SC restrs start -------" + write (iout,*) "Initial duscdiff,duscdiffx" + do i=loc_start,loc_end + write (iout,*) i,(duscdiff(jik,i),jik=1,3), + & (duscdiffx(jik,i),jik=1,3) + enddo +#endif + do i=loc_start,loc_end + usc_diff_i=0.0d0 ! argument of Gaussian for single k + guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures +c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy +c write(iout,*) "xxtab, yytab, zztab" +c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i) + do k=1,constr_homology +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z +c write(iout,*) "dxx, dyy, dzz" +c write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz +c + usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument +c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d? +c uscdiffk(k)=usc_diff(i) + guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff + guscdiff(i)=guscdiff(i)+dexp(usc_diff_i) !Sum of Gaussians (pk) +c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j), +c & xxref(j),yyref(j),zzref(j) + enddo +c +c Gradient +c +c Generalized expression for multiple Gaussian acc to that for a single +c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014) +c +c Original implementation +c sum_guscdiff=guscdiff(i) +c +c sum_sguscdiff=0.0d0 +c do k=1,constr_homology +c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d? +c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff +c sum_sguscdiff=sum_sguscdiff+sguscdiff +c enddo +c +c Implementation of new expressions for gradient (Jan. 2015) +c +c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !? +#ifdef GRAD + do k=1,constr_homology +c +c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong +c before. Now the drivatives should be correct +c + dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str? +c Original sign inverted for calc of gradients (s. Econstr_back) + dyy=-yytpl(k,i)+yytab(i) ! ibid y + dzz=-zztpl(k,i)+zztab(i) ! ibid z +c +c New implementation +c + sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong! + & sigma_d(k,i) ! for the grad wrt r' +c sum_sguscdiff=sum_sguscdiff+sum_guscdiff +c +c +c New implementation + sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff + do jik=1,3 + duscdiff(jik,i-1)=duscdiff(jik,i-1)+ + & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+ + & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i) + duscdiff(jik,i)=duscdiff(jik,i)+ + & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+ + & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i) + duscdiffx(jik,i)=duscdiffx(jik,i)+ + & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+ + & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i) +c +#ifdef DEBUG + write(iout,*) "jik",jik,"i",i + write(iout,*) "dxx, dyy, dzz" + write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz + write(iout,*) "guscdiff2(",k,")",guscdiff2(k) +c write(iout,*) "sum_sguscdiff",sum_sguscdiff +cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i) +c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i) +c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i) +c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i) +c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i) +c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i) +c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i) +c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i) +c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i) +c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1) +c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i) +c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i) +c endif +#endif + enddo + enddo +#endif +c +c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required? +c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ? +c +c write (iout,*) i," uscdiff",uscdiff(i) +c +c Put together deviations from local geometry + +c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ +c & wfrag_back(3,i,iset)*uscdiff(i) + Erot=Erot-dLOG(guscdiff(i)/constr_homology) +c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps +c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s +c Uconst_back=Uconst_back+usc_diff(i) +c +c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?) +c +c New implment: multiplied by sum_sguscdiff +c + + enddo ! (i-loop for dscdiff) + +c endif + +#ifdef DEBUG + write(iout,*) "------- SC restrs end -------" + write (iout,*) "------ After SC loop in e_modeller ------" + do i=loc_start,loc_end + write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3) + write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3) + enddo + if (waga_theta.eq.1.0d0) then + write (iout,*) "in e_modeller after SC restr end: dutheta" + do i=ithet_start,ithet_end + write (iout,*) i,dutheta(i) + enddo + endif + if (waga_d.eq.1.0d0) then + write (iout,*) "e_modeller after SC loop: duscdiff/x" + do i=1,nres + write (iout,*) i,(duscdiff(j,i),j=1,3) + write (iout,*) i,(duscdiffx(j,i),j=1,3) + enddo + endif +#endif + +c Total energy from homology restraints +#ifdef DEBUG + write (iout,*) "odleg",odleg," kat",kat + write (iout,*) "odleg",odleg," kat",kat + write (iout,*) "Eval",Eval," Erot",Erot + write (iout,*) "waga_homology(",iset,")",waga_homology(iset) + write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle + write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d +#endif +c +c Addition of energy of theta angle and SC local geom over constr_homologs ref strs +c +c ehomology_constr=odleg+kat +c +c For Lorentzian-type Urestr +c + + if (waga_dist.ge.0.0d0) then +c +c For Gaussian-type Urestr +c +c ehomology_constr=(waga_dist*odleg+waga_angle*kat+ +c & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) + ehomology_constr=waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot +c write (iout,*) "ehomology_constr=",ehomology_constr + else +c +c For Lorentzian-type Urestr +c +c ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ +c & waga_theta*Eval+waga_d*Erot)*waga_homology(iset) + ehomology_constr=-waga_dist*odleg+waga_angle*kat+ + & waga_theta*Eval+waga_d*Erot +c write (iout,*) "ehomology_constr=",ehomology_constr + endif +#ifdef DEBUG + write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat, + & "Eval",waga_theta,eval, + & "Erot",waga_d,Erot + write (iout,*) "ehomology_constr",ehomology_constr +#endif + return + + 748 format(a8,f12.3,a6,f12.3,a7,f12.3) + 747 format(a12,i4,i4,i4,f8.3,f8.3) + 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3) + 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3) + 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, + & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3) + end +c----------------------------------------------------------------------- subroutine ebond(estr) c c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds @@ -3059,6 +4046,7 @@ c implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' include 'COMMON.LOCAL' include 'COMMON.GEO' include 'COMMON.INTERACT' @@ -3076,37 +4064,43 @@ C write (iout,*) "distchainmax",distchainmax estr1=0.0d0 c write (iout,*) "distchainmax",distchainmax do i=nnt+1,nct - if (itype(i-1).eq.21 .or. itype(i).eq.21) then - estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) - do j=1,3 - gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) - & *dc(j,i-1)/vbld(i) - enddo - if (energy_dec) write(iout,*) - & "estr1",i,vbld(i),distchainmax, - & gnmr1(vbld(i),-1.0d0,distchainmax) - else + if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle +C estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) +C do j=1,3 +C gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) +C & *dc(j,i-1)/vbld(i) +C enddo +C if (energy_dec) write(iout,*) +C & "estr1",i,vbld(i),distchainmax, +C & gnmr1(vbld(i),-1.0d0,distchainmax) +C else + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then + diff = vbld(i)-vbldpDUM +C write(iout,*) i,diff + else diff = vbld(i)-vbldp0 c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff + endif estr=estr+diff*diff do j=1,3 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) enddo - endif - +C endif +C write (iout,'(a7,i5,4f7.3)') +C & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff enddo estr=0.5d0*AKP*estr+estr1 c c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included c do i=nnt,nct - iti=itype(i) - if (iti.ne.10 .and. iti.ne.21) then + iti=iabs(itype(i)) + if (iti.ne.10 .and. iti.ne.ntyp1) then nbi=nbondterm(iti) if (nbi.eq.1) then diff=vbld(i+nres)-vbldsc0(1,iti) -c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, -c & AKSC(1,iti),AKSC(1,iti)*diff*diff +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) @@ -3177,15 +4171,35 @@ c write (iout,*) "nres",nres c write (*,'(a,i2)') 'EBEND ICG=',icg c write (iout,*) ithet_start,ithet_end do i=ithet_start,ithet_end - if (itype(i-1).eq.21) cycle +C if (itype(i-1).eq.ntyp1) cycle + if (i.le.2) cycle + if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 + & .or.itype(i).eq.ntyp1) cycle C Zero the energy function and its derivative at 0 or pi. call splinthet(theta(i),0.5d0*delta,ss,ssd) it=itype(i-1) - if (i.gt.3 .and. itype(i-2).ne.21) then + ichir1=isign(1,itype(i-2)) + ichir2=isign(1,itype(i)) + if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1)) + if (itype(i).eq.10) ichir2=isign(1,itype(i-1)) + if (itype(i-1).eq.10) then + itype1=isign(10,itype(i-2)) + ichir11=isign(1,itype(i-2)) + ichir12=isign(1,itype(i-2)) + itype2=isign(10,itype(i)) + ichir21=isign(1,itype(i)) + ichir22=isign(1,itype(i)) + endif + if (i.eq.3) then + y(1)=0.0D0 + y(2)=0.0D0 + else + + if (i.gt.3 .and. itype(i-3).ne.ntyp1) then #ifdef OSF phii=phi(i) - icrc=0 - call proc_proc(phii,icrc) +c icrc=0 +c call proc_proc(phii,icrc) if (icrc.eq.1) phii=150.0 #else phii=phi(i) @@ -3196,11 +4210,12 @@ C Zero the energy function and its derivative at 0 or pi. y(1)=0.0D0 y(2)=0.0D0 endif - if (i.lt.nres .and. itype(i).ne.21) then + endif + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then #ifdef OSF phii1=phi(i+1) - icrc=0 - call proc_proc(phii1,icrc) +c icrc=0 +c call proc_proc(phii1,icrc) if (icrc.eq.1) phii1=150.0 phii1=pinorm(phii1) z(1)=cos(phii1) @@ -3218,8 +4233,12 @@ 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) + athetk=athet(k,it,ichir1,ichir2) + bthetk=bthet(k,it,ichir1,ichir2) + if (it.eq.10) then + athetk=athet(k,itype1,ichir11,ichir12) + bthetk=bthet(k,itype2,ichir21,ichir22) + endif thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) enddo c write (iout,*) "thet_pred_mean",thet_pred_mean @@ -3227,8 +4246,16 @@ c write (iout,*) "thet_pred_mean",thet_pred_mean thet_pred_mean=thet_pred_mean*ss+a0thet(it) c write (iout,*) "thet_pred_mean",thet_pred_mean 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 + dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) + &+athet(2,it,ichir1,ichir2)*y(1))*ss + dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) + & +bthet(2,it,ichir1,ichir2)*z(1))*ss + if (it.eq.10) then + dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) + &+athet(2,itype1,ichir11,ichir12)*y(1))*ss + dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) + & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss + endif if (theta(i).gt.pi-delta) then call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, & E_tc0) @@ -3251,12 +4278,41 @@ C Derivatives of the "mean" values in gamma1 and gamma2. & E_theta,E_tc) endif etheta=etheta+ethetai +c write (iout,'(a6,i5,0pf7.3,f7.3,i5)') +c & 'ebend',i,ethetai,theta(i),itype(i) c write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i), c & rad2deg*phii,rad2deg*phii1,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) - 1215 continue +c 1215 continue + enddo + ethetacnstr=0.0d0 +C print *,ithetaconstr_start,ithetaconstr_end,"TU" + do i=1,ntheta_constr + itheta=itheta_constr(i) + thetiii=theta(itheta) + difi=pinorm(thetiii-theta_constr0(i)) + if (difi.gt.theta_drange(i)) then + difi=difi-theta_drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else + difi=0.0 + endif +C if (energy_dec) then +C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", +C & i,itheta,rad2deg*thetiii, +C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), +C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, +C & gloc(itheta+nphi-2,icg) +C endif enddo C Ufff.... We've done all this!!! return @@ -3381,6 +4437,7 @@ C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' include 'COMMON.LOCAL' include 'COMMON.GEO' include 'COMMON.INTERACT' @@ -3399,24 +4456,31 @@ C etheta=0.0D0 c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) do i=ithet_start,ithet_end - if (itype(i-1).eq.21) cycle + if (i.eq.2) cycle +c print *,i,itype(i-1),itype(i),itype(i-2) + if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1) + & .or.(itype(i).eq.ntyp1)) cycle +C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF + + if (iabs(itype(i+1)).eq.20) iblock=2 + if (iabs(itype(i+1)).ne.20) iblock=1 dethetai=0.0d0 dephii=0.0d0 dephii1=0.0d0 theti2=0.5d0*theta(i) - ityp2=ithetyp(itype(i-1)) + ityp2=ithetyp((itype(i-1))) do k=1,nntheterm coskt(k)=dcos(k*theti2) sinkt(k)=dsin(k*theti2) enddo - if (i.gt.3 .and. itype(i-2).ne.21) then + if (i.gt.3 .and. itype(i-3).ne.ntyp1) then #ifdef OSF phii=phi(i) if (phii.ne.phii) phii=150.0 #else phii=phi(i) #endif - ityp1=ithetyp(itype(i-2)) + ityp1=ithetyp((itype(i-2))) do k=1,nsingle cosph1(k)=dcos(k*phii) sinph1(k)=dsin(k*phii) @@ -3429,7 +4493,7 @@ c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) sinph1(k)=0.0d0 enddo endif - if (i.lt.nres .and. itype(i).ne.21) then + if (i.lt.nres .and. itype(i+1).ne.ntyp1) then #ifdef OSF phii1=phi(i+1) if (phii1.ne.phii1) phii1=150.0 @@ -3437,7 +4501,7 @@ c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) #else phii1=phi(i+1) #endif - ityp3=ithetyp(itype(i)) + ityp3=ithetyp((itype(i))) do k=1,nsingle cosph2(k)=dcos(k*phii1) sinph2(k)=dsin(k*phii1) @@ -3453,7 +4517,7 @@ c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) c write (iout,*) "i",i," ityp1",itype(i-2),ityp1, c & " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3 c call flush(iout) - ethetai=aa0thet(ityp1,ityp2,ityp3) + ethetai=aa0thet(ityp1,ityp2,ityp3,iblock) do k=1,ndouble do l=1,k-1 ccl=cosph1(l)*cosph2(k-l) @@ -3475,11 +4539,12 @@ c call flush(iout) 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) + ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k) + dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) & *coskt(k) if (lprn) - & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), + & write (iout,*) "k",k," + & aathet",aathet(k,ityp1,ityp2,ityp3,iblock), & " ethetai",ethetai enddo if (lprn) then @@ -3498,24 +4563,24 @@ c call flush(iout) 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) + aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) + & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) + & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) + & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k) ethetai=ethetai+sinkt(m)*aux dethetai=dethetai+0.5d0*m*aux*coskt(m) dephii=dephii+k*sinkt(m)*( - & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- - & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) + & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- + & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)) dephii1=dephii1+k*sinkt(m)*( - & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- - & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) + & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- + & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)) if (lprn) & write (iout,*) "m",m," k",k," bbthet", - & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", - & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", - & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", - & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai + & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", + & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", + & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", + & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai enddo enddo if (lprn) @@ -3523,28 +4588,29 @@ c call flush(iout) 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) + aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l) ethetai=ethetai+sinkt(m)*aux dethetai=dethetai+0.5d0*m*coskt(m)*aux dephii=dephii+l*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*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)) + & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) dephii1=dephii1+(k-l)*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*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)) + & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) if (lprn) then write (iout,*) "m",m," k",k," l",l," ffthet", - & ffthet(l,k,m,ityp1,ityp2,ityp3), - & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", - & ggthet(l,k,m,ityp1,ityp2,ityp3), - & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai + & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock), + & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet", + & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock), + & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock), + & " ethetai",ethetai write (iout,*) cosph1ph2(l,k)*sinkt(m), & cosph1ph2(k,l)*sinkt(m), & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) @@ -3559,10 +4625,40 @@ c call flush(iout) 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 +c gloc(nphi+i-2,icg)=wang*dethetai + gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai + enddo +C now constrains + ethetacnstr=0.0d0 +C print *,ithetaconstr_start,ithetaconstr_end,"TU" + do i=1,ntheta_constr + itheta=itheta_constr(i) + thetiii=theta(itheta) + difi=pinorm(thetiii-theta_constr0(i)) + if (difi.gt.theta_drange(i)) then + difi=difi-theta_drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else if (difi.lt.-drange(i)) then + difi=difi+drange(i) + ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 + gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) + & +for_thet_constr(i)*difi**3 + else + difi=0.0 + endif +C if (energy_dec) then +C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", +C & i,itheta,rad2deg*thetiii, +C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), +C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, +C & gloc(itheta+nphi-2,icg) +C endif enddo return end + #endif #ifdef CRYST_SC c----------------------------------------------------------------------------- @@ -3587,14 +4683,14 @@ C ALPHA and OMEGA. common /sccalc/ time11,time12,time112,theti,it,nlobit delta=0.02d0*pi escloc=0.0D0 -c write (iout,'(a)') 'ESC' +C write (iout,*) 'ESC' do i=loc_start,loc_end it=itype(i) - if (it.eq.21) cycle + if (it.eq.ntyp1) cycle if (it.eq.10) goto 1 - nlobit=nlob(it) + nlobit=nlob(iabs(it)) c print *,'i=',i,' it=',it,' nlobit=',nlobit -c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad +C write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad theti=theta(i+1)-pipol x(1)=dtan(theti) x(2)=alph(i) @@ -3630,8 +4726,8 @@ c write (iout,*) "i",i," x",x(1),x(2),x(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 + write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, + & esclocbi,ss,ssd escloci=ss*escloci+(1.0d0-ss)*esclocbi c escloci=esclocbi c write (iout,*) escloci @@ -3665,15 +4761,17 @@ c write (iout,*) escloci enddo dersc(2)=dersc(2)+ssd*(escloci-esclocbi) c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd +c & esclocbi,ss,ssd escloci=ss*escloci+(1.0d0-ss)*esclocbi -c write (iout,*) escloci +C write (iout,*) 'i=',i, escloci else call enesc(x,escloci,dersc,ddummy,.false.) endif escloc=escloc+escloci -c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc +C write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc + write (iout,'(a6,i5,0pf7.3)') + & 'escloc',i,escloci gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ & wscloc*dersc(1) @@ -3747,7 +4845,7 @@ C Compute the contribution to SC energy and derivatives do iii=-1,1 do j=1,nlobit - expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) cd print *,'j=',j,' expfac=',expfac escloc_i=escloc_i+expfac do k=1,3 @@ -3828,7 +4926,7 @@ 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) + expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin) escloc_i=escloc_i+expfac do k=1,2 dersc(k)=dersc(k)+Ax(k,j)*expfac @@ -3858,6 +4956,7 @@ C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.VAR' @@ -3883,7 +4982,7 @@ C delta=0.02d0*pi escloc=0.0D0 do i=loc_start,loc_end - if (itype(i).eq.21) cycle + if (itype(i).eq.ntyp1) cycle costtab(i+1) =dcos(theta(i+1)) sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) @@ -3892,7 +4991,7 @@ C cosfac=dsqrt(cosfac2) sinfac2=0.5d0/(1.0d0-costtab(i+1)) sinfac=dsqrt(sinfac2) - it=itype(i) + it=iabs(itype(i)) if (it.eq.10) goto 1 c C Compute the axes of tghe local cartesian coordinates system; store in @@ -3910,7 +5009,7 @@ C & dc_norm(3,i+nres) y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac enddo do j = 1,3 - z_prime(j) = -uz(j,i-1) + z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i))) enddo c write (2,*) "i",i c write (2,*) "x_prime",(x_prime(j),j=1,3) @@ -3942,7 +5041,7 @@ C C Compute the energy of the ith side cbain C c write (2,*) "xx",xx," yy",yy," zz",zz - it=itype(i) + it=iabs(itype(i)) do j = 1,65 x(j) = sc_parmin(j,it) enddo @@ -3950,7 +5049,7 @@ c write (2,*) "xx",xx," yy",yy," zz",zz Cc diagnostics - remove later xx1 = dcos(alph(2)) yy1 = dsin(alph(2))*dcos(omeg(2)) - zz1 = -dsin(alph(2))*dsin(omeg(2)) + zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2)) write(2,'(3f8.1,3f9.3,1x,3f9.3)') & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, & xx1,yy1,zz1 @@ -3993,6 +5092,8 @@ c & dscp1,dscp2,sumene c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) escloc = escloc + sumene c write (2,*) "escloc",escloc +c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i), +c & zz,xx,yy if (.not. calc_grad) goto 1 #ifdef DEBUG C @@ -4121,8 +5222,10 @@ c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) 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) + dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) + & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) + dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) + & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) enddo dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) @@ -4274,8 +5377,8 @@ C Set lprn=.true. for debugging c lprn=.true. etors=0.0D0 do i=iphi_start,iphi_end - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21) cycle + if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1) cycle itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) phii=phi(i) @@ -4323,15 +5426,16 @@ c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) 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 + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 else if (difi.lt.-drange(i)) then difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 endif -! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) +C write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih", +C & i,itori,rad2deg*phii, +C & rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg) enddo ! write (iout,*) 'edihcnstr',edihcnstr return @@ -4359,18 +5463,25 @@ C Set lprn=.true. for debugging c lprn=.true. etors=0.0D0 do i=iphi_start,iphi_end - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21 - & .or. itype(i-3).eq.ntyp1) cycle + if (i.le.2) cycle + if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 + & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle +C if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 +C & .or. itype(i).eq.ntyp1) cycle if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215 + if (iabs(itype(i)).eq.20) then + iblock=2 + else + iblock=1 + endif itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) phii=phi(i) gloci=0.0D0 C Regular cosine and sine terms - do j=1,nterm(itori,itori1) - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) + do j=1,nterm(itori,itori1,iblock) + v1ij=v1(j,itori,itori1,iblock) + v2ij=v2(j,itori,itori1,iblock) cosphi=dcos(j*phii) sinphi=dsin(j*phii) etors=etors+v1ij*cosphi+v2ij*sinphi @@ -4383,22 +5494,24 @@ 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) + do j=1,nlor(itori,itori1,iblock) vl1ij=vlor1(j,itori,itori1) vl2ij=vlor2(j,itori,itori1) vl3ij=vlor3(j,itori,itori1) pom=vl2ij*cosphi+vl3ij*sinphi pom1=1.0d0/(pom*pom+1.0d0) etors=etors+vl1ij*pom1 +c if (energy_dec) etors_ii=etors_ii+ +c & 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) + etors=etors-v0(itori,itori1,iblock) if (lprn) & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) + & (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6) gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) 1215 continue @@ -4412,21 +5525,24 @@ c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) edihi=0.0d0 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 - edihi=0.25d0*ftors*difi**4 + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + edihi=0.25d0*ftors(i)*difi**4 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 - edihi=0.25d0*ftors*difi**4 + edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 + gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 + edihi=0.25d0*ftors(i)*difi**4 else difi=0.0d0 endif + write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih", + & i,itori,rad2deg*phii, + & rad2deg*difi,0.25d0*ftors(i)*difi**4 c write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi, c & drange(i),edihi ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) +! & rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg) enddo ! write (iout,*) 'edihcnstr',edihcnstr return @@ -4454,9 +5570,12 @@ C Set lprn=.true. for debugging c lprn=.true. etors_d=0.0D0 do i=iphi_start,iphi_end-1 - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21 .or. itype(i+1).eq.21 - & .or. itype(i-3).eq.ntyp1) cycle + if (i.le.3) cycle +C if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 +C & .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle + if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or. + & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or. + & (itype(i+1).eq.ntyp1)) cycle if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0) & goto 1215 itori=itortyp(itype(i-2)) @@ -4466,12 +5585,14 @@ c lprn=.true. phii1=phi(i+1) gloci1=0.0D0 gloci2=0.0D0 + iblock=1 + if (iabs(itype(i+1)).eq.20) iblock=2 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) + do j=1,ntermd_1(itori,itori1,itori2,iblock) + v1cij=v1c(1,j,itori,itori1,itori2,iblock) + v1sij=v1s(1,j,itori,itori1,itori2,iblock) + v2cij=v1c(2,j,itori,itori1,itori2,iblock) + v2sij=v1s(2,j,itori,itori1,itori2,iblock) cosphi1=dcos(j*phii) sinphi1=dsin(j*phii) cosphi2=dcos(j*phii1) @@ -4481,12 +5602,12 @@ C Regular cosine and sine terms gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) enddo - do k=2,ntermd_2(itori,itori1,itori2) + do k=2,ntermd_2(itori,itori1,itori2,iblock) 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) + v1cdij = v2c(k,l,itori,itori1,itori2,iblock) + v2cdij = v2c(l,k,itori,itori1,itori2,iblock) + v1sdij = v2s(k,l,itori,itori1,itori2,iblock) + v2sdij = v2s(l,k,itori,itori1,itori2,iblock) cosphi1p2=dcos(l*phii+(k-l)*phii1) cosphi1m2=dcos(l*phii-(k-l)*phii1) sinphi1p2=dsin(l*phii+(k-l)*phii1) @@ -4496,7 +5617,7 @@ C Regular cosine and sine terms gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) + & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) enddo enddo gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1 @@ -4517,6 +5638,7 @@ c amino-acid residues. implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.LOCAL' @@ -4686,9 +5808,9 @@ c------------------------------------------------------------------------------ integer dimen1,dimen2,atom,indx double precision buffer(dimen1,dimen2) double precision zapas - common /contacts_hb/ zapas(3,20,maxres,7), - & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), - & num_cont_hb(maxres),jcont_hb(20,maxres) + common /contacts_hb/ zapas(3,ntyp,maxres,7), + & facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres), + & num_cont_hb(maxres),jcont_hb(ntyp,maxres) num_kont=num_cont_hb(atom) do i=1,num_kont do k=1,7 @@ -4711,9 +5833,10 @@ c------------------------------------------------------------------------------ integer dimen1,dimen2,atom,indx double precision buffer(dimen1,dimen2) double precision zapas - common /contacts_hb/ zapas(3,20,maxres,7), - & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), - & num_cont_hb(maxres),jcont_hb(20,maxres) + common /contacts_hb/ zapas(3,ntyp,maxres,7), + & facont_hb(ntyp,maxres),ees0p(ntyp,maxres), + & ees0m(ntyp,maxres), + & num_cont_hb(maxres),jcont_hb(ntyp,maxres) num_kont=buffer(1,indx+26) num_kont_old=num_cont_hb(atom) num_cont_hb(atom)=num_kont+num_kont_old @@ -4946,6 +6069,7 @@ C This subroutine calculates multi-body contributions to hydrogen-bonding C Set lprn=.true. for debugging lprn=.false. eturn6=0.0d0 + ecorr6=0.0d0 #ifdef MPL n_corr=0 n_corr1=0 @@ -5135,7 +6259,11 @@ cd & dabs(eello6(i,j,i+1,j1,jj,kk)) cd write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1 eturn6=eturn6+eello_turn6(i,jj,kk) cd write (2,*) 'multibody_eello:eturn6',eturn6 + else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then + eturn6=0.0d0 + ecorr6=0.0d0 endif + ENDIF 1111 continue else if (j1.eq.j) then @@ -5156,6 +6284,7 @@ c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) enddo ! kk enddo ! jj enddo ! i + write (iout,*) "eturn6",eturn6,ecorr6 return end c------------------------------------------------------------------------------ @@ -7462,4 +8591,62 @@ C----------------------------------------------------------------------------- scalar=sc return end +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----------------------------------------------------------------------- +C----------------------------------------------------------------------- + double precision function sscagrad(r) + double precision r,gamm + include "COMMON.SPLITELE" + if(r.lt.r_cut-rlamb) then + sscagrad=0.0d0 + else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then + gamm=(r-(r_cut-rlamb))/rlamb + sscagrad=gamm*(6*gamm-6.0d0)/rlamb + else + sscagrad=0.0d0 + endif + return + end +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + double precision function sscalelip(r) + double precision r,gamm + include "COMMON.SPLITELE" +C if(r.lt.r_cut-rlamb) then +C sscale=1.0d0 +C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then +C gamm=(r-(r_cut-rlamb))/rlamb + sscalelip=1.0d0+r*r*(2*r-3.0d0) +C else +C sscale=0d0 +C endif + return + end +C----------------------------------------------------------------------- + double precision function sscagradlip(r) + double precision r,gamm + include "COMMON.SPLITELE" +C if(r.lt.r_cut-rlamb) then +C sscagrad=0.0d0 +C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then +C gamm=(r-(r_cut-rlamb))/rlamb + sscagradlip=r*(6*r-6.0d0) +C else +C sscagrad=0.0d0 +C endif + return + end diff --git a/source/wham/src-M/geomout.F b/source/wham/src-M/geomout.F index 941810f..6747e76 100644 --- a/source/wham/src-M/geomout.F +++ b/source/wham/src-M/geomout.F @@ -22,7 +22,7 @@ ires=0 do i=nnt,nct iti=itype(i) - if (iti.eq.21) then + if (iti.eq.ntyp1) then ichain=ichain+1 ires=0 write (ipdb,'(a)') 'TER' @@ -41,12 +41,12 @@ enddo write (ipdb,'(a)') 'TER' do i=nnt,nct-1 - if (itype(i).eq.21) cycle - if (itype(i).eq.10 .and. itype(i+1).ne.21) then + if (itype(i).eq.ntyp1) cycle + if (itype(i).eq.10 .and. itype(i+1).ne.ntyp1) then write (ipdb,30) ica(i),ica(i+1) - else if (itype(i).ne.10 .and. itype(i+1).ne.21) then + else if (itype(i).ne.10 .and. itype(i+1).ne.ntyp1) then write (ipdb,30) ica(i),ica(i+1),ica(i)+1 - else if (itype(i).ne.10 .and. itype(i+1).eq.21) then + else if (itype(i).ne.10 .and. itype(i+1).eq.ntyp1) then write (ipdb,30) ica(i),ica(i)+1 endif enddo @@ -54,7 +54,11 @@ write (ipdb,30) ica(nct),ica(nct)+1 endif do i=1,nss - write (ipdb,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 +C if (dyn_ss) then +C write (iunit,30) ica(idssb(i))+1,ica(jdssb(i))+1 +C else +C write (ipdb,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1 +C endif enddo write (ipdb,'(a6)') 'ENDMDL' 10 FORMAT ('ATOM',I7,' CA ',A3,1X,A1,I4,4X,3F8.3,f15.3) @@ -105,7 +109,18 @@ C format. write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1 enddo do i=1,nss - write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 +C write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1 + if (dyn_ss) then + write(imol2,'(a6,i4,1x,a3,i7,4x,a3,i7)') + & 'SSBOND',i,'CYS',ihpb(i)-1-nres, + & 'CYS',jhpb(i)-1-nres +C & 'SSBOND',i,'CYS',idssb(i)-nnt+1, +C & 'CYS',jdssb(i)-nnt+1 + else + write(imol2,'(a6,i4,1x,a3,i7,4x,a3,i7)') + & 'SSBOND',i,'CYS',ihpb(i)-nnt+1-nres, + & 'CYS',jhpb(i)-nnt+1-nres + endif enddo write (imol2,'(a)') '\@SUBSTRUCTURE' do i=nnt,nct diff --git a/source/wham/src-M/gnmr1.f b/source/wham/src-M/gnmr1.f index 905e746..8bfc43a 100644 --- a/source/wham/src-M/gnmr1.f +++ b/source/wham/src-M/gnmr1.f @@ -41,3 +41,33 @@ c------------------------------------------------------------------------------- return end c--------------------------------------------------------------------------------- + double precision function rlornmr1(y,ymin,ymax,sigma) + implicit none + double precision y,ymin,ymax,sigma + double precision wykl /4.0d0/ + if (y.lt.ymin) then + rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl) + else if (y.gt.ymax) then + rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl) + else + rlornmr1=0.0d0 + endif + return + end +c------------------------------------------------------------------------------ + double precision function rlornmr1prim(y,ymin,ymax,sigma) + implicit none + double precision y,ymin,ymax,sigma + double precision wykl /4.0d0/ + if (y.lt.ymin) then + rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ + & ((ymin-y)**wykl+sigma**wykl)**2 + else if (y.gt.ymax) then + rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ + & ((y-ymax)**wykl+sigma**wykl)**2 + else + rlornmr1prim=0.0d0 + endif + return + end + diff --git a/source/wham/src-M/include_unres/COMMON.DERIV b/source/wham/src-M/include_unres/COMMON.DERIV index 79f8630..7f8ddfb 100644 --- a/source/wham/src-M/include_unres/COMMON.DERIV +++ b/source/wham/src-M/include_unres/COMMON.DERIV @@ -1,15 +1,33 @@ double precision dcdv,dxdv,dxds,gradx,gradc,gvdwc,gelc,gvdwpp, & gradx_scp,gvdwc_scp,ghpbx,ghpbc,gloc,gvdwx,gradcorr,gradxorr, + & gliptranc,gliptranx, & gradcorr5,gradcorr6,gel_loc,gcorr3_turn,gcorr4_turn,gcorr6_turn, & gel_loc_loc,gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc, & g_corr5_loc,g_corr6_loc,gradb,gradbx,gsccorc,gsccorx,gsccor_loc, - & gscloc,gsclocx + & gscloc,gsclocx,gshieldx,gradafm, + & gshieldc, gshieldc_loc, gshieldx_ec, gshieldc_ec, + & gshieldc_loc_ec, gshieldx_t3,gshieldc_t3,gshieldc_loc_t3, + & gshieldx_t4, gshieldc_t4,gshieldc_loc_t4,gshieldx_ll, + & gshieldc_ll, gshieldc_loc_ll + integer nfl,icg logical calc_grad 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),gvdwpp(3,maxres), & gradx_scp(3,maxres), + & gliptranc(3,-1:maxres), + & gliptranx(3,-1:maxres), + & gshieldx(3,-1:maxres), gshieldc(3,-1:maxres), + & gshieldc_loc(3,-1:maxres), + & gshieldx_ec(3,-1:maxres), gshieldc_ec(3,-1:maxres), + & gshieldc_loc_ec(3,-1:maxres), + & gshieldx_t3(3,-1:maxres), gshieldc_t3(3,-1:maxres), + & gshieldc_loc_t3(3,-1:maxres), + & gshieldx_t4(3,-1:maxres), gshieldc_t4(3,-1:maxres), + & gshieldc_loc_t4(3,-1:maxres), + & gshieldx_ll(3,-1:maxres), gshieldc_ll(3,-1:maxres), + & gshieldc_loc_ll(3,-1:maxres), & gvdwc_scp(3,maxres),ghpbx(3,maxres),ghpbc(3,maxres), & gloc(maxvar,2),gradcorr(3,maxres),gradxorr(3,maxres), & gradcorr5(3,maxres),gradcorr6(3,maxres), diff --git a/source/wham/src-M/include_unres/COMMON.FFIELD b/source/wham/src-M/include_unres/COMMON.FFIELD index 0c169f7..6c432a9 100644 --- a/source/wham/src-M/include_unres/COMMON.FFIELD +++ b/source/wham/src-M/include_unres/COMMON.FFIELD @@ -6,11 +6,11 @@ C----------------------------------------------------------------------- double precision wsc,wscp,welec,wstrain,wtor,wtor_d,wang,wscloc, & wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4, & wturn6,wvdwpp,wbond,weights,scal14,cutoff_corr,delt_corr, - & r0_corr + & r0_corr,wliptran integer ipot,n_ene_comp common /ffield/ wsc,wscp,welec,wstrain,wtor,wtor_d,wang,wscloc, & wcorr,wcorr4,wcorr5,wcorr6,wsccor,wel_loc,wturn3,wturn4, - & wturn6,wvdwpp,wbond,weights(max_ene), + & wturn6,wvdwpp,wbond,wliptran,weights(max_ene), & scal14,cutoff_corr,delt_corr,r0_corr,ipot,n_ene_comp common /potentials/ potname(5) character*3 potname diff --git a/source/wham/src-M/include_unres/COMMON.INTERACT b/source/wham/src-M/include_unres/COMMON.INTERACT index d4a58b5..7d6b59f 100644 --- a/source/wham/src-M/include_unres/COMMON.INTERACT +++ b/source/wham/src-M/include_unres/COMMON.INTERACT @@ -1,8 +1,10 @@ - double precision aa,bb,augm,aad,bad,app,bpp,ael6,ael3 + double precision aa_aq,bb_aq,augm,aad,bad,app,bpp,ael6,ael3, + & aa_lip,bb_lip integer nnt,nct,nint_gr,istart,iend,itype,itel,itypro,ielstart, & ielend,nscp_gr,iscpstart,iscpend,iatsc_s,iatsc_e,iatel_s, & iatel_e,iatscp_s,iatscp_e,ispp,iscp,expon,expon2 - common /interact/aa(ntyp,ntyp),bb(ntyp,ntyp),augm(ntyp,ntyp), + common /interact/aa_aq(ntyp,ntyp),bb_aq(ntyp,ntyp), + & augm(ntyp,ntyp),aa_lip(ntyp,ntyp),bb_lip(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, @@ -12,15 +14,23 @@ C 12/1/95 Array EPS included in the COMMON block. double precision eps,sigma,sigmaii,rs0,chi,chip,chip0,alp,signa0, & sigii,sigma0,rr0,r0,r0e,r0d,rpp,epp,elpp6,elpp3,eps_scp,rscp, - & eps_orig + & eps_orig,epslip common /body/eps(ntyp,ntyp),sigma(ntyp,ntyp),sigmaii(ntyp,ntyp), + &epslip(ntyp,ntyp), & rs0(ntyp,ntyp),chi(ntyp,ntyp),chip(ntyp),chip0(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),eps_orig(ntyp,ntyp) + & eps_scp(ntyp,2),rscp(ntyp,2),eps_orig(ntyp,ntyp) c 12/5/03 modified 09/18/03 Bond stretching parameters. double precision vbldp0,vbldsc0,akp,aksc,abond0,distchainmax + &,vbldpDUM integer nbondterm common /stretch/ vbldp0,vbldsc0(maxbondterm,ntyp),akp, & aksc(maxbondterm,ntyp),abond0(maxbondterm,ntyp), & distchainmax,nbondterm(ntyp) + &,vbldpDUM +C 01/29/15 Lipidic parameters + double precision pepliptran,liptranene + common /lipid/ pepliptran,liptranene(ntyp) + + diff --git a/source/wham/src-M/include_unres/COMMON.LOCAL b/source/wham/src-M/include_unres/COMMON.LOCAL index a248d99..3e68e82 100644 --- a/source/wham/src-M/include_unres/COMMON.LOCAL +++ b/source/wham/src-M/include_unres/COMMON.LOCAL @@ -1,36 +1,53 @@ double precision a0thet,athet,bthet,polthet,gthet,theta0,sig0, - & sigc0,dsc,dsc_inv,bsc,censc,gaussc,dsc0,vbl,vblinv,vblinv2, - & vbl_cis,vbl0,vbld_inv - integer nlob,loc_start,loc_end,ithet_start,ithet_end, - & iphi_start,iphi_end,itau_start,itau_end + & sigc0,dsc,dsc_inv,bsc,censc,gaussc,dsc0 + integer nlob C Parameters of the virtual-bond-angle probability distribution - common /thetas/ a0thet(ntyp),athet(2,ntyp),bthet(2,ntyp), - & polthet(0:3,ntyp),gthet(3,ntyp),theta0(ntyp),sig0(ntyp), - & sigc0(ntyp) -C Parameters of ab initio-derived potential of virtual-bond-angle bending - integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, - & ithetyp(ntyp1),nntheterm - double precision aa0thet(maxthetyp1,maxthetyp1,maxthetyp1), - & aathet(maxtheterm,maxthetyp1,maxthetyp1,maxthetyp1), - & bbthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ccthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ddthet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & eethet(maxsingle,maxtheterm2,maxthetyp1,maxthetyp1,maxthetyp1), - & ffthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1), - & ggthet(maxdouble,maxdouble,maxtheterm3,maxthetyp1,maxthetyp1, - & maxthetyp1) - common /theta_abinitio/aa0thet,aathet,bbthet,ccthet,ddthet,eethet, - & ffthet, - & ggthet,ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, - & ndouble,nntheterm + common /thetas/ a0thet(-ntyp:ntyp),athet(2,-ntyp:ntyp,-1:1,-1:1), + & bthet(2,-ntyp:ntyp,-1:1,-1:1),polthet(0:3,-ntyp:ntyp), + & gthet(3,-ntyp:ntyp),theta0(-ntyp:ntyp),sig0(-ntyp:ntyp), + & sigc0(-ntyp:ntyp) C Parameters of the side-chain probability distribution common /sclocal/ dsc(ntyp1),dsc_inv(ntyp1),bsc(maxlob,ntyp), - & censc(3,maxlob,ntyp),gaussc(3,3,maxlob,ntyp),dsc0(ntyp1), + & censc(3,maxlob,-ntyp:ntyp),gaussc(3,3,maxlob,-ntyp:ntyp), + &dsc0(ntyp1), & nlob(ntyp1) +C Parameters of ab initio-derived potential of virtual-bond-angle bending + integer nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle,ndouble, + & ithetyp(-ntyp1:ntyp1),nntheterm + common /theta_abinitio/ aa0thet(-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & aathet(maxtheterm,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & bbthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ccthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ddthet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & eethet(maxsingle,maxtheterm2,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1,-maxthetyp1:maxthetyp1,2), + & ffthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2), + & ggthet(maxdouble,maxdouble,maxtheterm3,-maxthetyp1:maxthetyp1, + &-maxthetyp1:maxthetyp1, -maxthetyp1:maxthetyp1,2), + & ithetyp,nthetyp,ntheterm,ntheterm2,ntheterm3,nsingle, + & ndouble,nntheterm + + double precision aa0thet,aathet,bbthet,ccthet,ddthet,eethet, + & ffthet, + & ggthet C Virtual-bond lenghts + double precision vbl,vblinv,vblinv2,vbl_cis,vbl0,vbld_inv + integer loc_start,loc_end,ithet_start,ithet_end,iphi_start, + & iphi_end,iphid_start,iphid_end,ibond_start,ibond_end, + & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, + & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, + & iint_end,iphi1_start,iphi1_end,itau_start,itau_end common /peptbond/ vbl,vblinv,vblinv2,vbl_cis,vbl0 common /indices/ loc_start,loc_end,ithet_start,ithet_end, - & iphi_start,iphi_end,itau_start,itau_end + & iphi_start,iphi_end,iphid_start,iphid_end,ibond_start,ibond_end, + & ibondp_start,ibondp_end,ivec_start,ivec_end,iset_start,iset_end, + & iturn3_start,iturn3_end,iturn4_start,iturn4_end,iint_start, + & iint_end,iphi1_start,iphi1_end,itau_start,itau_end C Inverses of the actual virtual bond lengths common /invlen/ vbld_inv(maxres2) diff --git a/source/wham/src-M/include_unres/COMMON.NAMES b/source/wham/src-M/include_unres/COMMON.NAMES index a266339..7beefb7 100644 --- a/source/wham/src-M/include_unres/COMMON.NAMES +++ b/source/wham/src-M/include_unres/COMMON.NAMES @@ -1,6 +1,7 @@ character*3 restyp character*1 onelet - common /names/ restyp(ntyp+1),onelet(ntyp+1) + common /names/ restyp(-ntyp1:ntyp1), + & onelet(-ntyp1:ntyp1) character*10 ename,wname integer nprint_ene,print_order common /namterm/ ename(max_ene),wname(max_ene),nprint_ene, diff --git a/source/wham/src-M/include_unres/COMMON.SBRIDGE b/source/wham/src-M/include_unres/COMMON.SBRIDGE index 5c87412..028f9ae 100644 --- a/source/wham/src-M/include_unres/COMMON.SBRIDGE +++ b/source/wham/src-M/include_unres/COMMON.SBRIDGE @@ -1,9 +1,20 @@ - double precision ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss,dhpb, - & forcon,weidis - integer ns,nss,nfree,iss,ihpb,jhpb,nhpb,link_start,link_end - common /sbridge/ ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss,ns,nss, - & nfree,iss(maxss) - common /links/ dhpb(maxdim),forcon(maxdim),ihpb(maxdim), - & jhpb(maxdim),nhpb + double precision ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss + integer ns,nss,nfree,iss + common /sbridge/ ss_depth,ebr,d0cm,akcm,akth,akct,v1ss,v2ss,v3ss, + & ns,nss,nfree,iss(maxss) + double precision dhpb,dhpb1,forcon,fordepth + integer ihpb,jhpb,nhpb,idssb,jdssb,ibecarb + common /links/ dhpb(maxdim),dhpb1(maxdim),forcon(maxdim), + & fordepth(maxdim), + & ihpb(maxdim),jhpb(maxdim),nhpb + double precision weidis common /restraints/ weidis + integer link_start,link_end common /links_split/ link_start,link_end + double precision Ht,dyn_ssbond_ij,dtriss,atriss,btriss,ctriss + logical dyn_ss,dyn_ss_mask + common /dyn_ssbond/ dtriss,atriss,btriss,ctriss,Ht, + & dyn_ssbond_ij(maxres,maxres), + & idssb(maxdim),jdssb(maxdim),ibecarb(maxdim) + common /dyn_ss_logic/ + & dyn_ss,dyn_ss_mask(maxres) diff --git a/source/wham/src-M/include_unres/COMMON.SCROT b/source/wham/src-M/include_unres/COMMON.SCROT index 2da7b8f..a352775 100644 --- a/source/wham/src-M/include_unres/COMMON.SCROT +++ b/source/wham/src-M/include_unres/COMMON.SCROT @@ -1,3 +1,3 @@ C Parameters of the SC rotamers (local) term double precision sc_parmin - common/scrot/sc_parmin(maxsccoef,20) + common/scrot/sc_parmin(maxsccoef,ntyp) diff --git a/source/wham/src-M/include_unres/COMMON.SETUP b/source/wham/src-M/include_unres/COMMON.SETUP new file mode 100644 index 0000000..5039116 --- /dev/null +++ b/source/wham/src-M/include_unres/COMMON.SETUP @@ -0,0 +1,21 @@ + integer king,idint,idreal,idchar,is_done + parameter (king=0,idint=1105,idreal=1729,idchar=1597,is_done=1) + integer me,cg_rank,fg_rank,fg_rank1,nodes,Nprocs,nfgtasks,kolor, + & koniec(0:maxprocs-1),WhatsUp,ifinish(maxprocs-1),CG_COMM,FG_COMM, + & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp(0:maxprocs-1), + & kolor1,key1,nfgtasks1,MyRank, + & max_gs_size + logical yourjob, finished, cgdone + common/setup/me,MyRank,cg_rank,fg_rank,fg_rank1,nodes,Nprocs, + & nfgtasks,nfgtasks1, + & max_gs_size,kolor,koniec,WhatsUp,ifinish,CG_COMM,FG_COMM, + & FG_COMM1,CONT_FROM_COMM,CONT_TO_COMM,lentyp + integer MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, + & MPI_THET,MPI_GAM, + & MPI_ROTAT1(0:1),MPI_ROTAT2(0:1),MPI_ROTAT_OLD(0:1), + & MPI_PRECOMP11(0:1),MPI_PRECOMP12(0:1),MPI_PRECOMP22(0:1), + & MPI_PRECOMP23(0:1) + common /types/ MPI_UYZ,MPI_UYZGRAD,MPI_MU,MPI_MAT1,MPI_MAT2, + & MPI_THET,MPI_GAM, + & MPI_ROTAT1,MPI_ROTAT2,MPI_ROTAT_OLD,MPI_PRECOMP11,MPI_PRECOMP12, + & MPI_PRECOMP22,MPI_PRECOMP23 diff --git a/source/wham/src-M/include_unres/COMMON.TORCNSTR b/source/wham/src-M/include_unres/COMMON.TORCNSTR index f8fc3a1..845c44d 100644 --- a/source/wham/src-M/include_unres/COMMON.TORCNSTR +++ b/source/wham/src-M/include_unres/COMMON.TORCNSTR @@ -1,5 +1,14 @@ - integer ndih_constr,idih_constr(maxdih_constr) + integer ndih_constr,idih_constr(maxdih_constr),ntheta_constr, + & itheta_constr(maxdih_constr) integer ndih_nconstr,idih_nconstr(maxdih_constr) - double precision phi0(maxdih_constr),drange(maxdih_constr),ftors - common /torcnstr/ phi0,drange,ftors,ndih_constr,idih_constr, - & ndih_nconstr,idih_nconstr + integer idihconstr_start,idihconstr_end,ithetaconstr_start, + & ithetaconstr_end + double precision phi0(maxdih_constr),drange(maxdih_constr), + & ftors(maxdih_constr),theta_constr0(maxdih_constr), + & theta_drange(maxdih_constr),for_thet_constr(maxdih_constr) + common /torcnstr/ phi0,drange,ftors,theta_constr0,theta_drange, + & for_thet_constr, + & ndih_constr,idih_constr, + & ndih_nconstr,idih_nconstr,idihconstr_start,idihconstr_end, + & ntheta_constr,itheta_constr,ithetaconstr_start, + & ithetaconstr_end diff --git a/source/wham/src-M/include_unres/COMMON.TORSION b/source/wham/src-M/include_unres/COMMON.TORSION index 55cc7f4..71b0f1f 100644 --- a/source/wham/src-M/include_unres/COMMON.TORSION +++ b/source/wham/src-M/include_unres/COMMON.TORSION @@ -1,25 +1,35 @@ C Torsional constants of the rotation about virtual-bond dihedral angles double precision v1,v2,vlor1,vlor2,vlor3,v0 integer itortyp,ntortyp,nterm,nlor,nterm_old - common/torsion/v0(maxtor,maxtor),v1(maxterm,maxtor,maxtor), - & v2(maxterm,maxtor,maxtor),vlor1(maxlor,maxtor,maxtor), + common/torsion/v0(-maxtor:maxtor,-maxtor:maxtor,2), + & v1(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & v2(maxterm,-maxtor:maxtor,-maxtor:maxtor,2), + & vlor1(maxlor,-maxtor:maxtor,-maxtor:maxtor), & vlor2(maxlor,maxtor,maxtor),vlor3(maxlor,maxtor,maxtor), - & itortyp(ntyp),ntortyp,nterm(maxtor,maxtor), - & nlor(maxtor,maxtor),nterm_old + & itortyp(-ntyp:ntyp),ntortyp, + & nterm(-maxtor:maxtor,-maxtor:maxtor,2), + & nlor(-maxtor:maxtor,-maxtor:maxtor,2) + & ,nterm_old C 6/23/01 - constants for double torsionals double precision v1c,v1s,v2c,v2s integer ntermd_1,ntermd_2 - common /torsiond/ v1c(2,maxtermd_1,maxtor,maxtor,maxtor), - & v1s(2,maxtermd_1,maxtor,maxtor,maxtor), - & v2c(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), - & v2s(maxtermd_2,maxtermd_2,maxtor,maxtor,maxtor), - & ntermd_1(maxtor,maxtor,maxtor),ntermd_2(maxtor,maxtor,maxtor) + common /torsiond/ + &v1c(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v1s(2,maxtermd_1,-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + &v2c(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + &v2s(maxtermd_2,maxtermd_2,-maxtor:maxtor,-maxtor:maxtor, + & -maxtor:maxtor,2), + & ntermd_1(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2), + & ntermd_2(-maxtor:maxtor,-maxtor:maxtor,-maxtor:maxtor,2) C 9/18/99 - added Fourier coeffficients of the expansion of local energy C surface - double precision b1,b2,cc,dd,ee,ctilde,dtilde,b1tilde + double precision b1,b2,cc,dd,ee,ctilde,dtilde,b2tilde,b1tilde integer nloctyp - common/fourier/ b1(2,maxtor),b2(2,maxtor),cc(2,2,maxtor), - & dd(2,2,maxtor),ee(2,2,maxtor),ctilde(2,2,maxtor), - & dtilde(2,2,maxtor),b1tilde(2,maxtor),nloctyp + common/fourier/ b1(2,-maxtor:maxtor),b2(2,-maxtor:maxtor) + & ,cc(2,2,-maxtor:maxtor), + & dd(2,2,-maxtor:maxtor),ee(2,2,-maxtor:maxtor), + & ctilde(2,2,-maxtor:maxtor), + & dtilde(2,2,-maxtor:maxtor),b1tilde(2,-maxtor:maxtor),nloctyp double precision b - common /fourier1/ b(13,maxtor) + common /fourier1/ b(13,0:maxtor) diff --git a/source/wham/src-M/include_unres/COMMON.WEIGHTS b/source/wham/src-M/include_unres/COMMON.WEIGHTS index d7e6e23..86f8d7a 100644 --- a/source/wham/src-M/include_unres/COMMON.WEIGHTS +++ b/source/wham/src-M/include_unres/COMMON.WEIGHTS @@ -10,13 +10,13 @@ & epp_low(2,2),epp_up(2,2),rpp_low(2,2),rpp_up(2,2), & elpp6_low(2,2),elpp6_up(2,2),elpp3_low(2,2),elpp3_up(2,2), & b_low(13,3),b_up(13,3),x_up(max_paropt),x_low(max_paropt), - & epscp_low(0:20,2),epscp_up(0:20,2),rscp_low(0:20,2), - & rscp_up(0:20,2),epss_low(ntyp),epss_up(ntyp),epsp_low(nntyp), + & epscp_low(0:ntyp,2),epscp_up(0:ntyp,2),rscp_low(0:ntyp,2), + & rscp_up(0:ntyp,2),epss_low(ntyp),epss_up(ntyp),epsp_low(nntyp), & epsp_up(nntyp), & xm(max_paropt,0:maxprot),xm1(max_paropt,0:maxprot), & xm2(max_paropt,0:maxprot), & imask(max_ene),nsingle_sc,npair_sc,ityp_ssc(ntyp), & ityp_psc(2,nntyp),mask_elec(2,2,4), & mask_fourier(13,3), - & mask_scp(0:20,2,2),mod_other_params,mod_fourier(0:3), + & mask_scp(0:ntyp,2,2),mod_other_params,mod_fourier(0:3), & mod_elec,mod_scp,mod_side,indz(maxbatch+1,maxprot),iw(max_ene) diff --git a/source/wham/src-M/initialize_p.F b/source/wham/src-M/initialize_p.F index 7ca29e0..459c312 100644 --- a/source/wham/src-M/initialize_p.F +++ b/source/wham/src-M/initialize_p.F @@ -62,6 +62,8 @@ C ihist=30 iweight=31 izsc=32 +C Lipidic input file for parameters range 60-79 + iliptranpar=60 C C Set default weights of the energy terms. C @@ -88,8 +90,10 @@ C enddo do i=1,ntyp do j=1,ntyp - aa(i,j)=0.0D0 - bb(i,j)=0.0D0 + aa_lip(i,j)=0.0D0 + bb_lip(i,j)=0.0D0 + aa_aq(i,j)=0.0D0 + bb_aq(i,j)=0.0D0 augm(i,j)=0.0D0 sigma(i,j)=0.0D0 r0(i,j)=0.0D0 @@ -104,9 +108,13 @@ C sigii(i)=0.0D0 rr0(i)=0.0D0 a0thet(i)=0.0D0 - do j=1,2 - athet(j,i)=0.0D0 - bthet(j,i)=0.0D0 + do j=1,2 + do ichir1=-1,1 + do ichir2=-1,1 + athet(j,i,ichir1,ichir2)=0.0D0 + bthet(j,i,ichir1,ichir2)=0.0D0 + enddo + enddo enddo do j=0,3 polthet(j,i)=0.0D0 @@ -132,15 +140,37 @@ C enddo nlob(ntyp1)=0 dsc(ntyp1)=0.0D0 - do i=1,maxtor - itortyp(i)=0 - do j=1,maxtor - do k=1,maxterm - v1(k,j,i)=0.0D0 - v2(k,j,i)=0.0D0 + do i=-maxtor,maxtor + itortyp(i)=0 + do iblock=1,2 + do j=-maxtor,maxtor + do k=1,maxterm + v1(k,j,i,iblock)=0.0D0 + v2(k,j,i,iblock)=0.0D0 enddo enddo + enddo enddo + do iblock=1,2 + do i=-maxtor,maxtor + do j=-maxtor,maxtor + do k=-maxtor,maxtor + do l=1,maxtermd_1 + v1c(1,l,i,j,k,iblock)=0.0D0 + v1s(1,l,i,j,k,iblock)=0.0D0 + v1c(2,l,i,j,k,iblock)=0.0D0 + v1s(2,l,i,j,k,iblock)=0.0D0 + enddo !l + do l=1,maxtermd_2 + do m=1,maxtermd_2 + v2c(m,l,i,j,k,iblock)=0.0D0 + v2s(m,l,i,j,k,iblock)=0.0D0 + enddo !m + enddo !l + enddo !k + enddo !j + enddo !i + enddo !iblock do i=1,maxres itype(i)=0 itel(i)=0 @@ -158,6 +188,7 @@ C Initialize the bridge arrays do i=1,maxres ihpb(i)=0 jhpb(i)=0 + dyn_ss_mask(i)=.false. enddo C C Initialize timing. @@ -219,27 +250,35 @@ c------------------------------------------------------------------------- include 'COMMON.WEIGHTS' include 'COMMON.FFIELD' data restyp / + &'DD','DAU','DAI','DDB','DSM','DPR','DLY','DAR','DHI','DAS','DGL', + & 'DSG','DGN','DSN','DTH', + &'DYY','DAL','DTY','DTR','DVA','DLE','DIL','DPN','MED','DCY','ZER', &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR', - &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/ + &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','SME','DBZ', + &'AIB','ABU','D'/ data onelet / + &'z','z','z','z','z','p','k','r','h','d','e','n','q','s','t','g', + &'a','y','w','v','l','i','f','m','c','x', &'C','M','F','I','L','V','W','Y','A','G','T', - &'S','Q','N','E','D','H','R','K','P','X'/ + &'S','Q','N','E','D','H','R','K','P','z','z','z','z','X'/ data potname /'LJ','LJK','BP','GB','GBV'/ data ename / & "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ", & "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ", & "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB","EVDWPP", - & "EVDW2_14","ESTR","ESCCOR","EDIHC","EVDW_T"/ + & "EVDW2_14","ESTR","ESCCOR","EDIHC","EVDW_T","ELIPTRAN", + & "EAFM","ETHETC","EMPTY"/ data wname / & "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC", & "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD", - & "WHPB","WVDWPP","WSCP14","WBOND","WSCCOR","WDIHC","WSC"/ + & "WHPB","WVDWPP","WSCP14","WBOND","WSCCOR","WDIHC","WSC", + & "WLIPTRAN","WAFM","WTHETC","WSHIELD"/ data ww0 /1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0, & 1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,1.0d0,0.4d0,1.0d0,1.0d0, - & 0.0d0,0.0/ - data nprint_ene /21/ + & 0.0d0,0.0,0.0d0,0.0d0,0.0d0,0.0d0/ + data nprint_ene /22/ data print_order /1,2,3,18,11,12,13,14,4,5,6,7,8,9,10,19, - & 16,15,17,20,21/ + & 16,15,17,20,21,24,22,23,1/ end c--------------------------------------------------------------------------- subroutine init_int_table @@ -296,6 +335,7 @@ cd write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb', cd & (ihpb(i),jhpb(i),i=1,nss) do i=nnt,nct-1 scheck=.false. + if (dyn_ss) goto 10 do ii=1,nss if (ihpb(ii).eq.i+nres) then scheck=.true. @@ -505,7 +545,7 @@ C Partition local interactions #else loc_start=2 loc_end=nres-1 - ithet_start=3 + ithet_start=3 ithet_end=nres iphi_start=nnt+3 iphi_end=nct @@ -572,3 +612,47 @@ cd & ' nhpb',nhpb,' link_start=',link_start, cd & ' link_end',link_end return end +c------------------------------------------------------------------------------ + subroutine homology_partition + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.IOUNITS' +c include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.HOMRESTR' + write(iout,*)"homology_partition: lim_odl=",lim_odl, + & " lim_dih",lim_dih +#ifdef MPL + call int_bounds(lim_odl,link_start_homo,link_end_homo) + call int_bounds(lim_dih-nnt+1,idihconstr_start_homo, + & idihconstr_end_homo) + idihconstr_start_homo=idihconstr_start_homo+nnt-1 + idihconstr_end_homo=idihconstr_end_homo+nnt-1 + if (me.eq.king .or. .not. out1file) + & write (iout,*) 'Processor',fg_rank,' CG group',kolor, + & ' absolute rank',MyRank, + & ' lim_odl',lim_odl,' link_start=',link_start_homo, + & ' link_end',link_end_homo,' lim_dih',lim_dih, + & ' idihconstr_start_homo',idihconstr_start_homo, + & ' idihconstr_end_homo',idihconstr_end_homo +#else + link_start_homo=1 + link_end_homo=lim_odl + idihconstr_start_homo=nnt + idihconstr_end_homo=lim_dih + write (iout,*) + & ' lim_odl',lim_odl,' link_start=',link_start_homo, + & ' link_end',link_end_homo,' lim_dih',lim_dih, + & ' idihconstr_start_homo',idihconstr_start_homo, + & ' idihconstr_end_homo',idihconstr_end_homo +#endif + return + end diff --git a/source/wham/src-M/make_ensemble1.F b/source/wham/src-M/make_ensemble1.F index 5d7b750..7e2f88c 100644 --- a/source/wham/src-M/make_ensemble1.F +++ b/source/wham/src-M/make_ensemble1.F @@ -23,7 +23,7 @@ double precision fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl, & eprim,ebis,temper,kfac/2.4d0/,T0/300.0d0/ double precision etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors, - & escloc, + & escloc,ehomology_constr, & ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor,tt integer i,ii,ik,iproc,iscor,j,k,l,ib,iparm,iprot,nlist @@ -34,7 +34,7 @@ character*5 ctemper integer ilen external ilen - real*4 Fdimless(MaxStr) + real*4 Fdimless(MaxStr),Fdimless_(MaxStr) double precision enepot(MaxStr) integer iperm(MaxStr) integer islice @@ -162,6 +162,7 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft estr=enetb(18,i,iparm) esccor=enetb(19,i,iparm) edihcnstr=enetb(20,i,iparm) + ehomology_constr=enetb(22,i,iparm) #ifdef SPLITELE etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees & +wvdwpp*evdw1 @@ -171,7 +172,7 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft & +ft(2)*wturn3*eello_turn3 & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr + & +wbond*estr+ehomology_constr #else etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 & +ft(1)*welec*(ees+evdw1) @@ -181,14 +182,14 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft & +ft(2)*wturn3*eello_turn3 & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr + & +wbond*estr+ehomology_constr #endif #ifdef MPI - Fdimless(i)= + Fdimless_(i)= & beta_h(ib,iparm)*etot-entfac(i) potE(i,iparm)=etot #ifdef DEBUG - write (iout,*) i,indstart(me)+i-1,ib, + write (iout,*) 'EEE',i,indstart(me)+i-1,ib, & 1.0d0/(1.987d-3*beta_h(ib,iparm)),potE(i,iparm), & -entfac(i),Fdimless(i) #endif @@ -198,7 +199,7 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft #endif enddo ! i #ifdef MPI - call MPI_Gatherv(Fdimless(1),scount(me), + call MPI_Gatherv(Fdimless_(1),scount(me), & MPI_REAL,Fdimless(1), & scount(0),idispl(0),MPI_REAL,Master, & WHAM_COMM, IERROR) diff --git a/source/wham/src-M/molread_zs.F b/source/wham/src-M/molread_zs.F index 885c57b..dee1afc 100644 --- a/source/wham/src-M/molread_zs.F +++ b/source/wham/src-M/molread_zs.F @@ -5,6 +5,7 @@ C implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' include 'COMMON.IOUNITS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -52,34 +53,40 @@ C Convert sequence to numeric code write (iout,'(20i4)') (itype(i),i=1,nres) do i=1,nres-1 #ifdef PROCOR - if (itype(i).eq.21 .or. itype(i+1).eq.21) then + if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) then #else - if (itype(i).eq.21) then + if (itype(i).eq.ntyp1) then #endif itel(i)=0 #ifdef PROCOR - else if (itype(i+1).ne.20) then + else if (iabs(itype(i+1)).ne.20) then #else - else if (itype(i).ne.20) then + else if (iabs(itype(i)).ne.20) then #endif itel(i)=1 else itel(i)=2 endif enddo + write (iout,*) "ITEL" + do i=1,nres-1 + write (iout,*) i,itype(i),itel(i) + enddo call read_bridge if (with_dihed_constr) then read (inp,*) ndih_constr if (ndih_constr.gt.0) then - read (inp,*) ftors - write (iout,*) 'FTORS',ftors - read (inp,*) (idih_constr(i),phi0(i),drange(i),i=1,ndih_constr) +C read (inp,*) ftors +C write (iout,*) 'FTORS',ftors + read (inp,*) (idih_constr(i),phi0(i),drange(i),ftors(i), + & i=1,ndih_constr) 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) + write (iout,'(i5,3f8.3)') idih_constr(i),phi0(i),drange(i), + & ftors(i) enddo do i=1,ndih_constr phi0(i)=deg2rad*phi0(i) @@ -88,18 +95,76 @@ C Convert sequence to numeric code endif endif - + if (with_theta_constr) then +C with_theta_constr is keyword allowing for occurance of theta constrains + read (inp,*) ntheta_constr +C ntheta_constr is the number of theta constrains + if (ntheta_constr.gt.0) then +C read (inp,*) ftors + read (inp,*) (itheta_constr(i),theta_constr0(i), + & theta_drange(i),for_thet_constr(i), + & i=1,ntheta_constr) +C the above code reads from 1 to ntheta_constr +C itheta_constr(i) residue i for which is theta_constr +C theta_constr0 the global minimum value +C theta_drange is range for which there is no energy penalty +C for_thet_constr is the force constant for quartic energy penalty +C E=k*x**4 +C if(me.eq.king.or..not.out1file)then + write (iout,*) + & 'There are',ntheta_constr,' constraints on phi angles.' + do i=1,ntheta_constr + write (iout,'(i5,3f8.3)') itheta_constr(i),theta_constr0(i), + & theta_drange(i), + & for_thet_constr(i) + enddo +C endif + do i=1,ntheta_constr + theta_constr0(i)=deg2rad*theta_constr0(i) + theta_drange(i)=deg2rad*theta_drange(i) + enddo +C if(me.eq.king.or..not.out1file) +C & write (iout,*) 'FTORS',ftors +C do i=1,ntheta_constr +C ii = itheta_constr(i) +C thetabound(1,ii) = phi0(i)-drange(i) +C thetabound(2,ii) = phi0(i)+drange(i) +C enddo + endif ! ntheta_constr.gt.0 + endif! with_theta_constr nnt=1 nct=nres - if (itype(1).eq.21) nnt=2 - if (itype(nres).eq.21) nct=nct-1 + if (itype(1).eq.ntyp1) nnt=2 + if (itype(nres).eq.ntyp1) nct=nct-1 write(iout,*) 'NNT=',NNT,' NCT=',NCT + if (constr_homology.gt.0) then +c write (iout,*) "About to call read_constr_homology" +c call flush(iout) + call read_constr_homology + write (iout,*) "Exit read_constr_homology" + call flush(iout) +cref if (indpdb.gt.0 .or. pdbref) then +cref do i=1,2*nres +cref do j=1,3 +cref c(j,i)=crefjlee(j,i) +cref cref(j,i)=crefjlee(j,i) +cref enddo +cref enddo +cref endif + else + homol_nset=0 + endif + + call setup_var call init_int_table if (ns.gt.0) then write (iout,'(/a,i3,a)') 'The chain contains',ns, & ' disulfide-bridging cysteines.' write (iout,'(20i4)') (iss(i),i=1,ns) + if (dyn_ss) then + write(iout,*)"Running with dynamic disulfide-bond formation" + else write (iout,'(/a/)') 'Pre-formed links are:' do i=1,nss i1=ihpb(i)-nres @@ -111,7 +176,22 @@ C Convert sequence to numeric code & dhpb(i),ebr,forcon(i) enddo endif + endif write (iout,'(a)') + if (ns.gt.0.and.dyn_ss) then + do i=nss+1,nhpb + ihpb(i-nss)=ihpb(i) + jhpb(i-nss)=jhpb(i) + forcon(i-nss)=forcon(i) + dhpb(i-nss)=dhpb(i) + enddo + nhpb=nhpb-nss + nss=0 + call hpb_partition + do i=1,ns + dyn_ss_mask(iss(i))=.true. + enddo + endif return end c----------------------------------------------------------------------------- @@ -150,10 +230,12 @@ C Check whether the specified bridging residues are cystines. do i=1,ns if (itype(iss(i)).ne.1) then write (iout,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, + & 'Do you REALLY think that the residue ', + & restyp(itype(iss(i))),i, & ' can form a disulfide bridge?!!!' write (*,'(2a,i3,a)') - & 'Do you REALLY think that the residue ',restyp(iss(i)),i, + & 'Do you REALLY think that the residue ', + & restyp(itype(iss(i))),i, & ' can form a disulfide bridge?!!!' stop endif @@ -242,3 +324,422 @@ c print *,"energy",energ," iscor",iscor return 10 return1 end +c====------------------------------------------------------------------- + subroutine read_constr_homology + + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.INTERACT' + include 'COMMON.HOMRESTR' +c +c For new homol impl +c + include 'COMMON.VAR' +c include 'include_unres/COMMON.VAR' +c + +c double precision odl_temp,sigma_odl_temp,waga_theta,waga_d, +c & dist_cut +c common /przechowalnia/ odl_temp(maxres,maxres,max_template), +c & sigma_odl_temp(maxres,maxres,max_template) + character*2 kic2 + character*24 model_ki_dist, model_ki_angle + character*500 controlcard + integer ki, i, j, k, l, ii_in_use(maxdim),i_tmp,idomain_tmp + integer idomain(max_template,maxres) + logical lprn /.true./ + integer ilen + external ilen + logical unres_pdb +c +c FP - Nov. 2014 Temporary specifications for new vars +c + double precision rescore_tmp,x12,y12,z12,rescore2_tmp + double precision, dimension (max_template,maxres) :: rescore + double precision, dimension (max_template,maxres) :: rescore2 + character*24 tpl_k_rescore +c ----------------------------------------------------------------- +c Reading multiple PDB ref structures and calculation of retraints +c not using pre-computed ones stored in files model_ki_{dist,angle} +c FP (Nov., 2014) +c ----------------------------------------------------------------- +c +c +c Alternative: reading from input + call card_concat(controlcard,.true.) + call reada(controlcard,"HOMOL_DIST",waga_dist,1.0d0) + call reada(controlcard,"HOMOL_ANGLE",waga_angle,1.0d0) + call reada(controlcard,"HOMOL_THETA",waga_theta,1.0d0) ! new + call reada(controlcard,"HOMOL_SCD",waga_d,1.0d0) ! new + call reada(controlcard,'DIST_CUT',dist_cut,5.0d0) ! for diff ways of calc sigma + call reada(controlcard,'DIST2_CUT',dist2_cut,9999.0d0) + call readi(controlcard,"HOMOL_SET",homol_nset,1) + read2sigma=(index(controlcard,'READ2SIGMA').gt.0) + call readi(controlcard,"IHSET",ihset,1) + if (homol_nset.gt.1)then + call card_concat(controlcard,.true.) + read(controlcard,*) (waga_homology(i),i=1,homol_nset) + if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then + write(iout,*) "iset homology_weight " +c do i=1,homol_nset +c write(iout,*) i,waga_homology(i) +c enddo + endif + iset=mod(kolor,homol_nset)+1 + else + iset=1 + waga_homology(1)=1.0 + endif +c write(iout,*) "waga_homology(",iset,")",waga_homology(iset) + +cd write (iout,*) "nnt",nnt," nct",nct +cd call flush(iout) + + + lim_odl=0 + lim_dih=0 +c +c New +c + lim_theta=0 + lim_xx=0 +c +c Reading HM global scores (prob not required) +c + do i = nnt,nct + do k=1,constr_homology + idomain(k,i)=0 + enddo + enddo +c open (4,file="HMscore") +c do k=1,constr_homology +c read (4,*,end=521) hmscore_tmp +c hmscore(k)=hmscore_tmp ! Another transformation can be used +c write(*,*) "Model", k, ":", hmscore(k) +c enddo +c521 continue + + ii=0 + do i = nnt,nct-2 + do j=i+2,nct + ii=ii+1 + ii_in_use(ii)=0 + enddo + enddo +c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d + + do k=1,constr_homology + + read(inp,'(a)') pdbfile +c Next stament causes error upon compilation (?) +c if(me.eq.king.or. .not. out1file) +c write (iout,'(2a)') 'PDB data will be read from file ', +c & pdbfile(:ilen(pdbfile)) + write (iout,'(a,5x,a)') 'HOMOL: Opening PDB file', + & pdbfile(:ilen(pdbfile)) + open(ipdbin,file=pdbfile,status='old',err=33) + goto 34 + 33 write (iout,'(a,5x,a)') 'Error opening PDB file', + & pdbfile(:ilen(pdbfile)) + stop + 34 continue +c print *,'Begin reading pdb data' +c +c Files containing res sim or local scores (former containing sigmas) +c + + write(kic2,'(bz,i2.2)') k + + tpl_k_rescore="template"//kic2//".sco" + + unres_pdb=.false. + call readpdb +cref do i=1,2*nres +cref do j=1,3 +cref crefjlee(j,i)=c(j,i) +cref enddo +cref enddo +#ifdef DEBUG + do i=1,nres + write (iout,'(i5,3f8.3,5x,3f8.3)') i,(crefjlee(j,i),j=1,3), + & (crefjlee(j,i+nres),j=1,3) + enddo +#endif + write (iout,*) "read_constr_homology: after reading pdb file" + call flush(iout) + +c +c Distance restraints +c +c ... --> odl(k,ii) +C Copy the coordinates from reference coordinates (?) + do i=1,2*nres + do j=1,3 +c c(j,i)=cref(j,i) +c write (iout,*) "c(",j,i,") =",c(j,i) + enddo + enddo +c +c From read_dist_constr (commented out 25/11/2014 <-> res sim) +c +c write(iout,*) "tpl_k_rescore - ",tpl_k_rescore + open (ientin,file=tpl_k_rescore,status='old') + if (nnt.gt.1) rescore(k,1)=0.0d0 + do irec=nnt,maxdim ! loop for reading res sim + if (read2sigma) then + read (ientin,*,end=1401) i_tmp,rescore2_tmp,rescore_tmp, + & idomain_tmp + i_tmp=i_tmp+nnt-1 + idomain(k,i_tmp)=idomain_tmp + rescore(k,i_tmp)=rescore_tmp + rescore2(k,i_tmp)=rescore2_tmp + else + idomain(k,irec)=1 + read (ientin,*,end=1401) rescore_tmp + +c rescore(k,irec)=rescore_tmp+1.0d0 ! to avoid 0 values + rescore(k,irec)=0.5d0*(rescore_tmp+0.5d0) ! alt transf to reduce scores +c write(iout,*) "rescore(",k,irec,") =",rescore(k,irec) + endif + enddo + 1401 continue + close (ientin) + if (waga_dist.ne.0.0d0) then + ii=0 + do i = nnt,nct-2 + do j=i+2,nct + + x12=c(1,i)-c(1,j) + y12=c(2,i)-c(2,j) + z12=c(3,i)-c(3,j) + distal=dsqrt(x12*x12+y12*y12+z12*z12) +c write (iout,*) k,i,j,distal,dist2_cut + + if (idomain(k,i).eq.idomain(k,j).and.idomain(k,i).ne.0 + & .and. distal.le.dist2_cut ) then + + ii=ii+1 + ii_in_use(ii)=1 + l_homo(k,ii)=.true. + +c write (iout,*) "k",k +c write (iout,*) "i",i," j",j," constr_homology", +c & constr_homology + ires_homo(ii)=i + jres_homo(ii)=j + odl(k,ii)=distal + if (read2sigma) then + sigma_odl(k,ii)=0 + do ik=i,j + sigma_odl(k,ii)=sigma_odl(k,ii)+rescore2(k,ik) + enddo + sigma_odl(k,ii)=sigma_odl(k,ii)/(j-i+1) + if (odl(k,ii).gt.dist_cut) sigma_odl(k,ii) = + & sigma_odl(k,ii)*dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) + else + if (odl(k,ii).le.dist_cut) then + sigma_odl(k,ii)=rescore(k,i)+rescore(k,j) + else +#ifdef OLDSIGMA + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2) +#else + sigma_odl(k,ii)=(rescore(k,i)+rescore(k,j))* + & dexp(0.5d0*(odl(k,ii)/dist_cut)**2-0.5d0) +#endif + endif + endif + sigma_odl(k,ii)=1.0d0/(sigma_odl(k,ii)*sigma_odl(k,ii)) + else + ii=ii+1 + l_homo(k,ii)=.false. + endif + enddo + enddo + lim_odl=ii + endif +c +c Theta, dihedral and SC retraints +c + if (waga_angle.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_dih,status='old') +c do irec=1,maxres-3 ! loop for reading sigma_dih +c read (ientin,*,end=1402) i,j,ki,l,sigma_dih(k,i+nnt-1) ! j,ki,l what for? +c if (i+nnt-1.gt.lim_dih) lim_dih=i+nnt-1 ! right? +c sigma_dih(k,i+nnt-1)=sigma_dih(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_dih(k,i+nnt-1) +c enddo +c1402 continue +c close (ientin) + do i = nnt+3,nct + if (idomain(k,i).eq.0) then + sigma_dih(k,i)=0.0 + cycle + endif + dih(k,i)=phiref(i) ! right? +c read (ientin,*) sigma_dih(k,i) ! original variant +c write (iout,*) "dih(",k,i,") =",dih(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i), +c & "rescore(",k,i-1,") =",rescore(k,i-1), +c & "rescore(",k,i-2,") =",rescore(k,i-2), +c & "rescore(",k,i-3,") =",rescore(k,i-3) + + sigma_dih(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2)+rescore(k,i-3))/4.0 +c if (read2sigma) sigma_dih(k,i)=sigma_dih(k,i)/4.0 +c write (iout,*) "Raw sigmas for dihedral angle restraints" +c write (iout,'(i5,10(2f8.2,4x))') i,sigma_dih(k,i) +c sigma_dih(k,i)=hmscore(k)*rescore(k,i)*rescore(k,i-1)* +c rescore(k,i-2)*rescore(k,i-3) ! right expression ? +c Instead of res sim other local measure of b/b str reliability possible + sigma_dih(k,i)=1.0d0/(sigma_dih(k,i)*sigma_dih(k,i)) +c sigma_dih(k,i)=sigma_dih(k,i)*sigma_dih(k,i) + enddo + lim_dih=nct-nnt-2 + endif + + if (waga_theta.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_theta,status='old') +c do irec=1,maxres-2 ! loop for reading sigma_theta, right bounds? +c read (ientin,*,end=1403) i,j,ki,sigma_theta(k,i+nnt-1) ! j,ki what for? +c sigma_theta(k,i+nnt-1)=sigma_theta(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_theta(k,i+nnt-1) +c enddo +c1403 continue +c close (ientin) + + do i = nnt+2,nct ! right? without parallel. +c do i = i=1,nres ! alternative for bounds acc to readpdb? +c do i=ithet_start,ithet_end ! with FG parallel. + if (idomain(k,i).eq.0) then + sigma_theta(k,i)=0.0 + cycle + endif + thetatpl(k,i)=thetaref(i) +c write (iout,*) "thetatpl(",k,i,") =",thetatpl(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i), +c & "rescore(",k,i-1,") =",rescore(k,i-1), +c & "rescore(",k,i-2,") =",rescore(k,i-2) +c read (ientin,*) sigma_theta(k,i) ! 1st variant + sigma_theta(k,i)=(rescore(k,i)+rescore(k,i-1)+ + & rescore(k,i-2))/3.0 +c if (read2sigma) sigma_theta(k,i)=sigma_theta(k,i)/3.0 + sigma_theta(k,i)=1.0d0/(sigma_theta(k,i)*sigma_theta(k,i)) + +c sigma_theta(k,i)=hmscore(k)*rescore(k,i)*rescore(k,i-1)* +c rescore(k,i-2) ! right expression ? +c sigma_theta(k,i)=sigma_theta(k,i)*sigma_theta(k,i) + enddo + endif + lim_theta=nct-nnt-1 + + if (waga_d.gt.0.0d0) then +c open (ientin,file=tpl_k_sigma_d,status='old') +c do irec=1,maxres-1 ! loop for reading sigma_theta, right bounds? +c read (ientin,*,end=1404) i,j,sigma_d(k,i+nnt-1) ! j,ki what for? +c sigma_d(k,i+nnt-1)=sigma_d(k,i+nnt-1)* ! not inverse because of use of res. similarity +c & sigma_d(k,i+nnt-1) +c enddo +c1404 continue + + do i = nnt,nct ! right? without parallel. +c do i=2,nres-1 ! alternative for bounds acc to readpdb? +c do i=loc_start,loc_end ! with FG parallel. + if (itype(i).eq.10) cycle + if (idomain(k,i).eq.0 ) then + sigma_d(k,i)=0.0 + cycle + endif + xxtpl(k,i)=xxref(i) + yytpl(k,i)=yyref(i) + zztpl(k,i)=zzref(i) +c write (iout,*) "xxtpl(",k,i,") =",xxtpl(k,i) +c write (iout,*) "yytpl(",k,i,") =",yytpl(k,i) +c write (iout,*) "zztpl(",k,i,") =",zztpl(k,i) +c write(iout,*) "rescore(",k,i,") =",rescore(k,i) + sigma_d(k,i)=rescore(k,i) ! right expression ? + sigma_d(k,i)=1.0d0/(sigma_d(k,i)*sigma_d(k,i)) + +c sigma_d(k,i)=hmscore(k)*rescore(k,i) ! right expression ? +c sigma_d(k,i)=sigma_d(k,i)*sigma_d(k,i) +c read (ientin,*) sigma_d(k,i) ! 1st variant + if (i-nnt+1.gt.lim_xx) lim_xx=i-nnt+1 ! right? + enddo + lim_xx=nct-nnt+1 + endif + enddo +c +c remove distance restraints not used in any model from the list +c shift data in all arrays +c + if (waga_dist.ne.0.0d0) then + ii=0 + do i=nnt,nct-2 + do j=i+2,nct + ii=ii+1 + if (ii_in_use(ii).eq.0) then + do ki=ii,lim_odl-1 + ires_homo(ki)=ires_homo(ki+1) + jres_homo(ki)=jres_homo(ki+1) + ii_in_use(ki)=ii_in_use(ki+1) + do k=1,constr_homology + odl(k,ki)=odl(k,ki+1) + sigma_odl(k,ki)=sigma_odl(k,ki+1) + l_homo(k,ki)=l_homo(k,ki+1) + enddo + enddo + ii=ii-1 + lim_odl=lim_odl-1 + endif + enddo + enddo + endif + if (constr_homology.gt.0) call homology_partition + if (constr_homology.gt.0) call init_int_table +cd write (iout,*) "homology_partition: lim_theta= ",lim_theta, +cd & "lim_xx=",lim_xx +c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end +c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end +c +c Print restraints +c + if (.not.lprn) return +cd write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d + if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then + write (iout,*) "Distance restraints from templates" + do ii=1,lim_odl + write(iout,'(3i5,100(2f8.2,1x,l1,4x))') + & ii,ires_homo(ii),jres_homo(ii), + & (odl(ki,ii),1.0d0/dsqrt(sigma_odl(ki,ii)),l_homo(ki,ii), + & ki=1,constr_homology) + enddo + write (iout,*) "Dihedral angle restraints from templates" + do i=nnt+3,lim_dih + write (iout,'(i5,100(2f8.2,4x))') i,(rad2deg*dih(ki,i), + & rad2deg/dsqrt(sigma_dih(ki,i)),ki=1,constr_homology) + enddo + write (iout,*) "Virtual-bond angle restraints from templates" + do i=nnt+2,lim_theta + write (iout,'(i5,100(2f8.2,4x))') i,(rad2deg*thetatpl(ki,i), + & rad2deg/dsqrt(sigma_theta(ki,i)),ki=1,constr_homology) + enddo + write (iout,*) "SC restraints from templates" + do i=nnt,lim_xx + write(iout,'(i5,100(4f8.2,4x))') i, + & (xxtpl(ki,i),yytpl(ki,i),zztpl(ki,i), + & 1.0d0/dsqrt(sigma_d(ki,i)),ki=1,constr_homology) + enddo + endif +c ----------------------------------------------------------------- + return + end +c---------------------------------------------------------------------- diff --git a/source/wham/src-M/openunits.F b/source/wham/src-M/openunits.F index b9f54b7..5200b3e 100644 --- a/source/wham/src-M/openunits.F +++ b/source/wham/src-M/openunits.F @@ -48,6 +48,8 @@ C Get parameter filenames and open the parameter files. open (isidep,file=sidename,status='old') call mygetenv('SIDEP',sidepname) open (isidep1,file=sidepname,status="old") + call mygetenv('LIPTRANPAR',liptranname) + open (iliptranpar,file=liptranname,status='old',action='read') #ifndef OLDSCP C C 8/9/01 In the newest version SCp interaction constants are read from a file diff --git a/source/wham/src-M/parmread.F b/source/wham/src-M/parmread.F index da12677..eb007cd 100644 --- a/source/wham/src-M/parmread.F +++ b/source/wham/src-M/parmread.F @@ -21,8 +21,10 @@ C include 'COMMON.SCCOR' include 'COMMON.SCROT' include 'COMMON.FREE' + include 'COMMON.CONTROL' character*1 t1,t2,t3 character*1 onelett(4) /"G","A","P","D"/ + character*1 toronelet(-2:2) /"p","a","G","A","P"/ logical lprint dimension blower(3,3,maxlob) character*800 controlcard @@ -34,6 +36,7 @@ C character*16 key integer iparm double precision ip,mp + character*6 res1 C C Body C @@ -54,6 +57,66 @@ C Assign virtual-bond length write (iout,*) "iparm",iparm," myparm",myparm c If reading not own parameters, skip assignment + call reada(controlcard,"D0CM",d0cm,3.78d0) + call reada(controlcard,"AKCM",akcm,15.1d0) + call reada(controlcard,"AKTH",akth,11.0d0) + call reada(controlcard,"AKCT",akct,12.0d0) + call reada(controlcard,"V1SS",v1ss,-1.08d0) + call reada(controlcard,"V2SS",v2ss,7.61d0) + call reada(controlcard,"V3SS",v3ss,13.7d0) + call reada(controlcard,"EBR",ebr,-5.50D0) + call reada(controlcard,"DTRISS",dtriss,1.0D0) + call reada(controlcard,"ATRISS",atriss,0.3D0) + call reada(controlcard,"BTRISS",btriss,0.02D0) + call reada(controlcard,"CTRISS",ctriss,1.0D0) + dyn_ss=(index(controlcard,'DYN_SS').gt.0) + write(iout,*) "ATRISS",atriss + write(iout,*) "BTRISS",btriss + write(iout,*) "CTRISS",ctriss + write(iout,*) "DTRISS",dtriss + +C do i=1,maxres +C dyn_ss_mask(i)=.false. +C enddo +C ebr=-12.0D0 +c +c Old arbitrary potential - commented out. +c +c dbr= 4.20D0 +c fbr= 3.30D0 +c +c Constants of the disulfide-bond potential determined based on the RHF/6-31G** +c energy surface of diethyl disulfide. +c A. Liwo and U. Kozlowska, 11/24/03 +c + D0CM = 3.78d0 + AKCM = 15.1d0 + AKTH = 11.0d0 + AKCT = 12.0d0 + V1SS =-1.08d0 + V2SS = 7.61d0 + V3SS = 13.7d0 + + do i=1,maxres-1 + do j=i+1,maxres + dyn_ssbond_ij(i,j)=1.0d300 + enddo + enddo + call reada(controlcard,"HT",Ht,0.0D0) +C if (dyn_ss) then +C ss_depth=ebr/wsc-0.25*eps(1,1) +C write(iout,*) HT,wsc,eps(1,1),'KURWA' +C Ht=Ht/wsc-0.25*eps(1,1) + +C akcm=akcm*whpb/wsc +C akth=akth*whpb/wsc +C akct=akct*whpb/wsc +C v1ss=v1ss*whpb/wsc +C v2ss=v2ss*whpb/wsc +C v3ss=v3ss*whpb/wsc +C else +C ss_depth=ebr/whpb-0.25*eps(1,1)*wsc/whpb +C endif if (iparm.eq.myparm .or. .not.separate_parset) then @@ -149,7 +212,7 @@ c Read the virtual-bond parameters, masses, and moments of inertia c and Stokes' radii of the peptide group and side chains c #ifdef CRYST_BOND - read (ibond,*) vbldp0,akp + read (ibond,*) vbldp0,vbldpdum,akp do i=1,ntyp nbondterm(i)=1 read (ibond,*) vbldsc0(1,i),aksc(1,i) @@ -161,7 +224,7 @@ c endif enddo #else - read (ibond,*) ijunk,vbldp0,akp,rjunk + read (ibond,*) ijunk,vbldp0,vbldpdum,akp,rjunk do i=1,ntyp read (ibond,*) nbondterm(i),(vbldsc0(j,i),aksc(j,i),abond0(j,i), & j=1,nbondterm(i)) @@ -193,11 +256,46 @@ C Read the parameters of the probability distribution/energy expression C of the virtual-bond valence angles theta C do i=1,ntyp - read (ithep,*) a0thet(i),(athet(j,i),j=1,2),(bthet(j,i),j=1,2) + read (ithep,*) a0thet(i),(athet(j,i,1,1),j=1,2), + & (bthet(j,i,1,1),j=1,2) read (ithep,*) (polthet(j,i),j=0,3) - read (ithep,*) (gthet(j,i),j=1,3) - read (ithep,*) theta0(i),sig0(i),sigc0(i) - sigc0(i)=sigc0(i)**2 + read (ithep,*) (gthet(j,i),j=1,3) + read (ithep,*) theta0(i),sig0(i),sigc0(i) + sigc0(i)=sigc0(i)**2 + enddo + do i=1,ntyp + athet(1,i,1,-1)=athet(1,i,1,1) + athet(2,i,1,-1)=athet(2,i,1,1) + bthet(1,i,1,-1)=-bthet(1,i,1,1) + bthet(2,i,1,-1)=-bthet(2,i,1,1) + athet(1,i,-1,1)=-athet(1,i,1,1) + athet(2,i,-1,1)=-athet(2,i,1,1) + bthet(1,i,-1,1)=bthet(1,i,1,1) + bthet(2,i,-1,1)=bthet(2,i,1,1) + enddo + do i=-ntyp,-1 + a0thet(i)=a0thet(-i) + athet(1,i,-1,-1)=athet(1,-i,1,1) + athet(2,i,-1,-1)=-athet(2,-i,1,1) + bthet(1,i,-1,-1)=bthet(1,-i,1,1) + bthet(2,i,-1,-1)=-bthet(2,-i,1,1) + athet(1,i,-1,1)=athet(1,-i,1,1) + athet(2,i,-1,1)=-athet(2,-i,1,1) + bthet(1,i,-1,1)=-bthet(1,-i,1,1) + bthet(2,i,-1,1)=bthet(2,-i,1,1) + athet(1,i,1,-1)=-athet(1,-i,1,1) + athet(2,i,1,-1)=athet(2,-i,1,1) + bthet(1,i,1,-1)=bthet(1,-i,1,1) + bthet(2,i,1,-1)=-bthet(2,-i,1,1) + theta0(i)=theta0(-i) + sig0(i)=sig0(-i) + sigc0(i)=sigc0(-i) + do j=0,3 + polthet(j,i)=polthet(j,-i) + enddo + do j=1,3 + gthet(j,i)=gthet(j,-i) + enddo enddo close (ithep) if (lprint) then @@ -234,7 +332,8 @@ c enddo & ' b1*10^1 ',' b2*10^1 ' do i=1,ntyp write(iout,'(a3,1h&,2x,5(f8.3,1h&))') restyp(i), - & a0thet(i),(100*athet(j,i),j=1,2),(10*bthet(j,i),j=1,2) + & a0thet(i),(100*athet(j,i,1,1),j=1,2), + & (10*bthet(j,i,1,1),j=1,2) enddo write (iout,'(/a/9x,5a/79(1h-))') & 'Parameters of the expression for sigma(theta_c):', @@ -262,46 +361,58 @@ C & ntheterm3,nsingle,ndouble nntheterm=max0(ntheterm,ntheterm2,ntheterm3) read (ithep,*) (ithetyp(i),i=1,ntyp1) - do i=1,maxthetyp - do j=1,maxthetyp - do k=1,maxthetyp - aa0thet(i,j,k)=0.0d0 + do i=-ntyp1,-1 + ithetyp(i)=-ithetyp(-i) + enddo + write (iout,*) "tu dochodze" + do iblock=1,2 + do i=-maxthetyp,maxthetyp + do j=-maxthetyp,maxthetyp + do k=-maxthetyp,maxthetyp + aa0thet(i,j,k,iblock)=0.0d0 do l=1,ntheterm - aathet(l,i,j,k)=0.0d0 + aathet(l,i,j,k,iblock)=0.0d0 enddo do l=1,ntheterm2 do m=1,nsingle - bbthet(m,l,i,j,k)=0.0d0 - ccthet(m,l,i,j,k)=0.0d0 - ddthet(m,l,i,j,k)=0.0d0 - eethet(m,l,i,j,k)=0.0d0 + bbthet(m,l,i,j,k,iblock)=0.0d0 + ccthet(m,l,i,j,k,iblock)=0.0d0 + ddthet(m,l,i,j,k,iblock)=0.0d0 + eethet(m,l,i,j,k,iblock)=0.0d0 enddo enddo do l=1,ntheterm3 do m=1,ndouble do mm=1,ndouble - ffthet(mm,m,l,i,j,k)=0.0d0 - ggthet(mm,m,l,i,j,k)=0.0d0 + ffthet(mm,m,l,i,j,k,iblock)=0.0d0 + ggthet(mm,m,l,i,j,k,iblock)=0.0d0 enddo enddo enddo enddo enddo enddo - do i=1,nthetyp - do j=1,nthetyp - do k=1,nthetyp - read (ithep,'(3a)') res1,res2,res3 - read (ithep,*) aa0thet(i,j,k) - read (ithep,*)(aathet(l,i,j,k),l=1,ntheterm) + enddo +C write (iout,*) "KURWA1" + do iblock=1,2 + do i=0,nthetyp + do j=-nthetyp,nthetyp + do k=-nthetyp,nthetyp + read (ithep,'(6a)') res1 + write(iout,*) res1,i,j,k + read (ithep,*) aa0thet(i,j,k,iblock) + read (ithep,*)(aathet(l,i,j,k,iblock),l=1,ntheterm) read (ithep,*) - & ((bbthet(lll,ll,i,j,k),lll=1,nsingle), - & (ccthet(lll,ll,i,j,k),lll=1,nsingle), - & (ddthet(lll,ll,i,j,k),lll=1,nsingle), - & (eethet(lll,ll,i,j,k),lll=1,nsingle),ll=1,ntheterm2) + & ((bbthet(lll,ll,i,j,k,iblock),lll=1,nsingle), + & (ccthet(lll,ll,i,j,k,iblock),lll=1,nsingle), + & (ddthet(lll,ll,i,j,k,iblock),lll=1,nsingle), + & (eethet(lll,ll,i,j,k,iblock),lll=1,nsingle) + & ,ll=1,ntheterm2) read (ithep,*) - & (((ffthet(llll,lll,ll,i,j,k),ffthet(lll,llll,ll,i,j,k), - & ggthet(llll,lll,ll,i,j,k),ggthet(lll,llll,ll,i,j,k), + & (((ffthet(llll,lll,ll,i,j,k,iblock), + & ffthet(lll,llll,ll,i,j,k,iblock), + & ggthet(llll,lll,ll,i,j,k,iblock) + & ,ggthet(lll,llll,ll,i,j,k,iblock), & llll=1,lll-1),lll=2,ndouble),ll=1,ntheterm3) enddo enddo @@ -313,17 +424,55 @@ C do i=1,nthetyp do j=1,nthetyp do l=1,ntheterm - aathet(l,i,j,nthetyp+1)=aathet(l,i,j,1) - aathet(l,nthetyp+1,i,j)=aathet(l,1,i,j) + aathet(l,i,j,nthetyp+1,iblock)=0.0d0 + aathet(l,nthetyp+1,i,j,iblock)=0.0d0 enddo - aa0thet(i,j,nthetyp+1)=aa0thet(i,j,1) - aa0thet(nthetyp+1,i,j)=aa0thet(1,i,j) + aa0thet(i,j,nthetyp+1,iblock)=0.0d0 + aa0thet(nthetyp+1,i,j,iblock)=0.0d0 enddo do l=1,ntheterm - aathet(l,nthetyp+1,i,nthetyp+1)=aathet(l,1,i,1) + aathet(l,nthetyp+1,i,nthetyp+1,iblock)=0.0d0 enddo - aa0thet(nthetyp+1,i,nthetyp+1)=aa0thet(1,i,1) + aa0thet(nthetyp+1,i,nthetyp+1,iblock)=0.0d0 enddo + enddo +C write(iout,*) "KURWA1.5" +C Substitution for D aminoacids from symmetry. + do iblock=1,2 + do i=-nthetyp,0 + do j=-nthetyp,nthetyp + do k=-nthetyp,nthetyp + aa0thet(i,j,k,iblock)=aa0thet(-i,-j,-k,iblock) + do l=1,ntheterm + aathet(l,i,j,k,iblock)=aathet(l,-i,-j,-k,iblock) + enddo + do ll=1,ntheterm2 + do lll=1,nsingle + bbthet(lll,ll,i,j,k,iblock)=bbthet(lll,ll,-i,-j,-k,iblock) + ccthet(lll,ll,i,j,k,iblock)=-ccthet(lll,ll,-i,-j,-k,iblock) + ddthet(lll,ll,i,j,k,iblock)=ddthet(lll,ll,-i,-j,-k,iblock) + eethet(lll,ll,i,j,k,iblock)=-eethet(lll,ll,-i,-j,-k,iblock) + enddo + enddo + do ll=1,ntheterm3 + do lll=2,ndouble + do llll=1,lll-1 + ffthet(llll,lll,ll,i,j,k,iblock)= + & ffthet(llll,lll,ll,-i,-j,-k,iblock) + ffthet(lll,llll,ll,i,j,k,iblock)= + & ffthet(lll,llll,ll,-i,-j,-k,iblock) + ggthet(llll,lll,ll,i,j,k,iblock)= + & -ggthet(llll,lll,ll,-i,-j,-k,iblock) + ggthet(lll,llll,ll,i,j,k,iblock)= + & -ggthet(lll,llll,ll,-i,-j,-k,iblock) + enddo !ll + enddo !lll + enddo !llll + enddo !k + enddo !j + enddo !i + enddo !iblock + C C Control printout of the coefficients of virtual-bond-angle potentials C @@ -335,16 +484,16 @@ C write (iout,'(//4a)') & 'Type ',onelett(i),onelett(j),onelett(k) write (iout,'(//a,10x,a)') " l","a[l]" - write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k) + write (iout,'(i2,1pe15.5)') 0,aa0thet(i,j,k,iblock) write (iout,'(i2,1pe15.5)') - & (l,aathet(l,i,j,k),l=1,ntheterm) + & (l,aathet(l,i,j,k,iblock),l=1,ntheterm) do l=1,ntheterm2 write (iout,'(//2h m,4(9x,a,3h[m,i1,1h]))') & "b",l,"c",l,"d",l,"e",l do m=1,nsingle write (iout,'(i2,4(1pe15.5))') m, - & bbthet(m,l,i,j,k),ccthet(m,l,i,j,k), - & ddthet(m,l,i,j,k),eethet(m,l,i,j,k) + & bbthet(m,l,i,j,k,iblock),ccthet(m,l,i,j,k,iblock), + & ddthet(m,l,i,j,k,iblock),eethet(m,l,i,j,k,iblock) enddo enddo do l=1,ntheterm3 @@ -353,8 +502,10 @@ C do m=2,ndouble do n=1,m-1 write (iout,'(i1,1x,i1,4(1pe15.5))') n,m, - & ffthet(n,m,l,i,j,k),ffthet(m,n,l,i,j,k), - & ggthet(n,m,l,i,j,k),ggthet(m,n,l,i,j,k) + & ffthet(n,m,l,i,j,k,iblock), + & ffthet(m,n,l,i,j,k,iblock), + & ggthet(n,m,l,i,j,k,iblock), + & ggthet(m,n,l,i,j,k,iblock) enddo enddo enddo @@ -387,10 +538,17 @@ C enddo bsc(1,i)=0.0D0 read(irotam,*)(censc(k,1,i),k=1,3),((blower(k,l,1),l=1,k),k=1,3) + censc(1,1,-i)=censc(1,1,i) + censc(2,1,-i)=censc(2,1,i) + censc(3,1,-i)=-censc(3,1,i) do j=2,nlob(i) read (irotam,*) bsc(j,i) read (irotam,*) (censc(k,j,i),k=1,3), & ((blower(k,l,j),l=1,k),k=1,3) + censc(1,j,-i)=censc(1,j,i) + censc(2,j,-i)=censc(2,j,i) + censc(3,j,-i)=-censc(3,j,i) +C BSC is amplitude of Gaussian enddo do j=1,nlob(i) do k=1,3 @@ -401,6 +559,14 @@ C enddo gaussc(k,l,j,i)=akl gaussc(l,k,j,i)=akl + if (((k.eq.3).and.(l.ne.3)) + & .or.((l.eq.3).and.(k.ne.3))) then + gaussc(k,l,j,-i)=-akl + gaussc(l,k,j,-i)=-akl + else + gaussc(k,l,j,-i)=akl + gaussc(l,k,j,-i)=akl + endif enddo enddo enddo @@ -490,36 +656,51 @@ C read (itorp,*) ntortyp read (itorp,*) (itortyp(i),i=1,ntyp) write (iout,*) 'ntortyp',ntortyp - do i=1,ntortyp - do j=1,ntortyp - read (itorp,*) nterm(i,j),nlor(i,j) + do iblock=1,2 + do i=-ntyp,-1 + itortyp(i)=-itortyp(-i) + enddo +c write (iout,*) 'ntortyp',ntortyp + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + read (itorp,*) nterm(i,j,iblock), + & nlor(i,j,iblock) + nterm(-i,-j,iblock)=nterm(i,j,iblock) + nlor(-i,-j,iblock)=nlor(i,j,iblock) v0ij=0.0d0 si=-1.0d0 - do k=1,nterm(i,j) - read (itorp,*) kk,v1(k,i,j),v2(k,i,j) - v0ij=v0ij+si*v1(k,i,j) + do k=1,nterm(i,j,iblock) + read (itorp,*) kk,v1(k,i,j,iblock), + & v2(k,i,j,iblock) + v1(k,-i,-j,iblock)=v1(k,i,j,iblock) + v2(k,-i,-j,iblock)=-v2(k,i,j,iblock) + v0ij=v0ij+si*v1(k,i,j,iblock) si=-si - enddo - do k=1,nlor(i,j) - read (itorp,*) kk,vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) + enddo + do k=1,nlor(i,j,iblock) + read (itorp,*) kk,vlor1(k,i,j), + & vlor2(k,i,j),vlor3(k,i,j) v0ij=v0ij+vlor1(k,i,j)/(1+vlor3(k,i,j)**2) enddo - v0(i,j)=v0ij + v0(i,j,iblock)=v0ij + v0(-i,-j,iblock)=v0ij enddo enddo + enddo close (itorp) if (lprint) then - write (iout,'(/a/)') 'Torsional constants:' - do i=1,ntortyp - do j=1,ntortyp + write (iout,'(/a/)') 'Torsional constants:' + do i=1,ntortyp + do j=1,ntortyp write (iout,*) 'ityp',i,' jtyp',j write (iout,*) 'Fourier constants' - do k=1,nterm(i,j) - write (iout,'(2(1pe15.5))') v1(k,i,j),v2(k,i,j) + do k=1,nterm(i,j,iblock) + write (iout,'(2(1pe15.5))') v1(k,i,j,iblock), + & v2(k,i,j,iblock) enddo write (iout,*) 'Lorenz constants' - do k=1,nlor(i,j) - write (iout,'(3(1pe15.5))') + do k=1,nlor(i,j,iblock) + write (iout,'(3(1pe15.5))') & vlor1(k,i,j),vlor2(k,i,j),vlor3(k,i,j) enddo enddo @@ -528,58 +709,98 @@ C C C 6/23/01 Read parameters for double torsionals C - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp + do iblock=1,2 + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 read (itordp,'(3a1)') t1,t2,t3 - if (t1.ne.onelett(i) .or. t2.ne.onelett(j) - & .or. t3.ne.onelett(k)) then +c write (iout,*) "OK onelett", +c & i,j,k,t1,t2,t3 + + if (t1.ne.toronelet(i) .or. t2.ne.toronelet(j) + & .or. t3.ne.toronelet(k)) then write (iout,*) "Error in double torsional parameter file", & i,j,k,t1,t2,t3 +#ifdef MPI + call MPI_Finalize(Ierror) +#endif stop "Error in double torsional parameter file" endif - read (itordp,*) ntermd_1(i,j,k),ntermd_2(i,j,k) - read (itordp,*) (v1c(1,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) (v1s(1,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) (v1c(2,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) (v1s(2,l,i,j,k),l=1,ntermd_1(i,j,k)) - read (itordp,*) ((v2c(l,m,i,j,k),v2c(m,l,i,j,k), - & v2s(l,m,i,j,k),v2s(m,l,i,j,k),m=1,l-1),l=1,ntermd_2(i,j,k)) - enddo - enddo - enddo + read (itordp,*) ntermd_1(i,j,k,iblock), + & ntermd_2(i,j,k,iblock) + ntermd_1(-i,-j,-k,iblock)=ntermd_1(i,j,k,iblock) + ntermd_2(-i,-j,-k,iblock)=ntermd_2(i,j,k,iblock) + read (itordp,*) (v1c(1,l,i,j,k,iblock),l=1, + & ntermd_1(i,j,k,iblock)) + read (itordp,*) (v1s(1,l,i,j,k,iblock),l=1, + & ntermd_1(i,j,k,iblock)) + read (itordp,*) (v1c(2,l,i,j,k,iblock),l=1, + & ntermd_1(i,j,k,iblock)) + read (itordp,*) (v1s(2,l,i,j,k,iblock),l=1, + & ntermd_1(i,j,k,iblock)) +C Martix of D parameters for one dimesional foureir series + do l=1,ntermd_1(i,j,k,iblock) + v1c(1,l,-i,-j,-k,iblock)=v1c(1,l,i,j,k,iblock) + v1s(1,l,-i,-j,-k,iblock)=-v1s(1,l,i,j,k,iblock) + v1c(2,l,-i,-j,-k,iblock)=v1c(2,l,i,j,k,iblock) + v1s(2,l,-i,-j,-k,iblock)=-v1s(2,l,i,j,k,iblock) +c write(iout,*) "whcodze" , +c & v1s(2,l,-i,-j,-k,iblock),v1s(2,l,i,j,k,iblock) + enddo + read (itordp,*) ((v2c(l,m,i,j,k,iblock), + & v2c(m,l,i,j,k,iblock),v2s(l,m,i,j,k,iblock), + & v2s(m,l,i,j,k,iblock), + & m=1,l-1),l=1,ntermd_2(i,j,k,iblock)) +C Martix of D parameters for two dimesional fourier series + do l=1,ntermd_2(i,j,k,iblock) + do m=1,l-1 + v2c(l,m,-i,-j,-k,iblock)=v2c(l,m,i,j,k,iblock) + v2c(m,l,-i,-j,-k,iblock)=v2c(m,l,i,j,k,iblock) + v2s(l,m,-i,-j,-k,iblock)=-v2s(l,m,i,j,k,iblock) + v2s(m,l,-i,-j,-k,iblock)=-v2s(m,l,i,j,k,iblock) + enddo!m + enddo!l + enddo!k + enddo!j + enddo!i + enddo!iblock if (lprint) then - write (iout,*) + write (iout,*) write (iout,*) 'Constants for double torsionals' - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp + do iblock=1,2 + do i=0,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 write (iout,*) 'ityp',i,' jtyp',j,' ktyp',k, - & ' nsingle',ntermd_1(i,j,k),' ndouble',ntermd_2(i,j,k) + & ' nsingle',ntermd_1(i,j,k,iblock), + & ' ndouble',ntermd_2(i,j,k,iblock) write (iout,*) write (iout,*) 'Single angles:' - do l=1,ntermd_1(i,j,k) - write (iout,'(i5,2f10.5,5x,2f10.5)') l, - & v1c(1,l,i,j,k),v1s(1,l,i,j,k), - & v1c(2,l,i,j,k),v1s(2,l,i,j,k) + do l=1,ntermd_1(i,j,k,iblock) + write (iout,'(i5,2f10.5,5x,2f10.5,5x,2f10.5)') l, + & v1c(1,l,i,j,k,iblock),v1s(1,l,i,j,k,iblock), + & v1c(2,l,i,j,k,iblock),v1s(2,l,i,j,k,iblock), + & v1s(1,l,-i,-j,-k,iblock),v1s(2,l,-i,-j,-k,iblock) enddo write (iout,*) write (iout,*) 'Pairs of angles:' - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2c(l,m,i,j,k),m=1,ntermd_2(i,j,k)) + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) + do l=1,ntermd_2(i,j,k,iblock) + write (iout,'(i5,20f10.5)') + & l,(v2c(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)) enddo write (iout,*) - write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k)) - do l=1,ntermd_2(i,j,k) - write (iout,'(i5,20f10.5)') - & l,(v2s(l,m,i,j,k),m=1,ntermd_2(i,j,k)) + write (iout,'(3x,20i10)') (l,l=1,ntermd_2(i,j,k,iblock)) + do l=1,ntermd_2(i,j,k,iblock) + write (iout,'(i5,20f10.5)') + & l,(v2s(l,m,i,j,k,iblock),m=1,ntermd_2(i,j,k,iblock)), + & (v2s(l,m,-i,-j,-k,iblock),m=1,ntermd_2(i,j,k,iblock)) enddo write (iout,*) enddo enddo enddo + enddo endif #endif C Read of Side-chain backbone correlation parameters @@ -689,7 +910,7 @@ C 9/18/99 (AL) Read coefficients of the Fourier expansion of the local C interaction energy of the Gly, Ala, and Pro prototypes. C read (ifourier,*) nloctyp - do i=1,nloctyp + do i=0,nloctyp-1 read (ifourier,*) read (ifourier,*) (b(ii,i),ii=1,13) if (lprint) then @@ -698,30 +919,88 @@ C endif B1(1,i) = b(3,i) B1(2,i) = b(5,i) + B1(1,-i) = b(3,i) + B1(2,-i) = -b(5,i) +c b1(1,i)=0.0d0 +c b1(2,i)=0.0d0 B1tilde(1,i) = b(3,i) - B1tilde(2,i) =-b(5,i) + B1tilde(2,i) =-b(5,i) + B1tilde(1,-i) =-b(3,i) + B1tilde(2,-i) =b(5,i) +c b1tilde(1,i)=0.0d0 +c b1tilde(2,i)=0.0d0 B2(1,i) = b(2,i) B2(2,i) = b(4,i) + B2(1,-i) =b(2,i) + B2(2,-i) =-b(4,i) + +c b2(1,i)=0.0d0 +c b2(2,i)=0.0d0 CC(1,1,i)= b(7,i) CC(2,2,i)=-b(7,i) CC(2,1,i)= b(9,i) CC(1,2,i)= b(9,i) + CC(1,1,-i)= b(7,i) + CC(2,2,-i)=-b(7,i) + CC(2,1,-i)=-b(9,i) + CC(1,2,-i)=-b(9,i) +c CC(1,1,i)=0.0d0 +c CC(2,2,i)=0.0d0 +c CC(2,1,i)=0.0d0 +c CC(1,2,i)=0.0d0 Ctilde(1,1,i)=b(7,i) Ctilde(1,2,i)=b(9,i) Ctilde(2,1,i)=-b(9,i) Ctilde(2,2,i)=b(7,i) + Ctilde(1,1,-i)=b(7,i) + Ctilde(1,2,-i)=-b(9,i) + Ctilde(2,1,-i)=b(9,i) + Ctilde(2,2,-i)=b(7,i) + +c Ctilde(1,1,i)=0.0d0 +c Ctilde(1,2,i)=0.0d0 +c Ctilde(2,1,i)=0.0d0 +c Ctilde(2,2,i)=0.0d0 DD(1,1,i)= b(6,i) DD(2,2,i)=-b(6,i) DD(2,1,i)= b(8,i) DD(1,2,i)= b(8,i) + DD(1,1,-i)= b(6,i) + DD(2,2,-i)=-b(6,i) + DD(2,1,-i)=-b(8,i) + DD(1,2,-i)=-b(8,i) +c DD(1,1,i)=0.0d0 +c DD(2,2,i)=0.0d0 +c DD(2,1,i)=0.0d0 +c DD(1,2,i)=0.0d0 Dtilde(1,1,i)=b(6,i) Dtilde(1,2,i)=b(8,i) Dtilde(2,1,i)=-b(8,i) Dtilde(2,2,i)=b(6,i) + Dtilde(1,1,-i)=b(6,i) + Dtilde(1,2,-i)=-b(8,i) + Dtilde(2,1,-i)=b(8,i) + Dtilde(2,2,-i)=b(6,i) + +c Dtilde(1,1,i)=0.0d0 +c Dtilde(1,2,i)=0.0d0 +c Dtilde(2,1,i)=0.0d0 +c Dtilde(2,2,i)=0.0d0 EE(1,1,i)= b(10,i)+b(11,i) EE(2,2,i)=-b(10,i)+b(11,i) EE(2,1,i)= b(12,i)-b(13,i) EE(1,2,i)= b(12,i)+b(13,i) + EE(1,1,-i)= b(10,i)+b(11,i) + EE(2,2,-i)=-b(10,i)+b(11,i) + EE(2,1,-i)=-b(12,i)+b(13,i) + EE(1,2,-i)=-b(12,i)-b(13,i) + +c ee(1,1,i)=1.0d0 +c ee(2,2,i)=1.0d0 +c ee(2,1,i)=0.0d0 +c ee(1,2,i)=0.0d0 +c ee(2,1,i)=ee(1,2,i) + enddo if (lprint) then do i=1,nloctyp @@ -766,8 +1045,10 @@ C bpp (i,j)=-2.0D0*epp(i,j)*rri ael6(i,j)=elpp6(i,j)*4.2D0**6 ael3(i,j)=elpp3(i,j)*4.2D0**3 + lprint=.true. if (lprint) write(iout,'(2i3,4(1pe15.4))')i,j,app(i,j),bpp(i,j), & ael6(i,j),ael3(i,j) + lprint=.false. enddo enddo C @@ -808,13 +1089,25 @@ C----------------------- LJK potential -------------------------------- endif goto 50 C---------------------- GB or BP potential ----------------------------- - 30 read (isidep,*)((eps(i,j),j=i,ntyp),i=1,ntyp), - & (sigma0(i),i=1,ntyp),(sigii(i),i=1,ntyp),(chip0(i),i=1,ntyp), - & (alp(i),i=1,ntyp) + 30 do i=1,ntyp + read (isidep,*)(eps(i,j),j=i,ntyp) + enddo + read (isidep,*)(sigma0(i),i=1,ntyp) + read (isidep,*)(sigii(i),i=1,ntyp) + read (isidep,*)(chip(i),i=1,ntyp) + read (isidep,*)(alp(i),i=1,ntyp) + do i=1,ntyp + read (isidep,*)(epslip(i,j),j=i,ntyp) +C write(iout,*) "WARNING!!",i,ntyp + write(iout,*) "epslip", i, (epslip(i,j),j=i,ntyp) +C do j=1,ntyp +C epslip(i,j)=epslip(i,j)+0.05d0 +C enddo + enddo C For the GB potential convert sigma'**2 into chi' if (ipot.eq.4) then do i=1,ntyp - chip(i)=(chip0(i)-1.0D0)/(chip0(i)+1.0D0) + chip(i)=(chip(i)-1.0D0)/(chip(i)+1.0D0) enddo endif if (lprint) then @@ -849,6 +1142,7 @@ C Calculate the "working" parameters of SC interactions. do i=2,ntyp do j=1,i-1 eps(i,j)=eps(j,i) + epslip(i,j)=epslip(j,i) enddo enddo do i=1,ntyp @@ -866,6 +1160,7 @@ C Calculate the "working" parameters of SC interactions. do i=1,ntyp do j=i,ntyp epsij=eps(i,j) + epsijlip=epslip(i,j) if (ipot.eq.1 .or. ipot.eq.3 .or. ipot.eq.4) then rrij=sigma(i,j) else @@ -877,10 +1172,16 @@ C Calculate the "working" parameters of SC interactions. epsij=eps(i,j) sigeps=dsign(1.0D0,epsij) epsij=dabs(epsij) - aa(i,j)=epsij*rrij*rrij - bb(i,j)=-sigeps*epsij*rrij - aa(j,i)=aa(i,j) - bb(j,i)=bb(i,j) + aa_aq(i,j)=epsij*rrij*rrij + bb_aq(i,j)=-sigeps*epsij*rrij + aa_aq(j,i)=aa_aq(i,j) + bb_aq(j,i)=bb_aq(i,j) + sigeps=dsign(1.0D0,epsijlip) + epsijlip=dabs(epsijlip) + aa_lip(i,j)=epsijlip*rrij*rrij + bb_lip(i,j)=-sigeps*epsijlip*rrij + aa_lip(j,i)=aa_lip(i,j) + bb_lip(j,i)=bb_lip(i,j) if (ipot.gt.2) then sigt1sq=sigma0(i)**2 sigt2sq=sigma0(j)**2 @@ -913,7 +1214,7 @@ c augm(i,j)=0.5D0**(2*expon)*aa(i,j) endif if (lprint) then write (iout,'(2(a3,2x),3(1pe10.3),5(0pf8.3))') - & restyp(i),restyp(j),aa(i,j),bb(i,j),augm(i,j), + & restyp(i),restyp(j),aa_aq(i,j),bb_aq(i,j),augm(i,j), & sigma(i,j),r0(i,j),chi(i,j),chi(j,i) endif enddo @@ -969,7 +1270,7 @@ C C C Define the constants of the disulfide bridge C - ebr=-5.50D0 +C ebr=-12.0D0 c c Old arbitrary potential - commented out. c @@ -980,21 +1281,36 @@ c Constants of the disulfide-bond potential determined based on the RHF/6-31G** c energy surface of diethyl disulfide. c A. Liwo and U. Kozlowska, 11/24/03 c - D0CM = 3.78d0 - AKCM = 15.1d0 - AKTH = 11.0d0 - AKCT = 12.0d0 - V1SS =-1.08d0 - V2SS = 7.61d0 - V3SS = 13.7d0 +C D0CM = 3.78d0 +C AKCM = 15.1d0 +C AKTH = 11.0d0 +C AKCT = 12.0d0 +C V1SS =-1.08d0 +C V2SS = 7.61d0 +C V3SS = 13.7d0 + write (iout,*) dyn_ss,'dyndyn' + if (dyn_ss) then + ss_depth=ebr/wsc-0.25*eps(1,1) +C write(iout,*) akcm,whpb,wsc,'KURWA' + Ht=Ht/wsc-0.25*eps(1,1) - if (lprint) then + akcm=akcm*whpb/wsc + akth=akth*whpb/wsc + akct=akct*whpb/wsc + v1ss=v1ss*whpb/wsc + v2ss=v2ss*whpb/wsc + v3ss=v3ss*whpb/wsc + else + ss_depth=ebr/whpb-0.25*eps(1,1)*wsc/whpb + endif + +C if (lprint) then write (iout,'(/a)') "Disulfide bridge parameters:" write (iout,'(a,f10.2)') 'S-S bridge energy: ',ebr write (iout,'(2(a,f10.2))') 'd0cm:',d0cm,' akcm:',akcm write (iout,'(2(a,f10.2))') 'akth:',akth,' akct:',akct write (iout,'(3(a,f10.2))') 'v1ss:',v1ss,' v2ss:',v2ss, & ' v3ss:',v3ss - endif +C endif return end diff --git a/source/wham/src-M/permut.F b/source/wham/src-M/permut.F index 403a8a8..6a0d518 100644 --- a/source/wham/src-M/permut.F +++ b/source/wham/src-M/permut.F @@ -1,6 +1,7 @@ subroutine permut(isym) implicit real*8 (a-h,o-z) include 'DIMENSIONS' + include 'DIMENSIONS.FREE' include 'COMMON.LOCAL' include 'COMMON.VAR' include 'COMMON.CHAIN' diff --git a/source/wham/src-M/proc_cont.f b/source/wham/src-M/proc_cont.f index 9269496..f1a22f6 100644 --- a/source/wham/src-M/proc_cont.f +++ b/source/wham/src-M/proc_cont.f @@ -3,6 +3,7 @@ include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' include 'COMMON.IOUNITS' include 'COMMON.TIME1' include 'COMMON.SBRIDGE' diff --git a/source/wham/src-M/promienie.f b/source/wham/src-M/promienie.f index 12a2e80..d04927d 100644 --- a/source/wham/src-M/promienie.f +++ b/source/wham/src-M/promienie.f @@ -1,6 +1,7 @@ subroutine promienie(*) implicit none include 'DIMENSIONS' + include 'DIMENSIONS.FREE' include 'COMMON.CONTROL' include 'COMMON.INTERACT' include 'COMMON.IOUNITS' @@ -36,7 +37,7 @@ enddo close (isidep1) do i=1,ntyp1 - if (i.eq.10 .or. i.eq.21) then + if (i.eq.10 .or. i.eq.ntyp1) then dsc_inv(i)=0.0d0 else dsc_inv(i)=1.0d0/dsc(i) diff --git a/source/wham/src-M/qwolynes.f b/source/wham/src-M/qwolynes.f index 1820b35..98eb29f 100644 --- a/source/wham/src-M/qwolynes.f +++ b/source/wham/src-M/qwolynes.f @@ -3,6 +3,7 @@ include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' include 'COMMON.IOUNITS' include 'COMMON.COMPAR' include 'COMMON.CHAIN' diff --git a/source/wham/src-M/read_dist_constr.F b/source/wham/src-M/read_dist_constr.F index 3d803bb..5dd61d0 100644 --- a/source/wham/src-M/read_dist_constr.F +++ b/source/wham/src-M/read_dist_constr.F @@ -1,6 +1,7 @@ subroutine read_dist_constr implicit real*8 (a-h,o-z) include 'DIMENSIONS' + include 'DIMENSIONS.FREE' #ifdef MPI include 'mpif.h' #endif @@ -13,9 +14,12 @@ character*500 controlcard logical lprn /.true./ write (iout,*) "Calling read_dist_constr" - write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup +C write (iout,*) "nres",nres," nstart_sup",nstart_sup," nsup",nsup +C call flush(iout) + write(iout,*) "TU sie wywalam?" + call card_concat(controlcard,.false.) + write (iout,*) controlcard 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) @@ -96,14 +100,30 @@ c write (iout,*) i,ifrag_(1,i),ifrag_(2,i),wfrag_(i) endif enddo do i=1,ndist_ + if (constr_dist.eq.11) then + read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),dhpb(i),dhpb1(i), + & ibecarb(i),forcon(nhpb+1),fordepth(nhpb+1) + fordepth(nhpb+1)=fordepth(nhpb+1)/forcon(nhpb+1) +C write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", +C & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) + else read (inp,*) ihpb(nhpb+1),jhpb(nhpb+1),forcon(nhpb+1) + endif if (forcon(nhpb+1).gt.0.0d0) then nhpb=nhpb+1 - dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) + if (ibecarb(i).gt.0) then + ihpb(i)=ihpb(i)+nres + jhpb(i)=jhpb(i)+nres + endif + if (dhpb(nhpb).eq.0.0d0) + & dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) +C dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) write (iout,'(a,3i5,f8.2,f10.1)') "+dist.constr ", & nhpb,ihpb(nhpb),jhpb(nhpb),dhpb(nhpb),forcon(nhpb) endif +C endif enddo + call hpb_partition call flush(iout) return end diff --git a/source/wham/src-M/read_ref_str.F b/source/wham/src-M/read_ref_str.F index 2245a59..4966da1 100644 --- a/source/wham/src-M/read_ref_str.F +++ b/source/wham/src-M/read_ref_str.F @@ -7,6 +7,7 @@ C include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' include 'COMMON.IOUNITS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -29,10 +30,13 @@ C logical seq_comp integer i,j,k,nres_pdb,iaux double precision ddsc,dist + integer nnt_old,nct_old integer ilen,kkk external ilen C nres0=nres + nnt_old=nnt + nct_old=nct write (iout,*) "pdbref",pdbref if (pdbref) then read(inp,'(a)') pdbfile @@ -164,5 +168,8 @@ c print *,"Calling elecont" & 'Number of residues to be superposed:',nsup, & ' (from residue',nstart_sup,' to residue', & nend_sup,').' + nres=nres0 + nnt=nnt_old + nct=nct_old return end diff --git a/source/wham/src-M/readpdb.f b/source/wham/src-M/readpdb.f index fa2d05d..e7343d9 100644 --- a/source/wham/src-M/readpdb.f +++ b/source/wham/src-M/readpdb.f @@ -3,6 +3,7 @@ C Read the PDB file and convert the peptide geometry into virtual-chain C geometry. implicit none include 'DIMENSIONS' + include 'DIMENSIONS.FREE' include 'DIMENSIONS.ZSCOPT' include 'COMMON.CONTROL' include 'COMMON.LOCAL' @@ -26,8 +27,10 @@ C geometry. goto 10 else if (card(:3).eq.'TER') then C End current chain - ires_old=ires+1 - itype(ires_old)=21 +c ires_old=ires+1 + ires_old=ires+2 + itype(ires_old-1)=ntyp1 + itype(ires_old)=ntyp1 ibeg=2 c write (iout,*) "Chain ended",ires,ishift,ires_old call sccenter(ires,iii,sccor) @@ -48,7 +51,7 @@ c write (iout,'(a80)') card ishift=ires-1 if (res.ne.'GLY' .and. res.ne. 'ACE') then ishift=ishift-1 - itype(1)=21 + itype(1)=ntyp1 endif c write (iout,*) "ires",ires," ibeg",ibeg," ishift",ishift ibeg=0 @@ -85,14 +88,51 @@ C system nres=ires do i=2,nres-1 c write (iout,*) i,itype(i) - if (itype(i).eq.21) then -c write (iout,*) "dummy",i,itype(i) - do j=1,3 - c(j,i)=((c(j,i-1)+c(j,i+1))/2+2*c(j,i-1)-c(j,i-2))/2 -c c(j,i)=(c(j,i-1)+c(j,i+1))/2 - dc(j,i)=c(j,i) - enddo - endif + + if (itype(i).eq.ntyp1) then + if (itype(i+1).eq.ntyp1) then +C 16/01/2014 by Adasko: Adding to dummy atoms in the chain +C first is connected prevous chain (itype(i+1).eq.ntyp1)=true +C second dummy atom is conected to next chain itype(i+1).eq.ntyp1=false +C if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the last dummy residue +C call refsys(i-3,i-2,i-1,e1,e2,e3,fail) +C if (fail) then +C e2(1)=0.0d0 +C e2(2)=1.0d0 +C e2(3)=0.0d0 +C endif !fail +C do j=1,3 +C c(j,i)=c(j,i-1)-1.9d0*e2(j) +C enddo +C else !unres_pdb + do j=1,3 + dcj=(c(j,i-2)-c(j,i-3))/2.0 + c(j,i)=c(j,i-1)+dcj + c(j,nres+i)=c(j,i) + enddo +C endif !unres_pdb + else !itype(i+1).eq.ntyp1 +C if (unres_pdb) then +C 2/15/2013 by Adam: corrected insertion of the first dummy residue +C call refsys(i+1,i+2,i+3,e1,e2,e3,fail) +C if (fail) then +C e2(1)=0.0d0 +C e2(2)=1.0d0 +C e2(3)=0.0d0 +C endif +C do j=1,3 +C c(j,i)=c(j,i+1)-1.9d0*e2(j) +C enddo +C else !unres_pdb + do j=1,3 + dcj=(c(j,i+3)-c(j,i+2))/2.0 + c(j,i)=c(j,i+1)-dcj + c(j,nres+i)=c(j,i) + enddo +C endif !unres_pdb + endif !itype(i+1).eq.ntyp1 + endif !itype.eq.ntyp1 enddo C Calculate the CM of the last side chain. call sccenter(ires,iii,sccor) @@ -100,9 +140,9 @@ C Calculate the CM of the last side chain. nstart_sup=1 if (itype(nres).ne.10) then nres=nres+1 - itype(nres)=21 + itype(nres)=ntyp1 do j=1,3 - dcj=c(j,nres-2)-c(j,nres-3) + dcj=(c(j,nres-2)-c(j,nres-3))/2.0 c(j,nres)=c(j,nres-1)+dcj c(j,2*nres)=c(j,nres) enddo @@ -116,11 +156,11 @@ C Calculate the CM of the last side chain. c(j,nres+1)=c(j,1) c(j,2*nres)=c(j,nres) enddo - if (itype(1).eq.21) then + if (itype(1).eq.ntyp1) then nsup=nsup-1 nstart_sup=2 do j=1,3 - dcj=c(j,4)-c(j,3) + dcj=(c(j,4)-c(j,3))/2.0 c(j,1)=c(j,2)-dcj c(j,nres+1)=c(j,1) enddo @@ -131,7 +171,9 @@ C Calculate internal coordinates. & ires,itype(ires),restyp(itype(ires)),(c(j,ires),j=1,3), & (c(j,nres+ires),j=1,3) enddo + call int_from_cart1(.false.) call int_from_cart(.true.,.false.) + call sc_loc_geom(.true.) write (iout,*) "After int_from_cart" call flush(iout) do i=1,nres-1 @@ -148,6 +190,16 @@ C Calculate internal coordinates. c write (iout,*) i,(dc(j,i+nres),j=1,3),(dc_norm(j,i+nres),j=1,3), c & vbld_inv(i+nres) enddo + do i=1,nres + thetaref(i)=theta(i) + phiref(i)=phi(i) +c + phi_ref(i)=phi(i) + theta_ref(i)=theta(i) + alph_ref(i)=alph(i) + omeg_ref(i)=omeg(i) + enddo + c call chainbuild C Copy the coordinates to reference coordinates c do i=1,2*nres @@ -163,7 +215,7 @@ C Splits to single chain if occurs lll=lll+1 cc write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) if (i.gt.1) then - if (itype(i-1).eq.21) then + if ((itype(i-1).eq.ntyp1).and.(i.gt.2).and.(i.ne.nres)) then chain_length=lll-1 kkk=kkk+1 c write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) @@ -173,19 +225,19 @@ c write (iout,*) "spraw lancuchy",(c(j,i),j=1,3) do j=1,3 cref(j,i,cou)=c(j,i) cref(j,i+nres,cou)=c(j,i+nres) - if ((i.le.nres).and.(symetr.gt.1)) then + if (i.le.nres) then chain_rep(j,lll,kkk)=c(j,i) chain_rep(j,lll+nres,kkk)=c(j,i+nres) endif enddo enddo - if (symetr.gt.1) then + if (chain_length.eq.0) chain_length=nres + write (iout,*) chain_length do j=1,3 chain_rep(j,chain_length,symetr)=chain_rep(j,chain_length,1) chain_rep(j,chain_length+nres,symetr) &=chain_rep(j,chain_length+nres,1) enddo - endif c diagnostic c diagnostic @@ -280,27 +332,18 @@ c--------------------------------------------------------------------------- & ' Phi' endif endif - do i=2,nres + do i=1,nres-1 iti=itype(i) - write (iout,*) i,i-1,(c(j,i),j=1,3),(c(j,i-1),j=1,3),dist(i,i-1) - if (itype(i-1).ne.21 .and. itype(i).ne.21 .and. - & (dist(i,i-1).lt.2.0D0 .or. dist(i,i-1).gt.5.0D0)) then + if (iti.ne.ntyp1 .and. itype(i+1).ne.ntyp1 .and. + & (dist(i,i+1).lt.2.0D0 .or. dist(i,i+1).gt.5.0D0)) then write (iout,'(a,i4)') 'Bad Cartesians for residue',i stop endif - theta(i+1)=alpha(i-1,i,i+1) + vbld(i+1)=dist(i,i+1) + vbld_inv(i+1)=1.0d0/vbld(i+1) + if (i.gt.1) theta(i+1)=alpha(i-1,i,i+1) if (i.gt.2) phi(i+1)=beta(i-2,i-1,i,i+1) enddo - if (itype(1).eq.21) then - do j=1,3 - c(j,1)=c(j,2)+(c(j,3)-c(j,4)) - enddo - endif - if (itype(nres).eq.21) then - do j=1,3 - c(j,nres)=c(j,nres-1)+(c(j,nres-2)-c(j,nres-3)) - enddo - endif if (lside) then do i=2,nres-1 do j=1,3 @@ -326,6 +369,97 @@ c--------------------------------------------------------------------------- endif return end + +c------------------------------------------------------------------------------- + subroutine sc_loc_geom(lprn) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'DIMENSIONS.ZSCOPT' + include 'DIMENSIONS.FREE' + include 'COMMON.LOCAL' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.SETUP' + double precision x_prime(3),y_prime(3),z_prime(3) + logical lprn + do i=1,nres-1 + do j=1,3 + dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i)) + enddo + enddo + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + dc_norm(j,i+nres)=vbld_inv(i+nres)*(c(j,i+nres)-c(j,i)) + enddo + else + do j=1,3 + dc_norm(j,i+nres)=0.0d0 + enddo + endif + enddo + do i=2,nres-1 + costtab(i+1) =dcos(theta(i+1)) + sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) + cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) + sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) + cosfac2=0.5d0/(1.0d0+costtab(i+1)) + cosfac=dsqrt(cosfac2) + sinfac2=0.5d0/(1.0d0-costtab(i+1)) + sinfac=dsqrt(sinfac2) + it=itype(i) + if (it.ne.10 .and. itype(i).ne.ntyp1) then +c +C Compute the axes of tghe local cartesian coordinates system; store in +c x_prime, y_prime and z_prime +c + do j=1,3 + x_prime(j) = 0.00 + y_prime(j) = 0.00 + z_prime(j) = 0.00 + enddo + do j = 1,3 + x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac + y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac + enddo + call vecpr(x_prime,y_prime,z_prime) +c +C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), +C to local coordinate system. Store in xx, yy, zz. +c + xx=0.0d0 + yy=0.0d0 + zz=0.0d0 + do j = 1,3 + xx = xx + x_prime(j)*dc_norm(j,i+nres) + yy = yy + y_prime(j)*dc_norm(j,i+nres) + zz = zz + z_prime(j)*dc_norm(j,i+nres) + enddo + + xxref(i)=xx + yyref(i)=yy + zzref(i)=zz + else + xxref(i)=0.0d0 + yyref(i)=0.0d0 + zzref(i)=0.0d0 + endif + enddo + if (lprn) then + do i=2,nres + iti=itype(i) + if(me.eq.king.or..not.out1file) + & write (iout,'(a3,i4,3f10.5)') restyp(iti),i,xxref(i), + & yyref(i),zzref(i) + enddo + endif + return + end c--------------------------------------------------------------------------- subroutine sccenter(ires,nscat,sccor) implicit none diff --git a/source/wham/src-M/readrtns.F b/source/wham/src-M/readrtns.F index 36c13b1..271fca8 100644 --- a/source/wham/src-M/readrtns.F +++ b/source/wham/src-M/readrtns.F @@ -17,6 +17,8 @@ include "COMMON.FREE" include "COMMON.CONTROL" include "COMMON.ENERGIES" + include "COMMON.SPLITELE" + include "COMMON.SBRIDGE" character*800 controlcard integer i,j,k,ii,n_ene_found integer ind,itype1,itype2,itypf,itypsc,itypp @@ -25,7 +27,7 @@ character*16 ucase character*16 key external ucase - + double precision pi call card_concat(controlcard,.true.) call readi(controlcard,"N_ENE",n_ene,max_ene) if (n_ene.gt.max_ene) then @@ -74,6 +76,29 @@ call readi(controlcard,"RESCALE",rescale_mode,1) check_conf=index(controlcard,"NO_CHECK_CONF").eq.0 call reada(controlcard,'DISTCHAINMAX',distchainmax,50.0d0) + call reada(controlcard,'BOXX',boxxsize,100.0d0) + call reada(controlcard,'BOXY',boxysize,100.0d0) + call reada(controlcard,'BOXZ',boxzsize,100.0d0) +c Cutoff range for interactions + call reada(controlcard,"R_CUT",r_cut,15.0d0) + call reada(controlcard,"LAMBDA",rlamb,0.3d0) + call reada(controlcard,"LIPTHICK",lipthick,0.0d0) + call reada(controlcard,"LIPAQBUF",lipbufthick,0.0d0) + if (lipthick.gt.0.0d0) then + bordliptop=(boxzsize+lipthick)/2.0 + bordlipbot=bordliptop-lipthick +C endif + if ((bordliptop.gt.boxzsize).or.(bordlipbot.lt.0.0)) + & write(iout,*) "WARNING WRONG SIZE OF LIPIDIC PHASE" + buflipbot=bordlipbot+lipbufthick + bufliptop=bordliptop-lipbufthick + if ((lipbufthick*2.0d0).gt.lipthick) + &write(iout,*) "WARNING WRONG SIZE OF LIP AQ BUF" + endif + write(iout,*) "bordliptop=",bordliptop + write(iout,*) "bordlipbot=",bordlipbot + write(iout,*) "bufliptop=",bufliptop + write(iout,*) "buflipbot=",buflipbot call readi(controlcard,'SYM',symetr,1) write (iout,*) "DISTCHAINMAX",distchainmax write (iout,*) "delta",delta @@ -90,7 +115,21 @@ zscfile=index(controlcard,"ZSCFILE").gt.0 with_dihed_constr = index(controlcard,"WITH_DIHED_CONSTR").gt.0 write (iout,*) "with_dihed_constr ",with_dihed_constr + with_theta_constr = index(controlcard,"WITH_THETA_CONSTR").gt.0 + write (iout,*) "with_theta_constr ",with_theta_constr call readi(controlcard,'CONSTR_DIST',constr_dist,0) + write (iout,*) "with_dihed_constr ",with_dihed_constr, + & " CONSTR_DIST",constr_dist + call readi(controlcard,'CONSTR_HOMOL',constr_homology,0) + write (iout,*) "with_homology_constr ",with_dihed_constr, + & " CONSTR_HOMOLOGY",constr_homology + refstr = index(controlcard,'REFSTR').gt.0 + pdbref = index(controlcard,'PDBREF').gt.0 + dyn_ss=(index(controlcard,'DYN_SS').gt.0) +C /06/28/2013 Adasko: dyn_ss is keyword allowing to break and create bond +C disulfide bond. Note that in conterary to dynamics this in +C CONTROLCARD. The bond are read in molread_zs.F + call flush(iout) return end c------------------------------------------------------------------------------ @@ -177,6 +216,7 @@ C call flush(iout) enddo + write (iout,*) "HOMOL_NSET",homol_nset enddo if (hamil_rep) then @@ -400,7 +440,7 @@ c------------------------------------------------------------------------------- external ilen,iroof double precision rmsdev,energia(0:max_ene),efree,eini,temp double precision prop(maxQ) - integer ntot_all(maxslice,0:maxprocs-1) + integer ntot_all(maxslice,0:maxprocs-1), maxslice_buff integer iparm,ib,iib,ir,nprop,nthr,npars double precision etot,time integer ixdrf,iret @@ -531,7 +571,13 @@ c DA scratchfile. #ifdef MPI c Check if everyone has the same number of conformations - call MPI_Allgather(stot(1),maxslice,MPI_INTEGER, + +c call MPI_ALLgather(MPI_IN_PLACE,stot(1),MPI_DATATYPE_NULL, +c & ntot_all(1,0),maxslice,MPI_INTEGER,MPI_Comm_World,IERROR) + + maxslice_buff=maxslice + + call MPI_Allgather(stot(1),maxslice_buff,MPI_INTEGER, & ntot_all(1,0),maxslice,MPI_INTEGER,MPI_Comm_World,IERROR) lerr=.false. do i=0,nprocs-1 diff --git a/source/wham/src-M/rescode.f b/source/wham/src-M/rescode.f index b516fed..dbbb459 100644 --- a/source/wham/src-M/rescode.f +++ b/source/wham/src-M/rescode.f @@ -7,7 +7,7 @@ if (itype.eq.0) then - do i=1,ntyp1 + do i=-ntyp1,ntyp1 if (ucase(nam).eq.restyp(i)) then rescode=i return @@ -16,7 +16,7 @@ else - do i=1,ntyp1 + do i=-ntyp1,ntyp1 if (nam(1:1).eq.onelet(i)) then rescode=i return diff --git a/source/wham/src-M/rmscalc.f b/source/wham/src-M/rmscalc.f index 826167f..8e0b88a 100644 --- a/source/wham/src-M/rmscalc.f +++ b/source/wham/src-M/rmscalc.f @@ -3,6 +3,7 @@ include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' include 'COMMON.IOUNITS' include 'COMMON.COMPAR' include 'COMMON.CHAIN' @@ -100,6 +101,7 @@ c------------------------------------------------------------------------- include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' include 'COMMON.CONTROL' include 'COMMON.IOUNITS' include 'COMMON.COMPAR' @@ -142,6 +144,7 @@ c------------------------------------------------------------------------- include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' include 'COMMON.IOUNITS' include 'COMMON.COMPAR' include 'COMMON.CHAIN' @@ -155,13 +158,17 @@ c------------------------------------------------------------------------- rminrms=10.0d10 rmsminsing=10d10 nperm=1 +C write (iout,*) "tu2", nres,nsup + noverlap=nres + if (nres.gt.nsup) noverlap=nsup + write (iout,*) "tu3,",noverlap do i=1,symetr nperm=nperm*i enddo do kkk=1,nperm nnsup=0 - do i=1,nres - if (itype(i).ne.21) then + do i=1,noverlap + if (itype(i).ne.ntyp1) then nnsup=nnsup+1 do j=1,3 cc(j,nnsup)=c(j,i) diff --git a/source/wham/src-M/secondary.f b/source/wham/src-M/secondary.f index 9c9bc7d..9e1c55d 100644 --- a/source/wham/src-M/secondary.f +++ b/source/wham/src-M/secondary.f @@ -3,6 +3,7 @@ include 'DIMENSIONS' include 'DIMENSIONS.ZSCOPT' include 'DIMENSIONS.COMPAR' + include 'DIMENSIONS.FREE' include 'COMMON.IOUNITS' include 'COMMON.TIME1' include 'COMMON.FRAG' diff --git a/source/wham/src-M/ssMD.F b/source/wham/src-M/ssMD.F new file mode 100644 index 0000000..f298c98 --- /dev/null +++ b/source/wham/src-M/ssMD.F @@ -0,0 +1,2167 @@ +c---------------------------------------------------------------------------- + subroutine check_energies +c implicit none + +c Includes + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.SBRIDGE' + include 'COMMON.LOCAL' + include 'COMMON.GEO' + +c External functions + double precision ran_number + external ran_number + +c Local variables + integer i,j,k,l,lmax,p,pmax + double precision rmin,rmax + double precision eij + + double precision d + double precision wi,rij,tj,pj + + +c return + + i=5 + j=14 + + d=dsc(1) + rmin=2.0D0 + rmax=12.0D0 + + lmax=10000 + pmax=1 + + do k=1,3 + c(k,i)=0.0D0 + c(k,j)=0.0D0 + c(k,nres+i)=0.0D0 + c(k,nres+j)=0.0D0 + enddo + + do l=1,lmax + +ct wi=ran_number(0.0D0,pi) +c wi=ran_number(0.0D0,pi/6.0D0) +c wi=0.0D0 +ct tj=ran_number(0.0D0,pi) +ct pj=ran_number(0.0D0,pi) +c pj=ran_number(0.0D0,pi/6.0D0) +c pj=0.0D0 + + do p=1,pmax +ct rij=ran_number(rmin,rmax) + + c(1,j)=d*sin(pj)*cos(tj) + c(2,j)=d*sin(pj)*sin(tj) + c(3,j)=d*cos(pj) + + c(3,nres+i)=-rij + + c(1,i)=d*sin(wi) + c(3,i)=-rij-d*cos(wi) + + do k=1,3 + dc(k,nres+i)=c(k,nres+i)-c(k,i) + dc_norm(k,nres+i)=dc(k,nres+i)/d + dc(k,nres+j)=c(k,nres+j)-c(k,j) + dc_norm(k,nres+j)=dc(k,nres+j)/d + enddo + + call dyn_ssbond_ene(i,j,eij) + enddo + enddo + + call exit(1) + + return + end + +C----------------------------------------------------------------------------- + + subroutine dyn_ssbond_ene(resi,resj,eij) +c implicit none + +c Includes + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' +#ifndef CLUST +#ifndef WHAM +C include 'COMMON.MD' +#endif +#endif + +c External functions + double precision h_base + external h_base + +c Input arguments + integer resi,resj + +c Output arguments + double precision eij + +c Local variables + logical havebond +c integer itypi,itypj,k,l + double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi + double precision sig0ij,ljd,sig,fac,e1,e2 + double precision dcosom1(3),dcosom2(3),ed + double precision pom1,pom2 + double precision ljA,ljB,ljXs + double precision d_ljB(1:3) + double precision ssA,ssB,ssC,ssXs + double precision ssxm,ljxm,ssm,ljm + double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3) + double precision f1,f2,h1,h2,hd1,hd2 + double precision omega,delta_inv,deltasq_inv,fac1,fac2 +c-------FIRST METHOD + double precision xm,d_xm(1:3) +c-------END FIRST METHOD +c-------SECOND METHOD +c$$$ double precision ss,d_ss(0:3),ljf,d_ljf(0:3) +c-------END SECOND METHOD + +c-------TESTING CODE + logical checkstop,transgrad + common /sschecks/ checkstop,transgrad + + integer icheck,nicheck,jcheck,njcheck + double precision echeck(-1:1),deps,ssx0,ljx0 +c-------END TESTING CODE + + + i=resi + j=resj + + itypi=itype(i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=vbld_inv(i+nres) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + xi=mod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=mod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=mod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize + if ((zi.gt.bordlipbot) + &.and.(zi.lt.bordliptop)) then +C the energy transfer exist + if (zi.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((zi-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipi=sscalelip(fracinbuf) + ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick + elseif (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick) + sslipi=sscalelip(fracinbuf) + ssgradlipi=sscagradlip(fracinbuf)/lipbufthick + else + sslipi=1.0d0 + ssgradlipi=0.0 + endif + else + sslipi=0.0d0 + ssgradlipi=0.0 + endif + itypj=itype(j) + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + if ((zj.gt.bordlipbot) + &.and.(zj.lt.bordliptop)) then +C the energy transfer exist + if (zj.lt.buflipbot) then +C what fraction I am in + fracinbuf=1.0d0- + & ((zj-bordlipbot)/lipbufthick) +C lipbufthick is thickenes of lipid buffore + sslipj=sscalelip(fracinbuf) + ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick + elseif (zj.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick) + sslipj=sscalelip(fracinbuf) + ssgradlipj=sscagradlip(fracinbuf)/lipbufthick + else + sslipj=1.0d0 + ssgradlipj=0.0 + endif + else + sslipj=0.0d0 + ssgradlipj=0.0 + endif + aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 + bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0 + xj=xj-xi + yj=yj-yi + zj=zj-zi + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + dscj_inv=vbld_inv(j+nres) + + chi1=chi(itypi,itypj) + chi2=chi(itypj,itypi) + chi12=chi1*chi2 + chip1=chip(itypi) + chip2=chip(itypj) + chip12=chip1*chip2 + alf1=alp(itypi) + alf2=alp(itypj) + alf12=0.5D0*(alf1+alf2) + + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse +c The following are set in sc_angular +c erij(1)=xj*rij +c erij(2)=yj*rij +c erij(3)=zj*rij +c om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) +c om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) +c om12=dxi*dxj+dyi*dyj+dzi*dzj + call sc_angular + rij=1.0D0/rij ! Reset this so it makes sense + + sig0ij=sigma(itypi,itypj) + sig=sig0ij*dsqrt(1.0D0/sigsq) + + ljXs=sig-sig0ij + ljA=eps1*eps2rt**2*eps3rt**2 + ljB=ljA*bb + ljA=ljA*aa + ljxm=ljXs+(-2.0D0*aa/bb)**(1.0D0/6.0D0) + + ssXs=d0cm + deltat1=1.0d0-om1 + deltat2=1.0d0+om2 + deltat12=om2-om1+2.0d0 + cosphi=om12-om1*om2 + ssA=akcm + ssB=akct*deltat12 + ssC=ss_depth + & +akth*(deltat1*deltat1+deltat2*deltat2) + & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi + ssxm=ssXs-0.5D0*ssB/ssA + +c-------TESTING CODE +c$$$c Some extra output +c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +c$$$ ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj) +c$$$ ssx0=ssB*ssB-4.0d0*ssA*ssC +c$$$ if (ssx0.gt.0.0d0) then +c$$$ ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA +c$$$ else +c$$$ ssx0=ssxm +c$$$ endif +c$$$ ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ", +c$$$ & ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12 +c$$$ return +c-------END TESTING CODE + +c-------TESTING CODE +c Stop and plot energy and derivative as a function of distance + if (checkstop) then + ssm=ssC-0.25D0*ssB*ssB/ssA + ljm=-0.25D0*ljB*bb/aa + if (ssm.lt.ljm .and. + & dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then + nicheck=1000 + njcheck=1 + deps=0.5d-7 + else + checkstop=.false. + endif + endif + if (.not.checkstop) then + nicheck=0 + njcheck=-1 + endif + + do icheck=0,nicheck + do jcheck=-1,njcheck + if (checkstop) rij=(ssxm-1.0d0)+ + & ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps +c-------END TESTING CODE + + if (rij.gt.ljxm) then + havebond=.false. + ljd=rij-ljXs + fac=(1.0D0/ljd)**expon + e1=fac*fac*aa + e2=fac*bb + eij=eps1*eps2rt*eps3rt*(e1+e2) +C write(iout,*) eij,'TU?1' + eps2der=eij*eps3rt + eps3der=eij*eps2rt + eij=eij*eps2rt*eps3rt + + sigder=-sig/sigsq + e1=e1*eps1*eps2rt**2*eps3rt**2 + ed=-expon*(e1+eij)/ljd + sigder=ed*sigder + eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 + eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 + eom12=eij*eps1_om12+eps2der*eps2rt_om12 + & -2.0D0*alf12*eps3der+sigder*sigsq_om12 + else if (rij.lt.ssxm) then + havebond=.true. + ssd=rij-ssXs + eij=ssA*ssd*ssd+ssB*ssd+ssC +C write(iout,*) 'TU?2',ssc,ssd + ed=2*akcm*ssd+akct*deltat12 + pom1=akct*ssd + pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi + eom1=-2*akth*deltat1-pom1-om2*pom2 + eom2= 2*akth*deltat2+pom1-om1*pom2 + eom12=pom2 + else + omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi + + d_ssxm(1)=0.5D0*akct/ssA + d_ssxm(2)=-d_ssxm(1) + d_ssxm(3)=0.0D0 + + d_ljxm(1)=sig0ij/sqrt(sigsq**3) + d_ljxm(2)=d_ljxm(1)*sigsq_om2 + d_ljxm(3)=d_ljxm(1)*sigsq_om12 + d_ljxm(1)=d_ljxm(1)*sigsq_om1 + +c-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + xm=0.5d0*(ssxm+ljxm) + do k=1,3 + d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k)) + enddo + if (rij.lt.xm) then + havebond=.true. + ssm=ssC-0.25D0*ssB*ssB/ssA + d_ssm(1)=0.5D0*akct*ssB/ssA + d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) + d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) + d_ssm(3)=omega + f1=(rij-xm)/(ssxm-xm) + f2=(rij-ssxm)/(xm-ssxm) + h1=h_base(f1,hd1) + h2=h_base(f2,hd2) + eij=ssm*h1+Ht*h2 +C write(iout,*) eij,'TU?3' + delta_inv=1.0d0/(xm-ssxm) + deltasq_inv=delta_inv*delta_inv + fac=ssm*hd1-Ht*hd2 + fac1=deltasq_inv*fac*(xm-rij) + fac2=deltasq_inv*fac*(rij-ssxm) + ed=delta_inv*(Ht*hd2-ssm*hd1) + eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1) + eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2) + eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3) + else + havebond=.false. + ljm=-0.25D0*ljB*bb/aa + d_ljm(1)=-0.5D0*bb/aa*ljB + d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt) + d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- + + alf12/eps3rt) + d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt) + f1=(rij-ljxm)/(xm-ljxm) + f2=(rij-xm)/(ljxm-xm) + h1=h_base(f1,hd1) + h2=h_base(f2,hd2) + eij=Ht*h1+ljm*h2 +C write(iout,*) 'TU?4',ssA + delta_inv=1.0d0/(ljxm-xm) + deltasq_inv=delta_inv*delta_inv + fac=Ht*hd1-ljm*hd2 + fac1=deltasq_inv*fac*(ljxm-rij) + fac2=deltasq_inv*fac*(rij-xm) + ed=delta_inv*(ljm*hd2-Ht*hd1) + eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1) + eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2) + eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3) + endif +c-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE + +c-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE +c$$$ ssd=rij-ssXs +c$$$ ljd=rij-ljXs +c$$$ fac1=rij-ljxm +c$$$ fac2=rij-ssxm +c$$$ +c$$$ d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt) +c$$$ d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt) +c$$$ d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt) +c$$$ +c$$$ ssm=ssC-0.25D0*ssB*ssB/ssA +c$$$ d_ssm(1)=0.5D0*akct*ssB/ssA +c$$$ d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1) +c$$$ d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1) +c$$$ d_ssm(3)=omega +c$$$ +c$$$ ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj) +c$$$ do k=1,3 +c$$$ d_ljm(k)=ljm*d_ljB(k) +c$$$ enddo +c$$$ ljm=ljm*ljB +c$$$ +c$$$ ss=ssA*ssd*ssd+ssB*ssd+ssC +c$$$ d_ss(0)=2.0d0*ssA*ssd+ssB +c$$$ d_ss(2)=akct*ssd +c$$$ d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega +c$$$ d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega +c$$$ d_ss(3)=omega +c$$$ +c$$$ ljf=bb(itypi,itypj)/aa(itypi,itypj) +c$$$ ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0) +c$$$ d_ljf(0)=ljf*2.0d0*ljB*fac1 +c$$$ do k=1,3 +c$$$ d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1- +c$$$ & 2.0d0*ljB*fac1*d_ljxm(k)) +c$$$ enddo +c$$$ ljf=ljm+ljf*ljB*fac1*fac1 +c$$$ +c$$$ f1=(rij-ljxm)/(ssxm-ljxm) +c$$$ f2=(rij-ssxm)/(ljxm-ssxm) +c$$$ h1=h_base(f1,hd1) +c$$$ h2=h_base(f2,hd2) +c$$$ eij=ss*h1+ljf*h2 +c$$$ delta_inv=1.0d0/(ljxm-ssxm) +c$$$ deltasq_inv=delta_inv*delta_inv +c$$$ fac=ljf*hd2-ss*hd1 +c$$$ ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac +c$$$ eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(1)-fac2*(d_ljxm(1))) +c$$$ eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(2)-fac2*(d_ljxm(2))) +c$$$ eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac* +c$$$ & (fac1*d_ssxm(3)-fac2*(d_ljxm(3))) +c$$$ +c$$$ havebond=.false. +c$$$ if (ed.gt.0.0d0) havebond=.true. +c-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE + + endif + write(iout,*) 'havebond',havebond + if (havebond) then +#ifndef CLUST +#ifndef WHAM +c if (dyn_ssbond_ij(i,j).eq.1.0d300) then +c write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_E_FORM",totT,t_bath,i,j +c endif +#endif +#endif + dyn_ssbond_ij(i,j)=eij + else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then + dyn_ssbond_ij(i,j)=1.0d300 +#ifndef CLUST +#ifndef WHAM +c write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_E_BREAK",totT,t_bath,i,j +#endif +#endif + endif + +c-------TESTING CODE + if (checkstop) then + if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') + & "CHECKSTOP",rij,eij,ed + echeck(jcheck)=eij + endif + enddo + if (checkstop) then + write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps + endif + enddo + if (checkstop) then + transgrad=.true. + checkstop=.false. + endif +c-------END TESTING CODE + + do k=1,3 + dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij + dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij + enddo + do k=1,3 + gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) + enddo + do k=1,3 + gvdwx(k,i)=gvdwx(k,i)-gg(k) + & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) + & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv + gvdwx(k,j)=gvdwx(k,j)+gg(k) + & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) + & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv + enddo +cgrad do k=i,j-1 +cgrad do l=1,3 +cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) +cgrad enddo +cgrad enddo + + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo + + return + end + +C----------------------------------------------------------------------------- + + double precision function h_base(x,deriv) +c A smooth function going 0->1 in range [0,1] +c It should NOT be called outside range [0,1], it will not work there. + implicit none + +c Input arguments + double precision x + +c Output arguments + double precision deriv + +c Local variables + double precision xsq + + +c Two parabolas put together. First derivative zero at extrema +c$$$ if (x.lt.0.5D0) then +c$$$ h_base=2.0D0*x*x +c$$$ deriv=4.0D0*x +c$$$ else +c$$$ deriv=1.0D0-x +c$$$ h_base=1.0D0-2.0D0*deriv*deriv +c$$$ deriv=4.0D0*deriv +c$$$ endif + +c Third degree polynomial. First derivative zero at extrema + h_base=x*x*(3.0d0-2.0d0*x) + deriv=6.0d0*x*(1.0d0-x) + +c Fifth degree polynomial. First and second derivatives zero at extrema +c$$$ xsq=x*x +c$$$ h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0) +c$$$ deriv=x-1.0d0 +c$$$ deriv=deriv*deriv +c$$$ deriv=30.0d0*xsq*deriv + + return + end + +c---------------------------------------------------------------------------- + + subroutine dyn_set_nss +c Adjust nss and other relevant variables based on dyn_ssbond_ij +c implicit none + +c Includes + include 'DIMENSIONS' +#ifdef MPI + include "mpif.h" +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' +C include 'COMMON.SETUP' +#ifndef CLUST +#ifndef WHAM +C include 'COMMON.MD' +#endif +#endif + +c Local variables + double precision emin + integer i,j,imin + integer diff,allflag(maxdim),allnss, + & allihpb(maxdim),alljhpb(maxdim), + & newnss,newihpb(maxdim),newjhpb(maxdim) + logical found + integer i_newnss(1024),displ(0:1024) + integer g_newihpb(maxdim),g_newjhpb(maxdim),g_newnss + + allnss=0 + do i=1,nres-1 + do j=i+1,nres + if (dyn_ssbond_ij(i,j).lt.1.0d300) then + allnss=allnss+1 + allflag(allnss)=0 + allihpb(allnss)=i + alljhpb(allnss)=j + endif + enddo + enddo + +cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + 1 emin=1.0d300 + do i=1,allnss + if (allflag(i).eq.0 .and. + & dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then + emin=dyn_ssbond_ij(allihpb(i),alljhpb(i)) + imin=i + endif + enddo + if (emin.lt.1.0d300) then + allflag(imin)=1 + do i=1,allnss + if (allflag(i).eq.0 .and. + & (allihpb(i).eq.allihpb(imin) .or. + & alljhpb(i).eq.allihpb(imin) .or. + & allihpb(i).eq.alljhpb(imin) .or. + & alljhpb(i).eq.alljhpb(imin))) then + allflag(i)=-1 + endif + enddo + goto 1 + endif + +cmc write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss) + + newnss=0 + do i=1,allnss + if (allflag(i).eq.1) then + newnss=newnss+1 + newihpb(newnss)=allihpb(i) + newjhpb(newnss)=alljhpb(i) + endif + enddo + +#ifdef MPI + if (nfgtasks.gt.1)then + + call MPI_Reduce(newnss,g_newnss,1, + & MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR) + call MPI_Gather(newnss,1,MPI_INTEGER, + & i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR) + displ(0)=0 + do i=1,nfgtasks-1,1 + displ(i)=i_newnss(i-1)+displ(i-1) + enddo + call MPI_Gatherv(newihpb,newnss,MPI_INTEGER, + & g_newihpb,i_newnss,displ,MPI_INTEGER, + & king,FG_COMM,IERR) + call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER, + & g_newjhpb,i_newnss,displ,MPI_INTEGER, + & king,FG_COMM,IERR) + if(fg_rank.eq.0) then +c print *,'g_newnss',g_newnss +c print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss) +c print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss) + newnss=g_newnss + do i=1,newnss + newihpb(i)=g_newihpb(i) + newjhpb(i)=g_newjhpb(i) + enddo + endif + endif +#endif + + diff=newnss-nss + +cmc write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss) + + do i=1,nss + found=.false. + do j=1,newnss + if (idssb(i).eq.newihpb(j) .and. + & jdssb(i).eq.newjhpb(j)) found=.true. + enddo +#ifndef CLUST +#ifndef WHAM +c if (.not.found.and.fg_rank.eq.0) +c & write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i) +#endif +#endif + enddo + + do i=1,newnss + found=.false. + do j=1,nss + if (newihpb(i).eq.idssb(j) .and. + & newjhpb(i).eq.jdssb(j)) found=.true. + enddo +#ifndef CLUST +#ifndef WHAM +c if (.not.found.and.fg_rank.eq.0) +c & write(iout,'(a15,f12.2,f8.1,2i5)') +c & "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i) +#endif +#endif + enddo + + nss=newnss + do i=1,nss + idssb(i)=newihpb(i) + jdssb(i)=newjhpb(i) + enddo + + return + end + +c---------------------------------------------------------------------------- + +#ifdef WHAM + subroutine read_ssHist + implicit none + +c Includes + include 'DIMENSIONS' + include "DIMENSIONS.FREE" + include 'COMMON.FREE' + +c Local variables + integer i,j + character*80 controlcard + + do i=1,dyn_nssHist + call card_concat(controlcard,.true.) + read(controlcard,*) + & dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0)) + enddo + + return + end +#endif + +c---------------------------------------------------------------------------- + + +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- +C----------------------------------------------------------------------------- + +c$$$c----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax(i_in,j_in) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c Input arguments +c$$$ integer i_in,j_in +c$$$ +c$$$c Local variables +c$$$ integer i,iretcode,nfun_sc +c$$$ logical scfail +c$$$ double precision var(maxvar),e_sc,etot +c$$$ +c$$$ +c$$$ mask_r=.true. +c$$$ do i=nnt,nct +c$$$ mask_side(i)=0 +c$$$ enddo +c$$$ mask_side(i_in)=1 +c$$$ mask_side(j_in)=1 +c$$$ +c$$$c Minimize the two selected side-chains +c$$$ call overlap_sc(scfail) ! Better not fail! +c$$$ call minimize_sc(e_sc,var,iretcode,nfun_sc) +c$$$ +c$$$ mask_r=.false. +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c------------------------------------------------------------- +c$$$ +c$$$ subroutine minimize_sc(etot_sc,iretcode,nfun) +c$$$c Minimize side-chains only, starting from geom but without modifying +c$$$c bond lengths. +c$$$c If mask_r is already set, only the selected side-chains are minimized, +c$$$c otherwise all side-chains are minimized keeping the backbone frozen. +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.MINIM' +c$$$ integer icall +c$$$ common /srutu/ icall +c$$$ +c$$$c Output arguments +c$$$ double precision etot_sc +c$$$ integer iretcode,nfun +c$$$ +c$$$c External functions/subroutines +c$$$ external func_sc,grad_sc,fdum +c$$$ +c$$$c Local variables +c$$$ integer liv,lv +c$$$ parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +c$$$ integer iv(liv) +c$$$ double precision rdum(1) +c$$$ double precision d(maxvar),v(1:lv),x(maxvar),xx(maxvar) +c$$$ integer idum(1) +c$$$ integer i,nvar_restr +c$$$ +c$$$ +c$$$cmc start_minim=.true. +c$$$ call deflt(2,iv,liv,lv,v) +c$$$* 12 means fresh start, dont call deflt +c$$$ iv(1)=12 +c$$$* max num of fun calls +c$$$ if (maxfun.eq.0) maxfun=500 +c$$$ iv(17)=maxfun +c$$$* max num of iterations +c$$$ if (maxmin.eq.0) maxmin=1000 +c$$$ iv(18)=maxmin +c$$$* controls output +c$$$ iv(19)=1 +c$$$* selects output unit +c$$$ iv(21)=0 +c$$$c iv(21)=iout ! DEBUG +c$$$c iv(21)=8 ! DEBUG +c$$$* 1 means to print out result +c$$$ iv(22)=0 +c$$$c iv(22)=1 ! DEBUG +c$$$* 1 means to print out summary stats +c$$$ iv(23)=0 +c$$$c iv(23)=1 ! DEBUG +c$$$* 1 means to print initial x and d +c$$$ iv(24)=0 +c$$$c iv(24)=1 ! DEBUG +c$$$* min val for v(radfac) default is 0.1 +c$$$ v(24)=0.1D0 +c$$$* max val for v(radfac) default is 4.0 +c$$$ v(25)=2.0D0 +c$$$c v(25)=4.0D0 +c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +c$$$* the sumsl default is 0.1 +c$$$ v(26)=0.1D0 +c$$$* false conv if (act fnctn decrease) .lt. v(34) +c$$$* the sumsl default is 100*machep +c$$$ v(34)=v(34)/100.0D0 +c$$$* absolute convergence +c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 +c$$$ v(31)=tolf +c$$$* relative convergence +c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-1 +c$$$ v(32)=rtolf +c$$$* controls initial step size +c$$$ v(35)=1.0D-1 +c$$$* large vals of d correspond to small components of step +c$$$ do i=1,nphi +c$$$ d(i)=1.0D-1 +c$$$ enddo +c$$$ do i=nphi+1,nvar +c$$$ d(i)=1.0D-1 +c$$$ enddo +c$$$ +c$$$ call geom_to_var(nvar,x) +c$$$ IF (mask_r) THEN +c$$$ do i=1,nres ! Just in case... +c$$$ mask_phi(i)=0 +c$$$ mask_theta(i)=0 +c$$$ enddo +c$$$ call x2xx(x,xx,nvar_restr) +c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, +c$$$ & iv,liv,lv,v,idum,rdum,fdum) +c$$$ call xx2x(x,xx) +c$$$ ELSE +c$$$c When minimizing ALL side-chains, etotal_sc is a little +c$$$c faster if we don't set mask_r +c$$$ do i=1,nres +c$$$ mask_phi(i)=0 +c$$$ mask_theta(i)=0 +c$$$ mask_side(i)=1 +c$$$ enddo +c$$$ call x2xx(x,xx,nvar_restr) +c$$$ call sumsl(nvar_restr,d,xx,func_sc,grad_sc, +c$$$ & iv,liv,lv,v,idum,rdum,fdum) +c$$$ call xx2x(x,xx) +c$$$ ENDIF +c$$$ call var_to_geom(nvar,x) +c$$$ call chainbuild_sc +c$$$ etot_sc=v(10) +c$$$ iretcode=iv(1) +c$$$ nfun=iv(6) +c$$$ return +c$$$ end +c$$$ +c$$$C-------------------------------------------------------------------------- +c$$$ +c$$$ subroutine chainbuild_sc +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c Local variables +c$$$ integer i +c$$$ +c$$$ +c$$$ do i=nnt,nct +c$$$ if (.not.mask_r .or. mask_side(i).eq.1) then +c$$$ call locate_side_chain(i) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C-------------------------------------------------------------------------- +c$$$ +c$$$ subroutine func_sc(n,x,nf,f,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.MINIM' +c$$$ include 'COMMON.IOUNITS' +c$$$ +c$$$c Input arguments +c$$$ integer n +c$$$ double precision x(maxvar) +c$$$ double precision ufparm +c$$$ external ufparm +c$$$ +c$$$c Input/Output arguments +c$$$ integer nf +c$$$ integer uiparm(1) +c$$$ double precision urparm(1) +c$$$ +c$$$c Output arguments +c$$$ double precision f +c$$$ +c$$$c Local variables +c$$$ double precision energia(0:n_ene) +c$$$#ifdef OSF +c$$$c Variables used to intercept NaNs +c$$$ double precision x_sum +c$$$ integer i_NAN +c$$$#endif +c$$$ +c$$$ +c$$$ nfl=nf +c$$$ icg=mod(nf,2)+1 +c$$$ +c$$$#ifdef OSF +c$$$c Intercept NaNs in the coordinates, before calling etotal_sc +c$$$ x_sum=0.D0 +c$$$ do i_NAN=1,n +c$$$ x_sum=x_sum+x(i_NAN) +c$$$ enddo +c$$$c Calculate the energy only if the coordinates are ok +c$$$ if ((.not.(x_sum.lt.0.D0)) .and. (.not.(x_sum.ge.0.D0))) then +c$$$ write(iout,*)" *** func_restr_sc : Found NaN in coordinates" +c$$$ f=1.0D+77 +c$$$ nf=0 +c$$$ else +c$$$#endif +c$$$ +c$$$ call var_to_geom_restr(n,x) +c$$$ call zerograd +c$$$ call chainbuild_sc +c$$$ call etotal_sc(energia(0)) +c$$$ f=energia(0) +c$$$ if (energia(1).eq.1.0D20 .or. energia(0).eq.1.0D99) nf=0 +c$$$ +c$$$#ifdef OSF +c$$$ endif +c$$$#endif +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c------------------------------------------------------- +c$$$ +c$$$ subroutine grad_sc(n,x,nf,g,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.MINIM' +c$$$ +c$$$c Input arguments +c$$$ integer n +c$$$ double precision x(maxvar) +c$$$ double precision ufparm +c$$$ external ufparm +c$$$ +c$$$c Input/Output arguments +c$$$ integer nf +c$$$ integer uiparm(1) +c$$$ double precision urparm(1) +c$$$ +c$$$c Output arguments +c$$$ double precision g(maxvar) +c$$$ +c$$$c Local variables +c$$$ double precision f,gphii,gthetai,galphai,gomegai +c$$$ integer ig,ind,i,j,k,igall,ij +c$$$ +c$$$ +c$$$ icg=mod(nf,2)+1 +c$$$ if (nf-nfl+1) 20,30,40 +c$$$ 20 call func_sc(n,x,nf,f,uiparm,urparm,ufparm) +c$$$c write (iout,*) 'grad 20' +c$$$ if (nf.eq.0) return +c$$$ goto 40 +c$$$ 30 call var_to_geom_restr(n,x) +c$$$ call chainbuild_sc +c$$$C +c$$$C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +c$$$C +c$$$ 40 call cartder +c$$$C +c$$$C Convert the Cartesian gradient into internal-coordinate gradient. +c$$$C +c$$$ +c$$$ ig=0 +c$$$ ind=nres-2 +c$$$ do i=2,nres-2 +c$$$ IF (mask_phi(i+2).eq.1) THEN +c$$$ gphii=0.0D0 +c$$$ do j=i+1,nres-1 +c$$$ ind=ind+1 +c$$$ do k=1,3 +c$$$ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) +c$$$ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) +c$$$ enddo +c$$$ enddo +c$$$ ig=ig+1 +c$$$ g(ig)=gphii +c$$$ ELSE +c$$$ ind=ind+nres-1-i +c$$$ ENDIF +c$$$ enddo +c$$$ +c$$$ +c$$$ ind=0 +c$$$ do i=1,nres-2 +c$$$ IF (mask_theta(i+2).eq.1) THEN +c$$$ ig=ig+1 +c$$$ gthetai=0.0D0 +c$$$ do j=i+1,nres-1 +c$$$ ind=ind+1 +c$$$ do k=1,3 +c$$$ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) +c$$$ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) +c$$$ enddo +c$$$ enddo +c$$$ g(ig)=gthetai +c$$$ ELSE +c$$$ ind=ind+nres-1-i +c$$$ ENDIF +c$$$ enddo +c$$$ +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ ig=ig+1 +c$$$ galphai=0.0D0 +c$$$ do k=1,3 +c$$$ galphai=galphai+dxds(k,i)*gradx(k,i,icg) +c$$$ enddo +c$$$ g(ig)=galphai +c$$$ ENDIF +c$$$ endif +c$$$ enddo +c$$$ +c$$$ +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ ig=ig+1 +c$$$ gomegai=0.0D0 +c$$$ do k=1,3 +c$$$ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) +c$$$ enddo +c$$$ g(ig)=gomegai +c$$$ ENDIF +c$$$ endif +c$$$ enddo +c$$$ +c$$$C +c$$$C Add the components corresponding to local energy terms. +c$$$C +c$$$ +c$$$ ig=0 +c$$$ igall=0 +c$$$ do i=4,nres +c$$$ igall=igall+1 +c$$$ if (mask_phi(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ do i=3,nres +c$$$ igall=igall+1 +c$$$ if (mask_theta(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ enddo +c$$$ +c$$$ do ij=1,2 +c$$$ do i=2,nres-1 +c$$$ if (itype(i).ne.10) then +c$$$ igall=igall+1 +c$$$ if (mask_side(i).eq.1) then +c$$$ ig=ig+1 +c$$$ g(ig)=g(ig)+gloc(igall,icg) +c$$$ endif +c$$$ endif +c$$$ enddo +c$$$ enddo +c$$$ +c$$$cd do i=1,ig +c$$$cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +c$$$cd enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine etotal_sc(energy_sc) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.FFIELD' +c$$$ +c$$$c Output arguments +c$$$ double precision energy_sc(0:n_ene) +c$$$ +c$$$c Local variables +c$$$ double precision evdw,escloc +c$$$ integer i,j +c$$$ +c$$$ +c$$$ do i=1,n_ene +c$$$ energy_sc(i)=0.0D0 +c$$$ enddo +c$$$ +c$$$ if (mask_r) then +c$$$ call egb_sc(evdw) +c$$$ call esc_sc(escloc) +c$$$ else +c$$$ call egb(evdw) +c$$$ call esc(escloc) +c$$$ endif +c$$$ +c$$$ if (evdw.eq.1.0D20) then +c$$$ energy_sc(0)=evdw +c$$$ else +c$$$ energy_sc(0)=wsc*evdw+wscloc*escloc +c$$$ endif +c$$$ energy_sc(1)=evdw +c$$$ energy_sc(12)=escloc +c$$$ +c$$$C +c$$$C Sum up the components of the Cartesian gradient. +c$$$C +c$$$ do i=1,nct +c$$$ do j=1,3 +c$$$ gradx(j,i,icg)=wsc*gvdwx(j,i) +c$$$ enddo +c$$$ enddo +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine egb_sc(evdw) +c$$$C +c$$$C This subroutine calculates the interaction energy of nonbonded side chains +c$$$C assuming the Gay-Berne potential of interaction. +c$$$C +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.CALC' +c$$$ include 'COMMON.CONTROL' +c$$$ logical lprn +c$$$ evdw=0.0D0 +c$$$ energy_dec=.false. +c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon +c$$$ evdw=0.0D0 +c$$$ lprn=.false. +c$$$c if (icall.eq.0) lprn=.false. +c$$$ ind=0 +c$$$ do i=iatsc_s,iatsc_e +c$$$ itypi=itype(i) +c$$$ itypi1=itype(i+1) +c$$$ xi=c(1,nres+i) +c$$$ yi=c(2,nres+i) +c$$$ zi=c(3,nres+i) +c$$$ dxi=dc_norm(1,nres+i) +c$$$ dyi=dc_norm(2,nres+i) +c$$$ dzi=dc_norm(3,nres+i) +c$$$c dsci_inv=dsc_inv(itypi) +c$$$ dsci_inv=vbld_inv(i+nres) +c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +c$$$C +c$$$C Calculate SC interaction energy. +c$$$C +c$$$ do iint=1,nint_gr(i) +c$$$ do j=istart(i,iint),iend(i,iint) +c$$$ IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN +c$$$ ind=ind+1 +c$$$ itypj=itype(j) +c$$$c dscj_inv=dsc_inv(itypj) +c$$$ dscj_inv=vbld_inv(j+nres) +c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c$$$c & 1.0d0/vbld(j+nres) +c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) +c$$$ sig0ij=sigma(itypi,itypj) +c$$$ chi1=chi(itypi,itypj) +c$$$ chi2=chi(itypj,itypi) +c$$$ chi12=chi1*chi2 +c$$$ chip1=chip(itypi) +c$$$ chip2=chip(itypj) +c$$$ chip12=chip1*chip2 +c$$$ alf1=alp(itypi) +c$$$ alf2=alp(itypj) +c$$$ alf12=0.5D0*(alf1+alf2) +c$$$C For diagnostics only!!! +c$$$c chi1=0.0D0 +c$$$c chi2=0.0D0 +c$$$c chi12=0.0D0 +c$$$c chip1=0.0D0 +c$$$c chip2=0.0D0 +c$$$c chip12=0.0D0 +c$$$c alf1=0.0D0 +c$$$c alf2=0.0D0 +c$$$c alf12=0.0D0 +c$$$ xj=c(1,nres+j)-xi +c$$$ yj=c(2,nres+j)-yi +c$$$ zj=c(3,nres+j)-zi +c$$$ dxj=dc_norm(1,nres+j) +c$$$ dyj=dc_norm(2,nres+j) +c$$$ dzj=dc_norm(3,nres+j) +c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi +c$$$c write (iout,*) "j",j," dc_norm", +c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) +c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c$$$ rij=dsqrt(rrij) +c$$$C Calculate angle-dependent terms of energy and contributions to their +c$$$C derivatives. +c$$$ call sc_angular +c$$$ sigsq=1.0D0/sigsq +c$$$ sig=sig0ij*dsqrt(sigsq) +c$$$ rij_shift=1.0D0/rij-sig+sig0ij +c$$$c for diagnostics; uncomment +c$$$c rij_shift=1.2*sig0ij +c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! +c$$$ if (rij_shift.le.0.0D0) then +c$$$ evdw=1.0D20 +c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$cd & restyp(itypi),i,restyp(itypj),j, +c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) +c$$$ return +c$$$ endif +c$$$ sigder=-sig*sigsq +c$$$c--------------------------------------------------------------- +c$$$ rij_shift=1.0D0/rij_shift +c$$$ fac=rij_shift**expon +c$$$ e1=fac*fac*aa(itypi,itypj) +c$$$ e2=fac*bb(itypi,itypj) +c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) +c$$$ eps2der=evdwij*eps3rt +c$$$ eps3der=evdwij*eps2rt +c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 +c$$$ evdwij=evdwij*eps2rt*eps3rt +c$$$ evdw=evdw+evdwij +c$$$ if (lprn) then +c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$ & restyp(itypi),i,restyp(itypj),j, +c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, +c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, +c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, +c$$$ & evdwij +c$$$ endif +c$$$ +c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') +c$$$ & 'evdw',i,j,evdwij +c$$$ +c$$$C Calculate gradient components. +c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 +c$$$ fac=-expon*(e1+evdwij)*rij_shift +c$$$ sigder=fac*sigder +c$$$ fac=rij*fac +c$$$c fac=0.0d0 +c$$$C Calculate the radial part of the gradient +c$$$ gg(1)=xj*fac +c$$$ gg(2)=yj*fac +c$$$ gg(3)=zj*fac +c$$$C Calculate angular part of the gradient. +c$$$ call sc_grad +c$$$ ENDIF +c$$$ enddo ! j +c$$$ enddo ! iint +c$$$ enddo ! i +c$$$ energy_dec=.false. +c$$$ return +c$$$ end +c$$$ +c$$$c----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine esc_sc(escloc) +c$$$C Calculate the local energy of a side chain and its derivatives in the +c$$$C corresponding virtual-bond valence angles THETA and the spherical angles +c$$$C ALPHA and OMEGA. +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.FFIELD' +c$$$ include 'COMMON.CONTROL' +c$$$ double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), +c$$$ & ddersc0(3),ddummy(3),xtemp(3),temp(3) +c$$$ common /sccalc/ time11,time12,time112,theti,it,nlobit +c$$$ delta=0.02d0*pi +c$$$ escloc=0.0D0 +c$$$c write (iout,'(a)') 'ESC' +c$$$ do i=loc_start,loc_end +c$$$ IF (mask_side(i).eq.1) THEN +c$$$ it=itype(i) +c$$$ if (it.eq.10) goto 1 +c$$$ nlobit=nlob(it) +c$$$c print *,'i=',i,' it=',it,' nlobit=',nlobit +c$$$c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad +c$$$ theti=theta(i+1)-pipol +c$$$ x(1)=dtan(theti) +c$$$ x(2)=alph(i) +c$$$ x(3)=omeg(i) +c$$$ +c$$$ if (x(2).gt.pi-delta) then +c$$$ xtemp(1)=x(1) +c$$$ xtemp(2)=pi-delta +c$$$ xtemp(3)=x(3) +c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) +c$$$ xtemp(2)=pi +c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) +c$$$ call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), +c$$$ & escloci,dersc(2)) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), +c$$$ & ddersc0(1),dersc(1)) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), +c$$$ & ddersc0(3),dersc(3)) +c$$$ xtemp(2)=pi-delta +c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) +c$$$ xtemp(2)=pi +c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) +c$$$ call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, +c$$$ & dersc0(2),esclocbi,dersc02) +c$$$ call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), +c$$$ & dersc12,dersc01) +c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) +c$$$ dersc0(1)=dersc01 +c$$$ dersc0(2)=dersc02 +c$$$ dersc0(3)=0.0d0 +c$$$ do k=1,3 +c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) +c$$$ enddo +c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c$$$c & esclocbi,ss,ssd +c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi +c$$$c escloci=esclocbi +c$$$c write (iout,*) escloci +c$$$ else if (x(2).lt.delta) then +c$$$ xtemp(1)=x(1) +c$$$ xtemp(2)=delta +c$$$ xtemp(3)=x(3) +c$$$ call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) +c$$$ xtemp(2)=0.0d0 +c$$$ call enesc(xtemp,escloci1,dersc1,ddummy,.false.) +c$$$ call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), +c$$$ & escloci,dersc(2)) +c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), +c$$$ & ddersc0(1),dersc(1)) +c$$$ call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), +c$$$ & ddersc0(3),dersc(3)) +c$$$ xtemp(2)=delta +c$$$ call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) +c$$$ xtemp(2)=0.0d0 +c$$$ call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) +c$$$ call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, +c$$$ & dersc0(2),esclocbi,dersc02) +c$$$ call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), +c$$$ & dersc12,dersc01) +c$$$ dersc0(1)=dersc01 +c$$$ dersc0(2)=dersc02 +c$$$ dersc0(3)=0.0d0 +c$$$ call splinthet(x(2),0.5d0*delta,ss,ssd) +c$$$ do k=1,3 +c$$$ dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) +c$$$ enddo +c$$$ dersc(2)=dersc(2)+ssd*(escloci-esclocbi) +c$$$c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, +c$$$c & esclocbi,ss,ssd +c$$$ escloci=ss*escloci+(1.0d0-ss)*esclocbi +c$$$c write (iout,*) escloci +c$$$ else +c$$$ call enesc(x,escloci,dersc,ddummy,.false.) +c$$$ endif +c$$$ +c$$$ escloc=escloc+escloci +c$$$ if (energy_dec) write (iout,'(a6,i,0pf7.3)') +c$$$ & 'escloc',i,escloci +c$$$c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc +c$$$ +c$$$ gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ +c$$$ & wscloc*dersc(1) +c$$$ gloc(ialph(i,1),icg)=wscloc*dersc(2) +c$$$ gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) +c$$$ 1 continue +c$$$ ENDIF +c$$$ enddo +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine egb_ij(i_sc,j_sc,evdw) +c$$$C +c$$$C This subroutine calculates the interaction energy of nonbonded side chains +c$$$C assuming the Gay-Berne potential of interaction. +c$$$C +c$$$ implicit real*8 (a-h,o-z) +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.NAMES' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.CALC' +c$$$ include 'COMMON.CONTROL' +c$$$ logical lprn +c$$$ evdw=0.0D0 +c$$$ energy_dec=.false. +c$$$c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon +c$$$ evdw=0.0D0 +c$$$ lprn=.false. +c$$$ ind=0 +c$$$c$$$ do i=iatsc_s,iatsc_e +c$$$ i=i_sc +c$$$ itypi=itype(i) +c$$$ itypi1=itype(i+1) +c$$$ xi=c(1,nres+i) +c$$$ yi=c(2,nres+i) +c$$$ zi=c(3,nres+i) +c$$$ dxi=dc_norm(1,nres+i) +c$$$ dyi=dc_norm(2,nres+i) +c$$$ dzi=dc_norm(3,nres+i) +c$$$c dsci_inv=dsc_inv(itypi) +c$$$ dsci_inv=vbld_inv(i+nres) +c$$$c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres) +c$$$c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi +c$$$C +c$$$C Calculate SC interaction energy. +c$$$C +c$$$c$$$ do iint=1,nint_gr(i) +c$$$c$$$ do j=istart(i,iint),iend(i,iint) +c$$$ j=j_sc +c$$$ ind=ind+1 +c$$$ itypj=itype(j) +c$$$c dscj_inv=dsc_inv(itypj) +c$$$ dscj_inv=vbld_inv(j+nres) +c$$$c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv, +c$$$c & 1.0d0/vbld(j+nres) +c$$$c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) +c$$$ sig0ij=sigma(itypi,itypj) +c$$$ chi1=chi(itypi,itypj) +c$$$ chi2=chi(itypj,itypi) +c$$$ chi12=chi1*chi2 +c$$$ chip1=chip(itypi) +c$$$ chip2=chip(itypj) +c$$$ chip12=chip1*chip2 +c$$$ alf1=alp(itypi) +c$$$ alf2=alp(itypj) +c$$$ alf12=0.5D0*(alf1+alf2) +c$$$C For diagnostics only!!! +c$$$c chi1=0.0D0 +c$$$c chi2=0.0D0 +c$$$c chi12=0.0D0 +c$$$c chip1=0.0D0 +c$$$c chip2=0.0D0 +c$$$c chip12=0.0D0 +c$$$c alf1=0.0D0 +c$$$c alf2=0.0D0 +c$$$c alf12=0.0D0 +c$$$ xj=c(1,nres+j)-xi +c$$$ yj=c(2,nres+j)-yi +c$$$ zj=c(3,nres+j)-zi +c$$$ dxj=dc_norm(1,nres+j) +c$$$ dyj=dc_norm(2,nres+j) +c$$$ dzj=dc_norm(3,nres+j) +c$$$c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi +c$$$c write (iout,*) "j",j," dc_norm", +c$$$c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) +c$$$ rrij=1.0D0/(xj*xj+yj*yj+zj*zj) +c$$$ rij=dsqrt(rrij) +c$$$C Calculate angle-dependent terms of energy and contributions to their +c$$$C derivatives. +c$$$ call sc_angular +c$$$ sigsq=1.0D0/sigsq +c$$$ sig=sig0ij*dsqrt(sigsq) +c$$$ rij_shift=1.0D0/rij-sig+sig0ij +c$$$c for diagnostics; uncomment +c$$$c rij_shift=1.2*sig0ij +c$$$C I hate to put IF's in the loops, but here don't have another choice!!!! +c$$$ if (rij_shift.le.0.0D0) then +c$$$ evdw=1.0D20 +c$$$cd write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$cd & restyp(itypi),i,restyp(itypj),j, +c$$$cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq) +c$$$ return +c$$$ endif +c$$$ sigder=-sig*sigsq +c$$$c--------------------------------------------------------------- +c$$$ rij_shift=1.0D0/rij_shift +c$$$ fac=rij_shift**expon +c$$$ e1=fac*fac*aa(itypi,itypj) +c$$$ e2=fac*bb(itypi,itypj) +c$$$ evdwij=eps1*eps2rt*eps3rt*(e1+e2) +c$$$ eps2der=evdwij*eps3rt +c$$$ eps3der=evdwij*eps2rt +c$$$c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, +c$$$c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 +c$$$ evdwij=evdwij*eps2rt*eps3rt +c$$$ evdw=evdw+evdwij +c$$$ if (lprn) then +c$$$ sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) +c$$$ epsi=bb(itypi,itypj)**2/aa(itypi,itypj) +c$$$ write (iout,'(2(a3,i3,2x),17(0pf7.3))') +c$$$ & restyp(itypi),i,restyp(itypj),j, +c$$$ & epsi,sigm,chi1,chi2,chip1,chip2, +c$$$ & eps1,eps2rt**2,eps3rt**2,sig,sig0ij, +c$$$ & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, +c$$$ & evdwij +c$$$ endif +c$$$ +c$$$ if (energy_dec) write (iout,'(a6,2i,0pf7.3)') +c$$$ & 'evdw',i,j,evdwij +c$$$ +c$$$C Calculate gradient components. +c$$$ e1=e1*eps1*eps2rt**2*eps3rt**2 +c$$$ fac=-expon*(e1+evdwij)*rij_shift +c$$$ sigder=fac*sigder +c$$$ fac=rij*fac +c$$$c fac=0.0d0 +c$$$C Calculate the radial part of the gradient +c$$$ gg(1)=xj*fac +c$$$ gg(2)=yj*fac +c$$$ gg(3)=zj*fac +c$$$C Calculate angular part of the gradient. +c$$$ call sc_grad +c$$$c$$$ enddo ! j +c$$$c$$$ enddo ! iint +c$$$c$$$ enddo ! i +c$$$ energy_dec=.false. +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine perturb_side_chain(i,angle) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.LOCAL' +c$$$ include 'COMMON.IOUNITS' +c$$$ +c$$$c External functions +c$$$ external ran_number +c$$$ double precision ran_number +c$$$ +c$$$c Input arguments +c$$$ integer i +c$$$ double precision angle ! In degrees +c$$$ +c$$$c Local variables +c$$$ integer i_sc +c$$$ double precision rad_ang,rand_v(3),length,cost,sint +c$$$ +c$$$ +c$$$ i_sc=i+nres +c$$$ rad_ang=angle*deg2rad +c$$$ +c$$$ length=0.0 +c$$$ do while (length.lt.0.01) +c$$$ rand_v(1)=ran_number(0.01D0,1.0D0) +c$$$ rand_v(2)=ran_number(0.01D0,1.0D0) +c$$$ rand_v(3)=ran_number(0.01D0,1.0D0) +c$$$ length=rand_v(1)*rand_v(1)+rand_v(2)*rand_v(2)+ +c$$$ + rand_v(3)*rand_v(3) +c$$$ length=sqrt(length) +c$$$ rand_v(1)=rand_v(1)/length +c$$$ rand_v(2)=rand_v(2)/length +c$$$ rand_v(3)=rand_v(3)/length +c$$$ cost=rand_v(1)*dc_norm(1,i_sc)+rand_v(2)*dc_norm(2,i_sc)+ +c$$$ + rand_v(3)*dc_norm(3,i_sc) +c$$$ length=1.0D0-cost*cost +c$$$ if (length.lt.0.0D0) length=0.0D0 +c$$$ length=sqrt(length) +c$$$ rand_v(1)=rand_v(1)-cost*dc_norm(1,i_sc) +c$$$ rand_v(2)=rand_v(2)-cost*dc_norm(2,i_sc) +c$$$ rand_v(3)=rand_v(3)-cost*dc_norm(3,i_sc) +c$$$ enddo +c$$$ rand_v(1)=rand_v(1)/length +c$$$ rand_v(2)=rand_v(2)/length +c$$$ rand_v(3)=rand_v(3)/length +c$$$ +c$$$ cost=dcos(rad_ang) +c$$$ sint=dsin(rad_ang) +c$$$ dc(1,i_sc)=vbld(i_sc)*(dc_norm(1,i_sc)*cost+rand_v(1)*sint) +c$$$ dc(2,i_sc)=vbld(i_sc)*(dc_norm(2,i_sc)*cost+rand_v(2)*sint) +c$$$ dc(3,i_sc)=vbld(i_sc)*(dc_norm(3,i_sc)*cost+rand_v(3)*sint) +c$$$ dc_norm(1,i_sc)=dc(1,i_sc)*vbld_inv(i_sc) +c$$$ dc_norm(2,i_sc)=dc(2,i_sc)*vbld_inv(i_sc) +c$$$ dc_norm(3,i_sc)=dc(3,i_sc)*vbld_inv(i_sc) +c$$$ c(1,i_sc)=c(1,i)+dc(1,i_sc) +c$$$ c(2,i_sc)=c(2,i)+dc(2,i_sc) +c$$$ c(3,i_sc)=c(3,i)+dc(3,i_sc) +c$$$ +c$$$ call chainbuild_cart +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c---------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax3(i_in,j_in) +c$$$ implicit none +c$$$ +c$$$c Includes +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.INTERACT' +c$$$ +c$$$c External functions +c$$$ external ran_number +c$$$ double precision ran_number +c$$$ +c$$$c Input arguments +c$$$ integer i_in,j_in +c$$$ +c$$$c Local variables +c$$$ double precision energy_sc(0:n_ene),etot +c$$$ double precision org_dc(3),org_dc_norm(3),org_c(3) +c$$$ double precision ang_pert,rand_fact,exp_fact,beta +c$$$ integer n,i_pert,i +c$$$ logical notdone +c$$$ +c$$$ +c$$$ beta=1.0D0 +c$$$ +c$$$ mask_r=.true. +c$$$ do i=nnt,nct +c$$$ mask_side(i)=0 +c$$$ enddo +c$$$ mask_side(i_in)=1 +c$$$ mask_side(j_in)=1 +c$$$ +c$$$ call etotal_sc(energy_sc) +c$$$ etot=energy_sc(0) +c$$$c write(iout,'(a,3d15.5)')" SS_MC_START ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ +c$$$ notdone=.true. +c$$$ n=0 +c$$$ do while (notdone) +c$$$ if (mod(n,2).eq.0) then +c$$$ i_pert=i_in +c$$$ else +c$$$ i_pert=j_in +c$$$ endif +c$$$ n=n+1 +c$$$ +c$$$ do i=1,3 +c$$$ org_dc(i)=dc(i,i_pert+nres) +c$$$ org_dc_norm(i)=dc_norm(i,i_pert+nres) +c$$$ org_c(i)=c(i,i_pert+nres) +c$$$ enddo +c$$$ ang_pert=ran_number(0.0D0,3.0D0) +c$$$ call perturb_side_chain(i_pert,ang_pert) +c$$$ call etotal_sc(energy_sc) +c$$$ exp_fact=exp(beta*(etot-energy_sc(0))) +c$$$ rand_fact=ran_number(0.0D0,1.0D0) +c$$$ if (rand_fact.lt.exp_fact) then +c$$$c write(iout,'(a,3d15.5)')" SS_MC_ACCEPT ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ etot=energy_sc(0) +c$$$ else +c$$$c write(iout,'(a,3d15.5)')" SS_MC_REJECT ",energy_sc(0), +c$$$c + energy_sc(1),energy_sc(12) +c$$$ do i=1,3 +c$$$ dc(i,i_pert+nres)=org_dc(i) +c$$$ dc_norm(i,i_pert+nres)=org_dc_norm(i) +c$$$ c(i,i_pert+nres)=org_c(i) +c$$$ enddo +c$$$ endif +c$$$ +c$$$ if (n.eq.10000.or.etot.lt.30.0D0) notdone=.false. +c$$$ enddo +c$$$ +c$$$ mask_r=.false. +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$c---------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_relax2(etot,iretcode,nfun,i_in,j_in) +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ integer liv,lv +c$$$ parameter (liv=60,lv=(77+maxres6*(maxres6+17)/2)) +c$$$********************************************************************* +c$$$* OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * +c$$$* the calling subprogram. * +c$$$* when d(i)=1.0, then v(35) is the length of the initial step, * +c$$$* calculated in the usual pythagorean way. * +c$$$* absolute convergence occurs when the function is within v(31) of * +c$$$* zero. unless you know the minimum value in advance, abs convg * +c$$$* is probably not useful. * +c$$$* relative convergence is when the model predicts that the function * +c$$$* will decrease by less than v(32)*abs(fun). * +c$$$********************************************************************* +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.GEO' +c$$$ include 'COMMON.MINIM' +c$$$ include 'COMMON.CHAIN' +c$$$ +c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist +c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), +c$$$ + orig_ss_dist(maxres2,maxres2) +c$$$ +c$$$ double precision etot +c$$$ integer iretcode,nfun,i_in,j_in +c$$$ +c$$$ external dist +c$$$ double precision dist +c$$$ external ss_func,fdum +c$$$ double precision ss_func,fdum +c$$$ +c$$$ integer iv(liv),uiparm(2) +c$$$ double precision v(lv),x(maxres6),d(maxres6),rdum +c$$$ integer i,j,k +c$$$ +c$$$ +c$$$ call deflt(2,iv,liv,lv,v) +c$$$* 12 means fresh start, dont call deflt +c$$$ iv(1)=12 +c$$$* max num of fun calls +c$$$ if (maxfun.eq.0) maxfun=500 +c$$$ iv(17)=maxfun +c$$$* max num of iterations +c$$$ if (maxmin.eq.0) maxmin=1000 +c$$$ iv(18)=maxmin +c$$$* controls output +c$$$ iv(19)=2 +c$$$* selects output unit +c$$$c iv(21)=iout +c$$$ iv(21)=0 +c$$$* 1 means to print out result +c$$$ iv(22)=0 +c$$$* 1 means to print out summary stats +c$$$ iv(23)=0 +c$$$* 1 means to print initial x and d +c$$$ iv(24)=0 +c$$$* min val for v(radfac) default is 0.1 +c$$$ v(24)=0.1D0 +c$$$* max val for v(radfac) default is 4.0 +c$$$ v(25)=2.0D0 +c$$$c v(25)=4.0D0 +c$$$* check false conv if (act fnctn decrease) .lt. v(26)*(exp decrease) +c$$$* the sumsl default is 0.1 +c$$$ v(26)=0.1D0 +c$$$* false conv if (act fnctn decrease) .lt. v(34) +c$$$* the sumsl default is 100*machep +c$$$ v(34)=v(34)/100.0D0 +c$$$* absolute convergence +c$$$ if (tolf.eq.0.0D0) tolf=1.0D-4 +c$$$ v(31)=tolf +c$$$ v(31)=1.0D-1 +c$$$* relative convergence +c$$$ if (rtolf.eq.0.0D0) rtolf=1.0D-4 +c$$$ v(32)=rtolf +c$$$ v(32)=1.0D-1 +c$$$* controls initial step size +c$$$ v(35)=1.0D-1 +c$$$* large vals of d correspond to small components of step +c$$$ do i=1,6*nres +c$$$ d(i)=1.0D0 +c$$$ enddo +c$$$ +c$$$ do i=0,2*nres +c$$$ do j=1,3 +c$$$ orig_ss_dc(j,i)=dc(j,i) +c$$$ enddo +c$$$ enddo +c$$$ call geom_to_var(nvar,orig_ss_var) +c$$$ +c$$$ do i=1,nres +c$$$ do j=i,nres +c$$$ orig_ss_dist(j,i)=dist(j,i) +c$$$ orig_ss_dist(j+nres,i)=dist(j+nres,i) +c$$$ orig_ss_dist(j,i+nres)=dist(j,i+nres) +c$$$ orig_ss_dist(j+nres,i+nres)=dist(j+nres,i+nres) +c$$$ enddo +c$$$ enddo +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ x(k)=dc(j,i) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ x(k)=dc(j,i+nres) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ +c$$$ uiparm(1)=i_in +c$$$ uiparm(2)=j_in +c$$$ call smsno(k,d,x,ss_func,iv,liv,lv,v,uiparm,rdum,fdum) +c$$$ etot=v(10) +c$$$ iretcode=iv(1) +c$$$ nfun=iv(6)+iv(30) +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i)=x(k) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i+nres)=x(k) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ call chainbuild_cart +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$ +c$$$ subroutine ss_func(n,x,nf,f,uiparm,urparm,ufparm) +c$$$ implicit none +c$$$ include 'DIMENSIONS' +c$$$ include 'COMMON.DERIV' +c$$$ include 'COMMON.IOUNITS' +c$$$ include 'COMMON.VAR' +c$$$ include 'COMMON.CHAIN' +c$$$ include 'COMMON.INTERACT' +c$$$ include 'COMMON.SBRIDGE' +c$$$ +c$$$ double precision orig_ss_dc,orig_ss_var,orig_ss_dist +c$$$ common /orig_ss/ orig_ss_dc(3,0:maxres2),orig_ss_var(maxvar), +c$$$ + orig_ss_dist(maxres2,maxres2) +c$$$ +c$$$ integer n +c$$$ double precision x(maxres6) +c$$$ integer nf +c$$$ double precision f +c$$$ integer uiparm(2) +c$$$ real*8 urparm(1) +c$$$ external ufparm +c$$$ double precision ufparm +c$$$ +c$$$ external dist +c$$$ double precision dist +c$$$ +c$$$ integer i,j,k,ss_i,ss_j +c$$$ double precision tempf,var(maxvar) +c$$$ +c$$$ +c$$$ ss_i=uiparm(1) +c$$$ ss_j=uiparm(2) +c$$$ f=0.0D0 +c$$$ +c$$$ k=0 +c$$$ do i=1,nres-1 +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i)=x(k) +c$$$ enddo +c$$$ enddo +c$$$ do i=2,nres-1 +c$$$ if (ialph(i,1).gt.0) then +c$$$ do j=1,3 +c$$$ k=k+1 +c$$$ dc(j,i+nres)=x(k) +c$$$ enddo +c$$$ endif +c$$$ enddo +c$$$ call chainbuild_cart +c$$$ +c$$$ call geom_to_var(nvar,var) +c$$$ +c$$$c Constraints on all angles +c$$$ do i=1,nvar +c$$$ tempf=var(i)-orig_ss_var(i) +c$$$ f=f+tempf*tempf +c$$$ enddo +c$$$ +c$$$c Constraints on all distances +c$$$ do i=1,nres-1 +c$$$ if (i.gt.1) then +c$$$ tempf=dist(i+nres,i)-orig_ss_dist(i+nres,i) +c$$$ f=f+tempf*tempf +c$$$ endif +c$$$ do j=i+1,nres +c$$$ tempf=dist(j,i)-orig_ss_dist(j,i) +c$$$ if (tempf.lt.0.0D0 .or. j.eq.i+1) f=f+tempf*tempf +c$$$ tempf=dist(j+nres,i)-orig_ss_dist(j+nres,i) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ tempf=dist(j,i+nres)-orig_ss_dist(j,i+nres) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ tempf=dist(j+nres,i+nres)-orig_ss_dist(j+nres,i+nres) +c$$$ if (tempf.lt.0.0D0) f=f+tempf*tempf +c$$$ enddo +c$$$ enddo +c$$$ +c$$$c Constraints for the relevant CYS-CYS +c$$$ tempf=dist(nres+ss_i,nres+ss_j)-8.0D0 +c$$$ f=f+tempf*tempf +c$$$CCCCCCCCCCCCCCCCC ADD SOME ANGULAR STUFF +c$$$ +c$$$c$$$ if (nf.ne.nfl) then +c$$$c$$$ write(iout,'(a,i10,2d15.5)')"IN DIST_FUNC (NF,F,DIST)",nf, +c$$$c$$$ + f,dist(5+nres,14+nres) +c$$$c$$$ endif +c$$$ +c$$$ nfl=nf +c$$$ +c$$$ return +c$$$ end +c$$$ +c$$$C----------------------------------------------------------------------------- +c$$$C----------------------------------------------------------------------------- + subroutine triple_ssbond_ene(resi,resj,resk,eij) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + include 'COMMON.VAR' + include 'COMMON.IOUNITS' + include 'COMMON.CALC' +#ifndef CLUST +#ifndef WHAM +C include 'COMMON.MD' +#endif +#endif + +c External functions + double precision h_base + external h_base + +c Input arguments + integer resi,resj,resk + +c Output arguments + double precision eij,eij1,eij2,eij3 + +c Local variables + logical havebond +c integer itypi,itypj,k,l + double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi + double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij + double precision xik,yik,zik,xjk,yjk,zjk + double precision sig0ij,ljd,sig,fac,e1,e2 + double precision dcosom1(3),dcosom2(3),ed + double precision pom1,pom2 + double precision ljA,ljB,ljXs + double precision d_ljB(1:3) + double precision ssA,ssB,ssC,ssXs + double precision ssxm,ljxm,ssm,ljm + double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3) + + i=resi + j=resj + k=resk +C write(iout,*) resi,resj,resk + itypi=itype(i) + dxi=dc_norm(1,nres+i) + dyi=dc_norm(2,nres+i) + dzi=dc_norm(3,nres+i) + dsci_inv=vbld_inv(i+nres) + xi=c(1,nres+i) + yi=c(2,nres+i) + zi=c(3,nres+i) + + itypj=itype(j) + xj=c(1,nres+j) + yj=c(2,nres+j) + zj=c(3,nres+j) + + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + dscj_inv=vbld_inv(j+nres) + itypk=itype(k) + xk=c(1,nres+k) + yk=c(2,nres+k) + zk=c(3,nres+k) + + dxk=dc_norm(1,nres+k) + dyk=dc_norm(2,nres+k) + dzk=dc_norm(3,nres+k) + dscj_inv=vbld_inv(k+nres) + xij=xj-xi + xik=xk-xi + xjk=xk-xj + yij=yj-yi + yik=yk-yi + yjk=yk-yj + zij=zj-zi + zik=zk-zi + zjk=zk-zj + rrij=(xij*xij+yij*yij+zij*zij) + rij=dsqrt(rrij) ! sc_angular needs rij to really be the inverse + rrik=(xik*xik+yik*yik+zik*zik) + rik=dsqrt(rrik) + rrjk=(xjk*xjk+yjk*yjk+zjk*zjk) + rjk=dsqrt(rrjk) +C there are three combination of distances for each trisulfide bonds +C The first case the ith atom is the center +C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first +C distance y is second distance the a,b,c,d are parameters derived for +C this problem d parameter was set as a penalty currenlty set to 1. + eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**2+ctriss) +C second case jth atom is center + eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**2+ctriss) +C the third case kth atom is the center + eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**2+ctriss) +C eij2=0.0 +C eij3=0.0 +C eij1=0.0 + eij=eij1+eij2+eij3 +C write(iout,*)i,j,k,eij +C The energy penalty calculated now time for the gradient part +C derivative over rij + fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+2.0*btriss*(rij+rik)) + &-eij2**2/dtriss*(2.0*atriss*(rij-rjk)+2.0*btriss*(rij+rjk)) + gg(1)=xij*fac/rij + gg(2)=yij*fac/rij + gg(3)=zij*fac/rij + do m=1,3 + gvdwx(m,i)=gvdwx(m,i)-gg(m) + gvdwx(m,j)=gvdwx(m,j)+gg(m) + enddo + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,j)=gvdwc(l,j)+gg(l) + enddo +C now derivative over rik + fac=-eij1**2/dtriss*(-2.0*atriss*(rij-rik)+2.0*btriss*(rij+rik)) + &-eij3**2/dtriss*(2.0*atriss*(rik-rjk)+2.0*btriss*(rik+rjk)) + gg(1)=xik*fac/rik + gg(2)=yik*fac/rik + gg(3)=zik*fac/rik + do m=1,3 + gvdwx(m,i)=gvdwx(m,i)-gg(m) + gvdwx(m,k)=gvdwx(m,k)+gg(m) + enddo + do l=1,3 + gvdwc(l,i)=gvdwc(l,i)-gg(l) + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo +C now derivative over rjk + fac=-eij2**2/dtriss*(-2.0*atriss*(rij-rjk)+2.0*btriss*(rij+rjk))- + &eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+2.0*btriss*(rik+rjk)) + gg(1)=xjk*fac/rjk + gg(2)=yjk*fac/rjk + gg(3)=zjk*fac/rjk + do m=1,3 + gvdwx(m,j)=gvdwx(m,j)-gg(m) + gvdwx(m,k)=gvdwx(m,k)+gg(m) + enddo + do l=1,3 + gvdwc(l,j)=gvdwc(l,j)-gg(l) + gvdwc(l,k)=gvdwc(l,k)+gg(l) + enddo + return + end diff --git a/source/wham/src-M/store_parm.F b/source/wham/src-M/store_parm.F index 0811726..f44b6f4 100644 --- a/source/wham/src-M/store_parm.F +++ b/source/wham/src-M/store_parm.F @@ -19,7 +19,7 @@ C include 'COMMON.SCROT' include 'COMMON.SCCOR' include 'COMMON.ALLPARM' - integer i,j,k,l,m,mm,iparm + integer i,j,k,l,m,mm,iparm,ichir1,ichir2,iblock,iii c Store weights ww_all(1,iparm)=wsc @@ -40,6 +40,7 @@ c Store weights ww_all(16,iparm)=wvdwpp ww_all(17,iparm)=wbond ww_all(19,iparm)=wsccor + ww_all(22,iparm)=wliptran c Store bond parameters vbldp0_all(iparm)=vbldp0 akp_all(iparm)=akp @@ -53,11 +54,15 @@ c Store bond parameters enddo c Store bond angle parameters #ifdef CRYST_THETA - do i=1,ntyp + do i=-ntyp,ntyp a0thet_all(i,iparm)=a0thet(i) + do ichir1=-1,1 + do ichir2=-1,1 do j=1,2 - athet_all(j,i,iparm)=athet(j,i) - bthet_all(j,i,iparm)=bthet(j,i) + athet_all(j,i,ichir1,ichir2,iparm)=athet(j,i,ichir1,ichir2) + bthet_all(j,i,ichir1,ichir2,iparm)=bthet(j,i,ichir1,ichir2) + enddo + enddo enddo do j=0,3 polthet_all(j,i,iparm)=polthet(j,i) @@ -77,42 +82,60 @@ c Store bond angle parameters nsingle_all(iparm)=nsingle ndouble_all(iparm)=ndouble nntheterm_all(iparm)=nntheterm - do i=1,ntyp1 + do i=-ntyp,ntyp ithetyp_all(i,iparm)=ithetyp(i) enddo - do i=1,maxthetyp1 - do j=1,maxthetyp1 - do k=1,maxthetyp1 - aa0thet_all(i,j,k,iparm)=aa0thet(i,j,k) + do iblock=1,2 + do i=-maxthetyp1,maxthetyp1 + do j=-maxthetyp1,maxthetyp1 + do k=-maxthetyp1,maxthetyp1 + aa0thet_all(i,j,k,iblock,iparm)=aa0thet(i,j,k,iblock) do l=1,ntheterm - aathet_all(l,i,j,k,iparm)=aathet(l,i,j,k) + aathet_all(l,i,j,k,iblock,iparm)=aathet(l,i,j,k,iblock) enddo do l=1,ntheterm2 do m=1,nsingle - bbthet_all(m,l,i,j,k,iparm)=bbthet(m,l,i,j,k) - ccthet_all(m,l,i,j,k,iparm)=ccthet(m,l,i,j,k) - ddthet_all(m,l,i,j,k,iparm)=ddthet(m,l,i,j,k) - eethet_all(m,l,i,j,k,iparm)=eethet(m,l,i,j,k) + bbthet_all(m,l,i,j,k,iblock,iparm)= + & bbthet(m,l,i,j,k,iblock) + ccthet_all(m,l,i,j,k,iblock,iparm)= + &ccthet(m,l,i,j,k,iblock) + ddthet_all(m,l,i,j,k,iblock,iparm)= + &ddthet(m,l,i,j,k,iblock) + eethet_all(m,l,i,j,k,iblock,iparm)= + &eethet(m,l,i,j,k,iblock) enddo enddo do l=1,ntheterm3 do m=1,ndouble do mm=1,ndouble - ffthet_all(mm,m,l,i,j,k,iparm)=ffthet(mm,m,l,i,j,k) - ggthet_all(mm,m,l,i,j,k,iparm)=ggthet(mm,m,l,i,j,k) + if (iblock.eq.1) then + ffthet_all1(mm,m,l,i,j,k,iparm)= + & ffthet(mm,m,l,i,j,k,iblock) + ggthet_all1(mm,m,l,i,j,k,iparm)= + &ggthet(mm,m,l,i,j,k,iblock) + else + ffthet_all2(mm,m,l,i,j,k,iparm)= + & ffthet(mm,m,l,i,j,k,iblock) + ggthet_all2(mm,m,l,i,j,k,iparm)= + &ggthet(mm,m,l,i,j,k,iblock) + endif enddo enddo enddo enddo enddo enddo + enddo #endif #ifdef CRYST_SC c Store the sidechain rotamer parameters - do i=1,ntyp - nlob_all(i,iparm)=nlob(i) - do j=1,nlob(i) - bsc_all(j,i,iparm)=bsc(j,i) + do i=-ntyp,ntyp + iii=iabs(i) +cc write (iout,*) i,"storeparm1" + if (i.eq.0) cycle + nlob_all(iii,iparm)=nlob(iii) + do j=1,nlob(iii) + bsc_all(j,iii,iparm)=bsc(j,iii) do k=1,3 censc_all(k,j,i,iparm)=censc(k,j,i) enddo @@ -131,44 +154,48 @@ c Store the sidechain rotamer parameters enddo #endif c Store the torsional parameters - do i=1,ntortyp - do j=1,ntortyp - v0_all(i,j,iparm)=v0(i,j) - nterm_all(i,j,iparm)=nterm(i,j) - nlor_all(i,j,iparm)=nlor(i,j) - do k=1,nterm(i,j) - v1_all(k,i,j,iparm)=v1(k,i,j) - v2_all(k,i,j,iparm)=v2(i,i,j) + do iblock=1,2 + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + v0_all(i,j,iblock,iparm)=v0(i,j,iblock) + nterm_all(i,j,iblock,iparm)=nterm(i,j,iblock) + nlor_all(i,j,iblock,iparm)=nlor(i,j,iblock) + do k=1,nterm(i,j,iblock) + v1_all(k,i,j,iblock,iparm)=v1(k,i,j,iblock) + v2_all(k,i,j,iblock,iparm)=v2(k,i,j,iblock) enddo - do k=1,nlor(i,j) + do k=1,nlor(i,j,iblock) vlor1_all(k,i,j,iparm)=vlor1(k,i,j) vlor2_all(k,i,j,iparm)=vlor2(k,i,j) vlor3_all(k,i,j,iparm)=vlor3(k,i,j) enddo enddo + enddo enddo c Store the double torsional parameters - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - ntermd1_all(i,j,k,iparm)=ntermd_1(i,j,k) - ntermd2_all(i,j,k,iparm)=ntermd_2(i,j,k) - do l=1,ntermd_1(i,j,k) - v1c_all(1,l,i,j,k,iparm)=v1c(1,l,i,j,k) - v1c_all(2,l,i,j,k,iparm)=v1c(2,l,i,j,k) - v2c_all(1,l,i,j,k,iparm)=v2c(1,l,i,j,k) - v2c_all(2,l,i,j,k,iparm)=v2c(2,l,i,j,k) + do iblock=1,2 + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 + ntermd1_all(i,j,k,iblock,iparm)=ntermd_1(i,j,k,iblock) + ntermd2_all(i,j,k,iblock,iparm)=ntermd_2(i,j,k,iblock) + do l=1,ntermd_1(i,j,k,iblock) + v1c_all(1,l,i,j,k,iblock,iparm)=v1c(1,l,i,j,k,iblock) + v1c_all(2,l,i,j,k,iblock,iparm)=v1c(2,l,i,j,k,iblock) + v2c_all(1,l,i,j,k,iblock,iparm)=v2c(1,l,i,j,k,iblock) + v2c_all(2,l,i,j,k,iblock,iparm)=v2c(2,l,i,j,k,iblock) enddo - do l=1,ntermd_2(i,j,k) - do m=1,ntermd_2(i,j,k) - v2s_all(l,m,i,j,k,iparm)=v2s(l,m,i,j,k) + do l=1,ntermd_2(i,j,k,iblock) + do m=1,ntermd_2(i,j,k,iblock) + v2s_all(l,m,i,j,k,iblock,iparm)=v2s(l,m,i,j,k,iblock) enddo enddo enddo enddo enddo + enddo c Store parameters of the cumulants - do i=1,nloctyp + do i=-nloctyp,nloctyp do j=1,2 b1_all(j,i,iparm)=b1(j,i) b1tilde_all(j,i,iparm)=b1tilde(j,i) @@ -196,13 +223,16 @@ c Store the parameters of electrostatic interactions c Store sidechain parameters do i=1,ntyp do j=1,ntyp - aa_all(j,i,iparm)=aa(j,i) - bb_all(j,i,iparm)=bb(j,i) + aa_aq_all(j,i,iparm)=aa_aq(j,i) + bb_aq_all(j,i,iparm)=bb_aq(j,i) + aa_lip_all(j,i,iparm)=aa_lip(j,i) + bb_lip_all(j,i,iparm)=bb_lip(j,i) r0_all(j,i,iparm)=r0(j,i) sigma_all(j,i,iparm)=sigma(j,i) chi_all(j,i,iparm)=chi(j,i) augm_all(j,i,iparm)=augm(j,i) eps_all(j,i,iparm)=eps(j,i) + epslip_all(j,i,iparm)=epslip(j,i) enddo enddo do i=1,ntyp @@ -264,7 +294,7 @@ C include 'COMMON.SCROT' include 'COMMON.SCCOR' include 'COMMON.ALLPARM' - integer i,j,k,l,m,mm,iparm + integer i,j,k,l,m,mm,iparm,ichir1,ichir2,iblock,iii c Restore weights wsc=ww_all(1,iparm) @@ -285,6 +315,7 @@ c Restore weights wvdwpp=ww_all(16,iparm) wbond=ww_all(17,iparm) wsccor=ww_all(19,iparm) + wliptran=ww_all(22,iparm) c Restore bond parameters vbldp0=vbldp0_all(iparm) akp=akp_all(iparm) @@ -298,11 +329,15 @@ c Restore bond parameters enddo c Restore bond angle parameters #ifdef CRYST_THETA - do i=1,ntyp + do i=-ntyp,ntyp a0thet(i)=a0thet_all(i,iparm) + do ichir1=-1,1 + do ichir2=-1,1 do j=1,2 - athet(j,i)=athet_all(j,i,iparm) - bthet(j,i)=bthet_all(j,i,iparm) + athet(j,i,ichir1,ichir2)=athet_all(j,i,ichir1,ichir2,iparm) + bthet(j,i,ichir1,ichir2)=bthet_all(j,i,ichir1,ichir2,iparm) + enddo + enddo enddo do j=0,3 polthet(j,i)=polthet_all(j,i,iparm) @@ -322,42 +357,59 @@ c Restore bond angle parameters nsingle=nsingle_all(iparm) ndouble=ndouble_all(iparm) nntheterm=nntheterm_all(iparm) - do i=1,ntyp1 + do i=-ntyp,ntyp ithetyp(i)=ithetyp_all(i,iparm) enddo - do i=1,maxthetyp1 - do j=1,maxthetyp1 - do k=1,maxthetyp1 - aa0thet(i,j,k)=aa0thet_all(i,j,k,iparm) + do iblock=1,2 + do i=-maxthetyp1,maxthetyp1 + do j=-maxthetyp1,maxthetyp1 + do k=-maxthetyp1,maxthetyp1 + aa0thet(i,j,k,iblock)=aa0thet_all(i,j,k,iblock,iparm) do l=1,ntheterm - aathet(l,i,j,k)=aathet_all(l,i,j,k,iparm) + aathet(l,i,j,k,iblock)=aathet_all(l,i,j,k,iblock,iparm) enddo do l=1,ntheterm2 do m=1,nsingle - bbthet(m,l,i,j,k)=bbthet_all(m,l,i,j,k,iparm) - ccthet(m,l,i,j,k)=ccthet_all(m,l,i,j,k,iparm) - ddthet(m,l,i,j,k)=ddthet_all(m,l,i,j,k,iparm) - eethet(m,l,i,j,k)=eethet_all(m,l,i,j,k,iparm) + bbthet(m,l,i,j,k,iblock)= + &bbthet_all(m,l,i,j,k,iblock,iparm) + ccthet(m,l,i,j,k,iblock)= + &ccthet_all(m,l,i,j,k,iblock,iparm) + ddthet(m,l,i,j,k,iblock)= + &ddthet_all(m,l,i,j,k,iblock,iparm) + eethet(m,l,i,j,k,iblock)= + &eethet_all(m,l,i,j,k,iblock,iparm) enddo enddo do l=1,ntheterm3 do m=1,ndouble do mm=1,ndouble - ffthet(mm,m,l,i,j,k)=ffthet_all(mm,m,l,i,j,k,iparm) - ggthet(mm,m,l,i,j,k)=ggthet_all(mm,m,l,i,j,k,iparm) + if (iblock.eq.1) then + ffthet(mm,m,l,i,j,k,iblock)= + &ffthet_all1(mm,m,l,i,j,k,iparm) + ggthet(mm,m,l,i,j,k,iblock)= + &ggthet_all1(mm,m,l,i,j,k,iparm) + else + ffthet(mm,m,l,i,j,k,iblock)= + &ffthet_all2(mm,m,l,i,j,k,iparm) + ggthet(mm,m,l,i,j,k,iblock)= + &ggthet_all2(mm,m,l,i,j,k,iparm) + endif enddo enddo enddo enddo enddo enddo + enddo #endif c Restore the sidechain rotamer parameters #ifdef CRYST_SC - do i=1,ntyp - nlob(i)=nlob_all(i,iparm) - do j=1,nlob(i) - bsc(j,i)=bsc_all(j,i,iparm) + do i=-ntyp,ntyp + if (i.eq.0) cycle + iii=iabs(i) + nlob(iii)=nlob_all(iii,iparm) + do j=1,nlob(iii) + bsc(j,iii)=bsc_all(j,iii,iparm) do k=1,3 censc(k,j,i)=censc_all(k,j,i,iparm) enddo @@ -376,44 +428,48 @@ c Restore the sidechain rotamer parameters enddo #endif c Restore the torsional parameters - do i=1,ntortyp - do j=1,ntortyp - v0(i,j)=v0_all(i,j,iparm) - nterm(i,j)=nterm_all(i,j,iparm) - nlor(i,j)=nlor_all(i,j,iparm) - do k=1,nterm(i,j) - v1(k,i,j)=v1_all(k,i,j,iparm) - v2(i,i,j)=v2_all(k,i,j,iparm) + do iblock=1,2 + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + v0(i,j,iblock)=v0_all(i,j,iblock,iparm) + nterm(i,j,iblock)=nterm_all(i,j,iblock,iparm) + nlor(i,j,iblock)=nlor_all(i,j,iblock,iparm) + do k=1,nterm(i,j,iblock) + v1(k,i,j,iblock)=v1_all(k,i,j,iblock,iparm) + v2(k,i,j,iblock)=v2_all(k,i,j,iblock,iparm) enddo - do k=1,nlor(i,j) + do k=1,nlor(i,j,iblock) vlor1(k,i,j)=vlor1_all(k,i,j,iparm) vlor2(k,i,j)=vlor2_all(k,i,j,iparm) vlor3(k,i,j)=vlor3_all(k,i,j,iparm) enddo enddo enddo + enddo c Restore the double torsional parameters - do i=1,ntortyp - do j=1,ntortyp - do k=1,ntortyp - ntermd_1(i,j,k)=ntermd1_all(i,j,k,iparm) - ntermd_2(i,j,k)=ntermd2_all(i,j,k,iparm) - do l=1,ntermd_1(i,j,k) - v1c(1,l,i,j,k)=v1c_all(1,l,i,j,k,iparm) - v1c(2,l,i,j,k)=v1c_all(2,l,i,j,k,iparm) - v2c(1,l,i,j,k)=v2c_all(1,l,i,j,k,iparm) - v2c(2,l,i,j,k)=v2c_all(2,l,i,j,k,iparm) + do iblock=1,2 + do i=-ntortyp+1,ntortyp-1 + do j=-ntortyp+1,ntortyp-1 + do k=-ntortyp+1,ntortyp-1 + ntermd_1(i,j,k,iblock)=ntermd1_all(i,j,k,iblock,iparm) + ntermd_2(i,j,k,iblock)=ntermd2_all(i,j,k,iblock,iparm) + do l=1,ntermd_1(i,j,k,iblock) + v1c(1,l,i,j,k,iblock)=v1c_all(1,l,i,j,k,iblock,iparm) + v1c(2,l,i,j,k,iblock)=v1c_all(2,l,i,j,k,iblock,iparm) + v2c(1,l,i,j,k,iblock)=v2c_all(1,l,i,j,k,iblock,iparm) + v2c(2,l,i,j,k,iblock)=v2c_all(2,l,i,j,k,iblock,iparm) enddo - do l=1,ntermd_2(i,j,k) - do m=1,ntermd_2(i,j,k) - v2s(l,m,i,j,k)=v2s_all(l,m,i,j,k,iparm) + do l=1,ntermd_2(i,j,k,iblock) + do m=1,ntermd_2(i,j,k,iblock) + v2s(l,m,i,j,k,iblock)=v2s_all(l,m,i,j,k,iblock,iparm) enddo enddo enddo enddo enddo + enddo c Restore parameters of the cumulants - do i=1,nloctyp + do i=-nloctyp,nloctyp do j=1,2 b1(j,i)=b1_all(j,i,iparm) b1tilde(j,i)=b1tilde_all(j,i,iparm) @@ -441,13 +497,16 @@ c Restore the parameters of electrostatic interactions c Restore sidechain parameters do i=1,ntyp do j=1,ntyp - aa(j,i)=aa_all(j,i,iparm) - bb(j,i)=bb_all(j,i,iparm) + aa_aq(j,i)=aa_aq_all(j,i,iparm) + bb_aq(j,i)=bb_aq_all(j,i,iparm) + aa_lip(j,i)=aa_lip_all(j,i,iparm) + bb_lip(j,i)=bb_lip_all(j,i,iparm) r0(j,i)=r0_all(j,i,iparm) sigma(j,i)=sigma_all(j,i,iparm) chi(j,i)=chi_all(j,i,iparm) augm(j,i)=augm_all(j,i,iparm) eps(j,i)=eps_all(j,i,iparm) + epslip(j,i)=epslip_all(j,i,iparm) enddo enddo do i=1,ntyp diff --git a/source/wham/src-M/wham_calc1.F b/source/wham/src-M/wham_calc1.F index 15d6716..718bca4 100644 --- a/source/wham/src-M/wham_calc1.F +++ b/source/wham/src-M/wham_calc1.F @@ -50,7 +50,8 @@ c parameter (MaxHdim=200000) double precision energia(0:max_ene) #ifdef MPI integer tmax_t,upindE_p - double precision fi_p(MaxR,MaxT_h,Max_Parm) + double precision fi_p(MaxR,MaxT_h,Max_Parm), + & fi_p_min(MaxR,MaxT_h,Max_Parm) double precision sumW_p(0:nGridT,Max_Parm), & sumE_p(0:nGridT,Max_Parm),sumEsq_p(0:nGridT,Max_Parm), & sumQ_p(MaxQ1,0:nGridT,Max_Parm), @@ -62,7 +63,8 @@ c parameter (MaxHdim=200000) & hfin_ent_p(0:MaxHdim),histE_p(0:maxindE),sumH, & hrmsrgy_p(0:MaxBinRgy,0:MaxBinRms,maxT_h) double precision rgymin_t,rmsmin_t,rgymax_t,rmsmax_t - double precision potEmin_t,entmin_p,entmax_p + double precision potEmin_t,entmin_p,entmax_p, + & potEmin_t_all(maxT_h,Max_Parm) integer histent_p(0:2000) logical lprint /.true./ #endif @@ -74,17 +76,20 @@ c parameter (MaxHdim=200000) & sumEprim(0:NGridT,Max_Parm),sumEbis(0:NGridT,Max_Parm),betaT, & weight,econstr double precision fi(MaxR,maxT_h,Max_Parm), + & fi_min(MaxR,maxT_h,Max_Parm), & dd,dd1,dd2,hh,dmin,denom,finorm,avefi,pom, & hfin(0:MaxHdim,maxT_h),histE(0:maxindE), & hrmsrgy(0:MaxBinRgy,0:MaxBinRms,maxT_h), - & potEmin,ent, - & hfin_ent(0:MaxHdim),vmax,aux + & potEmin,ent,potEmin_all(maxT_h,Max_Parm),potEmin_min, + & hfin_ent(0:MaxHdim),vmax,aux,entfac_min double precision fT(6),fTprim(6),fTbis(6),quot,quotl1,quotl,kfacl, & eprim,ebis,temper,kfac/2.4d0/,T0/300.0d0/,startGridT/200.0d0/, & eplus,eminus,logfac,tanhT,tt double precision etot,evdw,evdw_t,evdw2,ees,evdw1,ebe,etors, & escloc,ehpb,ecorr,ecorr5,ecorr6,eello_turn4,eello_turn3, - & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor + & eturn6,eel_loc,edihcnstr,etors_d,estr,evdw2_14,esccor, + & ehomology_constr + integer ind_point(maxpoint),upindE,indE character*16 plik @@ -94,7 +99,6 @@ c parameter (MaxHdim=200000) character*128 nazwa integer ilen external ilen - write(licz2,'(bz,i2.2)') islice nbin1 = 1.0d0/delta write (iout,'(//80(1h-)/"Solving WHAM equations for slice", @@ -105,6 +109,11 @@ c parameter (MaxHdim=200000) dmin=0.0d0 tmax=0 potEmin=1.0d10 + do i=1,nParmset + do j=1,nT_h(i) + potEmin_all(j,i)=1.0d10 + enddo + enddo rgymin=1.0d10 rmsmin=1.0d10 rgymax=0.0d0 @@ -112,14 +121,15 @@ c parameter (MaxHdim=200000) do t=0,MaxN htot(t)=0 enddo +C#define DEBUG #ifdef MPI do i=1,scount(me1) #else do i=1,ntot(islice) #endif - do j=1,nParmSet - if (potE(i,j).le.potEmin) potEmin=potE(i,j) - enddo +C do j=1,nParmSet +C if (potE(i,j).le.potEmin) potEmin=potE(i,j) +C enddo if (q(nQ+1,i).lt.rmsmin) rmsmin=q(nQ+1,i) if (q(nQ+1,i).gt.rmsmax) rmsmax=q(nQ+1,i) if (q(nQ+2,i).lt.rgymin) rgymin=q(nQ+2,i) @@ -184,8 +194,8 @@ c & ind_point(i) call MPI_AllReduce(tmax,tmax_t,1,MPI_INTEGER,MPI_MAX, & WHAM_COMM,IERROR) tmax=tmax_t - call MPI_AllReduce(potEmin,potEmin_t,1,MPI_DOUBLE_PRECISION, - & MPI_MIN,WHAM_COMM,IERROR) +C call MPI_AllReduce(potEmin,potEmin_t,1,MPI_DOUBLE_PRECISION, +C & MPI_MIN,WHAM_COMM,IERROR) call MPI_AllReduce(rmsmin,rmsmin_t,1,MPI_DOUBLE_PRECISION, & MPI_MIN,WHAM_COMM,IERROR) call MPI_AllReduce(rmsmax,rmsmax_t,1,MPI_DOUBLE_PRECISION, @@ -194,7 +204,8 @@ c & ind_point(i) & MPI_MIN,WHAM_COMM,IERROR) call MPI_AllReduce(rgymax,rgymax_t,1,MPI_DOUBLE_PRECISION, & MPI_MAX,WHAM_COMM,IERROR) - potEmin=potEmin_t/2 +C potEmin=potEmin_t/2 + rgymin=rgymin_t rgymax=rgymax_t rmsmin=rmsmin_t @@ -227,7 +238,7 @@ c write (9,'(3i5,f10.5)') i,(iparm,potE(i,iparm),iparm=1,nParmSet) do iparm=1,nParmSet #ifdef DEBUG write (iout,'(2i5,21f8.2)') i,iparm, - & (enetb(k,i,iparm),k=1,21) + & (enetb(k,i,iparm),k=1,22) #endif call restore_parm(iparm) #ifdef DEBUG @@ -312,6 +323,7 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft estr=enetb(18,i,iparm) esccor=enetb(19,i,iparm) edihcnstr=enetb(20,i,iparm) + ehomology_constr=enetb(22,i,iparm) #ifdef DEBUG write (iout,'(3i5,6f5.2,14f12.3)') i,ib,iparm,(ft(l),l=1,6), & evdw+evdw_t,evdw2,ees,evdw1,ecorr,eel_loc,estr,ebe,escloc, @@ -353,6 +365,24 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft call enerprint(energia(0),fT) endif #endif +#ifdef DEBUG + write (iout,*) "homol_nset",homol_nset,nR(ib,iparm) +#endif + if (homol_nset.gt.1) then + + do kk=1,nR(ib,iparm) + Econstr=waga_homology(kk)*ehomology_constr + v(i,kk,ib,iparm)= + & -beta_h(ib,iparm)*(etot+Econstr) +#ifdef DEBUG + write (iout,'(4i5,4e15.5)') i,kk,ib,iparm, + & etot,Econstr,v(i,kk,ib,iparm) +#endif + enddo ! kk + + else + + etot=etot+ehomology_constr do kk=1,nR(ib,iparm) Econstr=0.0d0 do j=1,nQ @@ -361,12 +391,14 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft & *(dd-q0(j,kk,ib,iparm))**2 enddo v(i,kk,ib,iparm)= - & -beta_h(ib,iparm)*(etot-potEmin+Econstr) + & -beta_h(ib,iparm)*(etot+Econstr) #ifdef DEBUG write (iout,'(4i5,4e15.5)') i,kk,ib,iparm, & etot,potEmin,etot-potEmin,v(i,kk,ib,iparm) #endif enddo ! kk + + endif enddo ! ib enddo ! iparm enddo ! i @@ -377,6 +409,7 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft ! Compute new free-energy values corresponding to the righ-hand side of the ! equation and their derivatives. write (iout,*) "------------------------fi" + entfac_min=1.0d10 #ifdef MPI do t=1,scount(me1) #else @@ -402,10 +435,52 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft enddo enddo entfac(t)=-dlog(denom)-vmax + if (entfac(t).lt.entfac_min) entfac_min=entfac(t) #ifdef DEBUG write (iout,*) t,"vmax",vmax," denom",denom,"entfac",entfac(t) #endif enddo + + do iparm=1,nParmSet + do iib=1,nT_h(iparm) + do ii=1,nR(iib,iparm) +#ifdef MPI + fi_p_min(ii,iib,iparm)=-1.0d10 + do t=1,scount(me) + aux=v(t,ii,iib,iparm)+entfac(t) + if (aux.gt.fi_p_min(ii,iib,iparm)) + & fi_p_min(ii,iib,iparm)=aux + enddo +#else + do t=1,ntot(islice) + aux=v(t,ii,iib,iparm)+entfac(t) + if (aux.gt.fi_min(ii,iib,iparm)) + & fi_min(ii,iib,iparm)=aux + enddo +#endif + enddo ! ii + enddo ! iib + enddo ! iparm +#ifdef MPI +#ifdef DEBUG + write (iout,*) "fi_min before AllReduce" + do i=1,nParmSet + do j=1,nT_h(i) + write (iout,*) (i,j,k,fi_p_min(k,j,i),k=1,nR(j,i)) + enddo + enddo +#endif + call MPI_AllReduce(fi_p_min,fi_min,MaxR*MaxT_h*nParmSet, + & MPI_DOUBLE_PRECISION,MPI_MAX,WHAM_COMM,IERROR) +#ifdef DEBUG + write (iout,*) "fi_min after AllReduce" + do i=1,nParmSet + do j=1,nT_h(i) + write (iout,*) (i,j,k,fi_min(k,j,i),k=1,nR(j,i)) + enddo + enddo +#endif +#endif do iparm=1,nParmSet do iib=1,nT_h(iparm) do ii=1,nR(iib,iparm) @@ -413,17 +488,18 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft fi_p(ii,iib,iparm)=0.0d0 do t=1,scount(me) fi_p(ii,iib,iparm)=fi_p(ii,iib,iparm) - & +dexp(v(t,ii,iib,iparm)+entfac(t)) + & +dexp(v(t,ii,iib,iparm)+entfac(t)-fi_min(ii,iib,iparm)) #ifdef DEBUG - write (iout,'(4i5,3e15.5)') t,ii,iib,iparm, - & v(t,ii,iib,iparm),entfac(t),fi_p(ii,iib,iparm) + write (iout,'(4i5,4e15.5)') t,ii,iib,iparm, + & v(t,ii,iib,iparm),entfac(t),fi_min(ii,iib,iparm), + & fi_p(ii,iib,iparm) #endif enddo #else fi(ii,iib,iparm)=0.0d0 do t=1,ntot(islice) fi(ii,iib,iparm)=fi(ii,iib,iparm) - & +dexp(v(t,ii,iib,iparm)+entfac(t)) + & +dexp(v(t,ii,iib,iparm)+entfac(t)-fi_min(ii,iib,iparm)) enddo #endif enddo ! ii @@ -441,10 +517,12 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft enddo enddo #endif +#ifdef DEBUG write (iout,*) "REDUCE size",maxR,MaxT_h,nParmSet, & maxR*MaxT_h*nParmSet write (iout,*) "MPI_COMM_WORLD",MPI_COMM_WORLD, & " WHAM_COMM",WHAM_COMM +#endif call MPI_Reduce(fi_p(1,1,1),fi(1,1,1),maxR*MaxT_h*nParmSet, & MPI_DOUBLE_PRECISION, & MPI_SUM,Master,WHAM_COMM,IERROR) @@ -464,7 +542,7 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft do iparm=1,nParmSet do ib=1,nT_h(iparm) do i=1,nR(ib,iparm) - fi(i,ib,iparm)=-dlog(fi(i,ib,iparm)) + fi(i,ib,iparm)=-dlog(fi(i,ib,iparm))-fi_min(i,ib,iparm) avefi=avefi+fi(i,ib,iparm) enddo enddo @@ -514,6 +592,173 @@ c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft 20 continue ! Now, put together the histograms from all simulations, in order to get the ! unbiased total histogram. + +C Determine the minimum free energies +#ifdef MPI + do i=1,scount(me1) +#else + do i=1,ntot(islice) +#endif +c write (9,'(3i5,f10.5)') i,(iparm,potE(i,iparm),iparm=1,nParmSet) + do iparm=1,nParmSet +#ifdef DEBUG + write (iout,'(2i5,21f8.2)') i,iparm, + & (enetb(k,i,iparm),k=1,22) +#endif + call restore_parm(iparm) +#ifdef DEBUG + write (iout,*) wsc,wscp,welec,wvdwpp,wang,wtor,wscloc, + & wcorr,wcorr5,wcorr6,wturn4,wturn3,wturn6,wel_loc, + & wtor_d,wsccor,wbond +#endif + do ib=1,nT_h(iparm) + if (rescale_mode.eq.1) then + quot=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) + quotl=1.0d0 + kfacl=1.0d0 + do l=1,5 + quotl1=quotl + quotl=quotl*quot + kfacl=kfacl*kfac + fT(l)=kfacl/(kfacl-1.0d0+quotl) + enddo +#if defined(FUNCTH) + tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) + ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +#elif defined(FUNCT) + ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) +#else + ft(6)=1.0d0 +#endif + else if (rescale_mode.eq.2) then + quot=1.0d0/(T0*beta_h(ib,iparm)*1.987D-3) + quotl=1.0d0 + do l=1,5 + quotl=quotl*quot + fT(l)=1.12692801104297249644d0/ + & dlog(dexp(quotl)+dexp(-quotl)) + enddo +#if defined(FUNCTH) + tt = 1.0d0/(beta_h(ib,iparm)*1.987D-3) + ft(6)=(320.0d0+80.0d0*dtanh((tt-320.0d0)/80.0d0))/320.0d0 +#elif defined(FUNCT) + ft(6)=1.0d0/(beta_h(ib,iparm)*1.987D-3*T0) +#else + ft(6)=1.0d0 +#endif +c write (iout,*) 1.0d0/(beta_h(ib,iparm)*1.987D-3),ft + else if (rescale_mode.eq.0) then + do l=1,6 + fT(l)=1.0d0 + enddo + else + write (iout,*) "Error in WHAM_CALC: wrong RESCALE_MODE", + & rescale_mode + call flush(iout) + return1 + endif + evdw=enetb(21,i,iparm) + evdw_t=enetb(1,i,iparm) +#ifdef SCP14 + evdw2_14=enetb(17,i,iparm) + evdw2=enetb(2,i,iparm)+evdw2_14 +#else + evdw2=enetb(2,i,iparm) + evdw2_14=0.0d0 +#endif +#ifdef SPLITELE + ees=enetb(3,i,iparm) + evdw1=enetb(16,i,iparm) +#else + ees=enetb(3,i,iparm) + evdw1=0.0d0 +#endif + ecorr=enetb(4,i,iparm) + ecorr5=enetb(5,i,iparm) + ecorr6=enetb(6,i,iparm) + eel_loc=enetb(7,i,iparm) + eello_turn3=enetb(8,i,iparm) + eello_turn4=enetb(9,i,iparm) + eturn6=enetb(10,i,iparm) + ebe=enetb(11,i,iparm) + escloc=enetb(12,i,iparm) + etors=enetb(13,i,iparm) + etors_d=enetb(14,i,iparm) + ehpb=enetb(15,i,iparm) + estr=enetb(18,i,iparm) + esccor=enetb(19,i,iparm) + edihcnstr=enetb(20,i,iparm) + ehomology_constr=enetb(22,i,iparm) +#ifdef SPLITELE + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees + & +wvdwpp*evdw1 + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc + & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr+ehomology_constr +#else + etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2 + & +ft(1)*welec*(ees+evdw1) + & +wang*ebe+ft(1)*wtor*etors+wscloc*escloc + & +wstrain*ehpb+nss*ebr+ft(3)*wcorr*ecorr+ft(4)*wcorr5*ecorr5 + & +ft(5)*wcorr6*ecorr6+ft(3)*wturn4*eello_turn4 + & +ft(2)*wturn3*eello_turn3 + & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr + & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor + & +wbond*estr+ehomology_constr + +#endif + etot=etot-entfac(i)/beta_h(ib,iparm) + if(etot.lt.potEmin_all(ib,iparm)) potEmin_all(ib,iparm)=etot + + enddo ! ib + enddo ! iparm + enddo ! i +#ifdef DEBUG + write (iout,*) "The potEmin array before reduction" + do i=1,nParmSet + write (iout,*) "Parameter set",i + do j=1,nT_h(i) + write (iout,*) j,PotEmin_all(j,i) + enddo + enddo + write (iout,*) "potEmin_min",potEmin_min +#endif +#ifdef MPI +C Determine the minimum energes for all parameter sets and temperatures + call MPI_AllReduce(potEmin_all(1,1),potEmin_t_all(1,1), + & maxT_h*nParmSet,MPI_DOUBLE_PRECISION,MPI_MIN,WHAM_COMM,IERROR) + do i=1,nParmSet + do j=1,nT_h(i) + potEmin_all(j,i)=potEmin_t_all(j,i) + enddo + enddo +#endif + potEmin_min=potEmin_all(1,1) + do i=1,nParmSet + do j=1,nT_h(i) + if (potEmin_all(j,i).lt.potEmin_min) + & potEmin_min=potEmin_all(j,i) + enddo + enddo +#ifdef DEBUG + write (iout,*) "The potEmin array" + do i=1,nParmSet + write (iout,*) "Parameter set",i + do j=1,nT_h(i) + write (iout,*) j,1.0d0/(1.987d-3*beta_h(j,i)), + & PotEmin_all(j,i) + enddo + enddo + write (iout,*) "potEmin_min",potEmin_min +#endif + + +! Now, put together the histograms from all simulations, in order to get the +! unbiased total histogram. #ifdef MPI do t=0,tmax hfin_ent_p(t)=0.0d0 @@ -686,7 +931,9 @@ c write (iout,'(2i5,20f8.2)') t,t,(enetb(k,t,iparm),k=1,18) estr=enetb(18,t,iparm) esccor=enetb(19,t,iparm) edihcnstr=enetb(20,t,iparm) - edihcnstr=0.0d0 + ehomology_constr=enetb(22,t,iparm) + if (homol_nset.gt.1) + & ehomology_constr=waga_homology(ihset)*ehomology_constr do k=0,nGridT betaT=startGridT+k*delta_T temper=betaT @@ -767,6 +1014,36 @@ c ft=2*T0/(T0+betaT) c write (iout,*) "ftprim",ftprim c write (iout,*) "ftbis",ftbis betaT=1.0d0/(1.987D-3*betaT) + if (betaT.ge.beta_h(1,iparm)) then + potEmin=potEmin_all(1,iparm)+ + & (potEmin_all(1,iparm)-potEmin_all(2,iparm))/ + & (1.0/beta_h(1,iparm)-1.0/beta_h(2,iparm))* + & (1.0/betaT-1.0/beta_h(1,iparm)) +#ifdef DEBUG + write(iout,*) "first",temper,potEmin +#endif + else if (betaT.le.beta_h(nT_h(iparm),iparm)) then + potEmin=potEmin_all(nT_h(iparm),iparm)+ + &(potEmin_all(nT_h(iparm),iparm)-potEmin_all(nT_h(iparm)-1,iparm))/ + &(1.0/beta_h(nT_h(iparm),iparm)-1.0/beta_h(nT_h(iparm)-1,iparm))* + &(1.0/betaT-1.0/beta_h(nt_h(iparm),iparm)) +#ifdef DEBUG + write (iout,*) "last",temper,potEmin +#endif + else + do l=1,nT_h(iparm)-1 + if (betaT.le.beta_h(l,iparm) .and. + & betaT.gt.beta_h(l+1,iparm)) then + potEmin=potEmin_all(l,iparm) +#ifdef DEBUG + write (iout,*) "l",l, + & betaT,1.0d0/(1.987D-3*beta_h(l,iparm)), + & 1.0d0/(1.987D-3*beta_h(l+1,iparm)),temper,potEmin +#endif + exit + endif + enddo + endif #ifdef SPLITELE etot=wsc*(evdw+ft(6)*evdw_t)+wscp*evdw2+ft(1)*welec*ees & +wvdwpp*evdw1 @@ -776,7 +1053,7 @@ c write (iout,*) "ftbis",ftbis & +ft(2)*wturn3*eello_turn3 & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc & +edihcnstr+ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr + & +wbond*estr+ehomology_constr eprim=ftprim(6)*evdw_t+ftprim(1)*welec*ees & +ftprim(1)*wtor*etors+ & ftprim(3)*wcorr*ecorr+ftprim(4)*wcorr5*ecorr5+ @@ -799,7 +1076,7 @@ c write (iout,*) "ftbis",ftbis & +ft(2)*wturn3*eello_turn3 & +ft(5)*wturn6*eturn6+ft(2)*wel_loc*eel_loc+edihcnstr & +ft(2)*wtor_d*etors_d+ft(1)*wsccor*esccor - & +wbond*estr + & +wbond*estr+ehomology_constr eprim=ftprim(6)*evdw_t+ftprim(1)*welec*(ees+evdw1) & +ftprim(1)*wtor*etors+ & ftprim(3)*wcorr*ecorr+ftprim(4)*wcorr5*ecorr5+ @@ -812,7 +1089,10 @@ c write (iout,*) "ftbis",ftbis & ftbis(5)*wcorr6*ecorr6+ftbis(3)*wturn4*eello_turn4+ & ftbis(2)*wturn3*eello_turn3+ftbis(5)*wturn6*eturn6+ & ftbis(2)*wel_loc*eel_loc+ftbis(2)*wtor_d*etors_d+ - & ftprim(1)*wsccor*esccor + & ftbis(1)*wsccor*esccor + + endif + #endif weight=dexp(-betaT*(etot-potEmin)+entfac(t)) #ifdef DEBUG @@ -852,6 +1132,7 @@ c write (iout,*) "ftbis",ftbis endif #ifdef MPI do ib=1,nT_h(iparm) + potEmin=potEmin_all(ib,iparm) expfac=dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) hfin_p(ind,ib)=hfin_p(ind,ib)+ & dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) @@ -864,6 +1145,7 @@ c write (iout,*) "ftbis",ftbis enddo #else do ib=1,nT_h(iparm) + potEmin=potEmin_all(ib,iparm) expfac=dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) hfin(ind,ib)=hfin(ind,ib)+ & dexp(-beta_h(ib,iparm)*(etot-potEmin)+entfac(t)) @@ -1082,6 +1364,21 @@ c write (iout,*) "ftbis",ftbis write (iout,'(a,i3)') "Parameter set",iparm endif do i=0,NGridT + betaT=1.0d0/(1.987D-3*(startGridT+i*delta_T)) + if (betaT.ge.beta_h(1,iparm)) then + potEmin=potEmin_all(1,iparm) + else if (betaT.lt.beta_h(nT_h(iparm),iparm)) then + potEmin=potEmin_all(nT_h(iparm),iparm) + else + do l=1,nT_h(iparm)-1 + if (betaT.le.beta_h(l,iparm) .and. + & betaT.gt.beta_h(l+1,iparm)) then + potEmin=potEmin_all(l,iparm) + exit + endif + enddo + endif + sumE(i,iparm)=sumE(i,iparm)/sumW(i,iparm) sumEbis(i,iparm)=(startGridT+i*delta_T)*sumEbis(i,iparm)/ & sumW(i,iparm) diff --git a/source/wham/src-M/wham_multparm.F b/source/wham/src-M/wham_multparm.F index e80a39d..de73250 100644 --- a/source/wham/src-M/wham_multparm.F +++ b/source/wham/src-M/wham_multparm.F @@ -58,6 +58,7 @@ c NaNQ initialization call flush(iout) call molread(*10) call flush(iout) + if (constr_dist.gt.0) call read_dist_constr #ifdef MPI write (iout,*) "Calling proc_groups" call proc_groups @@ -88,8 +89,8 @@ c NaNQ initialization call read_ref_structure(*10) call proc_cont call fragment_list - if (constr_dist.gt.0) call read_dist_constr endif +C if (constr_dist.gt.0) call read_dist_constr write (iout,*) "Begin read_database" call flush(iout) call read_database(*10)