From: Cezary Czaplewski Date: Sat, 14 Mar 2020 08:09:09 +0000 (+0100) Subject: adam's update X-Git-Url: http://mmka.chem.univ.gda.pl/gitweb/?a=commitdiff_plain;h=96a3e89918e3059b88ffe0377b80b8c9f284ec0a;p=unres.git adam's update --- diff --git a/source/unres/src-HCD-5D/COMMON.CONTACTS b/source/unres/src-HCD-5D/COMMON.CONTACTS index 6309b36..d5c2d2e 100644 --- a/source/unres/src-HCD-5D/COMMON.CONTACTS +++ b/source/unres/src-HCD-5D/COMMON.CONTACTS @@ -1,89 +1,4 @@ -C Change 12/1/95 - common block CONTACTS1 included. integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont double precision facont,gacont common /contacts/ ncont,ncont_ref,icont(2,maxcont), & icont_ref(2,maxcont) - common /contacts1/ facont(maxconts,maxres), - & gacont(3,maxconts,maxres), - & num_cont(maxres),jcont(maxconts,maxres) -C 12/26/95 - H-bonding contacts - double precision gacontp_hb1,gacontp_hb2,gacontp_hb3,gacont_hbr, - & gacontm_hb1,gacontm_hb2,gacontm_hb3,grij_hb_cont,facont_hb, - & ees0p,ees0m,d_cont - integer num_cont_hb,jcont_hb - common /contacts_hb/ - & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), - & gacontp_hb3(3,maxconts,maxres), - & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), - & gacontm_hb3(3,maxconts,maxres), - & gacont_hbr(3,maxconts,maxres), - & grij_hb_cont(3,maxconts,maxres), - & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), - & ees0m(maxconts,maxres),d_cont(maxconts,maxres), - & num_cont_hb(maxres),jcont_hb(maxconts,maxres) -C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole -C interactions -c 7/25/08 Commented out; not needed when cumulants used -C Interactions of pseudo-dipoles generated by loc-el interactions. -c double precision dip,dipderg,dipderx -c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), -c & dipderx(3,5,4,maxconts,maxres) -C 10/30/99 Added other pre-computed vectors and matrices needed -C to calculate three - six-order el-loc correlation terms - double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, - & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,gmu,gUb2, - & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der, - & gtEug - common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), - & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), - & obrot_der(2,maxres),obrot2_der(2,maxres) -C This common block contains vectors and matrices dependent on a single -C amino-acid residue. - common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres), - & gmu(2,maxres),gUb2(2,maxres), - & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres), - & Dtobr2(2,maxres),Dtobr2der(2,maxres), - & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), - & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), - & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),gtEUg(2,2,maxres) -C This common block contains vectors and matrices dependent on two -C consecutive amino-acid residues. - double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, - & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder,Ug2DtEUg,Ug2DtEUgder - common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), - & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), - & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), - & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), - & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) - double precision costab,sintab,costab2,sintab2 - common /rotat_old/ costab(maxres),sintab(maxres), - & costab2(maxres),sintab2(maxres) -C This common block contains dipole-interaction matrices and their -C Cartesian derivatives. - double precision a_chuj,a_chuj_der - common /dipmat/ a_chuj(2,2,maxconts,maxres), - & a_chuj_der(2,2,3,5,maxconts,maxres) - double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, - & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, - & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont,EAEA,EAEAderg,EAEAderx, - & ADtEA1,AdTEA1derg,ADtEA1derx - common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), - & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), - & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), - & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), - & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), - & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), - & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), - & g_contij(3,2),ekont -C 12/13/2008 (again Poland-Jaruzel war anniversary) -C RE: Parallelization of 4th and higher order loc-el correlations - integer ncont_sent,ncont_recv,iint_sent,iisent_local, - & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to, - & nat_sent,iat_sent,iturn3_sent,iturn4_sent,iturn3_sent_local, - & iturn4_sent_local,iint_sent_local - common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres), - & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres), - & iturn3_sent(4,maxres),iturn4_sent(4,maxres), - & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres), - & nat_sent,iat_sent(maxres),itask_cont_from(0:max_fg_procs-1), - & itask_cont_to(0:max_fg_procs-1),ntask_cont_from,ntask_cont_to diff --git a/source/unres/src-HCD-5D/COMMON.CONTMAT b/source/unres/src-HCD-5D/COMMON.CONTMAT new file mode 100644 index 0000000..e681360 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.CONTMAT @@ -0,0 +1,39 @@ +C Change 12/1/95 - common block CONTACTS1 included. + common /contacts1/ facont(maxconts,maxres), + & gacont(3,maxconts,maxres), + & num_cont(maxres),jcont(maxconts,maxres) +C 12/26/95 - H-bonding contacts + double precision gacontp_hb1,gacontp_hb2,gacontp_hb3,gacont_hbr, + & gacontm_hb1,gacontm_hb2,gacontm_hb3,grij_hb_cont,facont_hb, + & ees0p,ees0m,d_cont + integer num_cont_hb,jcont_hb + common /contacts_hb/ + & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), + & gacontp_hb3(3,maxconts,maxres), + & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), + & gacontm_hb3(3,maxconts,maxres), + & gacont_hbr(3,maxconts,maxres), + & grij_hb_cont(3,maxconts,maxres), + & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), + & ees0m(maxconts,maxres),d_cont(maxconts,maxres), + & num_cont_hb(maxres),jcont_hb(maxconts,maxres) +C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole +C interactions +c 7/25/08 Commented out; not needed when cumulants used +C Interactions of pseudo-dipoles generated by loc-el interactions. +c double precision dip,dipderg,dipderx +c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), +c & dipderx(3,5,4,maxconts,maxres) +C 12/13/2008 (again Poland-Jaruzel war anniversary) +C RE: Parallelization of 4th and higher order loc-el correlations + integer ncont_sent,ncont_recv,iint_sent,iisent_local, + & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to, + & nat_sent,iat_sent,iint_sent_local + integer iturn3_sent,iturn4_sent,iturn3_sent_local, + & iturn4_sent_local + common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres), + & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres), + & nat_sent,iat_sent(maxres),itask_cont_from(0:max_fg_procs-1), + & itask_cont_to(0:max_fg_procs-1),ntask_cont_from,ntask_cont_to, + & iturn3_sent(4,maxres),iturn4_sent(4,maxres), + & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres) diff --git a/source/unres/src-HCD-5D/COMMON.CORRMAT b/source/unres/src-HCD-5D/COMMON.CORRMAT new file mode 100644 index 0000000..5f154e0 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.CORRMAT @@ -0,0 +1,47 @@ +C 10/30/99 Added other pre-computed vectors and matrices needed +C to calculate three - six-order el-loc correlation terms + double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, + & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,gmu,gUb2, + & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der, + & gtEug + common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), + & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), + & obrot_der(2,maxres),obrot2_der(2,maxres) +C This common block contains vectors and matrices dependent on a single +C amino-acid residue. + common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres), + & gmu(2,maxres),gUb2(2,maxres), + & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres), + & Dtobr2(2,maxres),Dtobr2der(2,maxres), + & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), + & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), + & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),gtEUg(2,2,maxres) +C This common block contains vectors and matrices dependent on two +C consecutive amino-acid residues. + double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, + & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder,Ug2DtEUg,Ug2DtEUgder + common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), + & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), + & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), + & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), + & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) + double precision costab,sintab,costab2,sintab2 + common /rotat_old/ costab(maxres),sintab(maxres), + & costab2(maxres),sintab2(maxres) +C This common block contains dipole-interaction matrices and their +C Cartesian derivatives. + double precision a_chuj,a_chuj_der + common /dipmat/ a_chuj(2,2,maxconts,maxres), + & a_chuj_der(2,2,3,5,maxconts,maxres) + double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, + & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, + & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont,EAEA,EAEAderg,EAEAderx, + & ADtEA1,AdTEA1derg,ADtEA1derx + common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), + & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), + & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), + & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), + & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), + & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), + & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), + & g_contij(3,2),ekont diff --git a/source/unres/src-HCD-5D/COMMON.DERIV b/source/unres/src-HCD-5D/COMMON.DERIV index 217b76c..1c39ed1 100644 --- a/source/unres/src-HCD-5D/COMMON.DERIV +++ b/source/unres/src-HCD-5D/COMMON.DERIV @@ -13,7 +13,9 @@ & gshieldc_ll, gshieldc_loc_ll double precision gdfad,gdfat,gdfan,gdfab integer nfl,icg - common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), +c common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), +c 3/12/20 Adam: Arrays dcdv, dxdv, and dxds removed following recoding of gradient. + common /derivat/ & gradx(3,-1:maxres,2),gradc(3,-1:maxres,2),gvdwx(3,-1:maxres), & gvdwc(3,-1:maxres),gelc(3,-1:maxres),gelc_long(3,-1:maxres), & gvdwpp(3,-1:maxres),gvdwc_scpp(3,-1:maxres), diff --git a/source/unres/src-HCD-5D/COMMON.DISTFIT b/source/unres/src-HCD-5D/COMMON.DISTFIT index 4f65205..9f2a302 100644 --- a/source/unres/src-HCD-5D/COMMON.DISTFIT +++ b/source/unres/src-HCD-5D/COMMON.DISTFIT @@ -2,12 +2,6 @@ c parameter (maxres22=maxres*(maxres+1)/2) parameter (maxres22=1) double precision w,d0,DRDG,DD,H,XX - integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0, - 1 lvar_frag,svar_frag,avar_frag - COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3) - COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3), - 1 lvar_frag(mxio,3),svar_frag(mxio,3), - 2 avar_frag(mxio,5) COMMON /WAGI/ w(MAXRES22),d0(MAXRES22) integer nx,ny,mask COMMON /POCHODNE/ NX,NY,DRDG(MAXRES22,MAXRES),DD(MAXRES22), diff --git a/source/unres/src-HCD-5D/COMMON.FRAG b/source/unres/src-HCD-5D/COMMON.FRAG new file mode 100644 index 0000000..f9e5385 --- /dev/null +++ b/source/unres/src-HCD-5D/COMMON.FRAG @@ -0,0 +1,7 @@ + integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0, + 1 lvar_frag,svar_frag,avar_frag + COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3) + COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3), + 1 lvar_frag(mxio,3),svar_frag(mxio,3), + 2 avar_frag(mxio,5) + diff --git a/source/unres/src-HCD-5D/COMMON.VAR b/source/unres/src-HCD-5D/COMMON.VAR index 1ab0a16..d061411 100644 --- a/source/unres/src-HCD-5D/COMMON.VAR +++ b/source/unres/src-HCD-5D/COMMON.VAR @@ -17,6 +17,6 @@ C in MCM). common /oldgeo/ varsave(maxvar,maxsave),esave(maxsave), & Origin(maxsave),nstore C freeze some variables - logical mask_r - common /restr/ varall(maxvar),mask_r,mask_theta(maxres), + logical mask_r,sideonly + common /restr/ varall(maxvar),mask_r,sideonly,mask_theta(maxres), & mask_phi(maxres),mask_side(maxres) diff --git a/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos b/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos index 372453e..fb434ea 100644 --- a/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos +++ b/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos @@ -37,7 +37,7 @@ all: no_option object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ pinorm.o randgens.o rescode.o intcor.o timing.o misc.o \ - cartder.o checkder_p.o econstr_local.o econstr_qlike.o \ + cart2intgrad.o checkder_p.o contact_cp econstr_local.o econstr_qlike.o \ econstrq-PMF.o PMFprocess.o energy_p_new_barrier.o \ energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ @@ -45,7 +45,7 @@ object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ eigen.o blas.o add.o entmcm.o minim_mcmf.o \ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o rmscalc.o elecont.o dihed_cons.o \ + banach.o distfit.o rmsd.o rmscalc.o elecont.o dihed_cons.o \ sc_move.o local_move.o djacob.o \ intcartderiv.o lagrangian_lesyng.o\ chain_symmetry.o permut.o seq2chains.o iperm.o\ @@ -53,12 +53,12 @@ object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ q_measure.o gnmr1.o mygauss.o ssMD.o -object_lbfgs = inform.o iounit.o keys.o linmin.o math.o minima.o scales.o output.o lbfgs.o search.o +object_lbfgs = inform.o iounit.o keys.o linmin.o math.o minima.o scales.o output.o lbfgs.o search.o optsave_dum.o no_option: GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC + -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DFOURBODY GAB: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_GAB-HCD.exe GAB: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c @@ -67,7 +67,7 @@ GAB: ${object} xdrf/libxdrf.a ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} 4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC + -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DFOURBODY 4P: BIN = ~/bin/unres-ms_KCC_ifort_MPICH-okeanos_4P-HCD.exe 4P: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c @@ -76,7 +76,7 @@ GAB: ${object} xdrf/libxdrf.a ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 + -DSPLITELE -DLANG0 -DFOURBODY E0LL2Y: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_E0LL2Y-HCD.exe E0LL2Y: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c @@ -85,22 +85,22 @@ E0LL2Y: ${object} xdrf/libxdrf.a ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} NEWCORR: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD #-DMYGAUSS #-DTIMING + -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD #-DFOURBODY #-DMYGAUSS #-DTIMING NEWCORR: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_SC-HCD.exe NEWCORR: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} NEWCORR5D: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD -FIVEDIAG -DLBFGS #-DMYGAUSS #-DTIMING -NEWCORR5D: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_SC-HCD5.exe + -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD -DFIVEDIAG -DLBFGS #-DMYGAUSS #-DTIMING +NEWCORR5D: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_SC-HCD5-40.exe NEWCORR5D: ${object} ${object_lbfgs} fdisy.o fdiag.o machpd.o kinetic_CASC.o xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} ${object_lbfgs} fdisy.o fdiag.o machpd.o kinetic_CASC.o cinfo.o ${LIBS} -o ${BIN} + ${FC} ${OPT} ${object} ${object_lbfgs} fdisy.o fdiag.o machpd.o kinetic_CASC.o cinfo.o ${LIBS} -o ${BIN} NEWCORR_DFA: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD -DDFA #-DMYGAUSS #-DTIMING @@ -109,7 +109,7 @@ NEWCORR_DFA: ${object} dfa.o xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} dfa.o cinfo.o ${LIBS} -o ${BIN} + ${FC} ${OPT} ${object} dfa.o cinfo.o ${LIBS} -o ${BIN} NEWCORR5D_DFA: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD -DFIVEDIAG -DLBFGS -DDFA #-DMYGAUSS #-DTIMING diff --git a/source/unres/src-HCD-5D/TODO.AFTER.CASP14 b/source/unres/src-HCD-5D/TODO.AFTER.CASP14 new file mode 100644 index 0000000..85ea11a --- /dev/null +++ b/source/unres/src-HCD-5D/TODO.AFTER.CASP14 @@ -0,0 +1,7 @@ +1. Replace SUMSL with LBFGS everywhere (currently only minim_ecart) +2. Parallelize the transformation of Cartesian derivatives to backbone-angle + derivatives (cart2int.F) +3. Parallelize usampl +4. HREMD +5. Fourbody interactions - eliminate pp-contact etc. storage (currently 4body + switched off by default, -DFOURBODY flag switches on). diff --git a/source/unres/src-HCD-5D/cart2intgrad.F b/source/unres/src-HCD-5D/cart2intgrad.F new file mode 100644 index 0000000..d6da6bb --- /dev/null +++ b/source/unres/src-HCD-5D/cart2intgrad.F @@ -0,0 +1,377 @@ + subroutine cart2intgrad(n,g) +*********************************************************************** +* This subroutine thransforms the gradient in virtual-bond vectors to +* that in the backbone and side-chain angular variables. +* Adapted from the cartder subroutine. +* +* 03/11/20 Adam. Array fromto eliminated, computed on the fly +* Fixed the problem with vbld indices, which caused errors in +* derivatives when the backbone virtual bond lengths were not equal. +*********************************************************************** + implicit none + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.INTERACT' + integer n + double precision g(n) + double precision drt(3,3,maxres),rdt(3,3,maxres),dp(3,3), + &temp(3,3),prordt(3,3,maxres),prodrt(3,3,maxres) + double precision xx(3),xx1(3),alphi,omegi,xj,dpjk,yp,xp,xxp,yyp + double precision cosalphi,sinalphi,cosomegi,sinomegi,theta2, + & cost2,sint2,rj,dxoiij,tempkl,dxoijk,dsci,zzp,dj,dpkl + double precision fromto(3,3),aux(6) + integer i,ii,j,jjj,k,l,m,indi,ind,ind1 +* get the position of the jth ijth fragment of the chain coordinate system +* in the fromto array. +c integer indmat +c indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 +c call chainbuild_extconf +c call cartprint +c call intout + g=0.0d0 +* 3/13/20 Adam: Skip calculating backbone derivatives if SC only +* requested. + if (sideonly) goto 10 +* +* calculate the derivatives of transformation matrix elements in theta +* + do i=1,nres-2 + rdt(1,1,i)=-rt(1,2,i) + rdt(1,2,i)= rt(1,1,i) + rdt(1,3,i)= 0.0d0 + rdt(2,1,i)=-rt(2,2,i) + rdt(2,2,i)= rt(2,1,i) + rdt(2,3,i)= 0.0d0 + rdt(3,1,i)=-rt(3,2,i) + rdt(3,2,i)= rt(3,1,i) + rdt(3,3,i)= 0.0d0 + enddo +* +* derivatives in phi +* + do i=2,nres-2 + drt(1,1,i)= 0.0d0 + drt(1,2,i)= 0.0d0 + drt(1,3,i)= 0.0d0 + drt(2,1,i)= rt(3,1,i) + drt(2,2,i)= rt(3,2,i) + drt(2,3,i)= rt(3,3,i) + drt(3,1,i)=-rt(2,1,i) + drt(3,2,i)=-rt(2,2,i) + drt(3,3,i)=-rt(2,3,i) + enddo +* +* Calculate backbone derivatives. +* This code invlves N^2 effort and should be parallelized, to be done +* later. + ind1=0 + do i=1,nres-2 + ind1=ind1+1 +* +* Derivatives of DC(i+1) in theta(i+2) +* +c write (iout,*) "theta i",i +c write(iout,'(7hprod 9f10.5)')((prod(k,l,i),l=1,3),k=1,3) +c write(iout,'(7hrdt 9f10.5)')((rdt(k,l,i),l=1,3),k=1,3) +c write(iout,*) "vbld",vbld(i+2) + if (n.gt.nphi) then + + do j=1,3 + do k=1,2 + dpjk=0.0D0 + do l=1,3 + dpjk=dpjk+prod(j,l,i)*rdt(l,k,i) + enddo + dp(j,k)=dpjk + prordt(j,k,i)=dp(j,k) + enddo + dp(j,3)=0.0D0 +c dcdv(j,ind1)=vbld(i+2)*dp(j,1) + g(nphi+i)=g(nphi+i)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg) + enddo +c write(iout,'(7hdcdv 3f10.5)')(dcdv(k,ind1),k=1,3) +* +* Derivatives of SC(i+1) in theta(i+2) +* + xx1(1)=-0.5D0*xloc(2,i+1) + xx1(2)= 0.5D0*xloc(1,i+1) + do j=1,3 + xj=0.0D0 + do k=1,2 + xj=xj+r(j,k,i)*xx1(k) + enddo + xx(j)=xj + enddo + do j=1,3 + rj=0.0D0 + do k=1,3 + rj=rj+prod(j,k,i)*xx(k) + enddo +c dxdv(j,ind1)=rj +c write (iout,*) "1:i",i," j",i+1,"ind1",ind1," dxdthet",rj, +c & " gradx",gradx(j,i+1,icg) + g(nphi+i)=g(nphi+i)+rj*gradx(j,i+1,icg) + enddo +c write (iout,*) "dxdv",(dxdv(j,ind1),j=1,3) +* +* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently +* than the other off-diagonal derivatives. +* + if (i.lt.nres-2) then + do j=1,3 + dxoiij=0.0D0 + do k=1,3 + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) + enddo +c dxdv(j,ind1+1)=dxoiij +c write (iout,*) "2:i",i," j",i+1,"ind1",ind1+1, +c & " dxdthet",dxoiij," gradx",gradx(j,i+2,icg) + g(nphi+i)=g(nphi+i)+dxoiij*gradx(j,i+2,icg) + enddo + endif +c write(iout,*)ind1+1,(dxdv(j,ind1+1),j=1,3) + + endif +* +* Derivatives of DC(i+1) in phi(i+2) +* + if (i.gt.1) then + do j=1,3 + do k=1,3 + dpjk=0.0 + do l=2,3 + dpjk=dpjk+prod(j,l,i)*drt(l,k,i) + enddo + dp(j,k)=dpjk + prodrt(j,k,i)=dp(j,k) + enddo +c dcdv(j+3,ind1)=vbld(i+2)*dp(j,1) + g(i-1)=g(i-1)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg) + enddo + endif +* +* Derivatives of SC(i+1) in phi(i+2) +* + xx(1)= 0.0D0 + xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i) + xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i) + if (i.gt.1) then + do j=1,3 + rj=0.0D0 + do k=2,3 + rj=rj+prod(j,k,i)*xx(k) + enddo +c dxdv(j+3,ind1)=-rj +c write (iout,*) "1:i",i," j",i+1,"ind1",ind1," dxdphi",-rj, +c & " gradx",gradx(j,i+1,icg) + g(i-1)=g(i-1)-rj*gradx(j,i+1,icg) + enddo + endif +* +* Derivatives of SC(i+1) in phi(i+3). +* + if (i.gt.1) then + do j=1,3 + dxoiij=0.0D0 + do k=1,3 + dxoiij=dxoiij+dp(j,k)*xrot(k,i+2) + enddo +c dxdv(j+3,ind1+1)=dxoiij + g(i-1)=g(i-1)+dxoiij*gradx(j,i+2,icg) +c write (iout,*) "2:i",i," j",i+2," ind1",ind1+1, +c & " dxdphi",dxoiij," gradx",gradx(j,i+2,icg) + enddo + endif +* +* Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru +* theta(nres) and phi(i+3) thru phi(nres). +* + do j=i+1,nres-2 + ind1=ind1+1 +c ind=indmat(i+1,j+1) +c write(iout,*)'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 + call build_fromto(i+1,j+1,fromto) +c write(iout,'(7hfromto 9f10.5)')((fromto(k,l),l=1,3),k=1,3) + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,2 + tempkl=tempkl+prordt(k,m,i)*fromto(m,l) + enddo + temp(k,l)=tempkl + enddo + enddo +c write(iout,'(7hfromto 9f10.5)')((fromto(k,l,ind),l=1,3),k=1,3) +c write(iout,'(7hprod 9f10.5)')((prod(k,l,i),l=1,3),k=1,3) +c write(iout,'(7htemp 9f10.5)')((temp(k,l),l=1,3),k=1,3) + if (n.gt.nphi) then +* Derivatives of virtual-bond vectors in theta + do k=1,3 +c dcdv(k,ind1)=vbld(j+2)*temp(k,1) + g(nphi+i)=g(nphi+i)+vbld(j+2)*temp(k,1)*gradc(k,j+1,icg) + enddo +c write(iout,'(7hdcdv 3f10.5)')(dcdv(k,ind1),k=1,3) +* Derivatives of SC vectors in theta + do k=1,3 + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) + enddo +c dxdv(k,ind1+1)=dxoijk +c write (iout,*) "3:i",i+1," j",j+2,"ind1",ind1+1, +c & " dxdthet",dxoijk," gradx",gradx(k,j+2,icg) + g(nphi+i)=g(nphi+i)+dxoijk*gradx(k,j+2,icg) + enddo +c write(iout,'(7htheta 3f10.5)')(dxdv(k,ind1),k=1,3) + endif +* +*--- Calculate the derivatives in phi +* + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,3 + tempkl=tempkl+prodrt(k,m,i)*fromto(m,l) + enddo + temp(k,l)=tempkl + enddo + enddo + if (i.gt.1) then + do k=1,3 +c dcdv(k+3,ind1)=vbld(j+2)*temp(k,1) + g(i-1)=g(i-1)+vbld(j+2)*temp(k,1)*gradc(k,j+1,icg) + enddo + do k=1,3 + dxoijk=0.0D0 + do l=1,3 + dxoijk=dxoijk+temp(k,l)*xrot(l,j+2) + enddo +c dxdv(k+3,ind1+1)=dxoijk + g(i-1)=g(i-1)+dxoijk*gradx(k,j+2,icg) +c write (iout,*) "3:i",i," j",j+2," ind1",ind1+1, +c & " dxdphi",dxoijk," gradx",gradx(k,j+2,icg) + enddo + endif + enddo + enddo + + if (nvar.le.nphi+ntheta) return + + 10 continue +* +* Derivatives in alpha and omega: +* + do i=2,nres-1 + if (iabs(itype(i)).eq.10 .or. itype(i).eq.ntyp1!) cycle + & .or. mask_side(i).eq.0 ) cycle + ii=ialph(i,1) + dsci=vbld(i+nres) +#ifdef OSF + alphi=alph(i) + omegi=omeg(i) + if(alphi.ne.alphi) alphi=100.0 + if(omegi.ne.omegi) omegi=-100.0 +#else + alphi=alph(i) + omegi=omeg(i) +#endif +cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi + cosalphi=dcos(alphi) + sinalphi=dsin(alphi) + cosomegi=dcos(omegi) + sinomegi=dsin(omegi) + temp(1,1)=-dsci*sinalphi + temp(2,1)= dsci*cosalphi*cosomegi + temp(3,1)=-dsci*cosalphi*sinomegi + temp(1,2)=0.0D0 + temp(2,2)=-dsci*sinalphi*sinomegi + temp(3,2)=-dsci*sinalphi*cosomegi + theta2=pi-0.5D0*theta(i+1) + cost2=dcos(theta2) + sint2=dsin(theta2) + jjj=0 +cd print *,((temp(l,k),l=1,3),k=1,2) + do j=1,2 + xp=temp(1,j) + yp=temp(2,j) + xxp= xp*cost2+yp*sint2 + yyp=-xp*sint2+yp*cost2 + zzp=temp(3,j) + xx(1)=xxp + xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) + xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) + do k=1,3 + dj=0.0D0 + do l=1,3 + dj=dj+prod(k,l,i-1)*xx(l) + enddo +c dxds(jjj+k,i)=dj + aux(jjj+k)=dj + enddo + jjj=jjj+3 + enddo + do k=1,3 + g(ii)=g(ii)+aux(k)*gradx(k,i,icg) + g(ii+nside)=g(ii+nside)+aux(k+3)*gradx(k,i,icg) + enddo + enddo + return + end +c----------------------------------------------------------------------------- + subroutine build_fromto(i,j,fromto) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + integer i,j,jj,k,l,m + double precision fromto(3,3),temp(3,3),dp(3,3) + double precision dpkl + save temp +* +* generate the matrix products of type r(i)t(i)...r(j)t(j) on the fly +* +c write (iout,*) "temp on entry" +c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3) +c do i=2,nres-2 +c ind=indmat(i,i+1) + if (j.eq.i+1) then + do k=1,3 + do l=1,3 + temp(k,l)=rt(k,l,i) + enddo + enddo + do k=1,3 + do l=1,3 + fromto(k,l)=temp(k,l) + enddo + enddo + else +c do j=i+1,nres-2 +c ind=indmat(i,j+1) + do k=1,3 + do l=1,3 + dpkl=0.0d0 + do m=1,3 + dpkl=dpkl+temp(k,m)*rt(m,l,j-1) + enddo + dp(k,l)=dpkl + fromto(k,l)=dpkl + enddo + enddo + do k=1,3 + do l=1,3 + temp(k,l)=dp(k,l) + enddo + enddo + endif +c write (iout,*) "temp upon exit" +c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3) +c enddo +c enddo + return + end diff --git a/source/unres/src-HCD-5D/cartder.F b/source/unres/src-HCD-5D/cartder.F index 68b51f0..36b4e63 100644 --- a/source/unres/src-HCD-5D/cartder.F +++ b/source/unres/src-HCD-5D/cartder.F @@ -353,56 +353,3 @@ cd print *,((temp(l,k),l=1,3),k=1,2) enddo return end -c----------------------------------------------------------------------------- - subroutine build_fromto(i,j,fromto) - implicit none - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - integer i,j,jj,k,l,m - double precision fromto(3,3),temp(3,3),dp(3,3) - double precision dpkl - save temp -* -* generate the matrix products of type r(i)t(i)...r(j)t(j) on the fly -* -c write (iout,*) "temp on entry" -c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3) -c do i=2,nres-2 -c ind=indmat(i,i+1) - if (j.eq.i+1) then - do k=1,3 - do l=1,3 - temp(k,l)=rt(k,l,i) - enddo - enddo - do k=1,3 - do l=1,3 - fromto(k,l)=temp(k,l) - enddo - enddo - else -c do j=i+1,nres-2 -c ind=indmat(i,j+1) - do k=1,3 - do l=1,3 - dpkl=0.0d0 - do m=1,3 - dpkl=dpkl+temp(k,m)*rt(m,l,j-1) - enddo - dp(k,l)=dpkl - fromto(k,l)=dpkl - enddo - enddo - do k=1,3 - do l=1,3 - temp(k,l)=dp(k,l) - enddo - enddo - endif -c write (iout,*) "temp upon exit" -c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3) -c enddo -c enddo - return - end diff --git a/source/unres/src-HCD-5D/check_cartgrad.F b/source/unres/src-HCD-5D/check_cartgrad.F new file mode 100644 index 0000000..f8894d6 --- /dev/null +++ b/source/unres/src-HCD-5D/check_cartgrad.F @@ -0,0 +1,179 @@ + subroutine check_cartgrad +C Check the gradient of Cartesian coordinates in internal coordinates. + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.GEO' + include 'COMMON.LOCAL' + include 'COMMON.DERIV' + double precision temp(6,maxres),xx(3),gg(3),thet,theti,phii,alphi, + & omegi,aincr2 + integer indmat + integer i,ii,j,k + indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 + integer nf +* +* Check the gradient of the virtual-bond and SC vectors in the internal +* coordinates. +* + print '("Calling CHECK_ECART",1pd12.3)',aincr + write (iout,'("Calling CHECK_ECART",1pd12.3)') aincr + aincr2=0.5d0*aincr + call chainbuild_extconf + call cartder + write (iout,'(a)') '**************** dx/dalpha' + write (iout,'(a)') + do i=2,nres-1 + alphi=alph(i) + alph(i)=alph(i)+aincr + do k=1,3 + temp(k,i)=dc(k,nres+i) + enddo + call chainbuild_extconf + do k=1,3 + gg(k)=(dc(k,nres+i)-temp(k,i))/aincr + xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr)) + enddo + write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') + & i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + alph(i)=alphi + call chainbuild_extconf + enddo + write (iout,'(a)') + write (iout,'(a)') '**************** dx/domega' + write (iout,'(a)') + do i=2,nres-1 + omegi=omeg(i) + omeg(i)=omeg(i)+aincr + do k=1,3 + temp(k,i)=dc(k,nres+i) + enddo + call chainbuild_extconf + do k=1,3 + gg(k)=(dc(k,nres+i)-temp(k,i))/aincr + xx(k)=dabs((gg(k)-dxds(k+3,i))/ + & (aincr*dabs(dxds(k+3,i))+aincr)) + enddo + write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') + & i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + omeg(i)=omegi + call chainbuild_extconf + enddo + write (iout,'(a)') + write (iout,'(a)') '**************** dx/dtheta' + write (iout,'(a)') + do i=3,nres + theti=theta(i) + theta(i)=theta(i)+aincr + do j=i-1,nres-1 + do k=1,3 + temp(k,j)=dc(k,nres+j) + enddo + enddo + call chainbuild_extconf + do j=i-1,nres-1 + ii = indmat(i-2,j) +c print *,'i=',i-2,' j=',j-1,' ii=',ii + do k=1,3 + gg(k)=(dc(k,nres+j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dxdv(k,ii))/ + & (aincr*dabs(dxdv(k,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') + & i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3) + write(iout,'(a)') + enddo + write (iout,'(a)') + theta(i)=theti + call chainbuild_extconf + enddo + write (iout,'(a)') '***************** dx/dphi' + write (iout,'(a)') + do i=4,nres + phi(i)=phi(i)+aincr + do j=i-1,nres-1 + do k=1,3 + temp(k,j)=dc(k,nres+j) + enddo + enddo + call chainbuild_extconf + do j=i-1,nres-1 + ii = indmat(i-2,j) +c print *,'ii=',ii + do k=1,3 + gg(k)=(dc(k,nres+j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ + & (aincr*dabs(dxdv(k+3,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') + & i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3) + write(iout,'(a)') + enddo + phi(i)=phi(i)-aincr + call chainbuild_extconf + enddo + write (iout,'(a)') '****************** ddc/dtheta' + do i=1,nres-2 + thet=theta(i+2) + theta(i+2)=thet+aincr + do j=i,nres + do k=1,3 + temp(k,j)=dc(k,j) + enddo + enddo + call chainbuild_extconf + do j=i+1,nres-1 + ii = indmat(i,j) +c print *,'ii=',ii + do k=1,3 + gg(k)=(dc(k,j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dcdv(k,ii))/ + & (aincr*dabs(dcdv(k,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') + & i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + enddo + do j=1,nres + do k=1,3 + dc(k,j)=temp(k,j) + enddo + enddo + theta(i+2)=thet + enddo + write (iout,'(a)') '******************* ddc/dphi' + do i=1,nres-3 + phii=phi(i+3) + phi(i+3)=phii+aincr + do j=1,nres + do k=1,3 + temp(k,j)=dc(k,j) + enddo + enddo + call chainbuild_extconf + do j=i+2,nres-1 + ii = indmat(i+1,j) +c print *,'ii=',ii + do k=1,3 + gg(k)=(dc(k,j)-temp(k,j))/aincr + xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ + & (aincr*dabs(dcdv(k+3,ii))+aincr)) + enddo + write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') + & i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3) + write (iout,'(a)') + enddo + do j=1,nres + do k=1,3 + dc(k,j)=temp(k,j) + enddo + enddo + phi(i+3)=phii + enddo + return + end diff --git a/source/unres/src-HCD-5D/checkder_p.F b/source/unres/src-HCD-5D/checkder_p.F index d1f8473..e7f0c1c 100644 --- a/source/unres/src-HCD-5D/checkder_p.F +++ b/source/unres/src-HCD-5D/checkder_p.F @@ -1,182 +1,3 @@ - subroutine check_cartgrad -C Check the gradient of Cartesian coordinates in internal coordinates. - implicit none - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.DERIV' - double precision temp(6,maxres),xx(3),gg(3),thet,theti,phii,alphi, - & omegi,aincr2 - integer indmat - integer i,ii,j,k - indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 - integer nf -* -* Check the gradient of the virtual-bond and SC vectors in the internal -* coordinates. -* - print '("Calling CHECK_ECART",1pd12.3)',aincr - write (iout,'("Calling CHECK_ECART",1pd12.3)') aincr - aincr2=0.5d0*aincr - call chainbuild_extconf - call cartder - write (iout,'(a)') '**************** dx/dalpha' - write (iout,'(a)') - do i=2,nres-1 - alphi=alph(i) - alph(i)=alph(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild_extconf - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') - & i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - alph(i)=alphi - call chainbuild_extconf - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/domega' - write (iout,'(a)') - do i=2,nres-1 - omegi=omeg(i) - omeg(i)=omeg(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild_extconf - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k+3,i))/ - & (aincr*dabs(dxds(k+3,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') - & i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - omeg(i)=omegi - call chainbuild_extconf - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/dtheta' - write (iout,'(a)') - do i=3,nres - theti=theta(i) - theta(i)=theta(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild_extconf - do j=i-1,nres-1 - ii = indmat(i-2,j) -c print *,'i=',i-2,' j=',j-1,' ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k,ii))/ - & (aincr*dabs(dxdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - write (iout,'(a)') - theta(i)=theti - call chainbuild_extconf - enddo - write (iout,'(a)') '***************** dx/dphi' - write (iout,'(a)') - do i=4,nres - phi(i)=phi(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild_extconf - do j=i-1,nres-1 - ii = indmat(i-2,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ - & (aincr*dabs(dxdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - phi(i)=phi(i)-aincr - call chainbuild_extconf - enddo - write (iout,'(a)') '****************** ddc/dtheta' - do i=1,nres-2 - thet=theta(i+2) - theta(i+2)=thet+aincr - do j=i,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild_extconf - do j=i+1,nres-1 - ii = indmat(i,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k,ii))/ - & (aincr*dabs(dcdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - theta(i+2)=thet - enddo - write (iout,'(a)') '******************* ddc/dphi' - do i=1,nres-3 - phii=phi(i+3) - phi(i+3)=phii+aincr - do j=1,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild_extconf - do j=i+2,nres-1 - ii = indmat(i+1,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ - & (aincr*dabs(dcdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - phi(i+3)=phii - enddo - return - end C---------------------------------------------------------------------------- subroutine check_ecart C Check the gradient of the energy in Cartesian coordinates. @@ -196,6 +17,8 @@ C Check the gradient of the energy in Cartesian coordinates. double precision energia(0:n_ene),energia1(0:n_ene) double precision aincr2,etot,etot1,etot2 double precision dist,alpha,beta + double precision funcgrad,ff + external funcgrad integer nf integer uiparm(1) double precision urparm(1) @@ -213,7 +36,11 @@ C Check the gradient of the energy in Cartesian coordinates. call etotal(energia(0)) etot=energia(0) call enerprint(energia(0)) +#ifdef LBFGS + ff=funcgrad(x,g) +#else call gradient(nvar,x,nf,g,uiparm,urparm,fdum) +#endif icall =1 do i=1,nres write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) @@ -320,17 +147,19 @@ C Check the gradient of the energy in Cartesian coordinates. call flush(iout) !el call enerprint(energia) !elwrite(iout,*) 'Calling CHECK_ECARTINT if' - call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) +c call flush(iout) +c write (iout,*) "enter cartgrad" +c call flush(iout) call cartgrad +c Transform the gradient to the CA-SC basis + call grad_transform !elwrite(iout,*) 'Calling CHECK_ECARTINT if' - write (iout,*) "exit cartgrad" - call flush(iout) +c write (iout,*) "exit cartgrad" +c call flush(iout) icall =1 - do i=1,nres - write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) - enddo +c do i=1,nres +c write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) +c enddo do j=1,3 grad_s(j,0)=gcart(j,0) enddo @@ -342,18 +171,20 @@ C Check the gradient of the energy in Cartesian coordinates. enddo enddo else - write(iout,*) 'Calling CHECK_ECARTIN else.' +c write(iout,*) 'Calling CHECK_ECARTIN else.' !- split gradient check call zerograd call etotal_long(energia) call enerprint(energia(0)) !el call enerprint(energia) - call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) +c call flush(iout) +c write (iout,*) "enter cartgrad" +c call flush(iout) call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) +c Transform the gradient to CA-SC coordinates + call grad_transform +c write (iout,*) "exit cartgrad" +c call flush(iout) icall =1 write (iout,*) "longrange grad" do i=1,nres @@ -373,11 +204,13 @@ C Check the gradient of the energy in Cartesian coordinates. call etotal_short(energia) call enerprint(energia(0)) call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) +c write (iout,*) "enter cartgrad" +c call flush(iout) call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) +c write (iout,*) "exit cartgrad" +c call flush(iout) +c Transform the gradient to CA-SC basis + call grad_transform icall =1 write (iout,*) "shortrange grad" do i=1,nres @@ -926,6 +759,8 @@ C Check the gradient of energy in internal coordinates. character*6 key double precision fdum external fdum + double precision funcgrad,ff + external funcgrad integer i,ii,nf double precision xi,etot,etot1,etot2 call zerograd @@ -955,7 +790,15 @@ c aincr=1.0D-7 nf=1 nfl=3 cd write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar) +c write (iout,*) "Before gradient" +c call flush(iout) +#ifdef LBFGS + ff=funcgrad(x,gana) +#else call gradient(nvar,x,nf,gana,uiparm,urparm,fdum) +#endif +c write (iout,*) "After gradient" +c call flush(iout) cd write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar) icall=1 do i=1,nvar @@ -971,7 +814,7 @@ cd write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar) call etotal(energia2(0)) etot2=energia2(0) gg(i)=(etot2-etot1)/aincr - write (iout,*) i,etot1,etot2 +c write (iout,*) i,etot1,etot2 x(i)=xi enddo write (iout,'(/2a)')' Variable Numerical Analytical', diff --git a/source/unres/src-HCD-5D/contact_cp.F b/source/unres/src-HCD-5D/contact_cp.F new file mode 100644 index 0000000..f2101e6 --- /dev/null +++ b/source/unres/src-HCD-5D/contact_cp.F @@ -0,0 +1,1007 @@ + subroutine contact_cp(var,var2,iff,ieval,in_pdb) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.SBRIDGE' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.FRAG' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.MINIM' + + character*50 linia + integer nf,ij(4) + double precision energy(0:n_ene) + double precision var(maxvar),var2(maxvar) + double precision time0,time1 + integer iff(maxres),ieval + double precision theta1(maxres),phi1(maxres),alph1(maxres), + & omeg1(maxres) + logical debug + + debug=.false. +c debug=.true. + if (ieval.eq.-1) debug=.true. + + +c +c store selected dist. constrains from 1st structure +c +#ifdef OSF +c Intercept NaNs in the coordinates +c write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,nvar + x_sum=x_sum+var(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** contact_cp : Found NaN in coordinates" + call flush(iout) + print *," *** contact_cp : Found NaN in coordinates" + return + endif +#endif + + + call var_to_geom(nvar,var) + call chainbuild + nhpb0=nhpb + ind=0 + do i=1,nres-3 + do j=i+3,nres + ind=ind+1 + if ( iff(i).eq.1.and.iff(j).eq.1 ) then +c d0(ind)=DIST(i,j) +c w(ind)=10.0 + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=10.0 + dhpb(nhpb)=DIST(i,j) + else +c w(ind)=0.0 + endif + enddo + enddo + call hpb_partition + + do i=1,nres + theta1(i)=theta(i) + phi1(i)=phi(i) + alph1(i)=alph(i) + omeg1(i)=omeg(i) + enddo + +c +c freeze sec.elements from 2nd structure +c + do i=1,nres + mask_phi(i)=1 + mask_theta(i)=1 + mask_side(i)=1 + enddo + + call var_to_geom(nvar,var2) + call secondary2(debug) + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) +c mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) +c mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + else + do i=bfrag(4,j),bfrag(3,j) +c mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + endif + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) +c mask(i)=0 + mask_phi(i)=0 + mask_theta(i)=0 + enddo + enddo + mask_r=.true. + +c +c copy selected res from 1st to 2nd structure +c + + do i=1,nres + if ( iff(i).eq.1 ) then + theta(i)=theta1(i) + phi(i)=phi1(i) + alph(i)=alph1(i) + omeg(i)=omeg1(i) + endif + enddo + + if(debug) then +c +c prepare description in linia variable +c + iwsk=0 + nf=0 + if (iff(1).eq.1) then + iwsk=1 + nf=nf+1 + ij(nf)=1 + endif + do i=2,nres + if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then + iwsk=1 + nf=nf+1 + ij(nf)=i + endif + if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then + iwsk=0 + nf=nf+1 + ij(nf)=i-1 + endif + enddo + if (iff(nres).eq.1) then + nf=nf+1 + ij(nf)=nres + endif + + write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') + & "SELECT",ij(1)-1,"-",ij(2)-1, + & ",",ij(3)-1,"-",ij(4)-1 + + endif +c +c run optimization +c + call contact_cp_min(var,ieval,in_pdb,linia,debug) + + return + end + + subroutine contact_cp_min(var,ieval,in_pdb,linia,debug) +c +c input : theta,phi,alph,omeg,in_pdb,linia,debug +c output : var,ieval +c + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SBRIDGE' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + include 'COMMON.FRAG' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.MINIM' + + character*50 linia + integer nf,ij(4) + double precision energy(0:n_ene) + double precision var(maxvar) + double precision time0,time1 + integer ieval,info(3) + logical debug,fail,check_var,reduce,change + + write(iout,'(a20,i6,a20)') + & '------------------',in_pdb,'-------------------' + + if (debug) then + call chainbuild + call write_pdb(1000+in_pdb,'combined structure',0d0) +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + endif + +c +c run optimization of distances +c +c uses d0(),w() and mask() for frozen 2D +c +ctest--------------------------------------------- +ctest NX=NRES-3 +ctest NY=((NRES-4)*(NRES-5))/2 +ctest call distfit(debug,5000) + + do i=1,nres + mask_side(i)=0 + enddo + + ipot01=ipot + maxmin01=maxmin + maxfun01=maxfun +c wstrain01=wstrain + wsc01=wsc + wscp01=wscp + welec01=welec + wvdwpp01=wvdwpp +c wang01=wang + wscloc01=wscloc + wtor01=wtor + wtor_d01=wtor_d + + ipot=6 + maxmin=2000 + maxfun=4000 +c wstrain=1.0 + wsc=0.0 + wscp=0.0 + welec=0.0 + wvdwpp=0.0 +c wang=0.0 + wscloc=0.0 + wtor=0.0 + wtor_d=0.0 + + call geom_to_var(nvar,var) +cde change=reduce(var) + if (check_var(var,info)) then + write(iout,*) 'cp_min error in input' + print *,'cp_min error in input' + return + endif + +cd call etotal(energy(0)) +cd call enerprint(energy(0)) +cd call check_eint + +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif +cdtest call minimize(etot,var,iretcode,nfun) +cdtest write(iout,*)'SUMSL return code is',iretcode,' eval SDIST',nfun +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + +cd call etotal(energy(0)) +cd call enerprint(energy(0)) +cd call check_eint + + do i=1,nres + mask_side(i)=1 + enddo + + ipot=ipot01 + maxmin=maxmin01 + maxfun=maxfun01 +c wstrain=wstrain01 + wsc=wsc01 + wscp=wscp01 + welec=welec01 + wvdwpp=wvdwpp01 +c wang=wang01 + wscloc=wscloc01 + wtor=wtor01 + wtor_d=wtor_d01 +ctest-------------------------------------------------- + + if(debug) then +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,a)')' Time for distfit ',time1-time0,' sec' + call write_pdb(2000+in_pdb,'distfit structure',0d0) + endif + + + ipot0=ipot + maxmin0=maxmin + maxfun0=maxfun + wstrain0=wstrain +c +c run soft pot. optimization +c with constrains: +c nhpb,ihpb(),jhpb(),forcon(),dhpb() and hpb_partition +c and frozen 2D: +c mask_phi(),mask_theta(),mask_side(),mask_r +c + ipot=6 + maxmin=2000 + maxfun=4000 + +cde change=reduce(var) +cde if (check_var(var,info)) write(iout,*) 'error before soft' +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + + write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, + & nfun/(time1-time0),' SOFT eval/s' + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(3000+in_pdb,'soft structure',etot) + endif +c +c run full UNRES optimization with constrains and frozen 2D +c the same variables as soft pot. optimizatio +c + ipot=ipot0 + maxmin=maxmin0 + maxfun=maxfun0 +c +c check overlaps before calling full UNRES minim +c + call var_to_geom(nvar,var) + call chainbuild + call etotal(energy(0)) +#ifdef OSF + write(iout,*) 'N7 ',energy(0) + if (energy(0).ne.energy(0)) then + write(iout,*) 'N7 error - gives NaN',energy(0) + endif +#endif + ieval=1 + if (energy(1).eq.1.0d20) then + write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw=1d20',energy(1) + call overlap_sc(fail) + if(.not.fail) then + call etotal(energy(0)) + ieval=ieval+1 + write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw after',energy(1) + else + mask_r=.false. + nhpb= nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + return + endif + endif + call flush(iout) +c +cdte time0=MPI_WTIME() +cde change=reduce(var) +cde if (check_var(var,info)) then +cde write(iout,*) 'error before mask dist' +cde call var_to_geom(nvar,var) +cde call chainbuild +cde call write_pdb(10000+in_pdb,'before mask dist',etot) +cde endif +cdte call minimize(etot,var,iretcode,nfun) +cdte write(iout,*)'SUMSL MASK DIST return code is',iretcode, +cdte & ' eval ',nfun +cdte ieval=ieval+nfun +cdte +cdte time1=MPI_WTIME() +cdte write (iout,'(a,f6.2,f8.2,a)') +cdte & ' Time for mask dist min.',time1-time0, +cdte & nfun/(time1-time0),' eval/s' +cdte call flush(iout) + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(4000+in_pdb,'mask dist',etot) + endif +c +c switch off freezing of 2D and +c run full UNRES optimization with constrains +c + mask_r=.false. +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif +cde change=reduce(var) +cde if (check_var(var,info)) then +cde write(iout,*) 'error before dist' +cde call var_to_geom(nvar,var) +cde call chainbuild +cde call write_pdb(11000+in_pdb,'before dist',etot) +cde endif + + call minimize(etot,var,iretcode,nfun) + +cde change=reduce(var) +cde if (check_var(var,info)) then +cde write(iout,*) 'error after dist',ico +cde call var_to_geom(nvar,var) +cde call chainbuild +cde call write_pdb(12000+in_pdb+ico*1000,'after dist',etot) +cde endif + write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun + ieval=ieval+nfun + +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for dist min.',time1-time0, + & nfun/(time1-time0),' eval/s' +cde call etotal(energy(0)) +cde write(iout,*) 'N7 after dist',energy(0) +c call flush(iout) + + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(in_pdb,linia,etot) + endif +c +c reset constrains +c + nhpb= nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + + return + end +c-------------------------------------------------------- + subroutine softreg + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.GEO' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.VAR' + include 'COMMON.CONTROL' + include 'COMMON.SBRIDGE' + include 'COMMON.FFIELD' + include 'COMMON.MINIM' + include 'COMMON.INTERACT' +c + include 'COMMON.FRAG' + integer iff(maxres) + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision var(maxvar) + integer ieval +c + logical debug,ltest,fail + character*50 linia +c + linia='test' + debug=.true. + in_pdb=0 + + + +c------------------------ +c +c freeze sec.elements +c + do i=1,nres + mask_phi(i)=1 + mask_theta(i)=1 + mask_side(i)=1 + iff(i)=0 + enddo + + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + if (bfrag(3,j).le.bfrag(4,j)) then + do i=bfrag(3,j),bfrag(4,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + else + do i=bfrag(4,j),bfrag(3,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + endif + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + mask_phi(i)=0 + mask_theta(i)=0 + iff(i)=1 + enddo + enddo + mask_r=.true. + + + + nhpb0=nhpb +c +c store dist. constrains +c + do i=1,nres-3 + do j=i+3,nres + if ( iff(i).eq.1.and.iff(j).eq.1 ) then + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=0.1 + dhpb(nhpb)=DIST(i,j) + endif + enddo + enddo + call hpb_partition + + if (debug) then + call chainbuild + call write_pdb(100+in_pdb,'input reg. structure',0d0) + endif + + + ipot0=ipot + maxmin0=maxmin + maxfun0=maxfun + wstrain0=wstrain + wang0=wang +c +c run soft pot. optimization +c + ipot=6 + wang=3.0 + maxmin=2000 + maxfun=4000 + call geom_to_var(nvar,var) +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + + write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, + & nfun/(time1-time0),' SOFT eval/s' + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(300+in_pdb,'soft structure',etot) + endif +c +c run full UNRES optimization with constrains and frozen 2D +c the same variables as soft pot. optimizatio +c + ipot=ipot0 + wang=wang0 + maxmin=maxmin0 + maxfun=maxfun0 +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'SUMSL MASK DIST return code is',iretcode, + & ' eval ',nfun + ieval=nfun + +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)') + & ' Time for mask dist min.',time1-time0, + & nfun/(time1-time0),' eval/s' + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(400+in_pdb,'mask & dist',etot) + endif +c +c switch off constrains and +c run full UNRES optimization with frozen 2D +c + +c +c reset constrains +c + nhpb_c=nhpb + nhpb=nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + + +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'SUMSL MASK return code is',iretcode,' eval ',nfun + ieval=ieval+nfun + +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for mask min.',time1-time0, + & nfun/(time1-time0),' eval/s' + + + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(500+in_pdb,'mask 2d frozen',etot) + endif + + mask_r=.false. + + +c +c run full UNRES optimization with constrains and NO frozen 2D +c + + nhpb=nhpb_c + link_start=1 + link_end=nhpb + maxfun=maxfun0/5 + + do ico=1,5 + + wstrain=wstrain0/ico + +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,'(a10,f6.3,a14,i3,a6,i5)') + & ' SUMSL DIST',wstrain,' return code is',iretcode, + & ' eval ',nfun + ieval=nfun + +#ifdef MPI + time1=MPI_WTIME() +#else + time0=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)') + & ' Time for dist min.',time1-time0, + & nfun/(time1-time0),' eval/s' + if (debug) then + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(600+in_pdb+ico,'dist cons',etot) + endif + + enddo +c + nhpb=nhpb0 + link_start=1 + link_end=nhpb + wstrain=wstrain0 + maxfun=maxfun0 + + +c + if (minim) then +#ifdef MPI + time0=MPI_WTIME() +#else + time0=tcpu() +#endif + call minimize(etot,var,iretcode,nfun) + write(iout,*)'------------------------------------------------' + write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, + & '+ DIST eval',ieval + +#ifdef MPI + time1=MPI_WTIME() +#else + time1=tcpu() +#endif + write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, + & nfun/(time1-time0),' eval/s' + + + call var_to_geom(nvar,var) + call chainbuild + call write_pdb(999,'full min',etot) + endif + + return + end + + + subroutine beta_slide(i1,i2,i3,i4,i5,ieval,ij) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.FRAG' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.FFIELD' + include 'COMMON.MINIM' + include 'COMMON.CHAIN' + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision var(maxvar) + integer jdata(5),isec(maxres) +c + jdata(1)=i1 + jdata(2)=i2 + jdata(3)=i3 + jdata(4)=i4 + jdata(5)=i5 + + call secondary2(.false.) + + do i=1,nres + isec(i)=0 + enddo + do j=1,nbfrag + do i=bfrag(1,j),bfrag(2,j) + isec(i)=1 + enddo + do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) + isec(i)=1 + enddo + enddo + do j=1,nhfrag + do i=hfrag(1,j),hfrag(2,j) + isec(i)=2 + enddo + enddo + +c +c cut strands at the ends +c + if (jdata(2)-jdata(1).gt.3) then + jdata(1)=jdata(1)+1 + jdata(2)=jdata(2)-1 + if (jdata(3).lt.jdata(4)) then + jdata(3)=jdata(3)+1 + jdata(4)=jdata(4)-1 + else + jdata(3)=jdata(3)-1 + jdata(4)=jdata(4)+1 + endif + endif + +cv call chainbuild +cv call etotal(energy(0)) +cv etot=energy(0) +cv write(iout,*) nnt,nct,etot +cv call write_pdb(ij*100,'first structure',etot) +cv write(iout,*) 'N16 test',(jdata(i),i=1,5) + +c------------------------ +c generate constrains +c + ishift=jdata(5)-2 + if(ishift.eq.0) ishift=-2 + nhpb0=nhpb + call chainbuild + do i=jdata(1),jdata(2) + isec(i)=-1 + if(jdata(4).gt.jdata(3))then + do j=jdata(3)+i-jdata(1)-2,jdata(3)+i-jdata(1)+2 + isec(j)=-1 +cd print *,i,j,j+ishift + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=1000.0 + dhpb(nhpb)=DIST(i,j+ishift) + enddo + else + do j=jdata(3)-i+jdata(1)+2,jdata(3)-i+jdata(1)-2,-1 + isec(j)=-1 +cd print *,i,j,j+ishift + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=1000.0 + dhpb(nhpb)=DIST(i,j+ishift) + enddo + endif + enddo + + do i=nnt,nct-2 + do j=i+2,nct + if(isec(i).gt.0.or.isec(j).gt.0) then +cd print *,i,j + nhpb=nhpb+1 + ihpb(nhpb)=i + jhpb(nhpb)=j + forcon(nhpb)=0.1 + dhpb(nhpb)=DIST(i,j) + endif + enddo + enddo + + call hpb_partition + + call geom_to_var(nvar,var) + maxfun0=maxfun + wstrain0=wstrain + maxfun=4000/5 + + do ico=1,5 + + wstrain=wstrain0/ico + +cv time0=MPI_WTIME() + call minimize(etot,var,iretcode,nfun) + write(iout,'(a10,f6.3,a14,i3,a6,i5)') + & ' SUMSL DIST',wstrain,' return code is',iretcode, + & ' eval ',nfun + ieval=ieval+nfun +cv time1=MPI_WTIME() +cv write (iout,'(a,f6.2,f8.2,a)') +cv & ' Time for dist min.',time1-time0, +cv & nfun/(time1-time0),' eval/s' +cv call var_to_geom(nvar,var) +cv call chainbuild +cv call write_pdb(ij*100+ico,'dist cons',etot) + + enddo +c + nhpb=nhpb0 + call hpb_partition + wstrain=wstrain0 + maxfun=maxfun0 +c +cd print *,etot + wscloc0=wscloc + wscloc=10.0 + call sc_move(nnt,nct,100,100d0,nft_sc,etot) + wscloc=wscloc0 +cv call chainbuild +cv call etotal(energy(0)) +cv etot=energy(0) +cv call write_pdb(ij*100+10,'sc_move',etot) +cd call intout +cd print *,nft_sc,etot + + return + end + + subroutine beta_zip(i1,i2,ieval,ij) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.GEO' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' + include 'COMMON.FRAG' + include 'COMMON.SBRIDGE' + include 'COMMON.CONTROL' + include 'COMMON.FFIELD' + include 'COMMON.MINIM' + include 'COMMON.CHAIN' + double precision time0,time1 + double precision energy(0:n_ene),ee + double precision var(maxvar) + character*10 test + +cv call chainbuild +cv call etotal(energy(0)) +cv etot=energy(0) +cv write(test,'(2i5)') i1,i2 +cv call write_pdb(ij*100,test,etot) +cv write(iout,*) 'N17 test',i1,i2,etot,ij + +c +c generate constrains +c + nhpb0=nhpb + nhpb=nhpb+1 + ihpb(nhpb)=i1 + jhpb(nhpb)=i2 + forcon(nhpb)=1000.0 + dhpb(nhpb)=4.0 + + call hpb_partition + + call geom_to_var(nvar,var) + maxfun0=maxfun + wstrain0=wstrain + maxfun=1000/5 + + do ico=1,5 + wstrain=wstrain0/ico +cv time0=MPI_WTIME() + call minimize(etot,var,iretcode,nfun) + write(iout,'(a10,f6.3,a14,i3,a6,i5)') + & ' SUMSL DIST',wstrain,' return code is',iretcode, + & ' eval ',nfun + ieval=ieval+nfun +cv time1=MPI_WTIME() +cv write (iout,'(a,f6.2,f8.2,a)') +cv & ' Time for dist min.',time1-time0, +cv & nfun/(time1-time0),' eval/s' +c do not comment the next line + call var_to_geom(nvar,var) +cv call chainbuild +cv call write_pdb(ij*100+ico,'dist cons',etot) + enddo + + nhpb=nhpb0 + call hpb_partition + wstrain=wstrain0 + maxfun=maxfun0 + +cv call etotal(energy(0)) +cv etot=energy(0) +cv write(iout,*) 'N17 test end',i1,i2,etot,ij + + + return + end +c---------------------------------------------------------------------------- + + subroutine write_pdb(npdb,titelloc,ee) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.IOUNITS' + character*50 titelloc1 + character*(*) titelloc + character*3 zahl + character*5 liczba5 + double precision ee + integer npdb,ilen + external ilen + + titelloc1=titelloc + lenpre=ilen(prefix) + if (npdb.lt.1000) then + call numstr(npdb,zahl) + open(ipdb,file=prefix(:lenpre)//'@@'//zahl//'.pdb') + else + if (npdb.lt.10000) then + write(liczba5,'(i1,i4)') 0,npdb + else + write(liczba5,'(i5)') npdb + endif + open(ipdb,file=prefix(:lenpre)//'@@'//liczba5//'.pdb') + endif + call pdbout(ee,titelloc1,ipdb) + close(ipdb) + return + end + diff --git a/source/unres/src-HCD-5D/elecont.f b/source/unres/src-HCD-5D/elecont.f index 73325f2..f43b037 100644 --- a/source/unres/src-HCD-5D/elecont.f +++ b/source/unres/src-HCD-5D/elecont.f @@ -82,6 +82,8 @@ c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ zj=mod(zj,boxzsize) if (zj.lt.0) zj=zj+boxzsize dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + write (iout,*) "i",i,xi,yi,zi," j",j,xj,yj,xj,"dist", + & dsqrt(dist_init) xj_safe=xj yj_safe=yj zj_safe=zj @@ -141,6 +143,7 @@ c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ endif ees=ees+eesij evdw=evdw+evdwij*sss + write (iout,*) "i"," j",j," rij",dsqrt(rij)," eesij",eesij 4 continue 1 continue if (lprint) then @@ -251,7 +254,7 @@ c-------------------------------------------- include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.CONTROL' diff --git a/source/unres/src-HCD-5D/energy_p_new-sep_barrier.F b/source/unres/src-HCD-5D/energy_p_new-sep_barrier.F index c7babd5..253dd88 100644 --- a/source/unres/src-HCD-5D/energy_p_new-sep_barrier.F +++ b/source/unres/src-HCD-5D/energy_p_new-sep_barrier.F @@ -78,7 +78,7 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' dimension gg(3) c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 @@ -164,7 +164,7 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' dimension gg(3) c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 @@ -1368,7 +1368,11 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -1442,9 +1446,11 @@ cd enddo eello_turn3=0.0d0 eello_turn4=0.0d0 ind=0 +#ifdef FOURBODY do i=1,nres num_cont_hb(i)=0 enddo +#endif cd print '(a)','Enter EELEC' cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e do i=1,nres @@ -1481,7 +1487,9 @@ C & .or. itype(i+4).eq.ntyp1 num_conti=0 call eelecij_scale(i,i+2,ees,evdw1,eel_loc) if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo do i=iturn4_start,iturn4_end if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 @@ -1505,11 +1513,15 @@ C & .or. itype(i-1).eq.ntyp1 if (ymedi.lt.0) ymedi=ymedi+boxysize zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif call eelecij_scale(i,i+3,ees,evdw1,eel_loc) if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) & call eturn4(i,eello_turn4) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i c c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 @@ -1534,8 +1546,10 @@ C & .or. itype(i-1).eq.ntyp1 if (ymedi.lt.0) ymedi=ymedi+boxysize zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) +c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif do j=ielstart(i),ielend(i) if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1 C & .or.itype(j+2).eq.ntyp1 @@ -1543,7 +1557,9 @@ C & .or.itype(j-1).eq.ntyp1 &) cycle call eelecij_scale(i,j,ees,evdw1,eel_loc) enddo ! j +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i c write (iout,*) "Number of loop steps in EELEC:",ind cd do i=1,nres @@ -1570,7 +1586,11 @@ C------------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -2249,6 +2269,7 @@ C Remaining derivatives of eello enddo ENDIF +#ifdef FOURBODY C Change 12/26/95 to calculate four-body contributions to H-bonding energy c if (j.gt.i+1 .and. num_conti.le.maxconts) then if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 @@ -2433,6 +2454,7 @@ cgrad ghalfm=0.5D0*gggm(k) endif ! num_conti.le.maxconts endif ! fcont.gt.0 endif ! j.gt.i+1 +#endif if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then do k=1,4 do l=1,3 @@ -2468,7 +2490,7 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' diff --git a/source/unres/src-HCD-5D/energy_p_new_barrier.F b/source/unres/src-HCD-5D/energy_p_new_barrier.F index e9ec117..b36b9a8 100644 --- a/source/unres/src-HCD-5D/energy_p_new_barrier.F +++ b/source/unres/src-HCD-5D/energy_p_new_barrier.F @@ -324,6 +324,7 @@ C else esccor=0.0d0 endif +#ifdef FOURBODY C print *,"PRZED MULIt" c print *,"Processor",myrank," computed Usccorr" C @@ -352,6 +353,7 @@ c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr, c & n_corr1 c call flush(iout) endif +#endif c print *,"Processor",myrank," computed Ucorr" c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode if (nsaxs.gt.0 .and. saxs_mode.eq.0) then @@ -1314,9 +1316,16 @@ C Bartek write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, & estr,wbond,ebe,wang, & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, +#ifdef FOURBODY & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr, + & ecorr5,wcorr5,ecorr6,wcorr6, +#endif + & eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4, +#ifdef FOURBODY + & eello_turn6,wturn6, +#endif + & esccor,wsccor,edihcnstr, & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce, & etube,wtube,esaxs,wsaxs,ehomology_constr, & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, @@ -1334,13 +1343,17 @@ C Bartek & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, & ' (SS bridges & dist. cnstr.)'/ +#ifdef FOURBODY & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ @@ -1361,9 +1374,16 @@ C Bartek write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, & estr,wbond,ebe,wang, & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, +#ifdef FOURBODY & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr, + & ecorr5,wcorr5,ecorr6,wcorr6, +#endif + & eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4, +#ifdef FOURBODY + & eello_turn6,wturn6, +#endif + & esccor,wsccor,edihcnstr, & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, & etube,wtube,esaxs,wsaxs,ehomology_constr, & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, @@ -1380,13 +1400,17 @@ C Bartek & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, & ' (SS bridges & dist. restr.)'/ +#ifdef FOURBODY & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ @@ -1425,7 +1449,10 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif double precision gg(3) double precision evdw,evdwij integer i,j,k,itypi,itypj,itypi1,num_conti,iint @@ -1491,6 +1518,7 @@ cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) cgrad enddo cgrad enddo C +#ifdef FOURBODY C 12/1/95, revised on 5/20/97 C C Calculate the contact function. The ith column of the array JCONT will @@ -1546,10 +1574,13 @@ cd write (iout,'(2i3,3f10.5)') cd & i,j,(gacont(kk,num_conti,i),kk=1,3) endif endif +#endif enddo ! j enddo ! iint C Change 12/1/95 +#ifdef FOURBODY num_cont(i)=num_conti +#endif enddo ! i do i=1,nct do j=1,3 @@ -2548,7 +2579,7 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' dimension gg(3) cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct evdw=0.0D0 @@ -2622,7 +2653,7 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -2946,7 +2977,7 @@ C-------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -3197,6 +3228,7 @@ c & EE(1,2,iti),EE(2,2,i) c write(iout,*) "Macierz EUG", c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2), c & eug(2,2,i-2) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2)) @@ -3205,6 +3237,7 @@ c & eug(2,2,i-2) call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2)) call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2)) endif +#endif else do k=1,2 Ub2(k,i-2)=0.0d0 @@ -3249,6 +3282,7 @@ c mu(k,i-2)=Ub2(k,i-2) cd write (iout,*) 'mu1',mu1(:,i-2) cd write (iout,*) 'mu2',mu2(:,i-2) cd write (iout,*) 'mu',i-2,mu(:,i-2) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) & then call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2)) @@ -3267,7 +3301,9 @@ C Vectors and matrices dependent on a single virtual-bond dihedral. call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2)) call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2)) endif +#endif enddo +#ifdef FOURBODY C Matrices dependent on two consecutive virtual-bond dihedrals. C The order of matrices is from left to right. if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) @@ -3284,6 +3320,7 @@ c do i=max0(ivec_start,2),ivec_end call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i)) enddo endif +#endif #if defined(MPI) && defined(PARMAT) #ifdef DEBUG c if (fg_rank.eq.0) then @@ -3352,6 +3389,7 @@ c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1) call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1), & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0), & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1), @@ -3427,6 +3465,7 @@ c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1) & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0), & MPI_MAT2,FG_COMM1,IERR) endif +#endif #else c Passes matrix info through the ring isend=fg_rank1 @@ -3471,6 +3510,7 @@ c call flush(iout) & iprev,6600+irecv,FG_COMM,status,IERR) c write (iout,*) "Gather PRECOMP12" c call flush(iout) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1, @@ -3490,6 +3530,7 @@ c call flush(iout) & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1, & MPI_PRECOMP23(lenrecv), & iprev,9900+irecv,FG_COMM,status,IERR) +#endif c write (iout,*) "Gather PRECOMP23" c call flush(iout) endif @@ -3565,7 +3606,11 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -3638,9 +3683,11 @@ cd enddo eello_turn3=0.0d0 eello_turn4=0.0d0 ind=0 +#ifdef FOURBODY do i=1,nres num_cont_hb(i)=0 enddo +#endif cd print '(a)','Enter EELEC' cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e do i=1,nres @@ -3690,7 +3737,9 @@ c end if num_conti=0 call eelecij(i,i+2,ees,evdw1,eel_loc) if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo do i=iturn4_start,iturn4_end if (i.lt.1) cycle @@ -3746,12 +3795,16 @@ c endif zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif c write(iout,*) "JESTEM W PETLI" call eelecij(i,i+3,ees,evdw1,eel_loc) if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) & call eturn4(i,eello_turn4) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i C Loop over all neighbouring boxes C do xshift=-1,1 @@ -3818,7 +3871,9 @@ c go to 166 c endif c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif C I TU KURWA do j=ielstart(i),ielend(i) C do j=16,17 @@ -3834,7 +3889,9 @@ c & .or.itype(j-1).eq.ntyp1 &) cycle call eelecij(i,j,ees,evdw1,eel_loc) enddo ! j +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i C enddo ! zshift C enddo ! yshift @@ -3865,7 +3922,11 @@ C------------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -4655,6 +4716,7 @@ C Remaining derivatives of eello ENDIF C Change 12/26/95 to calculate four-body contributions to H-bonding energy c if (j.gt.i+1 .and. num_conti.le.maxconts) then +#ifdef FOURBODY if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 & .and. num_conti.le.maxconts) then c write (iout,*) i,j," entered corr" @@ -4845,6 +4907,7 @@ cdiag enddo endif ! num_conti.le.maxconts endif ! fcont.gt.0 endif ! j.gt.i+1 +#endif if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then do k=1,4 do l=1,3 @@ -4877,7 +4940,7 @@ C Third- and fourth-order contributions from turns include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -5060,7 +5123,7 @@ C Third- and fourth-order contributions from turns include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -8726,6 +8789,7 @@ c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp return end +#ifdef FOURBODY c---------------------------------------------------------------------------- subroutine multibody(ecorr) C This subroutine calculates multi-body contributions to energy following @@ -8738,6 +8802,8 @@ C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision gx(3),gx1(3) logical lprn @@ -8792,6 +8858,8 @@ c------------------------------------------------------------------------------ include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.SHIELD' double precision gx(3),gx1(3) logical lprn @@ -8846,6 +8914,8 @@ C This subroutine calculates multi-body contributions to hydrogen-bonding include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.CONTROL' include 'COMMON.LOCAL' double precision gx(3),gx1(3),time00 @@ -9139,6 +9209,8 @@ c------------------------------------------------------------------------------ parameter (max_cont=maxconts) parameter (max_dim=26) include "COMMON.CONTACTS" + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision zapas(max_dim,maxconts,max_fg_procs), & zapas_recv(max_dim,maxconts,max_fg_procs) common /przechowalnia/ zapas @@ -9210,6 +9282,8 @@ C This subroutine calculates multi-body contributions to hydrogen-bonding include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.CHAIN' include 'COMMON.CONTROL' include 'COMMON.SHIELD' @@ -9580,6 +9654,8 @@ c------------------------------------------------------------------------------ parameter (max_cont=maxconts) parameter (max_dim=70) include "COMMON.CONTACTS" + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision zapas(max_dim,maxconts,max_fg_procs), & zapas_recv(max_dim,maxconts,max_fg_procs) common /przechowalnia/ zapas @@ -9633,6 +9709,8 @@ c------------------------------------------------------------------------------ include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.SHIELD' include 'COMMON.CONTROL' double precision gx(3),gx1(3) @@ -9808,6 +9886,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -9873,6 +9953,8 @@ C include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10259,6 +10341,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10380,6 +10464,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10784,6 +10870,8 @@ c-------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10924,6 +11012,8 @@ c-------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -11028,6 +11118,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -11213,6 +11305,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -11328,6 +11422,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -11572,6 +11668,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -11890,8 +11988,8 @@ cd write (2,*) 'ekont',ekont cd write (2,*) 'eel_turn6',ekont*eel_turn6 return end - C----------------------------------------------------------------------------- +#endif double precision function scalar(u,v) !DIR$ INLINEALWAYS scalar #ifndef OSF diff --git a/source/unres/src-HCD-5D/energy_split-sep.F b/source/unres/src-HCD-5D/energy_split-sep.F index 4b4711c..c4f6dd4 100644 --- a/source/unres/src-HCD-5D/energy_split-sep.F +++ b/source/unres/src-HCD-5D/energy_split-sep.F @@ -190,6 +190,7 @@ C else call escp_soft_sphere(evdw2,evdw2_14) endif +#ifdef FOURBODY C C 12/1/95 Multi-body terms C @@ -209,6 +210,7 @@ c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) endif +#endif C C If performing constraint dynamics, call the constraint energy C after the equilibration time diff --git a/source/unres/src-HCD-5D/geomout.F b/source/unres/src-HCD-5D/geomout.F index b0156a1..dd45a7d 100644 --- a/source/unres/src-HCD-5D/geomout.F +++ b/source/unres/src-HCD-5D/geomout.F @@ -7,7 +7,7 @@ include 'COMMON.IOUNITS' include 'COMMON.HEADER' include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.MD' #ifdef FIVEDIAG include 'COMMON.LAGRANGE.5diag' @@ -293,7 +293,7 @@ c---------------------------------------------------------------- include 'COMMON.IOUNITS' include 'COMMON.HEADER' include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.MD' include 'COMMON.QRESTR' integer i,j,k @@ -337,7 +337,7 @@ c----------------------------------------------------------------- include 'COMMON.IOUNITS' include 'COMMON.HEADER' include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.MD' include 'COMMON.QRESTR' double precision time @@ -441,7 +441,7 @@ c----------------------------------------------------------------- include 'COMMON.IOUNITS' include 'COMMON.HEADER' include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.MD' include 'COMMON.QRESTR' include 'COMMON.REMD' diff --git a/source/unres/src-HCD-5D/gradient_p.F b/source/unres/src-HCD-5D/gradient_p.F index 1d89e0f..82b8c34 100644 --- a/source/unres/src-HCD-5D/gradient_p.F +++ b/source/unres/src-HCD-5D/gradient_p.F @@ -1,3 +1,4 @@ +#ifndef LBFGS subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) implicit none include 'DIMENSIONS' @@ -36,60 +37,12 @@ c write (iout,*) 'grad 20' if (nf.eq.0) return goto 40 30 call var_to_geom(n,x) - call chainbuild + call chainbuild_extconf c write (iout,*) 'grad 30' C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartder -c write (iout,*) 'grad 40' -c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon +C Transform the gradient to the gradient in angles. C -C Convert the Cartesian gradient into internal-coordinate gradient. -C - ind=0 - ind1=0 - do i=1,nres-2 - gthetai=0.0D0 - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 -c ind=indmat(i,j) -c print *,'GRAD: i=',i,' jc=',j,' ind=',ind - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - enddo - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - enddo - enddo - do j=i+1,nres-1 - ind1=ind1+1 -c ind1=indmat(i,j) -c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 - do k=1,3 - gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) - gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) - enddo - enddo - if (i.gt.1) g(i-1)=gphii - if (n.gt.nphi) g(nphi+i)=gthetai - enddo - if (n.le.nphi+ntheta) goto 10 - do i=2,nres-1 - if (itype(i).ne.10) then - galphai=0.0D0 - gomegai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ialph(i,1))=galphai - g(ialph(i,1)+nside)=gomegai - endif - enddo + 40 call cart2intgrad(n,g) C C Add the components corresponding to local energy terms. C @@ -128,7 +81,7 @@ C------------------------------------------------------------------------- external ufparm integer uiparm(1) double precision urparm(1) - double precision x(maxvar),g(maxvar) + double precision x(maxvar),g(maxvar),gg(maxvar) integer i,j,k,ig,ind,ij,igall double precision f,gthetai,gphii,galphai,gomegai @@ -158,58 +111,33 @@ c write(iout,*) (var(i),i=1,nvar) C C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. C - 40 call cartder + 40 call cart2intgrad(n,gg) C C Convert the Cartesian gradient into internal-coordinate gradient. C ig=0 - ind=nres-2 + ind=nres-2 do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo + IF (mask_phi(i+2).eq.1) THEN ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i + g(ig)=gg(i-1) ENDIF enddo - ind=0 do i=1,nres-2 IF (mask_theta(i+2).eq.1) THEN ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i + g(ig)=gg(nphi+i) ENDIF enddo do i=2,nres-1 - if (itype(i).ne.10) then + if (itype(i).ne.10) then IF (mask_side(i).eq.1) THEN ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai + g(ig)=gg(ialph(i,1)) ENDIF endif enddo @@ -219,11 +147,7 @@ C if (itype(i).ne.10) then IF (mask_side(i).eq.1) THEN ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai + g(ig)=gg(ialph(i,1)+nside) ENDIF endif enddo @@ -267,6 +191,7 @@ cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) cd enddo return end +#endif C------------------------------------------------------------------------- subroutine cartgrad implicit none diff --git a/source/unres/src-HCD-5D/gradient_p.F.new b/source/unres/src-HCD-5D/gradient_p.F.new new file mode 100644 index 0000000..ee8b01a --- /dev/null +++ b/source/unres/src-HCD-5D/gradient_p.F.new @@ -0,0 +1,523 @@ + subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(n),g(n) + integer i,j,k,ind,ind1 + double precision f,gthetai,gphii,galphai,gomegai +c +c This subroutine calculates total internal coordinate gradient. +c Depending on the number of function evaluations, either whole energy +c is evaluated beforehand, Cartesian coordinates and their derivatives in +c internal coordinates are reevaluated or only the cartesian-in-internal +c coordinate derivatives are evaluated. The subroutine was designed to work +c with SUMSL. +c +c + icg=mod(nf,2)+1 + +cd print *,'grad',nf,icg + if (nf-nfl+1) 20,30,40 + 20 call func(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 call var_to_geom(n,x) + call chainbuild +c write (iout,*) 'grad 30' +C +C Transform the gradient to the gradient in angles. +C + 40 call cart2intgrad(n,g) +C +C Add the components corresponding to local energy terms. +C + 10 continue +c Add the usampl contributions + if (usampl) then + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) + enddo + endif + do i=1,nvar +cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) + g(i)=g(i)+gloc(i,icg) + enddo +C Uncomment following three lines for diagnostics. +cd call intout +cd call briefout(0,0.0d0) +cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) + return + end +C------------------------------------------------------------------------- + subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(maxvar),g(maxvar) + integer i,j,k,ig,ind,ij,igall + double precision f,gthetai,gphii,galphai,gomegai + + icg=mod(nf,2)+1 + if (nf-nfl+1) 20,30,40 + 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 continue +#ifdef OSF +c Intercept NaNs in the coordinates +c write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,n + x_sum=x_sum+x(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** grad_restr : Found NaN in coordinates" + call flush(iout) + print *," *** grad_restr : Found NaN in coordinates" + return + endif +#endif + call var_to_geom_restr(n,x) + call chainbuild +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + + ig=0 + ind=nres-2 + do i=2,nres-2 + IF (mask_phi(i+2).eq.1) THEN + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) + enddo + enddo + ig=ig+1 + g(ig)=gphii + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + + ind=0 + do i=1,nres-2 + IF (mask_theta(i+2).eq.1) THEN + ig=ig+1 + gthetai=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) + enddo + enddo + g(ig)=gthetai + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + galphai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + g(ig)=galphai + ENDIF + endif + enddo + + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + gomegai=0.0D0 + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ig)=gomegai + ENDIF + endif + enddo + +C +C Add the components corresponding to local energy terms. +C + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + endif + enddo + enddo + +cd do i=1,ig +cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +cd enddo + return + end +C------------------------------------------------------------------------- + subroutine cartgrad + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +c +c This subrouting calculates total Cartesian coordinate gradient. +c The subroutine chainbuild_cart and energy MUST be called beforehand. +c +#ifdef TIMING + time00=MPI_Wtime() +#endif + icg=1 +#ifdef DEBUG + write (iout,*) "Before sum_gradient" + do i=1,nres-1 + write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) + write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) + enddo + write (iout,*) "gsaxsc, gsaxcx" + do i=1,nres-1 + write (iout,*) i," gsaxsc ",(gsaxsc(j,i),j=1,3) + write (iout,*) i," gsaxsx ",(gsaxsx(j,i),j=1,3) + enddo +#endif + call sum_gradient +#ifdef TIMING +#endif +#ifdef DEBUG + write (iout,*) "After sum_gradient" + do i=1,nres-1 + write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) + write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) + enddo +#endif +c If performing constraint dynamics, add the gradients of the constraint energy + if(usampl.and.totT.gt.eq_time) then +#ifdef DEBUG + write (iout,*) "dudconst, duscdiff, dugamma,dutheta" + write (iout,*) "wumb",wumb + do i=1,nct + write (iout,'(i5,3f10.5,5x,3f10.5,5x,2f10.5)') + & i,(dudconst(j,i),j=1,3),(duscdiff(j,i),j=1,3), + & dugamma(i),dutheta(i) + enddo +#endif + do i=1,nct + do j=1,3 + gradc(j,i,icg)=gradc(j,i,icg)+ + & wumb*(dudconst(j,i)+duscdiff(j,i)) + gradx(j,i,icg)=gradx(j,i,icg)+ + & wumb*(dudxconst(j,i)+duscdiffx(j,i)) + enddo + enddo + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wumb*dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+wumb*dutheta(i) + enddo + endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + call intcartderiv +#ifdef TIMING + time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 +#endif +cd call checkintcartgrad +cd write(iout,*) 'calling int_to_cart' +#ifdef DEBUG + write (iout,*) "gcart, gxcart, gloc before int_to_cart" +#endif + do i=1,nct + do j=1,3 + gcart(j,i)=gradc(j,i,icg) + gxcart(j,i)=gradx(j,i,icg) + enddo +#ifdef DEBUG + if((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then + write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg), + & gloc(ialph(i,1),icg),gloc(ialph(i,1)+nside,icg) + else + write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg) + endif + call flush(iout) +#endif + enddo +#ifdef TIMING + time01=MPI_Wtime() +#endif + call int_to_cart +#ifdef TIMING + time_inttocart=time_inttocart+MPI_Wtime()-time01 +#endif +#ifdef DEBUG + write (iout,*) "gcart and gxcart after int_to_cart" + do i=0,nres-1 + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif +#ifdef TIMING + time_cartgrad=time_cartgrad+MPI_Wtime()-time00 +#endif + return + end +c--------------------------------------------------------------------------- +#ifdef FIVEDIAG + subroutine grad_transform + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +#ifdef DEBUG + write (iout,*)"Converting virtual-bond gradient to CA/SC gradient" +#endif + do i=nres,1,-1 + do j=1,3 + gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i) +! gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i) + enddo +! write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), & +! (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3) + enddo +! Correction: dummy residues + if (nnt.gt.1) then + do j=1,3 + gcart(j,nnt)=gcart(j,nnt)+gcart(j,1) + enddo + endif + if (nct.lt.nres) then + do j=1,3 +! gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres) + gcart(j,nct)=gcart(j,nct)+gcart(j,nres) + enddo + endif +#ifdef DEBUG + write (iout,*) "CA/SC gradient" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif + return + end +#endif +C------------------------------------------------------------------------- + subroutine zerograd + implicit none + include 'DIMENSIONS' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.SCCOR' + include 'COMMON.SHIELD' + integer i,j,kk,intertyp,maxshieldlist + maxshieldlist=0 +C +C Initialize Cartesian-coordinate gradient +C + do i=-1,nres + do j=1,3 + gvdwx(j,i)=0.0D0 + gradx_scp(j,i)=0.0D0 + gvdwc(j,i)=0.0D0 + gvdwc_scp(j,i)=0.0D0 + gvdwc_scpp(j,i)=0.0d0 + gelc (j,i)=0.0D0 +C below is zero grad for shielding in order: ees (p-p) +C ecorr4, eturn3, eturn4, eel_loc, c denotes calfa,x is side-chain + gshieldx(j,i)=0.0d0 + gshieldc(j,i)=0.0d0 + gshieldc_loc(j,i)=0.0d0 + gshieldx_ec(j,i)=0.0d0 + gshieldc_ec(j,i)=0.0d0 + gshieldc_loc_ec(j,i)=0.0d0 + gshieldx_t3(j,i)=0.0d0 + gshieldc_t3(j,i)=0.0d0 + gshieldc_loc_t3(j,i)=0.0d0 + gshieldx_t4(j,i)=0.0d0 + gshieldc_t4(j,i)=0.0d0 + gshieldc_loc_t4(j,i)=0.0d0 + gshieldx_ll(j,i)=0.0d0 + gshieldc_ll(j,i)=0.0d0 + gshieldc_loc_ll(j,i)=0.0d0 +C end of zero grad for shielding + gelc_long(j,i)=0.0D0 + gradb(j,i)=0.0d0 + gradbx(j,i)=0.0d0 + gvdwpp(j,i)=0.0d0 + gel_loc(j,i)=0.0d0 + gel_loc_long(j,i)=0.0d0 + ghpbc(j,i)=0.0D0 + ghpbx(j,i)=0.0D0 + gsaxsc(j,i)=0.0D0 + gsaxsx(j,i)=0.0D0 + gcorr3_turn(j,i)=0.0d0 + gcorr4_turn(j,i)=0.0d0 + gradcorr(j,i)=0.0d0 + gradcorr_long(j,i)=0.0d0 + gradcorr5_long(j,i)=0.0d0 + gradcorr6_long(j,i)=0.0d0 + gcorr6_turn_long(j,i)=0.0d0 + gradcorr5(j,i)=0.0d0 + gradcorr6(j,i)=0.0d0 + gcorr6_turn(j,i)=0.0d0 + gsccorc(j,i)=0.0d0 + gsccorx(j,i)=0.0d0 + gradc(j,i,icg)=0.0d0 + gradx(j,i,icg)=0.0d0 + gscloc(j,i)=0.0d0 + gsclocx(j,i)=0.0d0 + gliptranc(j,i)=0.0d0 + gliptranx(j,i)=0.0d0 + gradafm(j,i)=0.0d0 + grad_shield(j,i)=0.0d0 + gg_tube(j,i)=0.0d0 + gg_tube_sc(j,i)=0.0d0 +C grad_shield_side is Cbeta sidechain gradient + do kk=1,maxshieldlist + grad_shield_side(j,kk,i)=0.0d0 + grad_shield_loc(j,kk,i)=0.0d0 + +C grad_shield_side_ca is Calfa sidechain gradient + + +C grad_shield_side_ca(j,kk,i)=0.0d0 + enddo + do intertyp=1,3 + gloc_sc(intertyp,i,icg)=0.0d0 + enddo + enddo + enddo +#ifndef DFA + do i=1,nres + do j=1,3 + gdfad(j,i)=0.0d0 + gdfat(j,i)=0.0d0 + gdfan(j,i)=0.0d0 + gdfab(j,i)=0.0d0 + enddo + enddo +#endif +C +C Initialize the gradient of local energy terms. +C + do i=1,4*nres + gloc(i,icg)=0.0D0 + enddo + do i=1,nres + gel_loc_loc(i)=0.0d0 + gcorr_loc(i)=0.0d0 + g_corr5_loc(i)=0.0d0 + g_corr6_loc(i)=0.0d0 + gel_loc_turn3(i)=0.0d0 + gel_loc_turn4(i)=0.0d0 + gel_loc_turn6(i)=0.0d0 + gsccor_loc(i)=0.0d0 + enddo +c initialize gcart and gxcart + do i=0,nres + do j=1,3 + gcart(j,i)=0.0d0 + gxcart(j,i)=0.0d0 + enddo + enddo + return + end +c------------------------------------------------------------------------- + double precision function fdum() + fdum=0.0D0 + return + end diff --git a/source/unres/src-HCD-5D/gradient_p.F.org b/source/unres/src-HCD-5D/gradient_p.F.org new file mode 100644 index 0000000..1d89e0f --- /dev/null +++ b/source/unres/src-HCD-5D/gradient_p.F.org @@ -0,0 +1,571 @@ + subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(n),g(n) + integer i,j,k,ind,ind1 + double precision f,gthetai,gphii,galphai,gomegai +c +c This subroutine calculates total internal coordinate gradient. +c Depending on the number of function evaluations, either whole energy +c is evaluated beforehand, Cartesian coordinates and their derivatives in +c internal coordinates are reevaluated or only the cartesian-in-internal +c coordinate derivatives are evaluated. The subroutine was designed to work +c with SUMSL. +c +c + icg=mod(nf,2)+1 + +cd print *,'grad',nf,icg + if (nf-nfl+1) 20,30,40 + 20 call func(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 call var_to_geom(n,x) + call chainbuild +c write (iout,*) 'grad 30' +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +c write (iout,*) 'grad 40' +c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + ind=0 + ind1=0 + do i=1,nres-2 + gthetai=0.0D0 + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 +c ind=indmat(i,j) +c print *,'GRAD: i=',i,' jc=',j,' ind=',ind + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + enddo + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + enddo + enddo + do j=i+1,nres-1 + ind1=ind1+1 +c ind1=indmat(i,j) +c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 + do k=1,3 + gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) + gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) + enddo + enddo + if (i.gt.1) g(i-1)=gphii + if (n.gt.nphi) g(nphi+i)=gthetai + enddo + if (n.le.nphi+ntheta) goto 10 + do i=2,nres-1 + if (itype(i).ne.10) then + galphai=0.0D0 + gomegai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ialph(i,1))=galphai + g(ialph(i,1)+nside)=gomegai + endif + enddo +C +C Add the components corresponding to local energy terms. +C + 10 continue +c Add the usampl contributions + if (usampl) then + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) + enddo + endif + do i=1,nvar +cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) + g(i)=g(i)+gloc(i,icg) + enddo +C Uncomment following three lines for diagnostics. +cd call intout +cd call briefout(0,0.0d0) +cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) + return + end +C------------------------------------------------------------------------- + subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(maxvar),g(maxvar) + integer i,j,k,ig,ind,ij,igall + double precision f,gthetai,gphii,galphai,gomegai + + icg=mod(nf,2)+1 + if (nf-nfl+1) 20,30,40 + 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 continue +#ifdef OSF +c Intercept NaNs in the coordinates +c write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,n + x_sum=x_sum+x(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** grad_restr : Found NaN in coordinates" + call flush(iout) + print *," *** grad_restr : Found NaN in coordinates" + return + endif +#endif + call var_to_geom_restr(n,x) + call chainbuild +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + + ig=0 + ind=nres-2 + do i=2,nres-2 + IF (mask_phi(i+2).eq.1) THEN + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) + enddo + enddo + ig=ig+1 + g(ig)=gphii + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + + ind=0 + do i=1,nres-2 + IF (mask_theta(i+2).eq.1) THEN + ig=ig+1 + gthetai=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) + enddo + enddo + g(ig)=gthetai + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + galphai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + g(ig)=galphai + ENDIF + endif + enddo + + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + gomegai=0.0D0 + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ig)=gomegai + ENDIF + endif + enddo + +C +C Add the components corresponding to local energy terms. +C + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + endif + enddo + enddo + +cd do i=1,ig +cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +cd enddo + return + end +C------------------------------------------------------------------------- + subroutine cartgrad + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +c +c This subrouting calculates total Cartesian coordinate gradient. +c The subroutine chainbuild_cart and energy MUST be called beforehand. +c +#ifdef TIMING + time00=MPI_Wtime() +#endif + icg=1 +#ifdef DEBUG + write (iout,*) "Before sum_gradient" + do i=1,nres-1 + write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) + write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) + enddo + write (iout,*) "gsaxsc, gsaxcx" + do i=1,nres-1 + write (iout,*) i," gsaxsc ",(gsaxsc(j,i),j=1,3) + write (iout,*) i," gsaxsx ",(gsaxsx(j,i),j=1,3) + enddo +#endif + call sum_gradient +#ifdef TIMING +#endif +#ifdef DEBUG + write (iout,*) "After sum_gradient" + do i=1,nres-1 + write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) + write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) + enddo +#endif +c If performing constraint dynamics, add the gradients of the constraint energy + if(usampl.and.totT.gt.eq_time) then +#ifdef DEBUG + write (iout,*) "dudconst, duscdiff, dugamma,dutheta" + write (iout,*) "wumb",wumb + do i=1,nct + write (iout,'(i5,3f10.5,5x,3f10.5,5x,2f10.5)') + & i,(dudconst(j,i),j=1,3),(duscdiff(j,i),j=1,3), + & dugamma(i),dutheta(i) + enddo +#endif + do i=1,nct + do j=1,3 + gradc(j,i,icg)=gradc(j,i,icg)+ + & wumb*(dudconst(j,i)+duscdiff(j,i)) + gradx(j,i,icg)=gradx(j,i,icg)+ + & wumb*(dudxconst(j,i)+duscdiffx(j,i)) + enddo + enddo + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wumb*dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+wumb*dutheta(i) + enddo + endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + call intcartderiv +#ifdef TIMING + time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 +#endif +cd call checkintcartgrad +cd write(iout,*) 'calling int_to_cart' +#ifdef DEBUG + write (iout,*) "gcart, gxcart, gloc before int_to_cart" +#endif + do i=1,nct + do j=1,3 + gcart(j,i)=gradc(j,i,icg) + gxcart(j,i)=gradx(j,i,icg) + enddo +#ifdef DEBUG + if((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then + write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg), + & gloc(ialph(i,1),icg),gloc(ialph(i,1)+nside,icg) + else + write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg) + endif + call flush(iout) +#endif + enddo +#ifdef TIMING + time01=MPI_Wtime() +#endif + call int_to_cart +#ifdef TIMING + time_inttocart=time_inttocart+MPI_Wtime()-time01 +#endif +#ifdef DEBUG + write (iout,*) "gcart and gxcart after int_to_cart" + do i=0,nres-1 + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif +#ifdef TIMING + time_cartgrad=time_cartgrad+MPI_Wtime()-time00 +#endif + return + end +c--------------------------------------------------------------------------- +#ifdef FIVEDIAG + subroutine grad_transform + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +#ifdef DEBUG + write (iout,*)"Converting virtual-bond gradient to CA/SC gradient" +#endif + do i=nres,1,-1 + do j=1,3 + gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i) +! gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i) + enddo +! write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), & +! (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3) + enddo +! Correction: dummy residues + if (nnt.gt.1) then + do j=1,3 + gcart(j,nnt)=gcart(j,nnt)+gcart(j,1) + enddo + endif + if (nct.lt.nres) then + do j=1,3 +! gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres) + gcart(j,nct)=gcart(j,nct)+gcart(j,nres) + enddo + endif +#ifdef DEBUG + write (iout,*) "CA/SC gradient" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif + return + end +#endif +C------------------------------------------------------------------------- + subroutine zerograd + implicit none + include 'DIMENSIONS' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.SCCOR' + include 'COMMON.SHIELD' + integer i,j,kk,intertyp,maxshieldlist + maxshieldlist=0 +C +C Initialize Cartesian-coordinate gradient +C + do i=-1,nres + do j=1,3 + gvdwx(j,i)=0.0D0 + gradx_scp(j,i)=0.0D0 + gvdwc(j,i)=0.0D0 + gvdwc_scp(j,i)=0.0D0 + gvdwc_scpp(j,i)=0.0d0 + gelc (j,i)=0.0D0 +C below is zero grad for shielding in order: ees (p-p) +C ecorr4, eturn3, eturn4, eel_loc, c denotes calfa,x is side-chain + gshieldx(j,i)=0.0d0 + gshieldc(j,i)=0.0d0 + gshieldc_loc(j,i)=0.0d0 + gshieldx_ec(j,i)=0.0d0 + gshieldc_ec(j,i)=0.0d0 + gshieldc_loc_ec(j,i)=0.0d0 + gshieldx_t3(j,i)=0.0d0 + gshieldc_t3(j,i)=0.0d0 + gshieldc_loc_t3(j,i)=0.0d0 + gshieldx_t4(j,i)=0.0d0 + gshieldc_t4(j,i)=0.0d0 + gshieldc_loc_t4(j,i)=0.0d0 + gshieldx_ll(j,i)=0.0d0 + gshieldc_ll(j,i)=0.0d0 + gshieldc_loc_ll(j,i)=0.0d0 +C end of zero grad for shielding + gelc_long(j,i)=0.0D0 + gradb(j,i)=0.0d0 + gradbx(j,i)=0.0d0 + gvdwpp(j,i)=0.0d0 + gel_loc(j,i)=0.0d0 + gel_loc_long(j,i)=0.0d0 + ghpbc(j,i)=0.0D0 + ghpbx(j,i)=0.0D0 + gsaxsc(j,i)=0.0D0 + gsaxsx(j,i)=0.0D0 + gcorr3_turn(j,i)=0.0d0 + gcorr4_turn(j,i)=0.0d0 + gradcorr(j,i)=0.0d0 + gradcorr_long(j,i)=0.0d0 + gradcorr5_long(j,i)=0.0d0 + gradcorr6_long(j,i)=0.0d0 + gcorr6_turn_long(j,i)=0.0d0 + gradcorr5(j,i)=0.0d0 + gradcorr6(j,i)=0.0d0 + gcorr6_turn(j,i)=0.0d0 + gsccorc(j,i)=0.0d0 + gsccorx(j,i)=0.0d0 + gradc(j,i,icg)=0.0d0 + gradx(j,i,icg)=0.0d0 + gscloc(j,i)=0.0d0 + gsclocx(j,i)=0.0d0 + gliptranc(j,i)=0.0d0 + gliptranx(j,i)=0.0d0 + gradafm(j,i)=0.0d0 + grad_shield(j,i)=0.0d0 + gg_tube(j,i)=0.0d0 + gg_tube_sc(j,i)=0.0d0 +C grad_shield_side is Cbeta sidechain gradient + do kk=1,maxshieldlist + grad_shield_side(j,kk,i)=0.0d0 + grad_shield_loc(j,kk,i)=0.0d0 + +C grad_shield_side_ca is Calfa sidechain gradient + + +C grad_shield_side_ca(j,kk,i)=0.0d0 + enddo + do intertyp=1,3 + gloc_sc(intertyp,i,icg)=0.0d0 + enddo + enddo + enddo +#ifndef DFA + do i=1,nres + do j=1,3 + gdfad(j,i)=0.0d0 + gdfat(j,i)=0.0d0 + gdfan(j,i)=0.0d0 + gdfab(j,i)=0.0d0 + enddo + enddo +#endif +C +C Initialize the gradient of local energy terms. +C + do i=1,4*nres + gloc(i,icg)=0.0D0 + enddo + do i=1,nres + gel_loc_loc(i)=0.0d0 + gcorr_loc(i)=0.0d0 + g_corr5_loc(i)=0.0d0 + g_corr6_loc(i)=0.0d0 + gel_loc_turn3(i)=0.0d0 + gel_loc_turn4(i)=0.0d0 + gel_loc_turn6(i)=0.0d0 + gsccor_loc(i)=0.0d0 + enddo +c initialize gcart and gxcart + do i=0,nres + do j=1,3 + gcart(j,i)=0.0d0 + gxcart(j,i)=0.0d0 + enddo + enddo + return + end +c------------------------------------------------------------------------- + double precision function fdum() + fdum=0.0D0 + return + end diff --git a/source/unres/src-HCD-5D/gradient_p.F.org.debug b/source/unres/src-HCD-5D/gradient_p.F.org.debug new file mode 100644 index 0000000..e2ac689 --- /dev/null +++ b/source/unres/src-HCD-5D/gradient_p.F.org.debug @@ -0,0 +1,574 @@ + subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(n),g(n) + integer i,j,k,ind,ind1 + double precision f,gthetai,gphii,galphai,gomegai +c +c This subroutine calculates total internal coordinate gradient. +c Depending on the number of function evaluations, either whole energy +c is evaluated beforehand, Cartesian coordinates and their derivatives in +c internal coordinates are reevaluated or only the cartesian-in-internal +c coordinate derivatives are evaluated. The subroutine was designed to work +c with SUMSL. +c +c + icg=mod(nf,2)+1 + +cd print *,'grad',nf,icg + if (nf-nfl+1) 20,30,40 + 20 call func(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 call var_to_geom(n,x) + call chainbuild +c write (iout,*) 'grad 30' +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +c write (iout,*) 'grad 40' +c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + ind=0 + ind1=0 + do i=1,nres-2 + gthetai=0.0D0 + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 +c ind=indmat(i,j) +c print *,'GRAD: i=',i,' jc=',j,' ind=',ind + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + enddo + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + enddo + enddo + do j=i+1,nres-1 + ind1=ind1+1 +c ind1=indmat(i,j) +c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 + write (iout,*) "i",i," j",j," ind1",ind1 + write (iout,*) "dxdv",(dxdv(k,ind1),k=1,6) + write (iout,*) "gradx",(gradx(k,j,icg),k=1,3) + do k=1,3 + gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) + gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) + enddo + enddo + if (i.gt.1) g(i-1)=gphii + if (n.gt.nphi) g(nphi+i)=gthetai + enddo + if (n.le.nphi+ntheta) goto 10 + do i=2,nres-1 + if (itype(i).ne.10) then + galphai=0.0D0 + gomegai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ialph(i,1))=galphai + g(ialph(i,1)+nside)=gomegai + endif + enddo +C +C Add the components corresponding to local energy terms. +C + 10 continue +c Add the usampl contributions + if (usampl) then + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) + enddo + endif + do i=1,nvar +cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) + g(i)=g(i)+gloc(i,icg) + enddo +C Uncomment following three lines for diagnostics. +cd call intout +cd call briefout(0,0.0d0) +cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) + return + end +C------------------------------------------------------------------------- + subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm + external ufparm + integer uiparm(1) + double precision urparm(1) + double precision x(maxvar),g(maxvar) + integer i,j,k,ig,ind,ij,igall + double precision f,gthetai,gphii,galphai,gomegai + + icg=mod(nf,2)+1 + if (nf-nfl+1) 20,30,40 + 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm) +c write (iout,*) 'grad 20' + if (nf.eq.0) return + goto 40 + 30 continue +#ifdef OSF +c Intercept NaNs in the coordinates +c write(iout,*) (var(i),i=1,nvar) + x_sum=0.D0 + do i=1,n + x_sum=x_sum+x(i) + enddo + if (x_sum.ne.x_sum) then + write(iout,*)" *** grad_restr : Found NaN in coordinates" + call flush(iout) + print *," *** grad_restr : Found NaN in coordinates" + return + endif +#endif + call var_to_geom_restr(n,x) + call chainbuild +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + 40 call cartder +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + + ig=0 + ind=nres-2 + do i=2,nres-2 + IF (mask_phi(i+2).eq.1) THEN + gphii=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) + gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) + enddo + enddo + ig=ig+1 + g(ig)=gphii + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + + ind=0 + do i=1,nres-2 + IF (mask_theta(i+2).eq.1) THEN + ig=ig+1 + gthetai=0.0D0 + do j=i+1,nres-1 + ind=ind+1 + do k=1,3 + gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) + gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) + enddo + enddo + g(ig)=gthetai + ELSE + ind=ind+nres-1-i + ENDIF + enddo + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + galphai=0.0D0 + do k=1,3 + galphai=galphai+dxds(k,i)*gradx(k,i,icg) + enddo + g(ig)=galphai + ENDIF + endif + enddo + + + do i=2,nres-1 + if (itype(i).ne.10) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + gomegai=0.0D0 + do k=1,3 + gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) + enddo + g(ig)=gomegai + ENDIF + endif + enddo + +C +C Add the components corresponding to local energy terms. +C + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + endif + enddo + enddo + +cd do i=1,ig +cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +cd enddo + return + end +C------------------------------------------------------------------------- + subroutine cartgrad + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +c +c This subrouting calculates total Cartesian coordinate gradient. +c The subroutine chainbuild_cart and energy MUST be called beforehand. +c +#ifdef TIMING + time00=MPI_Wtime() +#endif + icg=1 +#ifdef DEBUG + write (iout,*) "Before sum_gradient" + do i=1,nres-1 + write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) + write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) + enddo + write (iout,*) "gsaxsc, gsaxcx" + do i=1,nres-1 + write (iout,*) i," gsaxsc ",(gsaxsc(j,i),j=1,3) + write (iout,*) i," gsaxsx ",(gsaxsx(j,i),j=1,3) + enddo +#endif + call sum_gradient +#ifdef TIMING +#endif +#ifdef DEBUG + write (iout,*) "After sum_gradient" + do i=1,nres-1 + write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3) + write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3) + enddo +#endif +c If performing constraint dynamics, add the gradients of the constraint energy + if(usampl.and.totT.gt.eq_time) then +#ifdef DEBUG + write (iout,*) "dudconst, duscdiff, dugamma,dutheta" + write (iout,*) "wumb",wumb + do i=1,nct + write (iout,'(i5,3f10.5,5x,3f10.5,5x,2f10.5)') + & i,(dudconst(j,i),j=1,3),(duscdiff(j,i),j=1,3), + & dugamma(i),dutheta(i) + enddo +#endif + do i=1,nct + do j=1,3 + gradc(j,i,icg)=gradc(j,i,icg)+ + & wumb*(dudconst(j,i)+duscdiff(j,i)) + gradx(j,i,icg)=gradx(j,i,icg)+ + & wumb*(dudxconst(j,i)+duscdiffx(j,i)) + enddo + enddo + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+wumb*dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+wumb*dutheta(i) + enddo + endif +#ifdef TIMING + time01=MPI_Wtime() +#endif + call intcartderiv +#ifdef TIMING + time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01 +#endif +cd call checkintcartgrad +cd write(iout,*) 'calling int_to_cart' +#ifdef DEBUG + write (iout,*) "gcart, gxcart, gloc before int_to_cart" +#endif + do i=1,nct + do j=1,3 + gcart(j,i)=gradc(j,i,icg) + gxcart(j,i)=gradx(j,i,icg) + enddo +#ifdef DEBUG + if((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then + write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg), + & gloc(ialph(i,1),icg),gloc(ialph(i,1)+nside,icg) + else + write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg) + endif + call flush(iout) +#endif + enddo +#ifdef TIMING + time01=MPI_Wtime() +#endif + call int_to_cart +#ifdef TIMING + time_inttocart=time_inttocart+MPI_Wtime()-time01 +#endif +#ifdef DEBUG + write (iout,*) "gcart and gxcart after int_to_cart" + do i=0,nres-1 + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif +#ifdef TIMING + time_cartgrad=time_cartgrad+MPI_Wtime()-time00 +#endif + return + end +c--------------------------------------------------------------------------- +#ifdef FIVEDIAG + subroutine grad_transform + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +#ifdef DEBUG + write (iout,*)"Converting virtual-bond gradient to CA/SC gradient" +#endif + do i=nres,1,-1 + do j=1,3 + gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i) +! gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i) + enddo +! write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), & +! (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3) + enddo +! Correction: dummy residues + if (nnt.gt.1) then + do j=1,3 + gcart(j,nnt)=gcart(j,nnt)+gcart(j,1) + enddo + endif + if (nct.lt.nres) then + do j=1,3 +! gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres) + gcart(j,nct)=gcart(j,nct)+gcart(j,nres) + enddo + endif +#ifdef DEBUG + write (iout,*) "CA/SC gradient" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif + return + end +#endif +C------------------------------------------------------------------------- + subroutine zerograd + implicit none + include 'DIMENSIONS' + include 'COMMON.DERIV' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + include 'COMMON.MD' + include 'COMMON.SCCOR' + include 'COMMON.SHIELD' + integer i,j,kk,intertyp,maxshieldlist + maxshieldlist=0 +C +C Initialize Cartesian-coordinate gradient +C + do i=-1,nres + do j=1,3 + gvdwx(j,i)=0.0D0 + gradx_scp(j,i)=0.0D0 + gvdwc(j,i)=0.0D0 + gvdwc_scp(j,i)=0.0D0 + gvdwc_scpp(j,i)=0.0d0 + gelc (j,i)=0.0D0 +C below is zero grad for shielding in order: ees (p-p) +C ecorr4, eturn3, eturn4, eel_loc, c denotes calfa,x is side-chain + gshieldx(j,i)=0.0d0 + gshieldc(j,i)=0.0d0 + gshieldc_loc(j,i)=0.0d0 + gshieldx_ec(j,i)=0.0d0 + gshieldc_ec(j,i)=0.0d0 + gshieldc_loc_ec(j,i)=0.0d0 + gshieldx_t3(j,i)=0.0d0 + gshieldc_t3(j,i)=0.0d0 + gshieldc_loc_t3(j,i)=0.0d0 + gshieldx_t4(j,i)=0.0d0 + gshieldc_t4(j,i)=0.0d0 + gshieldc_loc_t4(j,i)=0.0d0 + gshieldx_ll(j,i)=0.0d0 + gshieldc_ll(j,i)=0.0d0 + gshieldc_loc_ll(j,i)=0.0d0 +C end of zero grad for shielding + gelc_long(j,i)=0.0D0 + gradb(j,i)=0.0d0 + gradbx(j,i)=0.0d0 + gvdwpp(j,i)=0.0d0 + gel_loc(j,i)=0.0d0 + gel_loc_long(j,i)=0.0d0 + ghpbc(j,i)=0.0D0 + ghpbx(j,i)=0.0D0 + gsaxsc(j,i)=0.0D0 + gsaxsx(j,i)=0.0D0 + gcorr3_turn(j,i)=0.0d0 + gcorr4_turn(j,i)=0.0d0 + gradcorr(j,i)=0.0d0 + gradcorr_long(j,i)=0.0d0 + gradcorr5_long(j,i)=0.0d0 + gradcorr6_long(j,i)=0.0d0 + gcorr6_turn_long(j,i)=0.0d0 + gradcorr5(j,i)=0.0d0 + gradcorr6(j,i)=0.0d0 + gcorr6_turn(j,i)=0.0d0 + gsccorc(j,i)=0.0d0 + gsccorx(j,i)=0.0d0 + gradc(j,i,icg)=0.0d0 + gradx(j,i,icg)=0.0d0 + gscloc(j,i)=0.0d0 + gsclocx(j,i)=0.0d0 + gliptranc(j,i)=0.0d0 + gliptranx(j,i)=0.0d0 + gradafm(j,i)=0.0d0 + grad_shield(j,i)=0.0d0 + gg_tube(j,i)=0.0d0 + gg_tube_sc(j,i)=0.0d0 +C grad_shield_side is Cbeta sidechain gradient + do kk=1,maxshieldlist + grad_shield_side(j,kk,i)=0.0d0 + grad_shield_loc(j,kk,i)=0.0d0 + +C grad_shield_side_ca is Calfa sidechain gradient + + +C grad_shield_side_ca(j,kk,i)=0.0d0 + enddo + do intertyp=1,3 + gloc_sc(intertyp,i,icg)=0.0d0 + enddo + enddo + enddo +#ifndef DFA + do i=1,nres + do j=1,3 + gdfad(j,i)=0.0d0 + gdfat(j,i)=0.0d0 + gdfan(j,i)=0.0d0 + gdfab(j,i)=0.0d0 + enddo + enddo +#endif +C +C Initialize the gradient of local energy terms. +C + do i=1,4*nres + gloc(i,icg)=0.0D0 + enddo + do i=1,nres + gel_loc_loc(i)=0.0d0 + gcorr_loc(i)=0.0d0 + g_corr5_loc(i)=0.0d0 + g_corr6_loc(i)=0.0d0 + gel_loc_turn3(i)=0.0d0 + gel_loc_turn4(i)=0.0d0 + gel_loc_turn6(i)=0.0d0 + gsccor_loc(i)=0.0d0 + enddo +c initialize gcart and gxcart + do i=0,nres + do j=1,3 + gcart(j,i)=0.0d0 + gxcart(j,i)=0.0d0 + enddo + enddo + return + end +c------------------------------------------------------------------------- + double precision function fdum() + fdum=0.0D0 + return + end diff --git a/source/unres/src-HCD-5D/initialize_p.F b/source/unres/src-HCD-5D/initialize_p.F index 7465eec..c73426c 100644 --- a/source/unres/src-HCD-5D/initialize_p.F +++ b/source/unres/src-HCD-5D/initialize_p.F @@ -45,16 +45,19 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.MINIM' include 'COMMON.DERIV' include 'COMMON.SPLITELE' + include 'COMMON.VAR' c Common blocks from the diagonalization routines integer IR,IW,IP,IJK,IPK,IDAF,NAV,IODA,KDIAG,ICORFL,IXDR integer i,idumm,j,k,l,ichir1,ichir2,iblock,m double precision rr COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) COMMON /MACHSW/ KDIAG,ICORFL,IXDR - logical mask_r c real*8 text1 /'initial_i'/ mask_r=.false. + mask_theta=1 + mask_phi=1 + mask_side=1 #ifndef ISNAN c NaNQ initialization i=-1 @@ -311,6 +314,7 @@ C Initialize the variables responsible for the mode of gradient storage. C nfl=0 icg=1 + sideonly=.false. C C Initialize constants used to split the energy into long- and short-range C components @@ -441,7 +445,7 @@ c--------------------------------------------------------------------------- include 'COMMON.TORCNSTR' include 'COMMON.IOUNITS' include 'COMMON.DERIV' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' integer iturn3_start_all,iturn3_end_all,iturn4_start_all, & iturn4_end_all,iatel_s_all, & iatel_e_all,ielstart_all,ielend_all,ntask_cont_from_all, @@ -469,10 +473,12 @@ c--------------------------------------------------------------------------- & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs) C... Determine the numbers of start and end SC-SC interaction C... to deal with by current processor. +#ifdef FOURBODY do i=0,nfgtasks-1 itask_cont_from(i)=fg_rank itask_cont_to(i)=fg_rank enddo +#endif lprint=energy_dec if (lprint) &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct @@ -890,6 +896,7 @@ c nlen=nres-nnt+1 enddo call flush(iout) endif +#ifdef FOURBODY ntask_cont_from=0 ntask_cont_to=0 itask_cont_from(0)=fg_rank @@ -1090,6 +1097,7 @@ c call flush(iout) call MPI_Group_free(fg_group,ierr) call MPI_Group_free(cont_from_group,ierr) call MPI_Group_free(cont_to_group,ierr) +#endif call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR) call MPI_Type_commit(MPI_UYZ,IERROR) call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD, diff --git a/source/unres/src-HCD-5D/lbfgs.F b/source/unres/src-HCD-5D/lbfgs.F index 9173d45..dabcbb3 100644 --- a/source/unres/src-HCD-5D/lbfgs.F +++ b/source/unres/src-HCD-5D/lbfgs.F @@ -82,6 +82,7 @@ c character*240 record character*240 string external fgvalue,optsave + common /lbfgstat/ status,niter,ncalls c c c initialize some values to be used below @@ -254,6 +255,7 @@ c start of a new limited memory BFGS iteration c do while (.not. done) niter = niter + 1 +c write (jout,*) "LBFGS niter",niter muse = min(niter-1,msav) m = m + 1 if (m .gt. msav) m = 1 @@ -304,7 +306,9 @@ c c perform line search along the new conjugate direction c status = blank +c write (jout,*) "Before search" call search (nvar,f,g,x0,p,f_move,angle,ncalls,fgvalue,status) +c write (jout,*) "After search" c c update variables based on results of this iteration c diff --git a/source/unres/src-HCD-5D/map.F b/source/unres/src-HCD-5D/map.F new file mode 100644 index 0000000..ad139c8 --- /dev/null +++ b/source/unres/src-HCD-5D/map.F @@ -0,0 +1,99 @@ + subroutine map + implicit none + include 'DIMENSIONS' + include 'COMMON.MAP' + include 'COMMON.VAR' + include 'COMMON.GEO' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.NAMES' + include 'COMMON.CONTROL' + include 'COMMON.TORCNSTR' + double precision energia(0:n_ene) + character*5 angid(4) /'PHI','THETA','ALPHA','OMEGA'/ + double precision ang_list(10) + double precision g(maxvar),x(maxvar),gnorm,etot + integer i,ii,iii,j,k,nf,nfun,iretcode,nmax,ntot + integer uiparm(1) + double precision urparm(1),fdum + external fdum + double precision funcgrad,ff + external funcgrad + integer nn(10) + write (iout,'(a,i3,a)')'Energy map constructed in the following ', + & nmap,' groups of variables:' + do i=1,nmap + write (iout,'(2a,i3,a,i3)') angid(kang(i)),' of residues ', + & res1(i),' to ',res2(i) + enddo + nmax=nstep(1) + do i=2,nmap + if (nmax.lt.nstep(i)) nmax=nstep(i) + enddo + ntot=nmax**nmap + iii=0 + write (istat,'(1h#,a14,29a15)') (" ",k=1,nmap), + & (ename(print_order(k)),k=1,nprint_ene),"ETOT","GNORM" + do i=0,ntot-1 + ii=i + do j=1,nmap + nn(j)=mod(ii,nmax)+1 + ii=ii/nmax + enddo + do j=1,nmap + if (nn(j).gt.nstep(j)) goto 10 + enddo + iii=iii+1 +Cd write (iout,*) i,iii,(nn(j),j=1,nmap) + do j=1,nmap + ang_list(j)=ang_from(j) + & +(nn(j)-1)*(ang_to(j)-ang_from(j))/nstep(j) + do k=res1(j),res2(j) + goto (1,2,3,4), kang(j) + 1 phi(k)=deg2rad*ang_list(j) + if (minim) phi0(k-res1(j)+1)=deg2rad*ang_list(j) + goto 5 + 2 theta(k)=deg2rad*ang_list(j) + goto 5 + 3 alph(k)=deg2rad*ang_list(j) + goto 5 + 4 omeg(k)=deg2rad*ang_list(j) + 5 continue + enddo ! k + enddo ! j + call chainbuild + if (minim) then + call geom_to_var(nvar,x) + call minimize(etot,x,iretcode,nfun) + print *,'SUMSL return code is',iretcode,' eval ',nfun +c call intout + else + call zerograd + call geom_to_var(nvar,x) + endif + call etotal(energia(0)) + etot = energia(0) + nf=1 + nfl=3 +#ifdef LBFGS + ff=funcgrad(x,g) +#else + call gradient(nvar,x,nf,g,uiparm,urparm,fdum) +#endif + gnorm=0.0d0 + do k=1,nvar + gnorm=gnorm+g(k)**2 + enddo + etot=energia(0) + + gnorm=dsqrt(gnorm) +c write (iout,'(6(1pe15.5))') (ang_list(k),k=1,nmap),etot,gnorm + write (istat,'(30e15.5)') (ang_list(k),k=1,nmap), + & (energia(print_order(ii)),ii=1,nprint_ene),etot,gnorm +c write (iout,*) 'POINT',I,' ANGLES:',(ang_list(k),k=1,nmap) +c call intout +c call enerprint(energia) + 10 continue + enddo ! i + return + end diff --git a/source/unres/src-HCD-5D/minim_jlee.F b/source/unres/src-HCD-5D/minim_jlee.F index 56d5010..7162afb 100644 --- a/source/unres/src-HCD-5D/minim_jlee.F +++ b/source/unres/src-HCD-5D/minim_jlee.F @@ -1,13 +1,33 @@ subroutine minim_jlee +#ifdef LBFGS + use minima + use inform + use output + use iounit + use scales +#endif c controls minimization and sorting routines implicit real*8 (a-h,o-z) include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#ifndef LBFGS + integer liv,lv + parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#endif include 'COMMON.VAR' include 'COMMON.IOUNITS' include 'COMMON.MINIM' include 'COMMON.CONTROL' +#ifdef LBFGS + common /gacia/ nfun + double precision grdmin + external funcgrad + external optsave +#else external func,gradient,fdum + dimension iv(liv) + double precision v(1:lv+1) + common /przechowalnia/ v +#endif real ran1,ran2,ran3 #ifdef MPI include 'mpif.h' @@ -22,19 +42,40 @@ c controls minimization and sorting routines dimension var(maxvar),erg(mxch*(mxch+1)/2+1) dimension var2(maxvar) integer iffr(maxres),ihpbt(maxdim),jhpbt(maxdim) - double precision d(maxvar),v(1:lv+1),garbage(maxvar) + double precision d(maxvar),garbage(maxvar),g(maxvar) double precision energia(0:n_ene),time0s,time1s dimension indx(9),info(12) - dimension iv(liv) dimension idum(1),rdum(1) dimension icont(2,maxcont) logical check_var,fail integer iloop(2) - common /przechowalnia/ v data rad /1.745329252d-2/ c receive # of start ! print *,'Processor',me,' calling MINIM_JLEE maxfun',maxfun, ! & ' maxmin',maxmin,' tolf',tolf,' rtolf',rtolf +#ifdef LBFGS + maxiter=maxmin + coordtype='RIGIDBODY' + grdmin=tolf + jout=iout + jprint=print_min_stat + iwrite=0 + if (.not. allocated(scale)) allocate (scale(nvar)) +c +c set scaling parameter for function and derivative values; +c use square root of median eigenvalue of typical Hessian +c + set_scale = .true. +c nvar = 0 + do i = 1, nvar +c if (use(i)) then +c do j = 1, 3 +c nvar = nvar + 1 + scale(i) = 12.0d0 +c end do +c end if + end do +#endif nhpb0=nhpb 10 continue time0s=MPI_WTIME() @@ -161,8 +202,13 @@ crc overlap test nfun=nfun+1 write (iout,'(a,1pe14.5)')'#OVERLAP evdw after',energia(1) else +#ifdef LBFGS + etot=1.0d20 + nfun=-1 +#else v(10)=1.0d20 iv(1)=-1 +#endif goto 201 endif endif @@ -176,8 +222,12 @@ cd write(iout,*) 'sc_move',nft_sc,etot endif if (check_var(var,info)) then +#ifdef LBFGS + etot=1.0d21 +#else v(10)=1.0d21 iv(1)=6 +#endif goto 201 endif @@ -189,10 +239,22 @@ crc ! write (*,*) 'MINIM_JLEE: Processor',me,' received nvar',nvar ! write (*,'(8f10.4)') (var(i),i=1,nvar) - do i=1,nvar - garbage(i)=var(i) - enddo + do i=1,nvar + garbage(i)=var(i) + enddo +#ifdef LBFGS + eee=funcgrad(var,g) + nfun=nfun+1 + if(eee.ge.1.0d20) then +c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' +c print *,' energy before SUMSL =',eee +c print *,' aborting local minimization' + go to 201 + endif + call lbfgs (nvar,var,etot,grdmin,funcgrad,optsave) + deallocate(scale) +#else call deflt(2,iv,liv,lv,v) * 12 means fresh start, dont call deflt iv(1)=12 @@ -262,8 +324,12 @@ c print *, 'MINIM_JLEE: ',me,' before SUMSL ' c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' c print *,' energy before SUMSL =',eee c print *,' aborting local minimization' +#ifdef LBFGS + etot=eee +#else iv(1)=-1 v(10)=eee +#endif go to 201 endif @@ -274,6 +340,7 @@ c print *, 'MINIM_JLEE: ',me,' after SUMSL ' c find which conformation was returned from sumsl nfun=nfun+iv(7) +#endif ! print *,'Processor',me,' iv(17)',iv(17),' iv(18)',iv(18),' nf',nf, ! & ' retcode',iv(1),' energy',v(10),' tolf',v(31),' rtolf',v(32) c if (iv(1).ne.4 .or. nf.le.1) then @@ -311,7 +378,11 @@ c print *, 'MINIM_JLEE: ',me,' minimized: ',n 201 continue indx(1)=n c return code: 6-gradient 9-number of ftn evaluation, etc +#ifdef LBFGS + indx(2)=nfun +#else indx(2)=iv(1) +#endif c total # of ftn evaluations (for iwf=0, it includes all minimizations). indx(3)=nfun indx(4)=info(2) @@ -325,12 +396,21 @@ c total # of ftn evaluations (for iwf=0, it includes all minimizations). c send back energies c al & cc c calculate contact order +#ifdef LBFGS +#ifdef CO_BIAS + call contact(.false.,ncont,icont,co) + erg(1)=etot-1.0d2*co +#else + erg(1)=etot +#endif +#else #ifdef CO_BIAS call contact(.false.,ncont,icont,co) erg(1)=v(10)-1.0d2*co #else erg(1)=v(10) #endif +#endif j=1 call mpi_send(erg,j,mpi_double_precision,king,idreal, * CG_COMM,ierr) diff --git a/source/unres/src-HCD-5D/minim_mcmf.F b/source/unres/src-HCD-5D/minim_mcmf.F index 836d258..16623b6 100644 --- a/source/unres/src-HCD-5D/minim_mcmf.F +++ b/source/unres/src-HCD-5D/minim_mcmf.F @@ -1,12 +1,31 @@ subroutine minim_mcmf +#ifdef LBFGS + use minima + use inform + use output + use iounit + use scales +#endif implicit real*8 (a-h,o-z) include 'DIMENSIONS' +#ifndef LBFGS parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#endif include 'COMMON.VAR' include 'COMMON.IOUNITS' include 'COMMON.MINIM' include 'mpif.h' +#ifdef LBFGS + double precision grdmin + external funcgrad + external optsave +#else + double precision v(1:lv+1) + common /przechowalnia/ v external func,gradient,fdum + dimension iv(liv) +#endif + common /gacia/ nf real ran1,ran2,ran3 include 'COMMON.SETUP' include 'COMMON.GEO' @@ -14,14 +33,12 @@ include 'COMMON.FFIELD' dimension muster(mpi_status_size) dimension var(maxvar),erg(mxch*(mxch+1)/2+1) - double precision d(maxvar),v(1:lv+1),garbage(maxvar) + double precision d(maxvar),garbage(maxvar) dimension indx(6) - dimension iv(liv) dimension idum(1),rdum(1) double precision przes(3),obrot(3,3) logical non_conv data rad /1.745329252d-2/ - common /przechowalnia/ v ichuj=0 10 continue @@ -36,7 +53,41 @@ c print *, 'worker ',me,' received order ',n,ichuj * king,idreal,CG_COMM,muster,ierr) c print *, 'worker ',me,' var read ' - +#ifdef LBFGS + maxiter=maxmin + coordtype='RIGIDBODY' + grdmin=tolf + jout=iout + jprint=print_min_stat + iwrite=0 + if (.not. allocated(scale)) allocate (scale(nvar)) +c +c set scaling parameter for function and derivative values; +c use square root of median eigenvalue of typical Hessian +c + set_scale = .true. +c nvar = 0 + do i = 1, nvar +c if (use(i)) then +c do j = 1, 3 +c nvar = nvar + 1 + scale(i) = 12.0d0 +c end do +c end if + end do + eee=funcgrad(var,g) + if(eee.gt.1.0d18) then +c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' +c print *,' energy before SUMSL =',eee +c print *,' aborting local minimization' + nf=-1 + go to 201 + endif +c write (iout,*) "Calling lbfgs" + call lbfgs (nvar,x,eee,grdmin,funcgrad,optsave) + nf=nf+1 + deallocate(scale) +#else call deflt(2,iv,liv,lv,v) * 12 means fresh start, dont call deflt iv(1)=12 @@ -98,11 +149,16 @@ c print *,' aborting local minimization' call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) c find which conformation was returned from sumsl nf=iv(7)+1 +#endif 201 continue c total # of ftn evaluations (for iwf=0, it includes all minimizations). indx(4)=nf +#ifdef LBFGS + indx(5)=0 +#else indx(5)=iv(1) eee=v(10) +#endif call mpi_send(indx,6,mpi_integer,king,idint,CG_COMM, * ierr) diff --git a/source/unres/src-HCD-5D/minimize_p.F b/source/unres/src-HCD-5D/minimize_p.F index f163846..6b9d204 100644 --- a/source/unres/src-HCD-5D/minimize_p.F +++ b/source/unres/src-HCD-5D/minimize_p.F @@ -1,8 +1,17 @@ subroutine minimize(etot,x,iretcode,nfun) +#ifdef LBFGS + use minima + use inform + use output + use iounit + use scales +#endif implicit none include 'DIMENSIONS' +#ifndef LBFGS integer liv,lv parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#endif ********************************************************************* * OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * * the calling subprogram. * @@ -20,19 +29,59 @@ include 'COMMON.MINIM' integer icall common /srutu/ icall - integer iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) - double precision energia(0:n_ene) +#ifdef LBFGS + double precision grdmin + external funcgrad + external optsave +#else + dimension iv(liv) + double precision v(1:lv) + common /przechowalnia/ v integer idum double precision rdum double precision fdum external func,gradient,fdum external func_restr,grad_restr logical not_done,change,reduce +#endif + double precision x(maxvar),d(maxvar),xx(maxvar) + double precision energia(0:n_ene) integer i,nvar_restr,nfun,iretcode double precision etot c common /przechowalnia/ v +#ifdef LBFGS + maxiter=maxmin + coordtype='RIGIDBODY' + grdmin=tolf + jout=iout + jprint=print_min_stat + iwrite=0 + if (.not. allocated(scale)) allocate (scale(nvar)) +c +c set scaling parameter for function and derivative values; +c use square root of median eigenvalue of typical Hessian +c + set_scale = .true. +c nvar = 0 + do i = 1, nvar +c if (use(i)) then +c do j = 1, 3 +c nvar = nvar + 1 + scale(i) = 12.0d0 +c end do +c end if + end do +c write (iout,*) "Calling lbfgs" + write (iout,*) 'Calling LBFGS, minimization in angles' + call var_to_geom(nvar,x) + call chainbuild_extconf + call etotal(energia(0)) + call enerprint(energia(0)) + call lbfgs (nvar,x,etot,grdmin,funcgrad,optsave) + deallocate(scale) + write (iout,*) "Minimized energy",etot +#else icall = 1 NOT_DONE=.TRUE. @@ -85,10 +134,12 @@ c v(25)=4.0D0 do i=nphi+1,nvar d(i)=1.0D-1 enddo -cd print *,'Calling SUMSL' -c call var_to_geom(nvar,x) -c call chainbuild -c call etotal(energia(0)) + write (iout,*) 'Calling SUMSL' + call var_to_geom(nvar,x) + call chainbuild_extconf + call intout + call etotal(energia(0)) + call enerprint(energia(0)) c etot = energia(0) IF (mask_r) THEN call x2xx(x,xx,nvar_restr) @@ -110,7 +161,7 @@ c write (iout,'(a)') 'Reduction worked, minimizing again...' c else c not_done=.false. c endif - call chainbuild + call chainbuild_extconf c call etotal(energia(0)) c etot=energia(0) c call enerprint(energia(0)) @@ -119,7 +170,7 @@ c call enerprint(energia(0)) c write (*,*) 'Processor',MyID,' leaves MINIMIZE.' c ENDDO ! NOT_DONE - +#endif return end #ifdef MPI @@ -260,6 +311,53 @@ c call MATOUT2(my_ng_count,dimen3,maxres2,maxers2,ginv_block) end #endif ************************************************************************ +#ifdef LBFGS + double precision function funcgrad(x,g) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + double precision energia(0:n_ene) + double precision x(nvar),g(nvar) + integer i +c if (jjj.gt.0) then +c write (iout,*) "in func x" +c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) +c endif + call var_to_geom(nvar,x) + call zerograd + call chainbuild_extconf + call etotal(energia(0)) + call sum_gradient + funcgrad=energia(0) + call cart2intgrad(nvar,g) +C +C Add the components corresponding to local energy terms. +C +c Add the usampl contributions + if (usampl) then + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) + enddo + endif + do i=1,nvar +cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) + g(i)=g(i)+gloc(i,icg) + enddo + return + end +#else subroutine func(n,x,nf,f,uiparm,urparm,ufparm) implicit real*8 (a-h,o-z) include 'DIMENSIONS' @@ -331,46 +429,51 @@ c endif return end c------------------------------------------------------- +#endif subroutine x2xx(x,xx,n) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' double precision xx(maxvar),x(maxvar) +c write (iout,*) "nvar",nvar do i=1,nvar varall(i)=x(i) enddo - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 xx(ig)=x(igall) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 xx(ig)=x(igall) - endif + endif enddo - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 xx(ig)=x(igall) - endif - endif - enddo +c write (iout,*) "ij",ij," i",i," ig",ig," igall",igall +c write (iout,*) "x",x(igall)," xx",xx(ig) + endif + endif + enddo enddo n=ig @@ -384,40 +487,43 @@ c------------------------------------------------------- include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' double precision xx(maxvar),x(maxvar) do i=1,nvar x(i)=varall(i) enddo - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 x(igall)=xx(ig) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 x(igall)=xx(ig) - endif + endif enddo - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 x(igall)=xx(ig) - endif - endif - enddo +c write (iout,*) "ij",ij," i",i," ig",ig," igall",igall +c write (iout,*) "x",x(igall)," xx",xx(ig) + endif + endif + enddo enddo return @@ -451,7 +557,7 @@ c---------------------------------------------------------- #ifdef LBFGS double precision grdmin double precision funcgrad_dc - external funcgrad_dc + external funcgrad_dc,optsave #else dimension iv(liv) double precision v(1:lv) @@ -550,9 +656,10 @@ c nvar = nvar + 1 c end do c end if end do - write (iout,*) "Calling lbfgs" +c write (iout,*) "minim_dc Calling lbfgs" call lbfgs (nvarx,x,etot,grdmin,funcgrad_dc,optsave) - write (iout,*) "After lbfgs" + deallocate(scale) +c write (iout,*) "minim_dc After lbfgs" #else c----- c write (iout,*) "checkgrad before SUMSL" @@ -620,7 +727,9 @@ cd enddo integer k dimension x(maxvar),g(maxvar) double precision energia(0:n_ene) + common /gacia/ nf c + nf=nf+1 k=0 do i=1,nres-1 do j=1,3 @@ -645,7 +754,6 @@ C C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. C call cartgrad -cd print *,40 k=0 do i=1,nres-1 do j=1,3 diff --git a/source/unres/src-HCD-5D/newconf.f b/source/unres/src-HCD-5D/newconf.f index 5f93b95..9791555 100644 --- a/source/unres/src-HCD-5D/newconf.f +++ b/source/unres/src-HCD-5D/newconf.f @@ -10,7 +10,7 @@ ccccccccccccccccccccccccccccccccccccccccccccccccc include 'COMMON.INTERACT' include 'COMMON.HAIRPIN' include 'COMMON.VAR' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.GEO' include 'COMMON.CONTROL' logical nicht_getan,nicht_getan1,fail,lfound @@ -2299,7 +2299,7 @@ ccccccccccccccccccccccccccccccccccccccccccccccccc include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.HAIRPIN' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' character*50 linia integer isec(maxres) diff --git a/source/unres/src-HCD-5D/optsave_dum.f b/source/unres/src-HCD-5D/optsave_dum.f new file mode 100644 index 0000000..23f35c2 --- /dev/null +++ b/source/unres/src-HCD-5D/optsave_dum.f @@ -0,0 +1,7 @@ + subroutine optsave (ncycle,f,xx) + implicit none + integer ncycle + double precision f + double precision xx(*) + return + end diff --git a/source/unres/src-HCD-5D/parmread.F b/source/unres/src-HCD-5D/parmread.F index 7d4d912..2da8851 100644 --- a/source/unres/src-HCD-5D/parmread.F +++ b/source/unres/src-HCD-5D/parmread.F @@ -2036,8 +2036,15 @@ C 12/1/95 Added weight for the multi-body term WCORR call rescale_weights(t_bath) if(me.eq.king.or..not.out1file) & write (iout,22) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor, - & wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3, - & wturn4,wturn6 + & wtor_d,wstrain,wel_loc, +#ifdef FOURBODY + & wcorr,wcorr5,wcorr6, +#endif + & wsccor,wturn3, +#ifdef FOURBODY + & wturn4, +#endif + & wturn6 22 format (/'Energy-term weights (scaled):'// & 'WSCC= ',f10.6,' (SC-SC)'/ & 'WSCP= ',f10.6,' (SC-p)'/ @@ -2050,13 +2057,18 @@ C 12/1/95 Added weight for the multi-body term WCORR & 'WTORD= ',f10.6,' (double torsional)'/ & 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ & 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ +#ifdef FOURBODY & 'WCORR4= ',f10.6,' (multi-body 4th order)'/ & 'WCORR5= ',f10.6,' (multi-body 5th order)'/ & 'WCORR6= ',f10.6,' (multi-body 6th order)'/ - & 'WSCCOR= ',f10.6,' (back-scloc correlatkion)'/ +#endif + & 'WSCCOR= ',f10.6,' (back-scloc correlation)'/ & 'WTURN3= ',f10.6,' (turns, 3rd order)'/ & 'WTURN4= ',f10.6,' (turns, 4th order)'/ - & 'WTURN6= ',f10.6,' (turns, 6th order)') +#ifdef FOURBODY + & 'WTURN6= ',f10.6,' (turns, 6th order)' +#endif + & ) if(me.eq.king.or..not.out1file) & write (iout,*) "Reference temperature for weights calculation:", & temp0 diff --git a/source/unres/src-HCD-5D/readpdb.F b/source/unres/src-HCD-5D/readpdb.F index 78d0d98..943d67d 100644 --- a/source/unres/src-HCD-5D/readpdb.F +++ b/source/unres/src-HCD-5D/readpdb.F @@ -11,7 +11,7 @@ C geometry. include 'COMMON.GEO' include 'COMMON.NAMES' include 'COMMON.CONTROL' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.SETUP' include 'COMMON.SBRIDGE' character*3 seq,atom,res @@ -588,7 +588,7 @@ C and convert the peptide geometry into virtual-chain geometry. include 'COMMON.GEO' include 'COMMON.NAMES' include 'COMMON.CONTROL' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.SETUP' integer i,j,k,ibeg,ishift1,ires,iii,ires_old,ishift,ity, & ishift_pdb,ires_ca diff --git a/source/unres/src-HCD-5D/readrtns_CSA.F b/source/unres/src-HCD-5D/readrtns_CSA.F index 3c6fb51..cd60d6e 100644 --- a/source/unres/src-HCD-5D/readrtns_CSA.F +++ b/source/unres/src-HCD-5D/readrtns_CSA.F @@ -1568,12 +1568,11 @@ C Set up variable list. nphi=nres-3 nvar=ntheta+nphi nside=0 - write (iout,*) "SETUP_VAR ialph" do i=2,nres-1 if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - nside=nside+1 + nside=nside+1 ialph(i,1)=nvar+nside - ialph(nside,2)=i + ialph(nside,2)=i endif enddo if (indphi.gt.0) then @@ -1583,7 +1582,6 @@ C Set up variable list. else nvar=nvar+2*nside endif - write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1) return end c---------------------------------------------------------------------------- diff --git a/source/unres/src-HCD-5D/sc_minimize.F b/source/unres/src-HCD-5D/sc_minimize.F new file mode 100644 index 0000000..a284a7c --- /dev/null +++ b/source/unres/src-HCD-5D/sc_minimize.F @@ -0,0 +1,85 @@ + subroutine sc_minimize(etot,iretcode,nfun) +c Minimizes side-chains only, leaving backbone frozen +crc implicit none + +c Includes + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.VAR' + include 'COMMON.CHAIN' + include 'COMMON.FFIELD' + +c Output arguments + double precision etot + integer iretcode,nfun + +c Local variables + integer i + double precision orig_w(n_ene),energy(0:n_ene) + double precision var(maxvar) + + +c Set non side-chain weights to zero (minimization is faster) +c NOTE: e(2) does not actually depend on the side-chain, only CA + orig_w(2)=wscp + orig_w(3)=welec + orig_w(4)=wcorr + orig_w(5)=wcorr5 + orig_w(6)=wcorr6 + orig_w(7)=wel_loc + orig_w(8)=wturn3 + orig_w(9)=wturn4 + orig_w(10)=wturn6 + orig_w(11)=wang + orig_w(13)=wtor + orig_w(14)=wtor_d + + wscp=0.D0 + welec=0.D0 + wcorr=0.D0 + wcorr5=0.D0 + wcorr6=0.D0 + wel_loc=0.D0 + wturn3=0.D0 + wturn4=0.D0 + wturn6=0.D0 + wang=0.D0 + wtor=0.D0 + wtor_d=0.D0 + +c Prepare to freeze backbone + do i=1,nres + mask_phi(i)=0 + mask_theta(i)=0 + mask_side(i)=1 + enddo + +c Minimize the side-chains + mask_r=.true. + call geom_to_var(nvar,var) + call minimize(etot,var,iretcode,nfun) + call var_to_geom(nvar,var) + mask_r=.false. + +c Put the original weights back and calculate the full energy + wscp=orig_w(2) + welec=orig_w(3) + wcorr=orig_w(4) + wcorr5=orig_w(5) + wcorr6=orig_w(6) + wel_loc=orig_w(7) + wturn3=orig_w(8) + wturn4=orig_w(9) + wturn6=orig_w(10) + wang=orig_w(11) + wtor=orig_w(13) + wtor_d=orig_w(14) + + call chainbuild_extconf + call etotal(energy) + etot=energy(0) + + return + end + + diff --git a/source/unres/src-HCD-5D/sc_move.F b/source/unres/src-HCD-5D/sc_move.F index f353589..75b7211 100644 --- a/source/unres/src-HCD-5D/sc_move.F +++ b/source/unres/src-HCD-5D/sc_move.F @@ -45,7 +45,7 @@ c Local variables double precision orig_w(n_ene) double precision wtime - + sideonly=.true. c Set non side-chain weights to zero (minimization is faster) c NOTE: e(2) does not actually depend on the side-chain, only CA orig_w(2)=wscp @@ -152,7 +152,8 @@ c Put the original weights back to calculate the full energy wtor=orig_w(13) wtor_d=orig_w(14) wvdwpp=orig_w(15) - + sideonly=.false. + mask_side=1 crc n_fun=n_fun+1 ct write (iout,*) 'sc_local time= ',MPI_WTIME()-wtime return @@ -230,7 +231,7 @@ crc cur_e=orig_e nres_moved=0 do i=2,nres-1 c Don't do glycine (itype(j)==10) - if (itype(i).ne.10) then + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then sc_dist=dist(nres+i,nres+res_pick) else sc_dist=sc_dist_cutoff @@ -243,10 +244,11 @@ c Don't do glycine (itype(j)==10) endif enddo - call chainbuild + call chainbuild_extconf call egb1(evdw) call esc(escloc) e_sc=wsc*evdw+wscloc*escloc +c write (iout,*) "sc_move: e_sc",e_sc cd call etotal(energy) cd print *,'new ',(energy(k),k=0,n_ene) orig_e=e_sc @@ -271,7 +273,8 @@ crc orig_omeg(i)=omeg(i) crc enddo call minimize_sc1(e_sc,var,iretcode,loc_nfun) - +c write (iout,*) "n_try",n_try +c write (iout,*) "sc_move after minimze_sc1 e_sc",e_sc cv write(*,'(2i3,2f12.5,2i3)') cv & res_pick,nres_moved,orig_e,e_sc-cur_e, cv & iretcode,loc_nfun @@ -334,111 +337,74 @@ c Reset the minimization mask_r to false return end - -c------------------------------------------------------------- - - subroutine sc_minimize(etot,iretcode,nfun) -c Minimizes side-chains only, leaving backbone frozen -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - -c Output arguments - double precision etot - integer iretcode,nfun - -c Local variables - integer i - double precision orig_w(n_ene),energy(0:n_ene) - double precision var(maxvar) - - -c Set non side-chain weights to zero (minimization is faster) -c NOTE: e(2) does not actually depend on the side-chain, only CA - orig_w(2)=wscp - orig_w(3)=welec - orig_w(4)=wcorr - orig_w(5)=wcorr5 - orig_w(6)=wcorr6 - orig_w(7)=wel_loc - orig_w(8)=wturn3 - orig_w(9)=wturn4 - orig_w(10)=wturn6 - orig_w(11)=wang - orig_w(13)=wtor - orig_w(14)=wtor_d - - wscp=0.D0 - welec=0.D0 - wcorr=0.D0 - wcorr5=0.D0 - wcorr6=0.D0 - wel_loc=0.D0 - wturn3=0.D0 - wturn4=0.D0 - wturn6=0.D0 - wang=0.D0 - wtor=0.D0 - wtor_d=0.D0 - -c Prepare to freeze backbone - do i=1,nres - mask_phi(i)=0 - mask_theta(i)=0 - mask_side(i)=1 - enddo - -c Minimize the side-chains - mask_r=.true. - call geom_to_var(nvar,var) - call minimize(etot,var,iretcode,nfun) - call var_to_geom(nvar,var) - mask_r=.false. - -c Put the original weights back and calculate the full energy - wscp=orig_w(2) - welec=orig_w(3) - wcorr=orig_w(4) - wcorr5=orig_w(5) - wcorr6=orig_w(6) - wel_loc=orig_w(7) - wturn3=orig_w(8) - wturn4=orig_w(9) - wturn6=orig_w(10) - wang=orig_w(11) - wtor=orig_w(13) - wtor_d=orig_w(14) - - call chainbuild - call etotal(energy) - etot=energy(0) - - return - end - c------------------------------------------------------------- subroutine minimize_sc1(etot,x,iretcode,nfun) +#ifdef LBFGS_SC + use minima + use inform + use output + use iounit + use scales +#endif implicit real*8 (a-h,o-z) include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#ifndef LBFGS_SC +c parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) + parameter(max_sc_move=10) + parameter (liv=60,lv=(77+2*max_sc_move*(2*max_sc_move+17)/2)) +#endif include 'COMMON.IOUNITS' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.MINIM' common /srutu/ icall - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) + double precision x(maxvar),d(maxvar),xx(maxvar) double precision energia(0:n_ene) +#ifdef LBFGS_SC + integer nvar_restr + common /zmienne/ nvar_restr + double precision grdmin + double precision funcgrad_restr1 + external funcgrad_restr1 + external optsave +#else external func,gradient,fdum external func_restr1,grad_restr1 logical not_done,change,reduce + dimension iv(liv) + double precision v(1:lv) common /przechowalnia/ v - +#endif +#ifdef LBFGS_SC + maxiter=7 + coordtype='RIGIDBODY' + grdmin=tolf + jout=iout +c jprint=print_min_stat + jprint=0 + iwrite=0 + if (.not. allocated(scale)) allocate (scale(nvar)) +c +c set scaling parameter for function and derivative values; +c use square root of median eigenvalue of typical Hessian +c + call x2xx(x,xx,nvar_restr) + set_scale = .true. +c nvar = 0 + do i = 1, nvar_restr +c if (use(i)) then +c do j = 1, 3 +c nvar = nvar + 1 + scale(i) = 12.0d0 +c end do +c end if + end do +c write (iout,*) "Calling lbfgs" + call lbfgs (nvar_restr,xx,etot,grdmin,funcgrad_restr1,optsave) + deallocate(scale) +c write (iout,*) "After lbfgs" + call xx2x(x,xx) +#else call deflt(2,iv,liv,lv,v) * 12 means fresh start, dont call deflt iv(1)=12 @@ -451,8 +417,8 @@ c------------------------------------------------------------- * controls output iv(19)=2 * selects output unit -c iv(21)=iout iv(21)=0 +c iv(21)=0 * 1 means to print out result iv(22)=0 * 1 means to print out summary stats @@ -491,14 +457,158 @@ c v(25)=4.0D0 & iv,liv,lv,v,idum,rdum,fdum) call xx2x(x,xx) ELSE - call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) +c call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) ENDIF etot=v(10) iretcode=iv(1) nfun=iv(6) - +#endif return end +#ifdef LBFGS_SC + double precision function funcgrad_restr1(x,g) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + include 'COMMON.INTERACT' + include 'COMMON.TIME1' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + integer nvar_restr + common /zmienne/ nvar_restr + double precision energia(0:n_ene),evdw,escloc + double precision ufparm,e1,e2 + dimension x(maxvar),g(maxvar),gg(maxvar) +#ifdef OSF +c Intercept NaNs in the coordinates, before calling etotal + x_sum=0.D0 + do i=1,nvar_restr + x_sum=x_sum+x(i) + enddo + FOUND_NAN=.false. + if (x_sum.ne.x_sum) then + write(iout,*)" *** func_restr1 : Found NaN in coordinates" + f=1.0D+73 + FOUND_NAN=.true. + return + endif +#else + FOUND_NAN=.false. + do i=1,nvar_restr + if (isnan(x(i))) then + FOUND_NAN=.true. + f=1.0D+73 + funcgrad_restr1=f + write (iout,*) "NaN in coordinates" + return + endif + enddo +#endif + +c write (iout,*) "nvar_restr",nvar_restr +c write (iout,*) "x",(x(i),i=1,nvar_restr) + call var_to_geom_restr(nvar_restr,x) + call zerograd + call chainbuild_extconf +cd write (iout,*) 'ETOTAL called from FUNC' + call egb1(evdw) + call esc(escloc) + f=wsc*evdw+wscloc*escloc +c write (iout,*) "evdw",evdw," escloc",escloc + if (isnan(f)) then + f=1.0d20 + funcgrad_restr1=f + return + endif + funcgrad_restr1=f +c write (iout,*) "f",f +cd call etotal(energia(0)) +cd f=wsc*energia(1)+wscloc*energia(12) +cd print *,f,evdw,escloc,energia(0) +C +C Sum up the components of the Cartesian gradient. +C + do i=1,nct + do j=1,3 + gradx(j,i,icg)=wsc*gvdwx(j,i)+wscloc*gsclocx(j,i) + enddo + enddo + +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + call cart2intgrad(nvar,gg) +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + + ig=0 + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + g(ig)=gg(ialph(i,1)) +c write (iout,*) "i",i," ig",ig," ialph",ialph(i,1) +c write (iout,*) "g",g(ig)," gg",gg(ialph(i,1)) + ENDIF + endif + enddo + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + g(ig)=gg(ialph(i,1)+nside) +c write (iout,*) "i",i," ig",ig," ialph",ialph(i,1)+nside +c write (iout,*) "g",g(ig)," gg",gg(ialph(i,1)+nside) + ENDIF + endif + enddo + +C +C Add the components corresponding to local energy terms. +C + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) +c write (iout,*) "ij",ij," i",i," ig",ig," igall",igall +c write (iout,*) "gloc",gloc(igall,icg)," g",g(ig) + endif + endif + enddo + enddo + +cd do i=1,ig +cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +cd enddo + return + end +#else ************************************************************************ subroutine func_restr1(n,x,nf,f,uiparm,urparm,ufparm) implicit real*8 (a-h,o-z) @@ -509,9 +619,7 @@ c v(25)=4.0D0 include 'COMMON.FFIELD' include 'COMMON.INTERACT' include 'COMMON.TIME1' - common /chuju/ jjj double precision energia(0:n_ene),evdw,escloc - integer jjj double precision ufparm,e1,e2 external ufparm integer uiparm(1) @@ -537,11 +645,12 @@ c Intercept NaNs in the coordinates, before calling etotal call var_to_geom_restr(n,x) call zerograd - call chainbuild + call chainbuild_extconf cd write (iout,*) 'ETOTAL called from FUNC' call egb1(evdw) call esc(escloc) f=wsc*evdw+wscloc*escloc +c write (iout,*) "f",f cd call etotal(energia(0)) cd f=wsc*energia(1)+wscloc*energia(12) cd print *,f,evdw,escloc,energia(0) @@ -550,7 +659,7 @@ C Sum up the components of the Cartesian gradient. C do i=1,nct do j=1,3 - gradx(j,i,icg)=wsc*gvdwx(j,i) + gradx(j,i,icg)=wsc*gvdwx(j,i)+wscloc*gsclocx(j,i) enddo enddo @@ -569,7 +678,7 @@ c------------------------------------------------------- external ufparm integer uiparm(1) double precision urparm(1) - dimension x(maxvar),g(maxvar) + dimension x(maxvar),g(maxvar),gg(maxvar) icg=mod(nf,2)+1 if (nf-nfl+1) 20,30,40 @@ -578,76 +687,51 @@ c write (iout,*) 'grad 20' if (nf.eq.0) return goto 40 30 call var_to_geom_restr(n,x) - call chainbuild + call chainbuild_extconf C C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. C - 40 call cartder + 40 call cart2intgrad(nvar,gg) C C Convert the Cartesian gradient into internal-coordinate gradient. C ig=0 - ind=nres-2 + ind=nres-2 do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo + IF (mask_phi(i+2).eq.1) THEN ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i + g(ig)=gg(i-1) ENDIF enddo - ind=0 do i=1,nres-2 IF (mask_theta(i+2).eq.1) THEN ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i + g(ig)=gg(nphi+i) ENDIF enddo do i=2,nres-1 - if (itype(i).ne.10) then + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then IF (mask_side(i).eq.1) THEN ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai + g(ig)=gg(ialph(i,1)) +c write (iout,*) "i",i," ig",ig," ialph",ialph(i,1) +c write (iout,*) "g",g(ig)," gg",gg(ialph(i,1)) ENDIF endif enddo do i=2,nres-1 - if (itype(i).ne.10) then + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then IF (mask_side(i).eq.1) THEN ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai + g(ig)=gg(ialph(i,1)+nside) +c write (iout,*) "i",i," ig",ig," ialph",ialph(i,1)+nside +c write (iout,*) "g",g(ig)," gg",gg(ialph(i,1)+nside) ENDIF endif enddo @@ -676,11 +760,13 @@ C do ij=1,2 do i=2,nres-1 - if (itype(i).ne.10) then + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then igall=igall+1 if (mask_side(i).eq.1) then ig=ig+1 g(ig)=g(ig)+gloc(igall,icg) +c write (iout,*) "ij",ij," i",i," ig",ig," igall",igall +c write (iout,*) "gloc",gloc(igall,icg)," g",g(ig) endif endif enddo @@ -691,6 +777,7 @@ cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) cd enddo return end +#endif C----------------------------------------------------------------------------- subroutine egb1(evdw) C @@ -716,11 +803,12 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon lprn=.false. c if (icall.eq.0) lprn=.true. ind=0 - do i=iatsc_s,iatsc_e +c do i=iatsc_s,iatsc_e + do i=nnt,nct itypi=iabs(itype(i)) - if (itypi.eq.ntyp1) cycle + if (itypi.eq.ntyp1 .or. mask_side(i).eq.0) cycle itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) @@ -761,8 +849,9 @@ C lipbufthick is thickenes of lipid buffore C C Calculate SC interaction energy. C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) +c do iint=1,nint_gr(i) +c do j=istart(i,iint),iend(i,iint) + do j=i+1,nct IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN ind=ind+1 itypj=iabs(itype(j)) @@ -922,7 +1011,7 @@ C Calculate angular part of the gradient. call sc_grad ENDIF enddo ! j - enddo ! iint +c enddo ! iint enddo ! i end C----------------------------------------------------------------------------- diff --git a/source/unres/src-HCD-5D/search.f b/source/unres/src-HCD-5D/search.f index 5470518..b3adbbd 100644 --- a/source/unres/src-HCD-5D/search.f +++ b/source/unres/src-HCD-5D/search.f @@ -158,7 +158,19 @@ c c get new function and projected gradient following a step c ncalls = ncalls + 1 +c 3/14/2020 Adam Liwo: added the condition to prevent from infinite +c iteration loop + if (ncalls.gt.200) then + do i = 1, nvar + x(i) = x_0(i) + end do + f_b=f_a + deallocate (x_0) + deallocate (s) + return + endif f_b = fgvalue (x,g) +c write (2,*) "ncalls",ncalls," f_a",f_a," f_b",f_b," sg_a",sg_a sg_b = 0.0d0 do i = 1, nvar sg_b = sg_b + s(i)*g(i) diff --git a/source/unres/src-HCD-5D/test.F b/source/unres/src-HCD-5D/test.F index 7277b01..ac867d9 100644 --- a/source/unres/src-HCD-5D/test.F +++ b/source/unres/src-HCD-5D/test.F @@ -1858,978 +1858,3 @@ cd call write_pdb(6,'dist structure',etot) return end c----------------------------------------------------------- - subroutine contact_cp(var,var2,iff,ieval,in_pdb) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.MINIM' - - character*50 linia - integer nf,ij(4) - double precision energy(0:n_ene) - double precision var(maxvar),var2(maxvar) - double precision time0,time1 - integer iff(maxres),ieval - double precision theta1(maxres),phi1(maxres),alph1(maxres), - & omeg1(maxres) - logical debug - - debug=.false. -c debug=.true. - if (ieval.eq.-1) debug=.true. - - -c -c store selected dist. constrains from 1st structure -c -#ifdef OSF -c Intercept NaNs in the coordinates -c write(iout,*) (var(i),i=1,nvar) - x_sum=0.D0 - do i=1,nvar - x_sum=x_sum+var(i) - enddo - if (x_sum.ne.x_sum) then - write(iout,*)" *** contact_cp : Found NaN in coordinates" - call flush(iout) - print *," *** contact_cp : Found NaN in coordinates" - return - endif -#endif - - - call var_to_geom(nvar,var) - call chainbuild - nhpb0=nhpb - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( iff(i).eq.1.and.iff(j).eq.1 ) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - enddo - enddo - call hpb_partition - - do i=1,nres - theta1(i)=theta(i) - phi1(i)=phi(i) - alph1(i)=alph(i) - omeg1(i)=omeg(i) - enddo - -c -c freeze sec.elements from 2nd structure -c - do i=1,nres - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - enddo - - call var_to_geom(nvar,var2) - call secondary2(debug) - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - enddo - mask_r=.true. - -c -c copy selected res from 1st to 2nd structure -c - - do i=1,nres - if ( iff(i).eq.1 ) then - theta(i)=theta1(i) - phi(i)=phi1(i) - alph(i)=alph1(i) - omeg(i)=omeg1(i) - endif - enddo - - if(debug) then -c -c prepare description in linia variable -c - iwsk=0 - nf=0 - if (iff(1).eq.1) then - iwsk=1 - nf=nf+1 - ij(nf)=1 - endif - do i=2,nres - if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then - iwsk=1 - nf=nf+1 - ij(nf)=i - endif - if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then - iwsk=0 - nf=nf+1 - ij(nf)=i-1 - endif - enddo - if (iff(nres).eq.1) then - nf=nf+1 - ij(nf)=nres - endif - - write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') - & "SELECT",ij(1)-1,"-",ij(2)-1, - & ",",ij(3)-1,"-",ij(4)-1 - - endif -c -c run optimization -c - call contact_cp_min(var,ieval,in_pdb,linia,debug) - - return - end - - subroutine contact_cp_min(var,ieval,in_pdb,linia,debug) -c -c input : theta,phi,alph,omeg,in_pdb,linia,debug -c output : var,ieval -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.MINIM' - - character*50 linia - integer nf,ij(4) - double precision energy(0:n_ene) - double precision var(maxvar) - double precision time0,time1 - integer ieval,info(3) - logical debug,fail,check_var,reduce,change - - write(iout,'(a20,i6,a20)') - & '------------------',in_pdb,'-------------------' - - if (debug) then - call chainbuild - call write_pdb(1000+in_pdb,'combined structure',0d0) -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - endif - -c -c run optimization of distances -c -c uses d0(),w() and mask() for frozen 2D -c -ctest--------------------------------------------- -ctest NX=NRES-3 -ctest NY=((NRES-4)*(NRES-5))/2 -ctest call distfit(debug,5000) - - do i=1,nres - mask_side(i)=0 - enddo - - ipot01=ipot - maxmin01=maxmin - maxfun01=maxfun -c wstrain01=wstrain - wsc01=wsc - wscp01=wscp - welec01=welec - wvdwpp01=wvdwpp -c wang01=wang - wscloc01=wscloc - wtor01=wtor - wtor_d01=wtor_d - - ipot=6 - maxmin=2000 - maxfun=4000 -c wstrain=1.0 - wsc=0.0 - wscp=0.0 - welec=0.0 - wvdwpp=0.0 -c wang=0.0 - wscloc=0.0 - wtor=0.0 - wtor_d=0.0 - - call geom_to_var(nvar,var) -cde change=reduce(var) - if (check_var(var,info)) then - write(iout,*) 'cp_min error in input' - print *,'cp_min error in input' - return - endif - -cd call etotal(energy(0)) -cd call enerprint(energy(0)) -cd call check_eint - -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif -cdtest call minimize(etot,var,iretcode,nfun) -cdtest write(iout,*)'SUMSL return code is',iretcode,' eval SDIST',nfun -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - -cd call etotal(energy(0)) -cd call enerprint(energy(0)) -cd call check_eint - - do i=1,nres - mask_side(i)=1 - enddo - - ipot=ipot01 - maxmin=maxmin01 - maxfun=maxfun01 -c wstrain=wstrain01 - wsc=wsc01 - wscp=wscp01 - welec=welec01 - wvdwpp=wvdwpp01 -c wang=wang01 - wscloc=wscloc01 - wtor=wtor01 - wtor_d=wtor_d01 -ctest-------------------------------------------------- - - if(debug) then -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,a)')' Time for distfit ',time1-time0,' sec' - call write_pdb(2000+in_pdb,'distfit structure',0d0) - endif - - - ipot0=ipot - maxmin0=maxmin - maxfun0=maxfun - wstrain0=wstrain -c -c run soft pot. optimization -c with constrains: -c nhpb,ihpb(),jhpb(),forcon(),dhpb() and hpb_partition -c and frozen 2D: -c mask_phi(),mask_theta(),mask_side(),mask_r -c - ipot=6 - maxmin=2000 - maxfun=4000 - -cde change=reduce(var) -cde if (check_var(var,info)) write(iout,*) 'error before soft' -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, - & nfun/(time1-time0),' SOFT eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(3000+in_pdb,'soft structure',etot) - endif -c -c run full UNRES optimization with constrains and frozen 2D -c the same variables as soft pot. optimizatio -c - ipot=ipot0 - maxmin=maxmin0 - maxfun=maxfun0 -c -c check overlaps before calling full UNRES minim -c - call var_to_geom(nvar,var) - call chainbuild - call etotal(energy(0)) -#ifdef OSF - write(iout,*) 'N7 ',energy(0) - if (energy(0).ne.energy(0)) then - write(iout,*) 'N7 error - gives NaN',energy(0) - endif -#endif - ieval=1 - if (energy(1).eq.1.0d20) then - write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw=1d20',energy(1) - call overlap_sc(fail) - if(.not.fail) then - call etotal(energy(0)) - ieval=ieval+1 - write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw after',energy(1) - else - mask_r=.false. - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - return - endif - endif - call flush(iout) -c -cdte time0=MPI_WTIME() -cde change=reduce(var) -cde if (check_var(var,info)) then -cde write(iout,*) 'error before mask dist' -cde call var_to_geom(nvar,var) -cde call chainbuild -cde call write_pdb(10000+in_pdb,'before mask dist',etot) -cde endif -cdte call minimize(etot,var,iretcode,nfun) -cdte write(iout,*)'SUMSL MASK DIST return code is',iretcode, -cdte & ' eval ',nfun -cdte ieval=ieval+nfun -cdte -cdte time1=MPI_WTIME() -cdte write (iout,'(a,f6.2,f8.2,a)') -cdte & ' Time for mask dist min.',time1-time0, -cdte & nfun/(time1-time0),' eval/s' -cdte call flush(iout) - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(4000+in_pdb,'mask dist',etot) - endif -c -c switch off freezing of 2D and -c run full UNRES optimization with constrains -c - mask_r=.false. -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif -cde change=reduce(var) -cde if (check_var(var,info)) then -cde write(iout,*) 'error before dist' -cde call var_to_geom(nvar,var) -cde call chainbuild -cde call write_pdb(11000+in_pdb,'before dist',etot) -cde endif - - call minimize(etot,var,iretcode,nfun) - -cde change=reduce(var) -cde if (check_var(var,info)) then -cde write(iout,*) 'error after dist',ico -cde call var_to_geom(nvar,var) -cde call chainbuild -cde call write_pdb(12000+in_pdb+ico*1000,'after dist',etot) -cde endif - write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun - ieval=ieval+nfun - -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for dist min.',time1-time0, - & nfun/(time1-time0),' eval/s' -cde call etotal(energy(0)) -cde write(iout,*) 'N7 after dist',energy(0) - call flush(iout) - - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(in_pdb,linia,etot) - endif -c -c reset constrains -c - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - - return - end -c-------------------------------------------------------- - subroutine softreg - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.INTERACT' -c - include 'COMMON.DISTFIT' - integer iff(maxres) - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar) - integer ieval -c - logical debug,ltest,fail - character*50 linia -c - linia='test' - debug=.true. - in_pdb=0 - - - -c------------------------ -c -c freeze sec.elements -c - do i=1,nres - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - iff(i)=0 - enddo - - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - enddo - mask_r=.true. - - - - nhpb0=nhpb -c -c store dist. constrains -c - do i=1,nres-3 - do j=i+3,nres - if ( iff(i).eq.1.and.iff(j).eq.1 ) then - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=0.1 - dhpb(nhpb)=DIST(i,j) - endif - enddo - enddo - call hpb_partition - - if (debug) then - call chainbuild - call write_pdb(100+in_pdb,'input reg. structure',0d0) - endif - - - ipot0=ipot - maxmin0=maxmin - maxfun0=maxfun - wstrain0=wstrain - wang0=wang -c -c run soft pot. optimization -c - ipot=6 - wang=3.0 - maxmin=2000 - maxfun=4000 - call geom_to_var(nvar,var) -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, - & nfun/(time1-time0),' SOFT eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(300+in_pdb,'soft structure',etot) - endif -c -c run full UNRES optimization with constrains and frozen 2D -c the same variables as soft pot. optimizatio -c - ipot=ipot0 - wang=wang0 - maxmin=maxmin0 - maxfun=maxfun0 -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL MASK DIST return code is',iretcode, - & ' eval ',nfun - ieval=nfun - -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)') - & ' Time for mask dist min.',time1-time0, - & nfun/(time1-time0),' eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(400+in_pdb,'mask & dist',etot) - endif -c -c switch off constrains and -c run full UNRES optimization with frozen 2D -c - -c -c reset constrains -c - nhpb_c=nhpb - nhpb=nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - - -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL MASK return code is',iretcode,' eval ',nfun - ieval=ieval+nfun - -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for mask min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(500+in_pdb,'mask 2d frozen',etot) - endif - - mask_r=.false. - - -c -c run full UNRES optimization with constrains and NO frozen 2D -c - - nhpb=nhpb_c - link_start=1 - link_end=nhpb - maxfun=maxfun0/5 - - do ico=1,5 - - wstrain=wstrain0/ico - -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') - & ' SUMSL DIST',wstrain,' return code is',iretcode, - & ' eval ',nfun - ieval=nfun - -#ifdef MPI - time1=MPI_WTIME() -#else - time0=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)') - & ' Time for dist min.',time1-time0, - & nfun/(time1-time0),' eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(600+in_pdb+ico,'dist cons',etot) - endif - - enddo -c - nhpb=nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - maxfun=maxfun0 - - -c - if (minim) then -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, - & '+ DIST eval',ieval - -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(999,'full min',etot) - endif - - return - end - - - subroutine beta_slide(i1,i2,i3,i4,i5,ieval,ij) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar) - integer jdata(5),isec(maxres) -c - jdata(1)=i1 - jdata(2)=i2 - jdata(3)=i3 - jdata(4)=i4 - jdata(5)=i5 - - call secondary2(.false.) - - do i=1,nres - isec(i)=0 - enddo - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - isec(i)=1 - enddo - do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) - isec(i)=1 - enddo - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - isec(i)=2 - enddo - enddo - -c -c cut strands at the ends -c - if (jdata(2)-jdata(1).gt.3) then - jdata(1)=jdata(1)+1 - jdata(2)=jdata(2)-1 - if (jdata(3).lt.jdata(4)) then - jdata(3)=jdata(3)+1 - jdata(4)=jdata(4)-1 - else - jdata(3)=jdata(3)-1 - jdata(4)=jdata(4)+1 - endif - endif - -cv call chainbuild -cv call etotal(energy(0)) -cv etot=energy(0) -cv write(iout,*) nnt,nct,etot -cv call write_pdb(ij*100,'first structure',etot) -cv write(iout,*) 'N16 test',(jdata(i),i=1,5) - -c------------------------ -c generate constrains -c - ishift=jdata(5)-2 - if(ishift.eq.0) ishift=-2 - nhpb0=nhpb - call chainbuild - do i=jdata(1),jdata(2) - isec(i)=-1 - if(jdata(4).gt.jdata(3))then - do j=jdata(3)+i-jdata(1)-2,jdata(3)+i-jdata(1)+2 - isec(j)=-1 -cd print *,i,j,j+ishift - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=1000.0 - dhpb(nhpb)=DIST(i,j+ishift) - enddo - else - do j=jdata(3)-i+jdata(1)+2,jdata(3)-i+jdata(1)-2,-1 - isec(j)=-1 -cd print *,i,j,j+ishift - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=1000.0 - dhpb(nhpb)=DIST(i,j+ishift) - enddo - endif - enddo - - do i=nnt,nct-2 - do j=i+2,nct - if(isec(i).gt.0.or.isec(j).gt.0) then -cd print *,i,j - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=0.1 - dhpb(nhpb)=DIST(i,j) - endif - enddo - enddo - - call hpb_partition - - call geom_to_var(nvar,var) - maxfun0=maxfun - wstrain0=wstrain - maxfun=4000/5 - - do ico=1,5 - - wstrain=wstrain0/ico - -cv time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') - & ' SUMSL DIST',wstrain,' return code is',iretcode, - & ' eval ',nfun - ieval=ieval+nfun -cv time1=MPI_WTIME() -cv write (iout,'(a,f6.2,f8.2,a)') -cv & ' Time for dist min.',time1-time0, -cv & nfun/(time1-time0),' eval/s' -cv call var_to_geom(nvar,var) -cv call chainbuild -cv call write_pdb(ij*100+ico,'dist cons',etot) - - enddo -c - nhpb=nhpb0 - call hpb_partition - wstrain=wstrain0 - maxfun=maxfun0 -c -cd print *,etot - wscloc0=wscloc - wscloc=10.0 - call sc_move(nnt,nct,100,100d0,nft_sc,etot) - wscloc=wscloc0 -cv call chainbuild -cv call etotal(energy(0)) -cv etot=energy(0) -cv call write_pdb(ij*100+10,'sc_move',etot) -cd call intout -cd print *,nft_sc,etot - - return - end - - subroutine beta_zip(i1,i2,ieval,ij) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar) - character*10 test - -cv call chainbuild -cv call etotal(energy(0)) -cv etot=energy(0) -cv write(test,'(2i5)') i1,i2 -cv call write_pdb(ij*100,test,etot) -cv write(iout,*) 'N17 test',i1,i2,etot,ij - -c -c generate constrains -c - nhpb0=nhpb - nhpb=nhpb+1 - ihpb(nhpb)=i1 - jhpb(nhpb)=i2 - forcon(nhpb)=1000.0 - dhpb(nhpb)=4.0 - - call hpb_partition - - call geom_to_var(nvar,var) - maxfun0=maxfun - wstrain0=wstrain - maxfun=1000/5 - - do ico=1,5 - wstrain=wstrain0/ico -cv time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') - & ' SUMSL DIST',wstrain,' return code is',iretcode, - & ' eval ',nfun - ieval=ieval+nfun -cv time1=MPI_WTIME() -cv write (iout,'(a,f6.2,f8.2,a)') -cv & ' Time for dist min.',time1-time0, -cv & nfun/(time1-time0),' eval/s' -c do not comment the next line - call var_to_geom(nvar,var) -cv call chainbuild -cv call write_pdb(ij*100+ico,'dist cons',etot) - enddo - - nhpb=nhpb0 - call hpb_partition - wstrain=wstrain0 - maxfun=maxfun0 - -cv call etotal(energy(0)) -cv etot=energy(0) -cv write(iout,*) 'N17 test end',i1,i2,etot,ij - - - return - end diff --git a/source/unres/src-HCD-5D/unres.F b/source/unres/src-HCD-5D/unres.F index 76bd280..f556eb6 100644 --- a/source/unres/src-HCD-5D/unres.F +++ b/source/unres/src-HCD-5D/unres.F @@ -20,7 +20,7 @@ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC include 'COMMON.GEO' include 'COMMON.HEADER' include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.CHAIN' include 'COMMON.VAR' include 'COMMON.IOUNITS' @@ -73,8 +73,8 @@ c write (iout,*) "After readrtns" call flush(iout) C if (modecalc.eq.-2) then - call test - stop +c call test +c stop else if (modecalc.eq.-1) then write(iout,*) "call check_sc_map next" call check_bond @@ -199,7 +199,7 @@ c--------------------------------------------------------------------------- include 'COMMON.GEO' include 'COMMON.HEADER' include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.CHAIN' include 'COMMON.VAR' include 'COMMON.IOUNITS' @@ -217,6 +217,11 @@ c--------------------------------------------------------------------------- double precision rms,frac,frac_nn,co double precision varia(maxvar) double precision time00,time1,time_ene,evals +#ifdef LBFGS + character*9 status + integer niter + common /lbfgstat/ status,niter,nfun +#endif integer ilen if (indpdb.eq.0) call chainbuild if (indpdb.ne.0) then @@ -269,10 +274,18 @@ c print *,'after hairpin' c print *,'after secondary' if (minim) then crc overlap test + if (indpdb.ne.0 .and. .not.dccart) then + call bond_regular + call chainbuild_extconf + call etotal(energy(0)) + write (iout,*) "After bond regularization" + call enerprint(energy(0)) + endif + if (overlapsc) then - print *, 'Calling OVERLAP_SC' +c print *, 'Calling OVERLAP_SC' call overlap_sc(fail) - print *,"After overlap_sc" +c print *,"After overlap_sc" endif if (searchsc) then @@ -290,12 +303,8 @@ crc overlap test #endif call minim_dc(etot,iretcode,nfun) else - if (indpdb.ne.0) then - call bond_regular - call chainbuild_extconf - endif call geom_to_var(nvar,varia) - print *,'Calling MINIMIZE.' +c print *,'Calling MINIMIZE.' #ifdef MPI time1=MPI_WTIME() #else @@ -303,7 +312,11 @@ crc overlap test #endif call minimize(etot,varia,iretcode,nfun) endif +#ifdef LBFGS + print *,'LBFGS return code is',status,' eval ',nfun +#else print *,'SUMSL return code is',iretcode,' eval ',nfun +#endif #ifdef MPI evals=nfun/(MPI_WTIME()-time1) #else @@ -327,9 +340,15 @@ crc overlap test call cartoutx(0.0d0) endif if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) +#ifdef LBFGS + write (iout,'(a,a9)') 'LBFGS return code:',status + write (iout,'(a,i20)') '# of energy evaluations:',nfun+1 + write (iout,'(a,f16.3)')'# of energy evaluations/sec:',evals +#else write (iout,'(a,i3)') 'SUMSL return code:',iretcode write (iout,'(a,i20)') '# of energy evaluations:',nfun+1 write (iout,'(a,f16.3)')'# of energy evaluations/sec:',evals +#endif else print *,'refstr=',refstr if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) @@ -353,7 +372,7 @@ c--------------------------------------------------------------------------- include 'COMMON.GEO' include 'COMMON.HEADER' include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.CHAIN' include 'COMMON.VAR' include 'COMMON.IOUNITS' @@ -364,6 +383,11 @@ c--------------------------------------------------------------------------- double precision energy(0:n_ene) double precision etot,rms,frac,frac_nn,co integer iretcode +#ifdef LBFGS + character*9 status + integer niter,nfun + common /lbfgstat/ status,niter,nfun +#endif call gen_dist_constr call sc_conf @@ -378,7 +402,11 @@ c--------------------------------------------------------------------------- if (outpdb) call pdbout(etot,titel(:50),ipdb) if (outmol2) call mol2out(etot,titel(:32)) if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) +#ifdef LBFGS + write (iout,'(a,a9)') 'LBFGS return code:',status +#else write (iout,'(a,i3)') 'SUMSL return code:',iretcode +#endif return end c--------------------------------------------------------------------------- @@ -440,7 +468,7 @@ c--------------------------------------------------------------------------- include 'COMMON.GEO' include 'COMMON.HEADER' include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.CHAIN' include 'COMMON.VAR' include 'COMMON.IOUNITS' @@ -739,7 +767,7 @@ c--------------------------------------------------------------------------- include 'COMMON.GEO' include 'COMMON.HEADER' include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.CHAIN' include 'COMMON.VAR' include 'COMMON.IOUNITS' @@ -825,7 +853,8 @@ c enddo goto (10,20,30) icheckgrad 10 call check_ecartint return - 20 call check_cartgrad + 20 write (iout,*) + & "Checking the gradient of Cartesian coordinates disabled." return 30 call check_eint return diff --git a/source/unres/src-HCD-5D/xdrf b/source/unres/src-HCD-5D/xdrf new file mode 120000 index 0000000..26825c5 --- /dev/null +++ b/source/unres/src-HCD-5D/xdrf @@ -0,0 +1 @@ +../../lib/xdrf \ No newline at end of file diff --git a/source/unres/src-HCD-5D/xdrf/CMakeLists.txt b/source/unres/src-HCD-5D/xdrf/CMakeLists.txt deleted file mode 100644 index 26baa36..0000000 --- a/source/unres/src-HCD-5D/xdrf/CMakeLists.txt +++ /dev/null @@ -1,19 +0,0 @@ -# -# CMake project file for UNRESPACK -# - -# m4 macro processor -add_custom_command( - OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.c - COMMAND m4 - ARGS ${CMAKE_CURRENT_SOURCE_DIR}/underscore.m4 ${CMAKE_CURRENT_SOURCE_DIR}/libxdrf.m4 > ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.c - VERBATIM -) - -# add headers from current dir -include_directories(${CMAKE_CURRENT_SOURCE_DIR}) -# compile the libxdrf library -add_library(xdrf STATIC ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.c ftocstr.c) -set(UNRES_XDRFLIB ${CMAKE_CURRENT_BINARY_DIR}/libxdrf.a PARENT_SCOPE) - -#add_dependencies( ${UNRES_BIN} xdrf ) diff --git a/source/unres/src-HCD-5D/xdrf/Makefile b/source/unres/src-HCD-5D/xdrf/Makefile deleted file mode 100644 index 02c29f6..0000000 --- a/source/unres/src-HCD-5D/xdrf/Makefile +++ /dev/null @@ -1,27 +0,0 @@ -# This make file is part of the xdrf package. -# -# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl -# -# 2006 modified by Cezary Czaplewski - -# Set C compiler and flags for ARCH -CC = gcc -CFLAGS = -O - -M4 = m4 -M4FILE = underscore.m4 - -libxdrf.a: libxdrf.o ftocstr.o - ar cr libxdrf.a $? - -clean: - rm -f libxdrf.o ftocstr.o libxdrf.a - -ftocstr.o: ftocstr.c - $(CC) $(CFLAGS) -c ftocstr.c - -libxdrf.o: libxdrf.m4 $(M4FILE) - $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c - $(CC) $(CFLAGS) -c libxdrf.c - rm -f libxdrf.c - diff --git a/source/unres/src-HCD-5D/xdrf/Makefile_jubl b/source/unres/src-HCD-5D/xdrf/Makefile_jubl deleted file mode 100644 index 8dc35cf..0000000 --- a/source/unres/src-HCD-5D/xdrf/Makefile_jubl +++ /dev/null @@ -1,31 +0,0 @@ -# This make file is part of the xdrf package. -# -# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl -# -# 2006 modified by Cezary Czaplewski - -# Set C compiler and flags for ARCH -BGLSYS = /bgl/BlueLight/ppcfloor/bglsys - -CC = /usr/bin/blrts_xlc -CPPC = /usr/bin/blrts_xlc - -CFLAGS= -O2 -I$(BGLSYS)/include -L$(BGLSYS)/lib -qarch=440d -qtune=440 - -M4 = m4 -M4FILE = RS6K.m4 - -libxdrf.a: libxdrf.o ftocstr.o xdr_array.o xdr.o xdr_float.o xdr_stdio.o - ar cr libxdrf.a $? - -clean: - rm -f *.o libxdrf.a - -ftocstr.o: ftocstr.c - $(CC) $(CFLAGS) -c ftocstr.c - -libxdrf.o: libxdrf.m4 $(M4FILE) - $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c - $(CC) $(CFLAGS) -c libxdrf.c -# rm -f libxdrf.c - diff --git a/source/unres/src-HCD-5D/xdrf/Makefile_linux b/source/unres/src-HCD-5D/xdrf/Makefile_linux deleted file mode 100644 index f03276e..0000000 --- a/source/unres/src-HCD-5D/xdrf/Makefile_linux +++ /dev/null @@ -1,27 +0,0 @@ -# This make file is part of the xdrf package. -# -# (C) 1995 Frans van Hoesel, hoesel@chem.rug.nl -# -# 2006 modified by Cezary Czaplewski - -# Set C compiler and flags for ARCH -CC = cc -CFLAGS = -O - -M4 = m4 -M4FILE = underscore.m4 - -libxdrf.a: libxdrf.o ftocstr.o - ar cr libxdrf.a $? - -clean: - rm -f libxdrf.o ftocstr.o libxdrf.a - -ftocstr.o: ftocstr.c - $(CC) $(CFLAGS) -c ftocstr.c - -libxdrf.o: libxdrf.m4 $(M4FILE) - $(M4) $(M4FILE) libxdrf.m4 > libxdrf.c - $(CC) $(CFLAGS) -c libxdrf.c - rm -f libxdrf.c - diff --git a/source/unres/src-HCD-5D/xdrf/RS6K.m4 b/source/unres/src-HCD-5D/xdrf/RS6K.m4 deleted file mode 100644 index 0331d97..0000000 --- a/source/unres/src-HCD-5D/xdrf/RS6K.m4 +++ /dev/null @@ -1,20 +0,0 @@ -divert(-1) -undefine(`len') -# -# do nothing special to FORTRAN function names -# -define(`FUNCTION',`$1') -# -# FORTRAN character strings are passed as follows: -# a pointer to the base of the string is passed in the normal -# argument list, and the length is passed by value as an extra -# argument, after all of the other arguments. -# -define(`ARGS',`($1`'undivert(1))') -define(`SAVE',`divert(1)$1`'divert(0)') -define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')') -define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len') -define(`STRING_LEN',`$1_len') -define(`STRING_PTR',`$1_ptr') -divert(0) - diff --git a/source/unres/src-HCD-5D/xdrf/ftocstr.c b/source/unres/src-HCD-5D/xdrf/ftocstr.c deleted file mode 100644 index ed2113f..0000000 --- a/source/unres/src-HCD-5D/xdrf/ftocstr.c +++ /dev/null @@ -1,35 +0,0 @@ - - -int ftocstr(ds, dl, ss, sl) - char *ds, *ss; /* dst, src ptrs */ - int dl; /* dst max len */ - int sl; /* src len */ -{ - char *p; - - for (p = ss + sl; --p >= ss && *p == ' '; ) ; - sl = p - ss + 1; - dl--; - ds[0] = 0; - if (sl > dl) - return 1; - while (sl--) - (*ds++ = *ss++); - *ds = '\0'; - return 0; -} - - -int ctofstr(ds, dl, ss) - char *ds; /* dest space */ - int dl; /* max dest length */ - char *ss; /* src string (0-term) */ -{ - while (dl && *ss) { - *ds++ = *ss++; - dl--; - } - while (dl--) - *ds++ = ' '; - return 0; -} diff --git a/source/unres/src-HCD-5D/xdrf/libxdrf.m4 b/source/unres/src-HCD-5D/xdrf/libxdrf.m4 deleted file mode 100644 index eebf199..0000000 --- a/source/unres/src-HCD-5D/xdrf/libxdrf.m4 +++ /dev/null @@ -1,1237 +0,0 @@ -/*____________________________________________________________________________ - | - | libxdrf - portable fortran interface to xdr. some xdr routines - | are C routines for compressed coordinates - | - | version 1.1 - | - | This collection of routines is intended to write and read - | data in a portable way to a file, so data written on one type - | of machine can be read back on a different type. - | - | all fortran routines use an integer 'xdrid', which is an id to the - | current xdr file, and is set by xdrfopen. - | most routines have in integer 'ret' which is the return value. - | The value of 'ret' is zero on failure, and most of the time one - | on succes. - | - | There are three routines useful for C users: - | xdropen(), xdrclose(), xdr3dfcoord(). - | The first two replace xdrstdio_create and xdr_destroy, and *must* be - | used when you plan to use xdr3dfcoord(). (they are also a bit - | easier to interface). For writing data other than compressed coordinates - | you should use the standard C xdr routines (see xdr man page) - | - | xdrfopen(xdrid, filename, mode, ret) - | character *(*) filename - | character *(*) mode - | - | this will open the file with the given filename (string) - | and the given mode, it returns an id in xdrid, which is - | to be used in all other calls to xdrf routines. - | mode is 'w' to create, or update an file, for all other - | values of mode the file is opened for reading - | - | you need to call xdrfclose to flush the output and close - | the file. - | Note that you should not use xdrstdio_create, which comes with the - | standard xdr library - | - | xdrfclose(xdrid, ret) - | flush the data to the file, and closes the file; - | You should not use xdr_destroy (which comes standard with - | the xdr libraries. - | - | xdrfbool(xdrid, bp, ret) - | integer pb - | - | This filter produces values of either 1 or 0 - | - | xdrfchar(xdrid, cp, ret) - | character cp - | - | filter that translate between characters and their xdr representation - | Note that the characters in not compressed and occupies 4 bytes. - | - | xdrfdouble(xdrid, dp, ret) - | double dp - | - | read/write a double. - | - | xdrffloat(xdrid, fp, ret) - | float fp - | - | read/write a float. - | - | xdrfint(xdrid, ip, ret) - | integer ip - | - | read/write integer. - | - | xdrflong(xdrid, lp, ret) - | integer lp - | - | this routine has a possible portablility problem due to 64 bits longs. - | - | xdrfshort(xdrid, sp, ret) - | integer *2 sp - | - | xdrfstring(xdrid, sp, maxsize, ret) - | character *(*) - | integer maxsize - | - | read/write a string, with maximum length given by maxsize - | - | xdrfwrapstring(xdris, sp, ret) - | character *(*) - | - | read/write a string (it is the same as xdrfstring accept that it finds - | the stringlength itself. - | - | xdrfvector(xdrid, cp, size, xdrfproc, ret) - | character *(*) - | integer size - | external xdrfproc - | - | read/write an array pointed to by cp, with number of elements - | defined by 'size'. the routine 'xdrfproc' is the name - | of one of the above routines to read/write data (like xdrfdouble) - | In contrast with the c-version you don't need to specify the - | byte size of an element. - | xdrfstring is not allowed here (it is in the c version) - | - | xdrf3dfcoord(xdrid, fp, size, precision, ret) - | real (*) fp - | real precision - | integer size - | - | this is *NOT* a standard xdr routine. I named it this way, because - | it invites people to use the other xdr routines. - | It is introduced to store specifically 3d coordinates of molecules - | (as found in molecular dynamics) and it writes it in a compressed way. - | It starts by multiplying all numbers by precision and - | rounding the result to integer. effectively converting - | all floating point numbers to fixed point. - | it uses an algorithm for compression that is optimized for - | molecular data, but could be used for other 3d coordinates - | as well. There is subtantial overhead involved, so call this - | routine only if you have a large number of coordinates to read/write - | - | ________________________________________________________________________ - | - | Below are the routines to be used by C programmers. Use the 'normal' - | xdr routines to write integers, floats, etc (see man xdr) - | - | int xdropen(XDR *xdrs, const char *filename, const char *type) - | This will open the file with the given filename and the - | given mode. You should pass it an allocated XDR struct - | in xdrs, to be used in all other calls to xdr routines. - | Mode is 'w' to create, or update an file, and for all - | other values of mode the file is opened for reading. - | You need to call xdrclose to flush the output and close - | the file. - | - | Note that you should not use xdrstdio_create, which - | comes with the standard xdr library. - | - | int xdrclose(XDR *xdrs) - | Flush the data to the file, and close the file; - | You should not use xdr_destroy (which comes standard - | with the xdr libraries). - | - | int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) - | This is \fInot\fR a standard xdr routine. I named it this - | way, because it invites people to use the other xdr - | routines. - | - | (c) 1995 Frans van Hoesel, hoesel@chem.rug.nl -*/ - - -#include -#include -#include -#include -#include -#include -#include -#include "xdrf.h" - -int ftocstr(char *, int, char *, int); -int ctofstr(char *, int, char *); - -#define MAXID 20 -static FILE *xdrfiles[MAXID]; -static XDR *xdridptr[MAXID]; -static char xdrmodes[MAXID]; -static unsigned int cnt; - -typedef void (* FUNCTION(xdrfproc)) (int *, void *, int *); - -void -FUNCTION(xdrfbool) ARGS(`xdrid, pb, ret') -int *xdrid, *ret; -int *pb; -{ - *ret = xdr_bool(xdridptr[*xdrid], (bool_t *) pb); - cnt += sizeof(int); -} - -void -FUNCTION(xdrfchar) ARGS(`xdrid, cp, ret') -int *xdrid, *ret; -char *cp; -{ - *ret = xdr_char(xdridptr[*xdrid], cp); - cnt += sizeof(char); -} - -void -FUNCTION(xdrfdouble) ARGS(`xdrid, dp, ret') -int *xdrid, *ret; -double *dp; -{ - *ret = xdr_double(xdridptr[*xdrid], dp); - cnt += sizeof(double); -} - -void -FUNCTION(xdrffloat) ARGS(`xdrid, fp, ret') -int *xdrid, *ret; -float *fp; -{ - *ret = xdr_float(xdridptr[*xdrid], fp); - cnt += sizeof(float); -} - -void -FUNCTION(xdrfint) ARGS(`xdrid, ip, ret') -int *xdrid, *ret; -int *ip; -{ - *ret = xdr_int(xdridptr[*xdrid], ip); - cnt += sizeof(int); -} - -void -FUNCTION(xdrflong) ARGS(`xdrid, lp, ret') -int *xdrid, *ret; -long *lp; -{ - *ret = xdr_long(xdridptr[*xdrid], lp); - cnt += sizeof(long); -} - -void -FUNCTION(xdrfshort) ARGS(`xdrid, sp, ret') -int *xdrid, *ret; -short *sp; -{ - *ret = xdr_short(xdridptr[*xdrid], sp); - cnt += sizeof(sp); -} - -void -FUNCTION(xdrfuchar) ARGS(`xdrid, ucp, ret') -int *xdrid, *ret; -char *ucp; -{ - *ret = xdr_u_char(xdridptr[*xdrid], ucp); - cnt += sizeof(char); -} - -void -FUNCTION(xdrfulong) ARGS(`xdrid, ulp, ret') -int *xdrid, *ret; -unsigned long *ulp; -{ - *ret = xdr_u_long(xdridptr[*xdrid], ulp); - cnt += sizeof(unsigned long); -} - -void -FUNCTION(xdrfushort) ARGS(`xdrid, usp, ret') -int *xdrid, *ret; -unsigned short *usp; -{ - *ret = xdr_u_short(xdridptr[*xdrid], usp); - cnt += sizeof(unsigned short); -} - -void -FUNCTION(xdrf3dfcoord) ARGS(`xdrid, fp, size, precision, ret') -int *xdrid, *ret; -float *fp; -int *size; -float *precision; -{ - *ret = xdr3dfcoord(xdridptr[*xdrid], fp, size, precision); -} - -void -FUNCTION(xdrfstring) ARGS(`xdrid, STRING_ARG(sp), maxsize, ret') -int *xdrid, *ret; -STRING_ARG_DECL(sp); -int *maxsize; -{ - char *tsp; - - tsp = (char*) malloc(((STRING_LEN(sp)) + 1) * sizeof(char)); - if (tsp == NULL) { - *ret = -1; - return; - } - if (ftocstr(tsp, *maxsize+1, STRING_PTR(sp), STRING_LEN(sp))) { - *ret = -1; - free(tsp); - return; - } - *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int) *maxsize); - ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); - cnt += *maxsize; - free(tsp); -} - -void -FUNCTION(xdrfwrapstring) ARGS(`xdrid, STRING_ARG(sp), ret') -int *xdrid, *ret; -STRING_ARG_DECL(sp); -{ - char *tsp; - int maxsize; - maxsize = (STRING_LEN(sp)) + 1; - tsp = (char*) malloc(maxsize * sizeof(char)); - if (tsp == NULL) { - *ret = -1; - return; - } - if (ftocstr(tsp, maxsize, STRING_PTR(sp), STRING_LEN(sp))) { - *ret = -1; - free(tsp); - return; - } - *ret = xdr_string(xdridptr[*xdrid], (char **) &tsp, (u_int)maxsize); - ctofstr( STRING_PTR(sp), STRING_LEN(sp), tsp); - cnt += maxsize; - free(tsp); -} - -void -FUNCTION(xdrfopaque) ARGS(`xdrid, cp, ccnt, ret') -int *xdrid, *ret; -caddr_t *cp; -int *ccnt; -{ - *ret = xdr_opaque(xdridptr[*xdrid], (caddr_t)*cp, (u_int)*ccnt); - cnt += *ccnt; -} - -void -FUNCTION(xdrfsetpos) ARGS(`xdrid, pos, ret') -int *xdrid, *ret; -int *pos; -{ - *ret = xdr_setpos(xdridptr[*xdrid], (u_int) *pos); -} - -void -FUNCTION(xdrf) ARGS(`xdrid, pos') -int *xdrid, *pos; -{ - *pos = xdr_getpos(xdridptr[*xdrid]); -} - -void -FUNCTION(xdrfvector) ARGS(`xdrid, cp, size, elproc, ret') -int *xdrid, *ret; -char *cp; -int *size; -FUNCTION(xdrfproc) elproc; -{ - int lcnt; - cnt = 0; - for (lcnt = 0; lcnt < *size; lcnt++) { - elproc(xdrid, (cp+cnt) , ret); - } -} - - -void -FUNCTION(xdrfclose) ARGS(`xdrid, ret') -int *xdrid; -int *ret; -{ - *ret = xdrclose(xdridptr[*xdrid]); - cnt = 0; -} - -void -FUNCTION(xdrfopen) ARGS(`xdrid, STRING_ARG(fp), STRING_ARG(mode), ret') -int *xdrid; -STRING_ARG_DECL(fp); -STRING_ARG_DECL(mode); -int *ret; -{ - char fname[512]; - char fmode[3]; - - if (ftocstr(fname, sizeof(fname), STRING_PTR(fp), STRING_LEN(fp))) { - *ret = 0; - } - if (ftocstr(fmode, sizeof(fmode), STRING_PTR(mode), - STRING_LEN(mode))) { - *ret = 0; - } - - *xdrid = xdropen(NULL, fname, fmode); - if (*xdrid == 0) - *ret = 0; - else - *ret = 1; -} - -/*___________________________________________________________________________ - | - | what follows are the C routines for opening, closing xdr streams - | and the routine to read/write compressed coordinates together - | with some routines to assist in this task (those are marked - | static and cannot be called from user programs) -*/ -#define MAXABS INT_MAX-2 - -#ifndef MIN -#define MIN(x,y) ((x) < (y) ? (x):(y)) -#endif -#ifndef MAX -#define MAX(x,y) ((x) > (y) ? (x):(y)) -#endif -#ifndef SQR -#define SQR(x) ((x)*(x)) -#endif -static int magicints[] = { - 0, 0, 0, 0, 0, 0, 0, 0, 0, - 8, 10, 12, 16, 20, 25, 32, 40, 50, 64, - 80, 101, 128, 161, 203, 256, 322, 406, 512, 645, - 812, 1024, 1290, 1625, 2048, 2580, 3250, 4096, 5060, 6501, - 8192, 10321, 13003, 16384, 20642, 26007, 32768, 41285, 52015, 65536, - 82570, 104031, 131072, 165140, 208063, 262144, 330280, 416127, 524287, 660561, - 832255, 1048576, 1321122, 1664510, 2097152, 2642245, 3329021, 4194304, 5284491, 6658042, - 8388607, 10568983, 13316085, 16777216 }; - -#define FIRSTIDX 9 -/* note that magicints[FIRSTIDX-1] == 0 */ -#define LASTIDX (sizeof(magicints) / sizeof(*magicints)) - - -/*__________________________________________________________________________ - | - | xdropen - open xdr file - | - | This versions differs from xdrstdio_create, because I need to know - | the state of the file (read or write) so I can use xdr3dfcoord - | in eigther read or write mode, and the file descriptor - | so I can close the file (something xdr_destroy doesn't do). - | -*/ - -int xdropen(XDR *xdrs, const char *filename, const char *type) { - static int init_done = 0; - enum xdr_op lmode; - const char *type1; - int xdrid; - - if (init_done == 0) { - for (xdrid = 1; xdrid < MAXID; xdrid++) { - xdridptr[xdrid] = NULL; - } - init_done = 1; - } - xdrid = 1; - while (xdrid < MAXID && xdridptr[xdrid] != NULL) { - xdrid++; - } - if (xdrid == MAXID) { - return 0; - } - if (*type == 'w' || *type == 'W') { - type = "w+"; - type1 = "w+"; - lmode = XDR_ENCODE; - } else if (*type == 'a' || *type == 'A') { - type = "w+"; - type1 = "a+"; - lmode = XDR_ENCODE; - } else { - type = "r"; - type1 = "r"; - lmode = XDR_DECODE; - } - xdrfiles[xdrid] = fopen(filename, type1); - if (xdrfiles[xdrid] == NULL) { - xdrs = NULL; - return 0; - } - xdrmodes[xdrid] = *type; - /* next test isn't usefull in the case of C language - * but is used for the Fortran interface - * (C users are expected to pass the address of an already allocated - * XDR staructure) - */ - if (xdrs == NULL) { - xdridptr[xdrid] = (XDR *) malloc(sizeof(XDR)); - xdrstdio_create(xdridptr[xdrid], xdrfiles[xdrid], lmode); - } else { - xdridptr[xdrid] = xdrs; - xdrstdio_create(xdrs, xdrfiles[xdrid], lmode); - } - return xdrid; -} - -/*_________________________________________________________________________ - | - | xdrclose - close a xdr file - | - | This will flush the xdr buffers, and destroy the xdr stream. - | It also closes the associated file descriptor (this is *not* - | done by xdr_destroy). - | -*/ - -int xdrclose(XDR *xdrs) { - int xdrid; - - if (xdrs == NULL) { - fprintf(stderr, "xdrclose: passed a NULL pointer\n"); - exit(1); - } - for (xdrid = 1; xdrid < MAXID; xdrid++) { - if (xdridptr[xdrid] == xdrs) { - - xdr_destroy(xdrs); - fclose(xdrfiles[xdrid]); - xdridptr[xdrid] = NULL; - return 1; - } - } - fprintf(stderr, "xdrclose: no such open xdr file\n"); - exit(1); - -} - -/*____________________________________________________________________________ - | - | sendbits - encode num into buf using the specified number of bits - | - | This routines appends the value of num to the bits already present in - | the array buf. You need to give it the number of bits to use and you - | better make sure that this number of bits is enough to hold the value - | Also num must be positive. - | -*/ - -static void sendbits(int buf[], int num_of_bits, int num) { - - unsigned int cnt, lastbyte; - int lastbits; - unsigned char * cbuf; - - cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); - cnt = (unsigned int) buf[0]; - lastbits = buf[1]; - lastbyte =(unsigned int) buf[2]; - while (num_of_bits >= 8) { - lastbyte = (lastbyte << 8) | ((num >> (num_of_bits -8)) /* & 0xff*/); - cbuf[cnt++] = lastbyte >> lastbits; - num_of_bits -= 8; - } - if (num_of_bits > 0) { - lastbyte = (lastbyte << num_of_bits) | num; - lastbits += num_of_bits; - if (lastbits >= 8) { - lastbits -= 8; - cbuf[cnt++] = lastbyte >> lastbits; - } - } - buf[0] = cnt; - buf[1] = lastbits; - buf[2] = lastbyte; - if (lastbits>0) { - cbuf[cnt] = lastbyte << (8 - lastbits); - } -} - -/*_________________________________________________________________________ - | - | sizeofint - calculate bitsize of an integer - | - | return the number of bits needed to store an integer with given max size - | -*/ - -static int sizeofint(const int size) { - unsigned int num = 1; - int num_of_bits = 0; - - while (size >= num && num_of_bits < 32) { - num_of_bits++; - num <<= 1; - } - return num_of_bits; -} - -/*___________________________________________________________________________ - | - | sizeofints - calculate 'bitsize' of compressed ints - | - | given the number of small unsigned integers and the maximum value - | return the number of bits needed to read or write them with the - | routines receiveints and sendints. You need this parameter when - | calling these routines. Note that for many calls I can use - | the variable 'smallidx' which is exactly the number of bits, and - | So I don't need to call 'sizeofints for those calls. -*/ - -static int sizeofints( const int num_of_ints, unsigned int sizes[]) { - int i, num; - unsigned int num_of_bytes, num_of_bits, bytes[32], bytecnt, tmp; - num_of_bytes = 1; - bytes[0] = 1; - num_of_bits = 0; - for (i=0; i < num_of_ints; i++) { - tmp = 0; - for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { - tmp = bytes[bytecnt] * sizes[i] + tmp; - bytes[bytecnt] = tmp & 0xff; - tmp >>= 8; - } - while (tmp != 0) { - bytes[bytecnt++] = tmp & 0xff; - tmp >>= 8; - } - num_of_bytes = bytecnt; - } - num = 1; - num_of_bytes--; - while (bytes[num_of_bytes] >= num) { - num_of_bits++; - num *= 2; - } - return num_of_bits + num_of_bytes * 8; - -} - -/*____________________________________________________________________________ - | - | sendints - send a small set of small integers in compressed format - | - | this routine is used internally by xdr3dfcoord, to send a set of - | small integers to the buffer. - | Multiplication with fixed (specified maximum ) sizes is used to get - | to one big, multibyte integer. Allthough the routine could be - | modified to handle sizes bigger than 16777216, or more than just - | a few integers, this is not done, because the gain in compression - | isn't worth the effort. Note that overflowing the multiplication - | or the byte buffer (32 bytes) is unchecked and causes bad results. - | - */ - -static void sendints(int buf[], const int num_of_ints, const int num_of_bits, - unsigned int sizes[], unsigned int nums[]) { - - int i; - unsigned int bytes[32], num_of_bytes, bytecnt, tmp; - - tmp = nums[0]; - num_of_bytes = 0; - do { - bytes[num_of_bytes++] = tmp & 0xff; - tmp >>= 8; - } while (tmp != 0); - - for (i = 1; i < num_of_ints; i++) { - if (nums[i] >= sizes[i]) { - fprintf(stderr,"major breakdown in sendints num %d doesn't " - "match size %d\n", nums[i], sizes[i]); - exit(1); - } - /* use one step multiply */ - tmp = nums[i]; - for (bytecnt = 0; bytecnt < num_of_bytes; bytecnt++) { - tmp = bytes[bytecnt] * sizes[i] + tmp; - bytes[bytecnt] = tmp & 0xff; - tmp >>= 8; - } - while (tmp != 0) { - bytes[bytecnt++] = tmp & 0xff; - tmp >>= 8; - } - num_of_bytes = bytecnt; - } - if (num_of_bits >= num_of_bytes * 8) { - for (i = 0; i < num_of_bytes; i++) { - sendbits(buf, 8, bytes[i]); - } - sendbits(buf, num_of_bits - num_of_bytes * 8, 0); - } else { - for (i = 0; i < num_of_bytes-1; i++) { - sendbits(buf, 8, bytes[i]); - } - sendbits(buf, num_of_bits- (num_of_bytes -1) * 8, bytes[i]); - } -} - - -/*___________________________________________________________________________ - | - | receivebits - decode number from buf using specified number of bits - | - | extract the number of bits from the array buf and construct an integer - | from it. Return that value. - | -*/ - -static int receivebits(int buf[], int num_of_bits) { - - int cnt, num; - unsigned int lastbits, lastbyte; - unsigned char * cbuf; - int mask = (1 << num_of_bits) -1; - - cbuf = ((unsigned char *)buf) + 3 * sizeof(*buf); - cnt = buf[0]; - lastbits = (unsigned int) buf[1]; - lastbyte = (unsigned int) buf[2]; - - num = 0; - while (num_of_bits >= 8) { - lastbyte = ( lastbyte << 8 ) | cbuf[cnt++]; - num |= (lastbyte >> lastbits) << (num_of_bits - 8); - num_of_bits -=8; - } - if (num_of_bits > 0) { - if (lastbits < num_of_bits) { - lastbits += 8; - lastbyte = (lastbyte << 8) | cbuf[cnt++]; - } - lastbits -= num_of_bits; - num |= (lastbyte >> lastbits) & ((1 << num_of_bits) -1); - } - num &= mask; - buf[0] = cnt; - buf[1] = lastbits; - buf[2] = lastbyte; - return num; -} - -/*____________________________________________________________________________ - | - | receiveints - decode 'small' integers from the buf array - | - | this routine is the inverse from sendints() and decodes the small integers - | written to buf by calculating the remainder and doing divisions with - | the given sizes[]. You need to specify the total number of bits to be - | used from buf in num_of_bits. - | -*/ - -static void receiveints(int buf[], const int num_of_ints, int num_of_bits, - unsigned int sizes[], int nums[]) { - int bytes[32]; - int i, j, num_of_bytes, p, num; - - bytes[1] = bytes[2] = bytes[3] = 0; - num_of_bytes = 0; - while (num_of_bits > 8) { - bytes[num_of_bytes++] = receivebits(buf, 8); - num_of_bits -= 8; - } - if (num_of_bits > 0) { - bytes[num_of_bytes++] = receivebits(buf, num_of_bits); - } - for (i = num_of_ints-1; i > 0; i--) { - num = 0; - for (j = num_of_bytes-1; j >=0; j--) { - num = (num << 8) | bytes[j]; - p = num / sizes[i]; - bytes[j] = p; - num = num - p * sizes[i]; - } - nums[i] = num; - } - nums[0] = bytes[0] | (bytes[1] << 8) | (bytes[2] << 16) | (bytes[3] << 24); -} - -/*____________________________________________________________________________ - | - | xdr3dfcoord - read or write compressed 3d coordinates to xdr file. - | - | this routine reads or writes (depending on how you opened the file with - | xdropen() ) a large number of 3d coordinates (stored in *fp). - | The number of coordinates triplets to write is given by *size. On - | read this number may be zero, in which case it reads as many as were written - | or it may specify the number if triplets to read (which should match the - | number written). - | Compression is achieved by first converting all floating numbers to integer - | using multiplication by *precision and rounding to the nearest integer. - | Then the minimum and maximum value are calculated to determine the range. - | The limited range of integers so found, is used to compress the coordinates. - | In addition the differences between succesive coordinates is calculated. - | If the difference happens to be 'small' then only the difference is saved, - | compressing the data even more. The notion of 'small' is changed dynamically - | and is enlarged or reduced whenever needed or possible. - | Extra compression is achieved in the case of GROMOS and coordinates of - | water molecules. GROMOS first writes out the Oxygen position, followed by - | the two hydrogens. In order to make the differences smaller (and thereby - | compression the data better) the order is changed into first one hydrogen - | then the oxygen, followed by the other hydrogen. This is rather special, but - | it shouldn't harm in the general case. - | - */ - -int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) { - - - static int *ip = NULL; - static int oldsize; - static int *buf; - - int minint[3], maxint[3], mindiff, *lip, diff; - int lint1, lint2, lint3, oldlint1, oldlint2, oldlint3, smallidx; - int minidx, maxidx; - unsigned sizeint[3], sizesmall[3], bitsizeint[3], size3, *luip; - int flag, k; - int small, smaller, larger, i, is_small, is_smaller, run, prevrun; - float *lfp, lf; - int tmp, *thiscoord, prevcoord[3]; - unsigned int tmpcoord[30]; - - int bufsize, xdrid, lsize; - unsigned int bitsize; - float inv_precision; - int errval = 1; - - /* find out if xdrs is opened for reading or for writing */ - xdrid = 0; - while (xdridptr[xdrid] != xdrs) { - xdrid++; - if (xdrid >= MAXID) { - fprintf(stderr, "xdr error. no open xdr stream\n"); - exit (1); - } - } - if (xdrmodes[xdrid] == 'w') { - - /* xdrs is open for writing */ - - if (xdr_int(xdrs, size) == 0) - return 0; - size3 = *size * 3; - /* when the number of coordinates is small, don't try to compress; just - * write them as floats using xdr_vector - */ - if (*size <= 9 ) { - return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), - (xdrproc_t)xdr_float)); - } - - xdr_float(xdrs, precision); - if (ip == NULL) { - ip = (int *)malloc(size3 * sizeof(*ip)); - if (ip == NULL) { - fprintf(stderr,"malloc failed\n"); - exit(1); - } - bufsize = size3 * 1.2; - buf = (int *)malloc(bufsize * sizeof(*buf)); - if (buf == NULL) { - fprintf(stderr,"malloc failed\n"); - exit(1); - } - oldsize = *size; - } else if (*size > oldsize) { - ip = (int *)realloc(ip, size3 * sizeof(*ip)); - if (ip == NULL) { - fprintf(stderr,"malloc failed\n"); - exit(1); - } - bufsize = size3 * 1.2; - buf = (int *)realloc(buf, bufsize * sizeof(*buf)); - if (buf == NULL) { - fprintf(stderr,"malloc failed\n"); - exit(1); - } - oldsize = *size; - } - /* buf[0-2] are special and do not contain actual data */ - buf[0] = buf[1] = buf[2] = 0; - minint[0] = minint[1] = minint[2] = INT_MAX; - maxint[0] = maxint[1] = maxint[2] = INT_MIN; - prevrun = -1; - lfp = fp; - lip = ip; - mindiff = INT_MAX; - oldlint1 = oldlint2 = oldlint3 = 0; - while(lfp < fp + size3 ) { - /* find nearest integer */ - if (*lfp >= 0.0) - lf = *lfp * *precision + 0.5; - else - lf = *lfp * *precision - 0.5; - if (fabs(lf) > MAXABS) { - /* scaling would cause overflow */ - errval = 0; - } - lint1 = lf; - if (lint1 < minint[0]) minint[0] = lint1; - if (lint1 > maxint[0]) maxint[0] = lint1; - *lip++ = lint1; - lfp++; - if (*lfp >= 0.0) - lf = *lfp * *precision + 0.5; - else - lf = *lfp * *precision - 0.5; - if (fabs(lf) > MAXABS) { - /* scaling would cause overflow */ - errval = 0; - } - lint2 = lf; - if (lint2 < minint[1]) minint[1] = lint2; - if (lint2 > maxint[1]) maxint[1] = lint2; - *lip++ = lint2; - lfp++; - if (*lfp >= 0.0) - lf = *lfp * *precision + 0.5; - else - lf = *lfp * *precision - 0.5; - if (fabs(lf) > MAXABS) { - /* scaling would cause overflow */ - errval = 0; - } - lint3 = lf; - if (lint3 < minint[2]) minint[2] = lint3; - if (lint3 > maxint[2]) maxint[2] = lint3; - *lip++ = lint3; - lfp++; - diff = abs(oldlint1-lint1)+abs(oldlint2-lint2)+abs(oldlint3-lint3); - if (diff < mindiff && lfp > fp + 3) - mindiff = diff; - oldlint1 = lint1; - oldlint2 = lint2; - oldlint3 = lint3; - } - xdr_int(xdrs, &(minint[0])); - xdr_int(xdrs, &(minint[1])); - xdr_int(xdrs, &(minint[2])); - - xdr_int(xdrs, &(maxint[0])); - xdr_int(xdrs, &(maxint[1])); - xdr_int(xdrs, &(maxint[2])); - - if ((float)maxint[0] - (float)minint[0] >= MAXABS || - (float)maxint[1] - (float)minint[1] >= MAXABS || - (float)maxint[2] - (float)minint[2] >= MAXABS) { - /* turning value in unsigned by subtracting minint - * would cause overflow - */ - errval = 0; - } - sizeint[0] = maxint[0] - minint[0]+1; - sizeint[1] = maxint[1] - minint[1]+1; - sizeint[2] = maxint[2] - minint[2]+1; - - /* check if one of the sizes is to big to be multiplied */ - if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { - bitsizeint[0] = sizeofint(sizeint[0]); - bitsizeint[1] = sizeofint(sizeint[1]); - bitsizeint[2] = sizeofint(sizeint[2]); - bitsize = 0; /* flag the use of large sizes */ - } else { - bitsize = sizeofints(3, sizeint); - } - lip = ip; - luip = (unsigned int *) ip; - smallidx = FIRSTIDX; - while (smallidx < LASTIDX && magicints[smallidx] < mindiff) { - smallidx++; - } - xdr_int(xdrs, &smallidx); - maxidx = MIN(LASTIDX, smallidx + 8) ; - minidx = maxidx - 8; /* often this equal smallidx */ - smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; - small = magicints[smallidx] / 2; - sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; - larger = magicints[maxidx] / 2; - i = 0; - while (i < *size) { - is_small = 0; - thiscoord = (int *)(luip) + i * 3; - if (smallidx < maxidx && i >= 1 && - abs(thiscoord[0] - prevcoord[0]) < larger && - abs(thiscoord[1] - prevcoord[1]) < larger && - abs(thiscoord[2] - prevcoord[2]) < larger) { - is_smaller = 1; - } else if (smallidx > minidx) { - is_smaller = -1; - } else { - is_smaller = 0; - } - if (i + 1 < *size) { - if (abs(thiscoord[0] - thiscoord[3]) < small && - abs(thiscoord[1] - thiscoord[4]) < small && - abs(thiscoord[2] - thiscoord[5]) < small) { - /* interchange first with second atom for better - * compression of water molecules - */ - tmp = thiscoord[0]; thiscoord[0] = thiscoord[3]; - thiscoord[3] = tmp; - tmp = thiscoord[1]; thiscoord[1] = thiscoord[4]; - thiscoord[4] = tmp; - tmp = thiscoord[2]; thiscoord[2] = thiscoord[5]; - thiscoord[5] = tmp; - is_small = 1; - } - - } - tmpcoord[0] = thiscoord[0] - minint[0]; - tmpcoord[1] = thiscoord[1] - minint[1]; - tmpcoord[2] = thiscoord[2] - minint[2]; - if (bitsize == 0) { - sendbits(buf, bitsizeint[0], tmpcoord[0]); - sendbits(buf, bitsizeint[1], tmpcoord[1]); - sendbits(buf, bitsizeint[2], tmpcoord[2]); - } else { - sendints(buf, 3, bitsize, sizeint, tmpcoord); - } - prevcoord[0] = thiscoord[0]; - prevcoord[1] = thiscoord[1]; - prevcoord[2] = thiscoord[2]; - thiscoord = thiscoord + 3; - i++; - - run = 0; - if (is_small == 0 && is_smaller == -1) - is_smaller = 0; - while (is_small && run < 8*3) { - if (is_smaller == -1 && ( - SQR(thiscoord[0] - prevcoord[0]) + - SQR(thiscoord[1] - prevcoord[1]) + - SQR(thiscoord[2] - prevcoord[2]) >= smaller * smaller)) { - is_smaller = 0; - } - - tmpcoord[run++] = thiscoord[0] - prevcoord[0] + small; - tmpcoord[run++] = thiscoord[1] - prevcoord[1] + small; - tmpcoord[run++] = thiscoord[2] - prevcoord[2] + small; - - prevcoord[0] = thiscoord[0]; - prevcoord[1] = thiscoord[1]; - prevcoord[2] = thiscoord[2]; - - i++; - thiscoord = thiscoord + 3; - is_small = 0; - if (i < *size && - abs(thiscoord[0] - prevcoord[0]) < small && - abs(thiscoord[1] - prevcoord[1]) < small && - abs(thiscoord[2] - prevcoord[2]) < small) { - is_small = 1; - } - } - if (run != prevrun || is_smaller != 0) { - prevrun = run; - sendbits(buf, 1, 1); /* flag the change in run-length */ - sendbits(buf, 5, run+is_smaller+1); - } else { - sendbits(buf, 1, 0); /* flag the fact that runlength did not change */ - } - for (k=0; k < run; k+=3) { - sendints(buf, 3, smallidx, sizesmall, &tmpcoord[k]); - } - if (is_smaller != 0) { - smallidx += is_smaller; - if (is_smaller < 0) { - small = smaller; - smaller = magicints[smallidx-1] / 2; - } else { - smaller = small; - small = magicints[smallidx] / 2; - } - sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx]; - } - } - if (buf[1] != 0) buf[0]++;; - xdr_int(xdrs, &(buf[0])); /* buf[0] holds the length in bytes */ - return errval * (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0])); - } else { - - /* xdrs is open for reading */ - - if (xdr_int(xdrs, &lsize) == 0) - return 0; - if (*size != 0 && lsize != *size) { - fprintf(stderr, "wrong number of coordinates in xdr3dfcoor; " - "%d arg vs %d in file", *size, lsize); - } - *size = lsize; - size3 = *size * 3; - if (*size <= 9) { - return (xdr_vector(xdrs, (char *) fp, size3, sizeof(*fp), - (xdrproc_t)xdr_float)); - } - xdr_float(xdrs, precision); - if (ip == NULL) { - ip = (int *)malloc(size3 * sizeof(*ip)); - if (ip == NULL) { - fprintf(stderr,"malloc failed\n"); - exit(1); - } - bufsize = size3 * 1.2; - buf = (int *)malloc(bufsize * sizeof(*buf)); - if (buf == NULL) { - fprintf(stderr,"malloc failed\n"); - exit(1); - } - oldsize = *size; - } else if (*size > oldsize) { - ip = (int *)realloc(ip, size3 * sizeof(*ip)); - if (ip == NULL) { - fprintf(stderr,"malloc failed\n"); - exit(1); - } - bufsize = size3 * 1.2; - buf = (int *)realloc(buf, bufsize * sizeof(*buf)); - if (buf == NULL) { - fprintf(stderr,"malloc failed\n"); - exit(1); - } - oldsize = *size; - } - buf[0] = buf[1] = buf[2] = 0; - - xdr_int(xdrs, &(minint[0])); - xdr_int(xdrs, &(minint[1])); - xdr_int(xdrs, &(minint[2])); - - xdr_int(xdrs, &(maxint[0])); - xdr_int(xdrs, &(maxint[1])); - xdr_int(xdrs, &(maxint[2])); - - sizeint[0] = maxint[0] - minint[0]+1; - sizeint[1] = maxint[1] - minint[1]+1; - sizeint[2] = maxint[2] - minint[2]+1; - - /* check if one of the sizes is to big to be multiplied */ - if ((sizeint[0] | sizeint[1] | sizeint[2] ) > 0xffffff) { - bitsizeint[0] = sizeofint(sizeint[0]); - bitsizeint[1] = sizeofint(sizeint[1]); - bitsizeint[2] = sizeofint(sizeint[2]); - bitsize = 0; /* flag the use of large sizes */ - } else { - bitsize = sizeofints(3, sizeint); - } - - xdr_int(xdrs, &smallidx); - maxidx = MIN(LASTIDX, smallidx + 8) ; - minidx = maxidx - 8; /* often this equal smallidx */ - smaller = magicints[MAX(FIRSTIDX, smallidx-1)] / 2; - small = magicints[smallidx] / 2; - sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; - larger = magicints[maxidx]; - - /* buf[0] holds the length in bytes */ - - if (xdr_int(xdrs, &(buf[0])) == 0) - return 0; - if (xdr_opaque(xdrs, (caddr_t)&(buf[3]), (u_int)buf[0]) == 0) - return 0; - buf[0] = buf[1] = buf[2] = 0; - - lfp = fp; - inv_precision = 1.0 / * precision; - run = 0; - i = 0; - lip = ip; - while ( i < lsize ) { - thiscoord = (int *)(lip) + i * 3; - - if (bitsize == 0) { - thiscoord[0] = receivebits(buf, bitsizeint[0]); - thiscoord[1] = receivebits(buf, bitsizeint[1]); - thiscoord[2] = receivebits(buf, bitsizeint[2]); - } else { - receiveints(buf, 3, bitsize, sizeint, thiscoord); - } - - i++; - thiscoord[0] += minint[0]; - thiscoord[1] += minint[1]; - thiscoord[2] += minint[2]; - - prevcoord[0] = thiscoord[0]; - prevcoord[1] = thiscoord[1]; - prevcoord[2] = thiscoord[2]; - - - flag = receivebits(buf, 1); - is_smaller = 0; - if (flag == 1) { - run = receivebits(buf, 5); - is_smaller = run % 3; - run -= is_smaller; - is_smaller--; - } - if (run > 0) { - thiscoord += 3; - for (k = 0; k < run; k+=3) { - receiveints(buf, 3, smallidx, sizesmall, thiscoord); - i++; - thiscoord[0] += prevcoord[0] - small; - thiscoord[1] += prevcoord[1] - small; - thiscoord[2] += prevcoord[2] - small; - if (k == 0) { - /* interchange first with second atom for better - * compression of water molecules - */ - tmp = thiscoord[0]; thiscoord[0] = prevcoord[0]; - prevcoord[0] = tmp; - tmp = thiscoord[1]; thiscoord[1] = prevcoord[1]; - prevcoord[1] = tmp; - tmp = thiscoord[2]; thiscoord[2] = prevcoord[2]; - prevcoord[2] = tmp; - *lfp++ = prevcoord[0] * inv_precision; - *lfp++ = prevcoord[1] * inv_precision; - *lfp++ = prevcoord[2] * inv_precision; - } else { - prevcoord[0] = thiscoord[0]; - prevcoord[1] = thiscoord[1]; - prevcoord[2] = thiscoord[2]; - } - *lfp++ = thiscoord[0] * inv_precision; - *lfp++ = thiscoord[1] * inv_precision; - *lfp++ = thiscoord[2] * inv_precision; - } - } else { - *lfp++ = thiscoord[0] * inv_precision; - *lfp++ = thiscoord[1] * inv_precision; - *lfp++ = thiscoord[2] * inv_precision; - } - smallidx += is_smaller; - if (is_smaller < 0) { - small = smaller; - if (smallidx > FIRSTIDX) { - smaller = magicints[smallidx - 1] /2; - } else { - smaller = 0; - } - } else if (is_smaller > 0) { - smaller = small; - small = magicints[smallidx] / 2; - } - sizesmall[0] = sizesmall[1] = sizesmall[2] = magicints[smallidx] ; - } - } - return 1; -} - - - diff --git a/source/unres/src-HCD-5D/xdrf/underscore.m4 b/source/unres/src-HCD-5D/xdrf/underscore.m4 deleted file mode 100644 index 4d620a0..0000000 --- a/source/unres/src-HCD-5D/xdrf/underscore.m4 +++ /dev/null @@ -1,19 +0,0 @@ -divert(-1) -undefine(`len') -# -# append an underscore to FORTRAN function names -# -define(`FUNCTION',`$1_') -# -# FORTRAN character strings are passed as follows: -# a pointer to the base of the string is passed in the normal -# argument list, and the length is passed by value as an extra -# argument, after all of the other arguments. -# -define(`ARGS',`($1`'undivert(1))') -define(`SAVE',`divert(1)$1`'divert(0)') -define(`STRING_ARG',`$1_ptr`'SAVE(`, $1_len')') -define(`STRING_ARG_DECL',`char * $1_ptr; int $1_len') -define(`STRING_LEN',`$1_len') -define(`STRING_PTR',`$1_ptr') -divert(0) diff --git a/source/unres/src-HCD-5D/xdrf/xdrf.h b/source/unres/src-HCD-5D/xdrf/xdrf.h deleted file mode 100644 index dedf5a2..0000000 --- a/source/unres/src-HCD-5D/xdrf/xdrf.h +++ /dev/null @@ -1,10 +0,0 @@ -/*_________________________________________________________________ - | - | xdrf.h - include file for C routines that want to use the - | functions below. -*/ - -int xdropen(XDR *xdrs, const char *filename, const char *type); -int xdrclose(XDR *xdrs) ; -int xdr3dfcoord(XDR *xdrs, float *fp, int *size, float *precision) ; -