-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
--- /dev/null
+C Change 12/1/95 - common block CONTACTS1 included.
+ common /contacts1/ facont(maxconts,maxres),
+ & gacont(3,maxconts,maxres),
+ & num_cont(maxres),jcont(maxconts,maxres)
+C 12/26/95 - H-bonding contacts
+ double precision gacontp_hb1,gacontp_hb2,gacontp_hb3,gacont_hbr,
+ & gacontm_hb1,gacontm_hb2,gacontm_hb3,grij_hb_cont,facont_hb,
+ & ees0p,ees0m,d_cont
+ integer num_cont_hb,jcont_hb
+ common /contacts_hb/
+ & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres),
+ & gacontp_hb3(3,maxconts,maxres),
+ & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres),
+ & gacontm_hb3(3,maxconts,maxres),
+ & gacont_hbr(3,maxconts,maxres),
+ & grij_hb_cont(3,maxconts,maxres),
+ & facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
+ & ees0m(maxconts,maxres),d_cont(maxconts,maxres),
+ & num_cont_hb(maxres),jcont_hb(maxconts,maxres)
+C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
+C interactions
+c 7/25/08 Commented out; not needed when cumulants used
+C Interactions of pseudo-dipoles generated by loc-el interactions.
+c double precision dip,dipderg,dipderx
+c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres),
+c & dipderx(3,5,4,maxconts,maxres)
+C 12/13/2008 (again Poland-Jaruzel war anniversary)
+C RE: Parallelization of 4th and higher order loc-el correlations
+ integer ncont_sent,ncont_recv,iint_sent,iisent_local,
+ & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to,
+ & nat_sent,iat_sent,iint_sent_local
+ integer iturn3_sent,iturn4_sent,iturn3_sent_local,
+ & iturn4_sent_local
+ common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres),
+ & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres),
+ & nat_sent,iat_sent(maxres),itask_cont_from(0:max_fg_procs-1),
+ & itask_cont_to(0:max_fg_procs-1),ntask_cont_from,ntask_cont_to,
+ & iturn3_sent(4,maxres),iturn4_sent(4,maxres),
+ & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres)
--- /dev/null
+C 10/30/99 Added other pre-computed vectors and matrices needed
+C to calculate three - six-order el-loc correlation terms
+ double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der,
+ & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,gmu,gUb2,
+ & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der,
+ & gtEug
+ common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres),
+ & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres),
+ & obrot_der(2,maxres),obrot2_der(2,maxres)
+C This common block contains vectors and matrices dependent on a single
+C amino-acid residue.
+ common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres),
+ & gmu(2,maxres),gUb2(2,maxres),
+ & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres),
+ & Dtobr2(2,maxres),Dtobr2der(2,maxres),
+ & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres),
+ & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres),
+ & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),gtEUg(2,2,maxres)
+C This common block contains vectors and matrices dependent on two
+C consecutive amino-acid residues.
+ double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC,
+ & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder,Ug2DtEUg,Ug2DtEUgder
+ common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres),
+ & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres),
+ & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres),
+ & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres),
+ & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres)
+ double precision costab,sintab,costab2,sintab2
+ common /rotat_old/ costab(maxres),sintab(maxres),
+ & costab2(maxres),sintab2(maxres)
+C This common block contains dipole-interaction matrices and their
+C Cartesian derivatives.
+ double precision a_chuj,a_chuj_der
+ common /dipmat/ a_chuj(2,2,maxconts,maxres),
+ & a_chuj_der(2,2,3,5,maxconts,maxres)
+ double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx,
+ & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx,
+ & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont,EAEA,EAEAderg,EAEAderx,
+ & ADtEA1,AdTEA1derg,ADtEA1derx
+ common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2),
+ & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2),
+ & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2),
+ & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2),
+ & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2),
+ & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2),
+ & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2),
+ & g_contij(3,2),ekont
& 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),
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),
--- /dev/null
+ integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0,
+ 1 lvar_frag,svar_frag,avar_frag
+ COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3)
+ COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3),
+ 1 lvar_frag(mxio,3),svar_frag(mxio,3),
+ 2 avar_frag(mxio,5)
+
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)
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 \
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\
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
${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
${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
${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
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
--- /dev/null
+1. Replace SUMSL with LBFGS everywhere (currently only minim_ecart)
+2. Parallelize the transformation of Cartesian derivatives to backbone-angle
+ derivatives (cart2int.F)
+3. Parallelize usampl
+4. HREMD
+5. Fourbody interactions - eliminate pp-contact etc. storage (currently 4body
+ switched off by default, -DFOURBODY flag switches on).
--- /dev/null
+ subroutine cart2intgrad(n,g)
+***********************************************************************
+* This subroutine thransforms the gradient in virtual-bond vectors to
+* that in the backbone and side-chain angular variables.
+* Adapted from the cartder subroutine.
+*
+* 03/11/20 Adam. Array fromto eliminated, computed on the fly
+* Fixed the problem with vbld indices, which caused errors in
+* derivatives when the backbone virtual bond lengths were not equal.
+***********************************************************************
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.GEO'
+ include 'COMMON.LOCAL'
+ include 'COMMON.INTERACT'
+ integer n
+ double precision g(n)
+ double precision drt(3,3,maxres),rdt(3,3,maxres),dp(3,3),
+ &temp(3,3),prordt(3,3,maxres),prodrt(3,3,maxres)
+ double precision xx(3),xx1(3),alphi,omegi,xj,dpjk,yp,xp,xxp,yyp
+ double precision cosalphi,sinalphi,cosomegi,sinomegi,theta2,
+ & cost2,sint2,rj,dxoiij,tempkl,dxoijk,dsci,zzp,dj,dpkl
+ double precision fromto(3,3),aux(6)
+ integer i,ii,j,jjj,k,l,m,indi,ind,ind1
+* get the position of the jth ijth fragment of the chain coordinate system
+* in the fromto array.
+c integer indmat
+c indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
+c call chainbuild_extconf
+c call cartprint
+c call intout
+ g=0.0d0
+* 3/13/20 Adam: Skip calculating backbone derivatives if SC only
+* requested.
+ if (sideonly) goto 10
+*
+* calculate the derivatives of transformation matrix elements in theta
+*
+ do i=1,nres-2
+ rdt(1,1,i)=-rt(1,2,i)
+ rdt(1,2,i)= rt(1,1,i)
+ rdt(1,3,i)= 0.0d0
+ rdt(2,1,i)=-rt(2,2,i)
+ rdt(2,2,i)= rt(2,1,i)
+ rdt(2,3,i)= 0.0d0
+ rdt(3,1,i)=-rt(3,2,i)
+ rdt(3,2,i)= rt(3,1,i)
+ rdt(3,3,i)= 0.0d0
+ enddo
+*
+* derivatives in phi
+*
+ do i=2,nres-2
+ drt(1,1,i)= 0.0d0
+ drt(1,2,i)= 0.0d0
+ drt(1,3,i)= 0.0d0
+ drt(2,1,i)= rt(3,1,i)
+ drt(2,2,i)= rt(3,2,i)
+ drt(2,3,i)= rt(3,3,i)
+ drt(3,1,i)=-rt(2,1,i)
+ drt(3,2,i)=-rt(2,2,i)
+ drt(3,3,i)=-rt(2,3,i)
+ enddo
+*
+* Calculate backbone derivatives.
+* This code invlves N^2 effort and should be parallelized, to be done
+* later.
+ ind1=0
+ do i=1,nres-2
+ ind1=ind1+1
+*
+* Derivatives of DC(i+1) in theta(i+2)
+*
+c write (iout,*) "theta i",i
+c write(iout,'(7hprod 9f10.5)')((prod(k,l,i),l=1,3),k=1,3)
+c write(iout,'(7hrdt 9f10.5)')((rdt(k,l,i),l=1,3),k=1,3)
+c write(iout,*) "vbld",vbld(i+2)
+ if (n.gt.nphi) then
+
+ do j=1,3
+ do k=1,2
+ dpjk=0.0D0
+ do l=1,3
+ dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
+ enddo
+ dp(j,k)=dpjk
+ prordt(j,k,i)=dp(j,k)
+ enddo
+ dp(j,3)=0.0D0
+c dcdv(j,ind1)=vbld(i+2)*dp(j,1)
+ g(nphi+i)=g(nphi+i)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg)
+ enddo
+c write(iout,'(7hdcdv 3f10.5)')(dcdv(k,ind1),k=1,3)
+*
+* Derivatives of SC(i+1) in theta(i+2)
+*
+ xx1(1)=-0.5D0*xloc(2,i+1)
+ xx1(2)= 0.5D0*xloc(1,i+1)
+ do j=1,3
+ xj=0.0D0
+ do k=1,2
+ xj=xj+r(j,k,i)*xx1(k)
+ enddo
+ xx(j)=xj
+ enddo
+ do j=1,3
+ rj=0.0D0
+ do k=1,3
+ rj=rj+prod(j,k,i)*xx(k)
+ enddo
+c dxdv(j,ind1)=rj
+c write (iout,*) "1:i",i," j",i+1,"ind1",ind1," dxdthet",rj,
+c & " gradx",gradx(j,i+1,icg)
+ g(nphi+i)=g(nphi+i)+rj*gradx(j,i+1,icg)
+ enddo
+c write (iout,*) "dxdv",(dxdv(j,ind1),j=1,3)
+*
+* Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
+* than the other off-diagonal derivatives.
+*
+ if (i.lt.nres-2) then
+ do j=1,3
+ dxoiij=0.0D0
+ do k=1,3
+ dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
+ enddo
+c dxdv(j,ind1+1)=dxoiij
+c write (iout,*) "2:i",i," j",i+1,"ind1",ind1+1,
+c & " dxdthet",dxoiij," gradx",gradx(j,i+2,icg)
+ g(nphi+i)=g(nphi+i)+dxoiij*gradx(j,i+2,icg)
+ enddo
+ endif
+c write(iout,*)ind1+1,(dxdv(j,ind1+1),j=1,3)
+
+ endif
+*
+* Derivatives of DC(i+1) in phi(i+2)
+*
+ if (i.gt.1) then
+ do j=1,3
+ do k=1,3
+ dpjk=0.0
+ do l=2,3
+ dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
+ enddo
+ dp(j,k)=dpjk
+ prodrt(j,k,i)=dp(j,k)
+ enddo
+c dcdv(j+3,ind1)=vbld(i+2)*dp(j,1)
+ g(i-1)=g(i-1)+vbld(i+2)*dp(j,1)*gradc(j,i+1,icg)
+ enddo
+ endif
+*
+* Derivatives of SC(i+1) in phi(i+2)
+*
+ xx(1)= 0.0D0
+ xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
+ xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
+ if (i.gt.1) then
+ do j=1,3
+ rj=0.0D0
+ do k=2,3
+ rj=rj+prod(j,k,i)*xx(k)
+ enddo
+c dxdv(j+3,ind1)=-rj
+c write (iout,*) "1:i",i," j",i+1,"ind1",ind1," dxdphi",-rj,
+c & " gradx",gradx(j,i+1,icg)
+ g(i-1)=g(i-1)-rj*gradx(j,i+1,icg)
+ enddo
+ endif
+*
+* Derivatives of SC(i+1) in phi(i+3).
+*
+ if (i.gt.1) then
+ do j=1,3
+ dxoiij=0.0D0
+ do k=1,3
+ dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
+ enddo
+c dxdv(j+3,ind1+1)=dxoiij
+ g(i-1)=g(i-1)+dxoiij*gradx(j,i+2,icg)
+c write (iout,*) "2:i",i," j",i+2," ind1",ind1+1,
+c & " dxdphi",dxoiij," gradx",gradx(j,i+2,icg)
+ enddo
+ endif
+*
+* Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
+* theta(nres) and phi(i+3) thru phi(nres).
+*
+ do j=i+1,nres-2
+ ind1=ind1+1
+c ind=indmat(i+1,j+1)
+c write(iout,*)'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
+ call build_fromto(i+1,j+1,fromto)
+c write(iout,'(7hfromto 9f10.5)')((fromto(k,l),l=1,3),k=1,3)
+ do k=1,3
+ do l=1,3
+ tempkl=0.0D0
+ do m=1,2
+ tempkl=tempkl+prordt(k,m,i)*fromto(m,l)
+ enddo
+ temp(k,l)=tempkl
+ enddo
+ enddo
+c write(iout,'(7hfromto 9f10.5)')((fromto(k,l,ind),l=1,3),k=1,3)
+c write(iout,'(7hprod 9f10.5)')((prod(k,l,i),l=1,3),k=1,3)
+c write(iout,'(7htemp 9f10.5)')((temp(k,l),l=1,3),k=1,3)
+ if (n.gt.nphi) then
+* Derivatives of virtual-bond vectors in theta
+ do k=1,3
+c dcdv(k,ind1)=vbld(j+2)*temp(k,1)
+ g(nphi+i)=g(nphi+i)+vbld(j+2)*temp(k,1)*gradc(k,j+1,icg)
+ enddo
+c write(iout,'(7hdcdv 3f10.5)')(dcdv(k,ind1),k=1,3)
+* Derivatives of SC vectors in theta
+ do k=1,3
+ dxoijk=0.0D0
+ do l=1,3
+ dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
+ enddo
+c dxdv(k,ind1+1)=dxoijk
+c write (iout,*) "3:i",i+1," j",j+2,"ind1",ind1+1,
+c & " dxdthet",dxoijk," gradx",gradx(k,j+2,icg)
+ g(nphi+i)=g(nphi+i)+dxoijk*gradx(k,j+2,icg)
+ enddo
+c write(iout,'(7htheta 3f10.5)')(dxdv(k,ind1),k=1,3)
+ endif
+*
+*--- Calculate the derivatives in phi
+*
+ do k=1,3
+ do l=1,3
+ tempkl=0.0D0
+ do m=1,3
+ tempkl=tempkl+prodrt(k,m,i)*fromto(m,l)
+ enddo
+ temp(k,l)=tempkl
+ enddo
+ enddo
+ if (i.gt.1) then
+ do k=1,3
+c dcdv(k+3,ind1)=vbld(j+2)*temp(k,1)
+ g(i-1)=g(i-1)+vbld(j+2)*temp(k,1)*gradc(k,j+1,icg)
+ enddo
+ do k=1,3
+ dxoijk=0.0D0
+ do l=1,3
+ dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
+ enddo
+c dxdv(k+3,ind1+1)=dxoijk
+ g(i-1)=g(i-1)+dxoijk*gradx(k,j+2,icg)
+c write (iout,*) "3:i",i," j",j+2," ind1",ind1+1,
+c & " dxdphi",dxoijk," gradx",gradx(k,j+2,icg)
+ enddo
+ endif
+ enddo
+ enddo
+
+ if (nvar.le.nphi+ntheta) return
+
+ 10 continue
+*
+* Derivatives in alpha and omega:
+*
+ do i=2,nres-1
+ if (iabs(itype(i)).eq.10 .or. itype(i).eq.ntyp1!) cycle
+ & .or. mask_side(i).eq.0 ) cycle
+ ii=ialph(i,1)
+ dsci=vbld(i+nres)
+#ifdef OSF
+ alphi=alph(i)
+ omegi=omeg(i)
+ if(alphi.ne.alphi) alphi=100.0
+ if(omegi.ne.omegi) omegi=-100.0
+#else
+ alphi=alph(i)
+ omegi=omeg(i)
+#endif
+cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
+ cosalphi=dcos(alphi)
+ sinalphi=dsin(alphi)
+ cosomegi=dcos(omegi)
+ sinomegi=dsin(omegi)
+ temp(1,1)=-dsci*sinalphi
+ temp(2,1)= dsci*cosalphi*cosomegi
+ temp(3,1)=-dsci*cosalphi*sinomegi
+ temp(1,2)=0.0D0
+ temp(2,2)=-dsci*sinalphi*sinomegi
+ temp(3,2)=-dsci*sinalphi*cosomegi
+ theta2=pi-0.5D0*theta(i+1)
+ cost2=dcos(theta2)
+ sint2=dsin(theta2)
+ jjj=0
+cd print *,((temp(l,k),l=1,3),k=1,2)
+ do j=1,2
+ xp=temp(1,j)
+ yp=temp(2,j)
+ xxp= xp*cost2+yp*sint2
+ yyp=-xp*sint2+yp*cost2
+ zzp=temp(3,j)
+ xx(1)=xxp
+ xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
+ xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
+ do k=1,3
+ dj=0.0D0
+ do l=1,3
+ dj=dj+prod(k,l,i-1)*xx(l)
+ enddo
+c dxds(jjj+k,i)=dj
+ aux(jjj+k)=dj
+ enddo
+ jjj=jjj+3
+ enddo
+ do k=1,3
+ g(ii)=g(ii)+aux(k)*gradx(k,i,icg)
+ g(ii+nside)=g(ii+nside)+aux(k+3)*gradx(k,i,icg)
+ enddo
+ enddo
+ return
+ end
+c-----------------------------------------------------------------------------
+ subroutine build_fromto(i,j,fromto)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ integer i,j,jj,k,l,m
+ double precision fromto(3,3),temp(3,3),dp(3,3)
+ double precision dpkl
+ save temp
+*
+* generate the matrix products of type r(i)t(i)...r(j)t(j) on the fly
+*
+c write (iout,*) "temp on entry"
+c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3)
+c do i=2,nres-2
+c ind=indmat(i,i+1)
+ if (j.eq.i+1) then
+ do k=1,3
+ do l=1,3
+ temp(k,l)=rt(k,l,i)
+ enddo
+ enddo
+ do k=1,3
+ do l=1,3
+ fromto(k,l)=temp(k,l)
+ enddo
+ enddo
+ else
+c do j=i+1,nres-2
+c ind=indmat(i,j+1)
+ do k=1,3
+ do l=1,3
+ dpkl=0.0d0
+ do m=1,3
+ dpkl=dpkl+temp(k,m)*rt(m,l,j-1)
+ enddo
+ dp(k,l)=dpkl
+ fromto(k,l)=dpkl
+ enddo
+ enddo
+ do k=1,3
+ do l=1,3
+ temp(k,l)=dp(k,l)
+ enddo
+ enddo
+ endif
+c write (iout,*) "temp upon exit"
+c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3)
+c enddo
+c enddo
+ return
+ end
enddo
return
end
-c-----------------------------------------------------------------------------
- subroutine build_fromto(i,j,fromto)
- implicit none
- include 'DIMENSIONS'
- include 'COMMON.CHAIN'
- include 'COMMON.IOUNITS'
- integer i,j,jj,k,l,m
- double precision fromto(3,3),temp(3,3),dp(3,3)
- double precision dpkl
- save temp
-*
-* generate the matrix products of type r(i)t(i)...r(j)t(j) on the fly
-*
-c write (iout,*) "temp on entry"
-c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3)
-c do i=2,nres-2
-c ind=indmat(i,i+1)
- if (j.eq.i+1) then
- do k=1,3
- do l=1,3
- temp(k,l)=rt(k,l,i)
- enddo
- enddo
- do k=1,3
- do l=1,3
- fromto(k,l)=temp(k,l)
- enddo
- enddo
- else
-c do j=i+1,nres-2
-c ind=indmat(i,j+1)
- do k=1,3
- do l=1,3
- dpkl=0.0d0
- do m=1,3
- dpkl=dpkl+temp(k,m)*rt(m,l,j-1)
- enddo
- dp(k,l)=dpkl
- fromto(k,l)=dpkl
- enddo
- enddo
- do k=1,3
- do l=1,3
- temp(k,l)=dp(k,l)
- enddo
- enddo
- endif
-c write (iout,*) "temp upon exit"
-c write (iout,'(3f10.5)') ((temp(k,l),l=1,3),k=1,3)
-c enddo
-c enddo
- return
- end
--- /dev/null
+ subroutine 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
- 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.
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)
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)
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
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
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
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
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
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',
--- /dev/null
+ subroutine contact_cp(var,var2,iff,ieval,in_pdb)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FRAG'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.MINIM'
+
+ character*50 linia
+ integer nf,ij(4)
+ double precision energy(0:n_ene)
+ double precision var(maxvar),var2(maxvar)
+ double precision time0,time1
+ integer iff(maxres),ieval
+ double precision theta1(maxres),phi1(maxres),alph1(maxres),
+ & omeg1(maxres)
+ logical debug
+
+ debug=.false.
+c debug=.true.
+ if (ieval.eq.-1) debug=.true.
+
+
+c
+c store selected dist. constrains from 1st structure
+c
+#ifdef OSF
+c Intercept NaNs in the coordinates
+c write(iout,*) (var(i),i=1,nvar)
+ x_sum=0.D0
+ do i=1,nvar
+ x_sum=x_sum+var(i)
+ enddo
+ if (x_sum.ne.x_sum) then
+ write(iout,*)" *** contact_cp : Found NaN in coordinates"
+ call flush(iout)
+ print *," *** contact_cp : Found NaN in coordinates"
+ return
+ endif
+#endif
+
+
+ call var_to_geom(nvar,var)
+ call chainbuild
+ nhpb0=nhpb
+ ind=0
+ do i=1,nres-3
+ do j=i+3,nres
+ ind=ind+1
+ if ( iff(i).eq.1.and.iff(j).eq.1 ) then
+c d0(ind)=DIST(i,j)
+c w(ind)=10.0
+ nhpb=nhpb+1
+ ihpb(nhpb)=i
+ jhpb(nhpb)=j
+ forcon(nhpb)=10.0
+ dhpb(nhpb)=DIST(i,j)
+ else
+c w(ind)=0.0
+ endif
+ enddo
+ enddo
+ call hpb_partition
+
+ do i=1,nres
+ theta1(i)=theta(i)
+ phi1(i)=phi(i)
+ alph1(i)=alph(i)
+ omeg1(i)=omeg(i)
+ enddo
+
+c
+c freeze sec.elements from 2nd structure
+c
+ do i=1,nres
+ mask_phi(i)=1
+ mask_theta(i)=1
+ mask_side(i)=1
+ enddo
+
+ call var_to_geom(nvar,var2)
+ call secondary2(debug)
+ do j=1,nbfrag
+ do i=bfrag(1,j),bfrag(2,j)
+c mask(i)=0
+ mask_phi(i)=0
+ mask_theta(i)=0
+ enddo
+ if (bfrag(3,j).le.bfrag(4,j)) then
+ do i=bfrag(3,j),bfrag(4,j)
+c mask(i)=0
+ mask_phi(i)=0
+ mask_theta(i)=0
+ enddo
+ else
+ do i=bfrag(4,j),bfrag(3,j)
+c mask(i)=0
+ mask_phi(i)=0
+ mask_theta(i)=0
+ enddo
+ endif
+ enddo
+ do j=1,nhfrag
+ do i=hfrag(1,j),hfrag(2,j)
+c mask(i)=0
+ mask_phi(i)=0
+ mask_theta(i)=0
+ enddo
+ enddo
+ mask_r=.true.
+
+c
+c copy selected res from 1st to 2nd structure
+c
+
+ do i=1,nres
+ if ( iff(i).eq.1 ) then
+ theta(i)=theta1(i)
+ phi(i)=phi1(i)
+ alph(i)=alph1(i)
+ omeg(i)=omeg1(i)
+ endif
+ enddo
+
+ if(debug) then
+c
+c prepare description in linia variable
+c
+ iwsk=0
+ nf=0
+ if (iff(1).eq.1) then
+ iwsk=1
+ nf=nf+1
+ ij(nf)=1
+ endif
+ do i=2,nres
+ if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then
+ iwsk=1
+ nf=nf+1
+ ij(nf)=i
+ endif
+ if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then
+ iwsk=0
+ nf=nf+1
+ ij(nf)=i-1
+ endif
+ enddo
+ if (iff(nres).eq.1) then
+ nf=nf+1
+ ij(nf)=nres
+ endif
+
+ write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)')
+ & "SELECT",ij(1)-1,"-",ij(2)-1,
+ & ",",ij(3)-1,"-",ij(4)-1
+
+ endif
+c
+c run optimization
+c
+ call contact_cp_min(var,ieval,in_pdb,linia,debug)
+
+ return
+ end
+
+ subroutine contact_cp_min(var,ieval,in_pdb,linia,debug)
+c
+c input : theta,phi,alph,omeg,in_pdb,linia,debug
+c output : var,ieval
+c
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FRAG'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.MINIM'
+
+ character*50 linia
+ integer nf,ij(4)
+ double precision energy(0:n_ene)
+ double precision var(maxvar)
+ double precision time0,time1
+ integer ieval,info(3)
+ logical debug,fail,check_var,reduce,change
+
+ write(iout,'(a20,i6,a20)')
+ & '------------------',in_pdb,'-------------------'
+
+ if (debug) then
+ call chainbuild
+ call write_pdb(1000+in_pdb,'combined structure',0d0)
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ endif
+
+c
+c run optimization of distances
+c
+c uses d0(),w() and mask() for frozen 2D
+c
+ctest---------------------------------------------
+ctest NX=NRES-3
+ctest NY=((NRES-4)*(NRES-5))/2
+ctest call distfit(debug,5000)
+
+ do i=1,nres
+ mask_side(i)=0
+ enddo
+
+ ipot01=ipot
+ maxmin01=maxmin
+ maxfun01=maxfun
+c wstrain01=wstrain
+ wsc01=wsc
+ wscp01=wscp
+ welec01=welec
+ wvdwpp01=wvdwpp
+c wang01=wang
+ wscloc01=wscloc
+ wtor01=wtor
+ wtor_d01=wtor_d
+
+ ipot=6
+ maxmin=2000
+ maxfun=4000
+c wstrain=1.0
+ wsc=0.0
+ wscp=0.0
+ welec=0.0
+ wvdwpp=0.0
+c wang=0.0
+ wscloc=0.0
+ wtor=0.0
+ wtor_d=0.0
+
+ call geom_to_var(nvar,var)
+cde change=reduce(var)
+ if (check_var(var,info)) then
+ write(iout,*) 'cp_min error in input'
+ print *,'cp_min error in input'
+ return
+ endif
+
+cd call etotal(energy(0))
+cd call enerprint(energy(0))
+cd call check_eint
+
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+cdtest call minimize(etot,var,iretcode,nfun)
+cdtest write(iout,*)'SUMSL return code is',iretcode,' eval SDIST',nfun
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+
+cd call etotal(energy(0))
+cd call enerprint(energy(0))
+cd call check_eint
+
+ do i=1,nres
+ mask_side(i)=1
+ enddo
+
+ ipot=ipot01
+ maxmin=maxmin01
+ maxfun=maxfun01
+c wstrain=wstrain01
+ wsc=wsc01
+ wscp=wscp01
+ welec=welec01
+ wvdwpp=wvdwpp01
+c wang=wang01
+ wscloc=wscloc01
+ wtor=wtor01
+ wtor_d=wtor_d01
+ctest--------------------------------------------------
+
+ if(debug) then
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,a)')' Time for distfit ',time1-time0,' sec'
+ call write_pdb(2000+in_pdb,'distfit structure',0d0)
+ endif
+
+
+ ipot0=ipot
+ maxmin0=maxmin
+ maxfun0=maxfun
+ wstrain0=wstrain
+c
+c run soft pot. optimization
+c with constrains:
+c nhpb,ihpb(),jhpb(),forcon(),dhpb() and hpb_partition
+c and frozen 2D:
+c mask_phi(),mask_theta(),mask_side(),mask_r
+c
+ ipot=6
+ maxmin=2000
+ maxfun=4000
+
+cde change=reduce(var)
+cde if (check_var(var,info)) write(iout,*) 'error before soft'
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ call minimize(etot,var,iretcode,nfun)
+
+ write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0,
+ & nfun/(time1-time0),' SOFT eval/s'
+ if (debug) then
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(3000+in_pdb,'soft structure',etot)
+ endif
+c
+c run full UNRES optimization with constrains and frozen 2D
+c the same variables as soft pot. optimizatio
+c
+ ipot=ipot0
+ maxmin=maxmin0
+ maxfun=maxfun0
+c
+c check overlaps before calling full UNRES minim
+c
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call etotal(energy(0))
+#ifdef OSF
+ write(iout,*) 'N7 ',energy(0)
+ if (energy(0).ne.energy(0)) then
+ write(iout,*) 'N7 error - gives NaN',energy(0)
+ endif
+#endif
+ ieval=1
+ if (energy(1).eq.1.0d20) then
+ write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw=1d20',energy(1)
+ call overlap_sc(fail)
+ if(.not.fail) then
+ call etotal(energy(0))
+ ieval=ieval+1
+ write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw after',energy(1)
+ else
+ mask_r=.false.
+ nhpb= nhpb0
+ link_start=1
+ link_end=nhpb
+ wstrain=wstrain0
+ return
+ endif
+ endif
+ call flush(iout)
+c
+cdte time0=MPI_WTIME()
+cde change=reduce(var)
+cde if (check_var(var,info)) then
+cde write(iout,*) 'error before mask dist'
+cde call var_to_geom(nvar,var)
+cde call chainbuild
+cde call write_pdb(10000+in_pdb,'before mask dist',etot)
+cde endif
+cdte call minimize(etot,var,iretcode,nfun)
+cdte write(iout,*)'SUMSL MASK DIST return code is',iretcode,
+cdte & ' eval ',nfun
+cdte ieval=ieval+nfun
+cdte
+cdte time1=MPI_WTIME()
+cdte write (iout,'(a,f6.2,f8.2,a)')
+cdte & ' Time for mask dist min.',time1-time0,
+cdte & nfun/(time1-time0),' eval/s'
+cdte call flush(iout)
+ if (debug) then
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(4000+in_pdb,'mask dist',etot)
+ endif
+c
+c switch off freezing of 2D and
+c run full UNRES optimization with constrains
+c
+ mask_r=.false.
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+cde change=reduce(var)
+cde if (check_var(var,info)) then
+cde write(iout,*) 'error before dist'
+cde call var_to_geom(nvar,var)
+cde call chainbuild
+cde call write_pdb(11000+in_pdb,'before dist',etot)
+cde endif
+
+ call minimize(etot,var,iretcode,nfun)
+
+cde change=reduce(var)
+cde if (check_var(var,info)) then
+cde write(iout,*) 'error after dist',ico
+cde call var_to_geom(nvar,var)
+cde call chainbuild
+cde call write_pdb(12000+in_pdb+ico*1000,'after dist',etot)
+cde endif
+ write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun
+ ieval=ieval+nfun
+
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')' Time for dist min.',time1-time0,
+ & nfun/(time1-time0),' eval/s'
+cde call etotal(energy(0))
+cde write(iout,*) 'N7 after dist',energy(0)
+c call flush(iout)
+
+ if (debug) then
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(in_pdb,linia,etot)
+ endif
+c
+c reset constrains
+c
+ nhpb= nhpb0
+ link_start=1
+ link_end=nhpb
+ wstrain=wstrain0
+
+ return
+ end
+c--------------------------------------------------------
+ subroutine softreg
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.GEO'
+ include 'COMMON.CHAIN'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.VAR'
+ include 'COMMON.CONTROL'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MINIM'
+ include 'COMMON.INTERACT'
+c
+ include 'COMMON.FRAG'
+ integer iff(maxres)
+ double precision time0,time1
+ double precision energy(0:n_ene),ee
+ double precision var(maxvar)
+ integer ieval
+c
+ logical debug,ltest,fail
+ character*50 linia
+c
+ linia='test'
+ debug=.true.
+ in_pdb=0
+
+
+
+c------------------------
+c
+c freeze sec.elements
+c
+ do i=1,nres
+ mask_phi(i)=1
+ mask_theta(i)=1
+ mask_side(i)=1
+ iff(i)=0
+ enddo
+
+ do j=1,nbfrag
+ do i=bfrag(1,j),bfrag(2,j)
+ mask_phi(i)=0
+ mask_theta(i)=0
+ iff(i)=1
+ enddo
+ if (bfrag(3,j).le.bfrag(4,j)) then
+ do i=bfrag(3,j),bfrag(4,j)
+ mask_phi(i)=0
+ mask_theta(i)=0
+ iff(i)=1
+ enddo
+ else
+ do i=bfrag(4,j),bfrag(3,j)
+ mask_phi(i)=0
+ mask_theta(i)=0
+ iff(i)=1
+ enddo
+ endif
+ enddo
+ do j=1,nhfrag
+ do i=hfrag(1,j),hfrag(2,j)
+ mask_phi(i)=0
+ mask_theta(i)=0
+ iff(i)=1
+ enddo
+ enddo
+ mask_r=.true.
+
+
+
+ nhpb0=nhpb
+c
+c store dist. constrains
+c
+ do i=1,nres-3
+ do j=i+3,nres
+ if ( iff(i).eq.1.and.iff(j).eq.1 ) then
+ nhpb=nhpb+1
+ ihpb(nhpb)=i
+ jhpb(nhpb)=j
+ forcon(nhpb)=0.1
+ dhpb(nhpb)=DIST(i,j)
+ endif
+ enddo
+ enddo
+ call hpb_partition
+
+ if (debug) then
+ call chainbuild
+ call write_pdb(100+in_pdb,'input reg. structure',0d0)
+ endif
+
+
+ ipot0=ipot
+ maxmin0=maxmin
+ maxfun0=maxfun
+ wstrain0=wstrain
+ wang0=wang
+c
+c run soft pot. optimization
+c
+ ipot=6
+ wang=3.0
+ maxmin=2000
+ maxfun=4000
+ call geom_to_var(nvar,var)
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ call minimize(etot,var,iretcode,nfun)
+
+ write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0,
+ & nfun/(time1-time0),' SOFT eval/s'
+ if (debug) then
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(300+in_pdb,'soft structure',etot)
+ endif
+c
+c run full UNRES optimization with constrains and frozen 2D
+c the same variables as soft pot. optimizatio
+c
+ ipot=ipot0
+ wang=wang0
+ maxmin=maxmin0
+ maxfun=maxfun0
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ call minimize(etot,var,iretcode,nfun)
+ write(iout,*)'SUMSL MASK DIST return code is',iretcode,
+ & ' eval ',nfun
+ ieval=nfun
+
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')
+ & ' Time for mask dist min.',time1-time0,
+ & nfun/(time1-time0),' eval/s'
+ if (debug) then
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(400+in_pdb,'mask & dist',etot)
+ endif
+c
+c switch off constrains and
+c run full UNRES optimization with frozen 2D
+c
+
+c
+c reset constrains
+c
+ nhpb_c=nhpb
+ nhpb=nhpb0
+ link_start=1
+ link_end=nhpb
+ wstrain=wstrain0
+
+
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ call minimize(etot,var,iretcode,nfun)
+ write(iout,*)'SUMSL MASK return code is',iretcode,' eval ',nfun
+ ieval=ieval+nfun
+
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')' Time for mask min.',time1-time0,
+ & nfun/(time1-time0),' eval/s'
+
+
+ if (debug) then
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(500+in_pdb,'mask 2d frozen',etot)
+ endif
+
+ mask_r=.false.
+
+
+c
+c run full UNRES optimization with constrains and NO frozen 2D
+c
+
+ nhpb=nhpb_c
+ link_start=1
+ link_end=nhpb
+ maxfun=maxfun0/5
+
+ do ico=1,5
+
+ wstrain=wstrain0/ico
+
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ call minimize(etot,var,iretcode,nfun)
+ write(iout,'(a10,f6.3,a14,i3,a6,i5)')
+ & ' SUMSL DIST',wstrain,' return code is',iretcode,
+ & ' eval ',nfun
+ ieval=nfun
+
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')
+ & ' Time for dist min.',time1-time0,
+ & nfun/(time1-time0),' eval/s'
+ if (debug) then
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(600+in_pdb+ico,'dist cons',etot)
+ endif
+
+ enddo
+c
+ nhpb=nhpb0
+ link_start=1
+ link_end=nhpb
+ wstrain=wstrain0
+ maxfun=maxfun0
+
+
+c
+ if (minim) then
+#ifdef MPI
+ time0=MPI_WTIME()
+#else
+ time0=tcpu()
+#endif
+ call minimize(etot,var,iretcode,nfun)
+ write(iout,*)'------------------------------------------------'
+ write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun,
+ & '+ DIST eval',ieval
+
+#ifdef MPI
+ time1=MPI_WTIME()
+#else
+ time1=tcpu()
+#endif
+ write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0,
+ & nfun/(time1-time0),' eval/s'
+
+
+ call var_to_geom(nvar,var)
+ call chainbuild
+ call write_pdb(999,'full min',etot)
+ endif
+
+ return
+ end
+
+
+ subroutine beta_slide(i1,i2,i3,i4,i5,ieval,ij)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FRAG'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CONTROL'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MINIM'
+ include 'COMMON.CHAIN'
+ double precision time0,time1
+ double precision energy(0:n_ene),ee
+ double precision var(maxvar)
+ integer jdata(5),isec(maxres)
+c
+ jdata(1)=i1
+ jdata(2)=i2
+ jdata(3)=i3
+ jdata(4)=i4
+ jdata(5)=i5
+
+ call secondary2(.false.)
+
+ do i=1,nres
+ isec(i)=0
+ enddo
+ do j=1,nbfrag
+ do i=bfrag(1,j),bfrag(2,j)
+ isec(i)=1
+ enddo
+ do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j))
+ isec(i)=1
+ enddo
+ enddo
+ do j=1,nhfrag
+ do i=hfrag(1,j),hfrag(2,j)
+ isec(i)=2
+ enddo
+ enddo
+
+c
+c cut strands at the ends
+c
+ if (jdata(2)-jdata(1).gt.3) then
+ jdata(1)=jdata(1)+1
+ jdata(2)=jdata(2)-1
+ if (jdata(3).lt.jdata(4)) then
+ jdata(3)=jdata(3)+1
+ jdata(4)=jdata(4)-1
+ else
+ jdata(3)=jdata(3)-1
+ jdata(4)=jdata(4)+1
+ endif
+ endif
+
+cv call chainbuild
+cv call etotal(energy(0))
+cv etot=energy(0)
+cv write(iout,*) nnt,nct,etot
+cv call write_pdb(ij*100,'first structure',etot)
+cv write(iout,*) 'N16 test',(jdata(i),i=1,5)
+
+c------------------------
+c generate constrains
+c
+ ishift=jdata(5)-2
+ if(ishift.eq.0) ishift=-2
+ nhpb0=nhpb
+ call chainbuild
+ do i=jdata(1),jdata(2)
+ isec(i)=-1
+ if(jdata(4).gt.jdata(3))then
+ do j=jdata(3)+i-jdata(1)-2,jdata(3)+i-jdata(1)+2
+ isec(j)=-1
+cd print *,i,j,j+ishift
+ nhpb=nhpb+1
+ ihpb(nhpb)=i
+ jhpb(nhpb)=j
+ forcon(nhpb)=1000.0
+ dhpb(nhpb)=DIST(i,j+ishift)
+ enddo
+ else
+ do j=jdata(3)-i+jdata(1)+2,jdata(3)-i+jdata(1)-2,-1
+ isec(j)=-1
+cd print *,i,j,j+ishift
+ nhpb=nhpb+1
+ ihpb(nhpb)=i
+ jhpb(nhpb)=j
+ forcon(nhpb)=1000.0
+ dhpb(nhpb)=DIST(i,j+ishift)
+ enddo
+ endif
+ enddo
+
+ do i=nnt,nct-2
+ do j=i+2,nct
+ if(isec(i).gt.0.or.isec(j).gt.0) then
+cd print *,i,j
+ nhpb=nhpb+1
+ ihpb(nhpb)=i
+ jhpb(nhpb)=j
+ forcon(nhpb)=0.1
+ dhpb(nhpb)=DIST(i,j)
+ endif
+ enddo
+ enddo
+
+ call hpb_partition
+
+ call geom_to_var(nvar,var)
+ maxfun0=maxfun
+ wstrain0=wstrain
+ maxfun=4000/5
+
+ do ico=1,5
+
+ wstrain=wstrain0/ico
+
+cv time0=MPI_WTIME()
+ call minimize(etot,var,iretcode,nfun)
+ write(iout,'(a10,f6.3,a14,i3,a6,i5)')
+ & ' SUMSL DIST',wstrain,' return code is',iretcode,
+ & ' eval ',nfun
+ ieval=ieval+nfun
+cv time1=MPI_WTIME()
+cv write (iout,'(a,f6.2,f8.2,a)')
+cv & ' Time for dist min.',time1-time0,
+cv & nfun/(time1-time0),' eval/s'
+cv call var_to_geom(nvar,var)
+cv call chainbuild
+cv call write_pdb(ij*100+ico,'dist cons',etot)
+
+ enddo
+c
+ nhpb=nhpb0
+ call hpb_partition
+ wstrain=wstrain0
+ maxfun=maxfun0
+c
+cd print *,etot
+ wscloc0=wscloc
+ wscloc=10.0
+ call sc_move(nnt,nct,100,100d0,nft_sc,etot)
+ wscloc=wscloc0
+cv call chainbuild
+cv call etotal(energy(0))
+cv etot=energy(0)
+cv call write_pdb(ij*100+10,'sc_move',etot)
+cd call intout
+cd print *,nft_sc,etot
+
+ return
+ end
+
+ subroutine beta_zip(i1,i2,ieval,ij)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.GEO'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.FRAG'
+ include 'COMMON.SBRIDGE'
+ include 'COMMON.CONTROL'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MINIM'
+ include 'COMMON.CHAIN'
+ double precision time0,time1
+ double precision energy(0:n_ene),ee
+ double precision var(maxvar)
+ character*10 test
+
+cv call chainbuild
+cv call etotal(energy(0))
+cv etot=energy(0)
+cv write(test,'(2i5)') i1,i2
+cv call write_pdb(ij*100,test,etot)
+cv write(iout,*) 'N17 test',i1,i2,etot,ij
+
+c
+c generate constrains
+c
+ nhpb0=nhpb
+ nhpb=nhpb+1
+ ihpb(nhpb)=i1
+ jhpb(nhpb)=i2
+ forcon(nhpb)=1000.0
+ dhpb(nhpb)=4.0
+
+ call hpb_partition
+
+ call geom_to_var(nvar,var)
+ maxfun0=maxfun
+ wstrain0=wstrain
+ maxfun=1000/5
+
+ do ico=1,5
+ wstrain=wstrain0/ico
+cv time0=MPI_WTIME()
+ call minimize(etot,var,iretcode,nfun)
+ write(iout,'(a10,f6.3,a14,i3,a6,i5)')
+ & ' SUMSL DIST',wstrain,' return code is',iretcode,
+ & ' eval ',nfun
+ ieval=ieval+nfun
+cv time1=MPI_WTIME()
+cv write (iout,'(a,f6.2,f8.2,a)')
+cv & ' Time for dist min.',time1-time0,
+cv & nfun/(time1-time0),' eval/s'
+c do not comment the next line
+ call var_to_geom(nvar,var)
+cv call chainbuild
+cv call write_pdb(ij*100+ico,'dist cons',etot)
+ enddo
+
+ nhpb=nhpb0
+ call hpb_partition
+ wstrain=wstrain0
+ maxfun=maxfun0
+
+cv call etotal(energy(0))
+cv etot=energy(0)
+cv write(iout,*) 'N17 test end',i1,i2,etot,ij
+
+
+ return
+ end
+c----------------------------------------------------------------------------
+
+ subroutine write_pdb(npdb,titelloc,ee)
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.IOUNITS'
+ character*50 titelloc1
+ character*(*) titelloc
+ character*3 zahl
+ character*5 liczba5
+ double precision ee
+ integer npdb,ilen
+ external ilen
+
+ titelloc1=titelloc
+ lenpre=ilen(prefix)
+ if (npdb.lt.1000) then
+ call numstr(npdb,zahl)
+ open(ipdb,file=prefix(:lenpre)//'@@'//zahl//'.pdb')
+ else
+ if (npdb.lt.10000) then
+ write(liczba5,'(i1,i4)') 0,npdb
+ else
+ write(liczba5,'(i5)') npdb
+ endif
+ open(ipdb,file=prefix(:lenpre)//'@@'//liczba5//'.pdb')
+ endif
+ call pdbout(ee,titelloc1,ipdb)
+ close(ipdb)
+ return
+ end
+
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
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
include 'DIMENSIONS'
include 'COMMON.CHAIN'
include 'COMMON.IOUNITS'
- include 'COMMON.DISTFIT'
+ include 'COMMON.FRAG'
include 'COMMON.VAR'
include 'COMMON.GEO'
include 'COMMON.CONTROL'
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
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
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'
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
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
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
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
&) 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
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'
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
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
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'
else
esccor=0.0d0
endif
+#ifdef FOURBODY
C print *,"PRZED MULIt"
c print *,"Processor",myrank," computed Usccorr"
C
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
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,
& '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)'/
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,
& '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)'/
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
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
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
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
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'
include 'COMMON.CHAIN'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
- include 'COMMON.CONTACTS'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VECTORS'
include 'COMMON.FFIELD'
c write(iout,*) "Macierz EUG",
c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
c & eug(2,2,i-2)
+#ifdef FOURBODY
if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
& then
call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
call 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
cd write (iout,*) 'mu1',mu1(:,i-2)
cd write (iout,*) 'mu2',mu2(:,i-2)
cd write (iout,*) 'mu',i-2,mu(:,i-2)
+#ifdef FOURBODY
if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
& then
call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
call matmat2(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)
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
call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
& MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
& MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
+#ifdef FOURBODY
if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
& then
call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
& MPI_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
& 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,
& 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
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'
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
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
zmedi=mod(zmedi,boxzsize)
if (zmedi.lt.0) zmedi=zmedi+boxzsize
+#ifdef FOURBODY
num_conti=num_cont_hb(i)
+#endif
c write(iout,*) "JESTEM W PETLI"
call eelecij(i,i+3,ees,evdw1,eel_loc)
if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
& call eturn4(i,eello_turn4)
+#ifdef FOURBODY
num_cont_hb(i)=num_conti
+#endif
enddo ! i
C Loop over all neighbouring boxes
C do xshift=-1,1
c 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
&) 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
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'
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"
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
include 'COMMON.CHAIN'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
- include 'COMMON.CONTACTS'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VECTORS'
include 'COMMON.FFIELD'
include 'COMMON.CHAIN'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
- include 'COMMON.CONTACTS'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VECTORS'
include 'COMMON.FFIELD'
return
end
+#ifdef FOURBODY
c----------------------------------------------------------------------------
subroutine multibody(ecorr)
C This subroutine calculates multi-body contributions to energy following
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
double precision gx(3),gx1(3)
logical lprn
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
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
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
include 'COMMON.LOCAL'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
include 'COMMON.CHAIN'
include 'COMMON.CONTROL'
include 'COMMON.SHIELD'
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
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)
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VAR'
include 'COMMON.GEO'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VAR'
include 'COMMON.GEO'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VAR'
include 'COMMON.GEO'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VAR'
include 'COMMON.GEO'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VAR'
include 'COMMON.GEO'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VAR'
include 'COMMON.GEO'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VAR'
include 'COMMON.GEO'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VAR'
include 'COMMON.GEO'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VAR'
include 'COMMON.GEO'
include 'COMMON.DERIV'
include 'COMMON.INTERACT'
include 'COMMON.CONTACTS'
+ include 'COMMON.CONTMAT'
+ include 'COMMON.CORRMAT'
include 'COMMON.TORSION'
include 'COMMON.VAR'
include 'COMMON.GEO'
cd write (2,*) 'eel_turn6',ekont*eel_turn6
return
end
-
C-----------------------------------------------------------------------------
+#endif
double precision function scalar(u,v)
!DIR$ INLINEALWAYS scalar
#ifndef OSF
else
call escp_soft_sphere(evdw2,evdw2_14)
endif
+#ifdef FOURBODY
C
C 12/1/95 Multi-body terms
C
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
include 'COMMON.IOUNITS'
include 'COMMON.HEADER'
include 'COMMON.SBRIDGE'
- include 'COMMON.DISTFIT'
+ include 'COMMON.FRAG'
include 'COMMON.MD'
#ifdef FIVEDIAG
include 'COMMON.LAGRANGE.5diag'
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
include 'COMMON.IOUNITS'
include 'COMMON.HEADER'
include 'COMMON.SBRIDGE'
- include 'COMMON.DISTFIT'
+ include 'COMMON.FRAG'
include 'COMMON.MD'
include 'COMMON.QRESTR'
double precision time
include 'COMMON.IOUNITS'
include 'COMMON.HEADER'
include 'COMMON.SBRIDGE'
- include 'COMMON.DISTFIT'
+ include 'COMMON.FRAG'
include 'COMMON.MD'
include 'COMMON.QRESTR'
include 'COMMON.REMD'
+#ifndef LBFGS
subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
implicit none
include 'DIMENSIONS'
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
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
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
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
cd enddo
return
end
+#endif
C-------------------------------------------------------------------------
subroutine cartgrad
implicit none
--- /dev/null
+ subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.QRESTR'
+ include 'COMMON.IOUNITS'
+ integer n,nf
+ double precision ufparm
+ external ufparm
+ integer uiparm(1)
+ double precision urparm(1)
+ double precision x(n),g(n)
+ integer i,j,k,ind,ind1
+ double precision f,gthetai,gphii,galphai,gomegai
+c
+c This subroutine calculates total internal coordinate gradient.
+c Depending on the number of function evaluations, either whole energy
+c is evaluated beforehand, Cartesian coordinates and their derivatives in
+c internal coordinates are reevaluated or only the cartesian-in-internal
+c coordinate derivatives are evaluated. The subroutine was designed to work
+c with SUMSL.
+c
+c
+ icg=mod(nf,2)+1
+
+cd print *,'grad',nf,icg
+ if (nf-nfl+1) 20,30,40
+ 20 call func(n,x,nf,f,uiparm,urparm,ufparm)
+c write (iout,*) 'grad 20'
+ if (nf.eq.0) return
+ goto 40
+ 30 call var_to_geom(n,x)
+ call chainbuild
+c write (iout,*) 'grad 30'
+C
+C Transform the gradient to the gradient in angles.
+C
+ 40 call cart2intgrad(n,g)
+C
+C Add the components corresponding to local energy terms.
+C
+ 10 continue
+c Add the usampl contributions
+ if (usampl) then
+ do i=1,nres-3
+ gloc(i,icg)=gloc(i,icg)+dugamma(i)
+ enddo
+ do i=1,nres-2
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
+ enddo
+ endif
+ do i=1,nvar
+cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
+ g(i)=g(i)+gloc(i,icg)
+ enddo
+C Uncomment following three lines for diagnostics.
+cd call intout
+cd call briefout(0,0.0d0)
+cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
+ return
+ end
+C-------------------------------------------------------------------------
+ subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+ integer n,nf
+ double precision ufparm
+ external ufparm
+ integer uiparm(1)
+ double precision urparm(1)
+ double precision x(maxvar),g(maxvar)
+ integer i,j,k,ig,ind,ij,igall
+ double precision f,gthetai,gphii,galphai,gomegai
+
+ icg=mod(nf,2)+1
+ if (nf-nfl+1) 20,30,40
+ 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm)
+c write (iout,*) 'grad 20'
+ if (nf.eq.0) return
+ goto 40
+ 30 continue
+#ifdef OSF
+c Intercept NaNs in the coordinates
+c write(iout,*) (var(i),i=1,nvar)
+ x_sum=0.D0
+ do i=1,n
+ x_sum=x_sum+x(i)
+ enddo
+ if (x_sum.ne.x_sum) then
+ write(iout,*)" *** grad_restr : Found NaN in coordinates"
+ call flush(iout)
+ print *," *** grad_restr : Found NaN in coordinates"
+ return
+ endif
+#endif
+ call var_to_geom_restr(n,x)
+ call chainbuild
+C
+C Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
+C
+ 40 call cartder
+C
+C Convert the Cartesian gradient into internal-coordinate gradient.
+C
+
+ ig=0
+ ind=nres-2
+ do i=2,nres-2
+ IF (mask_phi(i+2).eq.1) THEN
+ gphii=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+ do k=1,3
+ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
+ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg)
+ enddo
+ enddo
+ ig=ig+1
+ g(ig)=gphii
+ ELSE
+ ind=ind+nres-1-i
+ ENDIF
+ enddo
+
+
+ ind=0
+ do i=1,nres-2
+ IF (mask_theta(i+2).eq.1) THEN
+ ig=ig+1
+ gthetai=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+ do k=1,3
+ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
+ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg)
+ enddo
+ enddo
+ g(ig)=gthetai
+ ELSE
+ ind=ind+nres-1-i
+ ENDIF
+ enddo
+
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ IF (mask_side(i).eq.1) THEN
+ ig=ig+1
+ galphai=0.0D0
+ do k=1,3
+ galphai=galphai+dxds(k,i)*gradx(k,i,icg)
+ enddo
+ g(ig)=galphai
+ ENDIF
+ endif
+ enddo
+
+
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ IF (mask_side(i).eq.1) THEN
+ ig=ig+1
+ gomegai=0.0D0
+ do k=1,3
+ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
+ enddo
+ g(ig)=gomegai
+ ENDIF
+ endif
+ enddo
+
+C
+C Add the components corresponding to local energy terms.
+C
+
+ ig=0
+ igall=0
+ do i=4,nres
+ igall=igall+1
+ if (mask_phi(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ enddo
+
+ do i=3,nres
+ igall=igall+1
+ if (mask_theta(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ enddo
+
+ do ij=1,2
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ igall=igall+1
+ if (mask_side(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ endif
+ enddo
+ enddo
+
+cd do i=1,ig
+cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i)
+cd enddo
+ return
+ end
+C-------------------------------------------------------------------------
+ subroutine cartgrad
+ implicit none
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.QRESTR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ integer i,j,kk
+c
+c This subrouting calculates total Cartesian coordinate gradient.
+c The subroutine chainbuild_cart and energy MUST be called beforehand.
+c
+#ifdef TIMING
+ time00=MPI_Wtime()
+#endif
+ icg=1
+#ifdef DEBUG
+ write (iout,*) "Before sum_gradient"
+ do i=1,nres-1
+ write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3)
+ write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3)
+ enddo
+ write (iout,*) "gsaxsc, gsaxcx"
+ do i=1,nres-1
+ write (iout,*) i," gsaxsc ",(gsaxsc(j,i),j=1,3)
+ write (iout,*) i," gsaxsx ",(gsaxsx(j,i),j=1,3)
+ enddo
+#endif
+ call sum_gradient
+#ifdef TIMING
+#endif
+#ifdef DEBUG
+ write (iout,*) "After sum_gradient"
+ do i=1,nres-1
+ write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3)
+ write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3)
+ enddo
+#endif
+c If performing constraint dynamics, add the gradients of the constraint energy
+ if(usampl.and.totT.gt.eq_time) then
+#ifdef DEBUG
+ write (iout,*) "dudconst, duscdiff, dugamma,dutheta"
+ write (iout,*) "wumb",wumb
+ do i=1,nct
+ write (iout,'(i5,3f10.5,5x,3f10.5,5x,2f10.5)')
+ & i,(dudconst(j,i),j=1,3),(duscdiff(j,i),j=1,3),
+ & dugamma(i),dutheta(i)
+ enddo
+#endif
+ do i=1,nct
+ do j=1,3
+ gradc(j,i,icg)=gradc(j,i,icg)+
+ & wumb*(dudconst(j,i)+duscdiff(j,i))
+ gradx(j,i,icg)=gradx(j,i,icg)+
+ & wumb*(dudxconst(j,i)+duscdiffx(j,i))
+ enddo
+ enddo
+ do i=1,nres-3
+ gloc(i,icg)=gloc(i,icg)+wumb*dugamma(i)
+ enddo
+ do i=1,nres-2
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)+wumb*dutheta(i)
+ enddo
+ endif
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call intcartderiv
+#ifdef TIMING
+ time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
+#endif
+cd call checkintcartgrad
+cd write(iout,*) 'calling int_to_cart'
+#ifdef DEBUG
+ write (iout,*) "gcart, gxcart, gloc before int_to_cart"
+#endif
+ do i=1,nct
+ do j=1,3
+ gcart(j,i)=gradc(j,i,icg)
+ gxcart(j,i)=gradx(j,i,icg)
+ enddo
+#ifdef DEBUG
+ if((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then
+ write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg),
+ & gloc(ialph(i,1),icg),gloc(ialph(i,1)+nside,icg)
+ else
+ write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg)
+ endif
+ call flush(iout)
+#endif
+ enddo
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call int_to_cart
+#ifdef TIMING
+ time_inttocart=time_inttocart+MPI_Wtime()-time01
+#endif
+#ifdef DEBUG
+ write (iout,*) "gcart and gxcart after int_to_cart"
+ do i=0,nres-1
+ write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3)
+ enddo
+#endif
+#ifdef TIMING
+ time_cartgrad=time_cartgrad+MPI_Wtime()-time00
+#endif
+ return
+ end
+c---------------------------------------------------------------------------
+#ifdef FIVEDIAG
+ subroutine grad_transform
+ implicit none
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.QRESTR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ integer i,j,kk
+#ifdef DEBUG
+ write (iout,*)"Converting virtual-bond gradient to CA/SC gradient"
+#endif
+ do i=nres,1,-1
+ do j=1,3
+ gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
+! gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
+ enddo
+! write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
+! (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
+ enddo
+! Correction: dummy residues
+ if (nnt.gt.1) then
+ do j=1,3
+ gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
+ enddo
+ endif
+ if (nct.lt.nres) then
+ do j=1,3
+! gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
+ gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
+ enddo
+ endif
+#ifdef DEBUG
+ write (iout,*) "CA/SC gradient"
+ do i=1,nres
+ write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3)
+ enddo
+#endif
+ return
+ end
+#endif
+C-------------------------------------------------------------------------
+ subroutine zerograd
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.DERIV'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.SCCOR'
+ include 'COMMON.SHIELD'
+ integer i,j,kk,intertyp,maxshieldlist
+ maxshieldlist=0
+C
+C Initialize Cartesian-coordinate gradient
+C
+ do i=-1,nres
+ do j=1,3
+ gvdwx(j,i)=0.0D0
+ gradx_scp(j,i)=0.0D0
+ gvdwc(j,i)=0.0D0
+ gvdwc_scp(j,i)=0.0D0
+ gvdwc_scpp(j,i)=0.0d0
+ gelc (j,i)=0.0D0
+C below is zero grad for shielding in order: ees (p-p)
+C ecorr4, eturn3, eturn4, eel_loc, c denotes calfa,x is side-chain
+ gshieldx(j,i)=0.0d0
+ gshieldc(j,i)=0.0d0
+ gshieldc_loc(j,i)=0.0d0
+ gshieldx_ec(j,i)=0.0d0
+ gshieldc_ec(j,i)=0.0d0
+ gshieldc_loc_ec(j,i)=0.0d0
+ gshieldx_t3(j,i)=0.0d0
+ gshieldc_t3(j,i)=0.0d0
+ gshieldc_loc_t3(j,i)=0.0d0
+ gshieldx_t4(j,i)=0.0d0
+ gshieldc_t4(j,i)=0.0d0
+ gshieldc_loc_t4(j,i)=0.0d0
+ gshieldx_ll(j,i)=0.0d0
+ gshieldc_ll(j,i)=0.0d0
+ gshieldc_loc_ll(j,i)=0.0d0
+C end of zero grad for shielding
+ gelc_long(j,i)=0.0D0
+ gradb(j,i)=0.0d0
+ gradbx(j,i)=0.0d0
+ gvdwpp(j,i)=0.0d0
+ gel_loc(j,i)=0.0d0
+ gel_loc_long(j,i)=0.0d0
+ ghpbc(j,i)=0.0D0
+ ghpbx(j,i)=0.0D0
+ gsaxsc(j,i)=0.0D0
+ gsaxsx(j,i)=0.0D0
+ gcorr3_turn(j,i)=0.0d0
+ gcorr4_turn(j,i)=0.0d0
+ gradcorr(j,i)=0.0d0
+ gradcorr_long(j,i)=0.0d0
+ gradcorr5_long(j,i)=0.0d0
+ gradcorr6_long(j,i)=0.0d0
+ gcorr6_turn_long(j,i)=0.0d0
+ gradcorr5(j,i)=0.0d0
+ gradcorr6(j,i)=0.0d0
+ gcorr6_turn(j,i)=0.0d0
+ gsccorc(j,i)=0.0d0
+ gsccorx(j,i)=0.0d0
+ gradc(j,i,icg)=0.0d0
+ gradx(j,i,icg)=0.0d0
+ gscloc(j,i)=0.0d0
+ gsclocx(j,i)=0.0d0
+ gliptranc(j,i)=0.0d0
+ gliptranx(j,i)=0.0d0
+ gradafm(j,i)=0.0d0
+ grad_shield(j,i)=0.0d0
+ gg_tube(j,i)=0.0d0
+ gg_tube_sc(j,i)=0.0d0
+C grad_shield_side is Cbeta sidechain gradient
+ do kk=1,maxshieldlist
+ grad_shield_side(j,kk,i)=0.0d0
+ grad_shield_loc(j,kk,i)=0.0d0
+
+C grad_shield_side_ca is Calfa sidechain gradient
+
+
+C grad_shield_side_ca(j,kk,i)=0.0d0
+ enddo
+ do intertyp=1,3
+ gloc_sc(intertyp,i,icg)=0.0d0
+ enddo
+ enddo
+ enddo
+#ifndef DFA
+ do i=1,nres
+ do j=1,3
+ gdfad(j,i)=0.0d0
+ gdfat(j,i)=0.0d0
+ gdfan(j,i)=0.0d0
+ gdfab(j,i)=0.0d0
+ enddo
+ enddo
+#endif
+C
+C Initialize the gradient of local energy terms.
+C
+ do i=1,4*nres
+ gloc(i,icg)=0.0D0
+ enddo
+ do i=1,nres
+ gel_loc_loc(i)=0.0d0
+ gcorr_loc(i)=0.0d0
+ g_corr5_loc(i)=0.0d0
+ g_corr6_loc(i)=0.0d0
+ gel_loc_turn3(i)=0.0d0
+ gel_loc_turn4(i)=0.0d0
+ gel_loc_turn6(i)=0.0d0
+ gsccor_loc(i)=0.0d0
+ enddo
+c initialize gcart and gxcart
+ do i=0,nres
+ do j=1,3
+ gcart(j,i)=0.0d0
+ gxcart(j,i)=0.0d0
+ enddo
+ enddo
+ return
+ end
+c-------------------------------------------------------------------------
+ double precision function fdum()
+ fdum=0.0D0
+ return
+ end
--- /dev/null
+ subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.QRESTR'
+ include 'COMMON.IOUNITS'
+ integer n,nf
+ double precision ufparm
+ external ufparm
+ integer uiparm(1)
+ double precision urparm(1)
+ double precision x(n),g(n)
+ integer i,j,k,ind,ind1
+ double precision f,gthetai,gphii,galphai,gomegai
+c
+c This subroutine calculates total internal coordinate gradient.
+c Depending on the number of function evaluations, either whole energy
+c is evaluated beforehand, Cartesian coordinates and their derivatives in
+c internal coordinates are reevaluated or only the cartesian-in-internal
+c coordinate derivatives are evaluated. The subroutine was designed to work
+c with SUMSL.
+c
+c
+ icg=mod(nf,2)+1
+
+cd print *,'grad',nf,icg
+ if (nf-nfl+1) 20,30,40
+ 20 call func(n,x,nf,f,uiparm,urparm,ufparm)
+c write (iout,*) 'grad 20'
+ if (nf.eq.0) return
+ goto 40
+ 30 call var_to_geom(n,x)
+ call chainbuild
+c write (iout,*) 'grad 30'
+C
+C Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
+C
+ 40 call cartder
+c write (iout,*) 'grad 40'
+c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
+C
+C Convert the Cartesian gradient into internal-coordinate gradient.
+C
+ ind=0
+ ind1=0
+ do i=1,nres-2
+ gthetai=0.0D0
+ gphii=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+c ind=indmat(i,j)
+c print *,'GRAD: i=',i,' jc=',j,' ind=',ind
+ do k=1,3
+ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
+ enddo
+ do k=1,3
+ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
+ enddo
+ enddo
+ do j=i+1,nres-1
+ ind1=ind1+1
+c ind1=indmat(i,j)
+c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
+ do k=1,3
+ gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
+ gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
+ enddo
+ enddo
+ if (i.gt.1) g(i-1)=gphii
+ if (n.gt.nphi) g(nphi+i)=gthetai
+ enddo
+ if (n.le.nphi+ntheta) goto 10
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ galphai=0.0D0
+ gomegai=0.0D0
+ do k=1,3
+ galphai=galphai+dxds(k,i)*gradx(k,i,icg)
+ enddo
+ do k=1,3
+ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
+ enddo
+ g(ialph(i,1))=galphai
+ g(ialph(i,1)+nside)=gomegai
+ endif
+ enddo
+C
+C Add the components corresponding to local energy terms.
+C
+ 10 continue
+c Add the usampl contributions
+ if (usampl) then
+ do i=1,nres-3
+ gloc(i,icg)=gloc(i,icg)+dugamma(i)
+ enddo
+ do i=1,nres-2
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
+ enddo
+ endif
+ do i=1,nvar
+cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
+ g(i)=g(i)+gloc(i,icg)
+ enddo
+C Uncomment following three lines for diagnostics.
+cd call intout
+cd call briefout(0,0.0d0)
+cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
+ return
+ end
+C-------------------------------------------------------------------------
+ subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+ integer n,nf
+ double precision ufparm
+ external ufparm
+ integer uiparm(1)
+ double precision urparm(1)
+ double precision x(maxvar),g(maxvar)
+ integer i,j,k,ig,ind,ij,igall
+ double precision f,gthetai,gphii,galphai,gomegai
+
+ icg=mod(nf,2)+1
+ if (nf-nfl+1) 20,30,40
+ 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm)
+c write (iout,*) 'grad 20'
+ if (nf.eq.0) return
+ goto 40
+ 30 continue
+#ifdef OSF
+c Intercept NaNs in the coordinates
+c write(iout,*) (var(i),i=1,nvar)
+ x_sum=0.D0
+ do i=1,n
+ x_sum=x_sum+x(i)
+ enddo
+ if (x_sum.ne.x_sum) then
+ write(iout,*)" *** grad_restr : Found NaN in coordinates"
+ call flush(iout)
+ print *," *** grad_restr : Found NaN in coordinates"
+ return
+ endif
+#endif
+ call var_to_geom_restr(n,x)
+ call chainbuild
+C
+C Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
+C
+ 40 call cartder
+C
+C Convert the Cartesian gradient into internal-coordinate gradient.
+C
+
+ ig=0
+ ind=nres-2
+ do i=2,nres-2
+ IF (mask_phi(i+2).eq.1) THEN
+ gphii=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+ do k=1,3
+ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
+ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg)
+ enddo
+ enddo
+ ig=ig+1
+ g(ig)=gphii
+ ELSE
+ ind=ind+nres-1-i
+ ENDIF
+ enddo
+
+
+ ind=0
+ do i=1,nres-2
+ IF (mask_theta(i+2).eq.1) THEN
+ ig=ig+1
+ gthetai=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+ do k=1,3
+ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
+ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg)
+ enddo
+ enddo
+ g(ig)=gthetai
+ ELSE
+ ind=ind+nres-1-i
+ ENDIF
+ enddo
+
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ IF (mask_side(i).eq.1) THEN
+ ig=ig+1
+ galphai=0.0D0
+ do k=1,3
+ galphai=galphai+dxds(k,i)*gradx(k,i,icg)
+ enddo
+ g(ig)=galphai
+ ENDIF
+ endif
+ enddo
+
+
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ IF (mask_side(i).eq.1) THEN
+ ig=ig+1
+ gomegai=0.0D0
+ do k=1,3
+ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
+ enddo
+ g(ig)=gomegai
+ ENDIF
+ endif
+ enddo
+
+C
+C Add the components corresponding to local energy terms.
+C
+
+ ig=0
+ igall=0
+ do i=4,nres
+ igall=igall+1
+ if (mask_phi(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ enddo
+
+ do i=3,nres
+ igall=igall+1
+ if (mask_theta(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ enddo
+
+ do ij=1,2
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ igall=igall+1
+ if (mask_side(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ endif
+ enddo
+ enddo
+
+cd do i=1,ig
+cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i)
+cd enddo
+ return
+ end
+C-------------------------------------------------------------------------
+ subroutine cartgrad
+ implicit none
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.QRESTR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ integer i,j,kk
+c
+c This subrouting calculates total Cartesian coordinate gradient.
+c The subroutine chainbuild_cart and energy MUST be called beforehand.
+c
+#ifdef TIMING
+ time00=MPI_Wtime()
+#endif
+ icg=1
+#ifdef DEBUG
+ write (iout,*) "Before sum_gradient"
+ do i=1,nres-1
+ write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3)
+ write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3)
+ enddo
+ write (iout,*) "gsaxsc, gsaxcx"
+ do i=1,nres-1
+ write (iout,*) i," gsaxsc ",(gsaxsc(j,i),j=1,3)
+ write (iout,*) i," gsaxsx ",(gsaxsx(j,i),j=1,3)
+ enddo
+#endif
+ call sum_gradient
+#ifdef TIMING
+#endif
+#ifdef DEBUG
+ write (iout,*) "After sum_gradient"
+ do i=1,nres-1
+ write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3)
+ write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3)
+ enddo
+#endif
+c If performing constraint dynamics, add the gradients of the constraint energy
+ if(usampl.and.totT.gt.eq_time) then
+#ifdef DEBUG
+ write (iout,*) "dudconst, duscdiff, dugamma,dutheta"
+ write (iout,*) "wumb",wumb
+ do i=1,nct
+ write (iout,'(i5,3f10.5,5x,3f10.5,5x,2f10.5)')
+ & i,(dudconst(j,i),j=1,3),(duscdiff(j,i),j=1,3),
+ & dugamma(i),dutheta(i)
+ enddo
+#endif
+ do i=1,nct
+ do j=1,3
+ gradc(j,i,icg)=gradc(j,i,icg)+
+ & wumb*(dudconst(j,i)+duscdiff(j,i))
+ gradx(j,i,icg)=gradx(j,i,icg)+
+ & wumb*(dudxconst(j,i)+duscdiffx(j,i))
+ enddo
+ enddo
+ do i=1,nres-3
+ gloc(i,icg)=gloc(i,icg)+wumb*dugamma(i)
+ enddo
+ do i=1,nres-2
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)+wumb*dutheta(i)
+ enddo
+ endif
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call intcartderiv
+#ifdef TIMING
+ time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
+#endif
+cd call checkintcartgrad
+cd write(iout,*) 'calling int_to_cart'
+#ifdef DEBUG
+ write (iout,*) "gcart, gxcart, gloc before int_to_cart"
+#endif
+ do i=1,nct
+ do j=1,3
+ gcart(j,i)=gradc(j,i,icg)
+ gxcart(j,i)=gradx(j,i,icg)
+ enddo
+#ifdef DEBUG
+ if((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then
+ write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg),
+ & gloc(ialph(i,1),icg),gloc(ialph(i,1)+nside,icg)
+ else
+ write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg)
+ endif
+ call flush(iout)
+#endif
+ enddo
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call int_to_cart
+#ifdef TIMING
+ time_inttocart=time_inttocart+MPI_Wtime()-time01
+#endif
+#ifdef DEBUG
+ write (iout,*) "gcart and gxcart after int_to_cart"
+ do i=0,nres-1
+ write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3)
+ enddo
+#endif
+#ifdef TIMING
+ time_cartgrad=time_cartgrad+MPI_Wtime()-time00
+#endif
+ return
+ end
+c---------------------------------------------------------------------------
+#ifdef FIVEDIAG
+ subroutine grad_transform
+ implicit none
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.QRESTR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ integer i,j,kk
+#ifdef DEBUG
+ write (iout,*)"Converting virtual-bond gradient to CA/SC gradient"
+#endif
+ do i=nres,1,-1
+ do j=1,3
+ gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
+! gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
+ enddo
+! write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
+! (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
+ enddo
+! Correction: dummy residues
+ if (nnt.gt.1) then
+ do j=1,3
+ gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
+ enddo
+ endif
+ if (nct.lt.nres) then
+ do j=1,3
+! gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
+ gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
+ enddo
+ endif
+#ifdef DEBUG
+ write (iout,*) "CA/SC gradient"
+ do i=1,nres
+ write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3)
+ enddo
+#endif
+ return
+ end
+#endif
+C-------------------------------------------------------------------------
+ subroutine zerograd
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.DERIV'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.SCCOR'
+ include 'COMMON.SHIELD'
+ integer i,j,kk,intertyp,maxshieldlist
+ maxshieldlist=0
+C
+C Initialize Cartesian-coordinate gradient
+C
+ do i=-1,nres
+ do j=1,3
+ gvdwx(j,i)=0.0D0
+ gradx_scp(j,i)=0.0D0
+ gvdwc(j,i)=0.0D0
+ gvdwc_scp(j,i)=0.0D0
+ gvdwc_scpp(j,i)=0.0d0
+ gelc (j,i)=0.0D0
+C below is zero grad for shielding in order: ees (p-p)
+C ecorr4, eturn3, eturn4, eel_loc, c denotes calfa,x is side-chain
+ gshieldx(j,i)=0.0d0
+ gshieldc(j,i)=0.0d0
+ gshieldc_loc(j,i)=0.0d0
+ gshieldx_ec(j,i)=0.0d0
+ gshieldc_ec(j,i)=0.0d0
+ gshieldc_loc_ec(j,i)=0.0d0
+ gshieldx_t3(j,i)=0.0d0
+ gshieldc_t3(j,i)=0.0d0
+ gshieldc_loc_t3(j,i)=0.0d0
+ gshieldx_t4(j,i)=0.0d0
+ gshieldc_t4(j,i)=0.0d0
+ gshieldc_loc_t4(j,i)=0.0d0
+ gshieldx_ll(j,i)=0.0d0
+ gshieldc_ll(j,i)=0.0d0
+ gshieldc_loc_ll(j,i)=0.0d0
+C end of zero grad for shielding
+ gelc_long(j,i)=0.0D0
+ gradb(j,i)=0.0d0
+ gradbx(j,i)=0.0d0
+ gvdwpp(j,i)=0.0d0
+ gel_loc(j,i)=0.0d0
+ gel_loc_long(j,i)=0.0d0
+ ghpbc(j,i)=0.0D0
+ ghpbx(j,i)=0.0D0
+ gsaxsc(j,i)=0.0D0
+ gsaxsx(j,i)=0.0D0
+ gcorr3_turn(j,i)=0.0d0
+ gcorr4_turn(j,i)=0.0d0
+ gradcorr(j,i)=0.0d0
+ gradcorr_long(j,i)=0.0d0
+ gradcorr5_long(j,i)=0.0d0
+ gradcorr6_long(j,i)=0.0d0
+ gcorr6_turn_long(j,i)=0.0d0
+ gradcorr5(j,i)=0.0d0
+ gradcorr6(j,i)=0.0d0
+ gcorr6_turn(j,i)=0.0d0
+ gsccorc(j,i)=0.0d0
+ gsccorx(j,i)=0.0d0
+ gradc(j,i,icg)=0.0d0
+ gradx(j,i,icg)=0.0d0
+ gscloc(j,i)=0.0d0
+ gsclocx(j,i)=0.0d0
+ gliptranc(j,i)=0.0d0
+ gliptranx(j,i)=0.0d0
+ gradafm(j,i)=0.0d0
+ grad_shield(j,i)=0.0d0
+ gg_tube(j,i)=0.0d0
+ gg_tube_sc(j,i)=0.0d0
+C grad_shield_side is Cbeta sidechain gradient
+ do kk=1,maxshieldlist
+ grad_shield_side(j,kk,i)=0.0d0
+ grad_shield_loc(j,kk,i)=0.0d0
+
+C grad_shield_side_ca is Calfa sidechain gradient
+
+
+C grad_shield_side_ca(j,kk,i)=0.0d0
+ enddo
+ do intertyp=1,3
+ gloc_sc(intertyp,i,icg)=0.0d0
+ enddo
+ enddo
+ enddo
+#ifndef DFA
+ do i=1,nres
+ do j=1,3
+ gdfad(j,i)=0.0d0
+ gdfat(j,i)=0.0d0
+ gdfan(j,i)=0.0d0
+ gdfab(j,i)=0.0d0
+ enddo
+ enddo
+#endif
+C
+C Initialize the gradient of local energy terms.
+C
+ do i=1,4*nres
+ gloc(i,icg)=0.0D0
+ enddo
+ do i=1,nres
+ gel_loc_loc(i)=0.0d0
+ gcorr_loc(i)=0.0d0
+ g_corr5_loc(i)=0.0d0
+ g_corr6_loc(i)=0.0d0
+ gel_loc_turn3(i)=0.0d0
+ gel_loc_turn4(i)=0.0d0
+ gel_loc_turn6(i)=0.0d0
+ gsccor_loc(i)=0.0d0
+ enddo
+c initialize gcart and gxcart
+ do i=0,nres
+ do j=1,3
+ gcart(j,i)=0.0d0
+ gxcart(j,i)=0.0d0
+ enddo
+ enddo
+ return
+ end
+c-------------------------------------------------------------------------
+ double precision function fdum()
+ fdum=0.0D0
+ return
+ end
--- /dev/null
+ subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.QRESTR'
+ include 'COMMON.IOUNITS'
+ integer n,nf
+ double precision ufparm
+ external ufparm
+ integer uiparm(1)
+ double precision urparm(1)
+ double precision x(n),g(n)
+ integer i,j,k,ind,ind1
+ double precision f,gthetai,gphii,galphai,gomegai
+c
+c This subroutine calculates total internal coordinate gradient.
+c Depending on the number of function evaluations, either whole energy
+c is evaluated beforehand, Cartesian coordinates and their derivatives in
+c internal coordinates are reevaluated or only the cartesian-in-internal
+c coordinate derivatives are evaluated. The subroutine was designed to work
+c with SUMSL.
+c
+c
+ icg=mod(nf,2)+1
+
+cd print *,'grad',nf,icg
+ if (nf-nfl+1) 20,30,40
+ 20 call func(n,x,nf,f,uiparm,urparm,ufparm)
+c write (iout,*) 'grad 20'
+ if (nf.eq.0) return
+ goto 40
+ 30 call var_to_geom(n,x)
+ call chainbuild
+c write (iout,*) 'grad 30'
+C
+C Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
+C
+ 40 call cartder
+c write (iout,*) 'grad 40'
+c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
+C
+C Convert the Cartesian gradient into internal-coordinate gradient.
+C
+ ind=0
+ ind1=0
+ do i=1,nres-2
+ gthetai=0.0D0
+ gphii=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+c ind=indmat(i,j)
+c print *,'GRAD: i=',i,' jc=',j,' ind=',ind
+ do k=1,3
+ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
+ enddo
+ do k=1,3
+ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
+ enddo
+ enddo
+ do j=i+1,nres-1
+ ind1=ind1+1
+c ind1=indmat(i,j)
+c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
+ write (iout,*) "i",i," j",j," ind1",ind1
+ write (iout,*) "dxdv",(dxdv(k,ind1),k=1,6)
+ write (iout,*) "gradx",(gradx(k,j,icg),k=1,3)
+ do k=1,3
+ gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
+ gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
+ enddo
+ enddo
+ if (i.gt.1) g(i-1)=gphii
+ if (n.gt.nphi) g(nphi+i)=gthetai
+ enddo
+ if (n.le.nphi+ntheta) goto 10
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ galphai=0.0D0
+ gomegai=0.0D0
+ do k=1,3
+ galphai=galphai+dxds(k,i)*gradx(k,i,icg)
+ enddo
+ do k=1,3
+ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
+ enddo
+ g(ialph(i,1))=galphai
+ g(ialph(i,1)+nside)=gomegai
+ endif
+ enddo
+C
+C Add the components corresponding to local energy terms.
+C
+ 10 continue
+c Add the usampl contributions
+ if (usampl) then
+ do i=1,nres-3
+ gloc(i,icg)=gloc(i,icg)+dugamma(i)
+ enddo
+ do i=1,nres-2
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
+ enddo
+ endif
+ do i=1,nvar
+cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
+ g(i)=g(i)+gloc(i,icg)
+ enddo
+C Uncomment following three lines for diagnostics.
+cd call intout
+cd call briefout(0,0.0d0)
+cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
+ return
+ end
+C-------------------------------------------------------------------------
+ subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm)
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.IOUNITS'
+ integer n,nf
+ double precision ufparm
+ external ufparm
+ integer uiparm(1)
+ double precision urparm(1)
+ double precision x(maxvar),g(maxvar)
+ integer i,j,k,ig,ind,ij,igall
+ double precision f,gthetai,gphii,galphai,gomegai
+
+ icg=mod(nf,2)+1
+ if (nf-nfl+1) 20,30,40
+ 20 call func_restr(n,x,nf,f,uiparm,urparm,ufparm)
+c write (iout,*) 'grad 20'
+ if (nf.eq.0) return
+ goto 40
+ 30 continue
+#ifdef OSF
+c Intercept NaNs in the coordinates
+c write(iout,*) (var(i),i=1,nvar)
+ x_sum=0.D0
+ do i=1,n
+ x_sum=x_sum+x(i)
+ enddo
+ if (x_sum.ne.x_sum) then
+ write(iout,*)" *** grad_restr : Found NaN in coordinates"
+ call flush(iout)
+ print *," *** grad_restr : Found NaN in coordinates"
+ return
+ endif
+#endif
+ call var_to_geom_restr(n,x)
+ call chainbuild
+C
+C Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
+C
+ 40 call cartder
+C
+C Convert the Cartesian gradient into internal-coordinate gradient.
+C
+
+ ig=0
+ ind=nres-2
+ do i=2,nres-2
+ IF (mask_phi(i+2).eq.1) THEN
+ gphii=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+ do k=1,3
+ gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
+ gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg)
+ enddo
+ enddo
+ ig=ig+1
+ g(ig)=gphii
+ ELSE
+ ind=ind+nres-1-i
+ ENDIF
+ enddo
+
+
+ ind=0
+ do i=1,nres-2
+ IF (mask_theta(i+2).eq.1) THEN
+ ig=ig+1
+ gthetai=0.0D0
+ do j=i+1,nres-1
+ ind=ind+1
+ do k=1,3
+ gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
+ gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg)
+ enddo
+ enddo
+ g(ig)=gthetai
+ ELSE
+ ind=ind+nres-1-i
+ ENDIF
+ enddo
+
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ IF (mask_side(i).eq.1) THEN
+ ig=ig+1
+ galphai=0.0D0
+ do k=1,3
+ galphai=galphai+dxds(k,i)*gradx(k,i,icg)
+ enddo
+ g(ig)=galphai
+ ENDIF
+ endif
+ enddo
+
+
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ IF (mask_side(i).eq.1) THEN
+ ig=ig+1
+ gomegai=0.0D0
+ do k=1,3
+ gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
+ enddo
+ g(ig)=gomegai
+ ENDIF
+ endif
+ enddo
+
+C
+C Add the components corresponding to local energy terms.
+C
+
+ ig=0
+ igall=0
+ do i=4,nres
+ igall=igall+1
+ if (mask_phi(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ enddo
+
+ do i=3,nres
+ igall=igall+1
+ if (mask_theta(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ enddo
+
+ do ij=1,2
+ do i=2,nres-1
+ if (itype(i).ne.10) then
+ igall=igall+1
+ if (mask_side(i).eq.1) then
+ ig=ig+1
+ g(ig)=g(ig)+gloc(igall,icg)
+ endif
+ endif
+ enddo
+ enddo
+
+cd do i=1,ig
+cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i)
+cd enddo
+ return
+ end
+C-------------------------------------------------------------------------
+ subroutine cartgrad
+ implicit none
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.QRESTR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ integer i,j,kk
+c
+c This subrouting calculates total Cartesian coordinate gradient.
+c The subroutine chainbuild_cart and energy MUST be called beforehand.
+c
+#ifdef TIMING
+ time00=MPI_Wtime()
+#endif
+ icg=1
+#ifdef DEBUG
+ write (iout,*) "Before sum_gradient"
+ do i=1,nres-1
+ write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3)
+ write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3)
+ enddo
+ write (iout,*) "gsaxsc, gsaxcx"
+ do i=1,nres-1
+ write (iout,*) i," gsaxsc ",(gsaxsc(j,i),j=1,3)
+ write (iout,*) i," gsaxsx ",(gsaxsx(j,i),j=1,3)
+ enddo
+#endif
+ call sum_gradient
+#ifdef TIMING
+#endif
+#ifdef DEBUG
+ write (iout,*) "After sum_gradient"
+ do i=1,nres-1
+ write (iout,*) i," gradc ",(gradc(j,i,icg),j=1,3)
+ write (iout,*) i," gradx ",(gradx(j,i,icg),j=1,3)
+ enddo
+#endif
+c If performing constraint dynamics, add the gradients of the constraint energy
+ if(usampl.and.totT.gt.eq_time) then
+#ifdef DEBUG
+ write (iout,*) "dudconst, duscdiff, dugamma,dutheta"
+ write (iout,*) "wumb",wumb
+ do i=1,nct
+ write (iout,'(i5,3f10.5,5x,3f10.5,5x,2f10.5)')
+ & i,(dudconst(j,i),j=1,3),(duscdiff(j,i),j=1,3),
+ & dugamma(i),dutheta(i)
+ enddo
+#endif
+ do i=1,nct
+ do j=1,3
+ gradc(j,i,icg)=gradc(j,i,icg)+
+ & wumb*(dudconst(j,i)+duscdiff(j,i))
+ gradx(j,i,icg)=gradx(j,i,icg)+
+ & wumb*(dudxconst(j,i)+duscdiffx(j,i))
+ enddo
+ enddo
+ do i=1,nres-3
+ gloc(i,icg)=gloc(i,icg)+wumb*dugamma(i)
+ enddo
+ do i=1,nres-2
+ gloc(nphi+i,icg)=gloc(nphi+i,icg)+wumb*dutheta(i)
+ enddo
+ endif
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call intcartderiv
+#ifdef TIMING
+ time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
+#endif
+cd call checkintcartgrad
+cd write(iout,*) 'calling int_to_cart'
+#ifdef DEBUG
+ write (iout,*) "gcart, gxcart, gloc before int_to_cart"
+#endif
+ do i=1,nct
+ do j=1,3
+ gcart(j,i)=gradc(j,i,icg)
+ gxcart(j,i)=gradx(j,i,icg)
+ enddo
+#ifdef DEBUG
+ if((itype(i).ne.10).and.(itype(i).ne.ntyp1)) then
+ write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg),
+ & gloc(ialph(i,1),icg),gloc(ialph(i,1)+nside,icg)
+ else
+ write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3),gloc(i,icg),gloc(i+nphi,icg)
+ endif
+ call flush(iout)
+#endif
+ enddo
+#ifdef TIMING
+ time01=MPI_Wtime()
+#endif
+ call int_to_cart
+#ifdef TIMING
+ time_inttocart=time_inttocart+MPI_Wtime()-time01
+#endif
+#ifdef DEBUG
+ write (iout,*) "gcart and gxcart after int_to_cart"
+ do i=0,nres-1
+ write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3)
+ enddo
+#endif
+#ifdef TIMING
+ time_cartgrad=time_cartgrad+MPI_Wtime()-time00
+#endif
+ return
+ end
+c---------------------------------------------------------------------------
+#ifdef FIVEDIAG
+ subroutine grad_transform
+ implicit none
+ include 'DIMENSIONS'
+#ifdef MPI
+ include 'mpif.h'
+#endif
+ include 'COMMON.CONTROL'
+ include 'COMMON.CHAIN'
+ include 'COMMON.DERIV'
+ include 'COMMON.VAR'
+ include 'COMMON.INTERACT'
+ include 'COMMON.FFIELD'
+ include 'COMMON.MD'
+ include 'COMMON.QRESTR'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.TIME1'
+ integer i,j,kk
+#ifdef DEBUG
+ write (iout,*)"Converting virtual-bond gradient to CA/SC gradient"
+#endif
+ do i=nres,1,-1
+ do j=1,3
+ gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
+! gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
+ enddo
+! write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
+! (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
+ enddo
+! Correction: dummy residues
+ if (nnt.gt.1) then
+ do j=1,3
+ gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
+ enddo
+ endif
+ if (nct.lt.nres) then
+ do j=1,3
+! gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
+ gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
+ enddo
+ endif
+#ifdef DEBUG
+ write (iout,*) "CA/SC gradient"
+ do i=1,nres
+ write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),
+ & (gxcart(j,i),j=1,3)
+ enddo
+#endif
+ return
+ end
+#endif
+C-------------------------------------------------------------------------
+ subroutine zerograd
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.DERIV'
+ include 'COMMON.CHAIN'
+ include 'COMMON.VAR'
+ include 'COMMON.MD'
+ include 'COMMON.SCCOR'
+ include 'COMMON.SHIELD'
+ integer i,j,kk,intertyp,maxshieldlist
+ maxshieldlist=0
+C
+C Initialize Cartesian-coordinate gradient
+C
+ do i=-1,nres
+ do j=1,3
+ gvdwx(j,i)=0.0D0
+ gradx_scp(j,i)=0.0D0
+ gvdwc(j,i)=0.0D0
+ gvdwc_scp(j,i)=0.0D0
+ gvdwc_scpp(j,i)=0.0d0
+ gelc (j,i)=0.0D0
+C below is zero grad for shielding in order: ees (p-p)
+C ecorr4, eturn3, eturn4, eel_loc, c denotes calfa,x is side-chain
+ gshieldx(j,i)=0.0d0
+ gshieldc(j,i)=0.0d0
+ gshieldc_loc(j,i)=0.0d0
+ gshieldx_ec(j,i)=0.0d0
+ gshieldc_ec(j,i)=0.0d0
+ gshieldc_loc_ec(j,i)=0.0d0
+ gshieldx_t3(j,i)=0.0d0
+ gshieldc_t3(j,i)=0.0d0
+ gshieldc_loc_t3(j,i)=0.0d0
+ gshieldx_t4(j,i)=0.0d0
+ gshieldc_t4(j,i)=0.0d0
+ gshieldc_loc_t4(j,i)=0.0d0
+ gshieldx_ll(j,i)=0.0d0
+ gshieldc_ll(j,i)=0.0d0
+ gshieldc_loc_ll(j,i)=0.0d0
+C end of zero grad for shielding
+ gelc_long(j,i)=0.0D0
+ gradb(j,i)=0.0d0
+ gradbx(j,i)=0.0d0
+ gvdwpp(j,i)=0.0d0
+ gel_loc(j,i)=0.0d0
+ gel_loc_long(j,i)=0.0d0
+ ghpbc(j,i)=0.0D0
+ ghpbx(j,i)=0.0D0
+ gsaxsc(j,i)=0.0D0
+ gsaxsx(j,i)=0.0D0
+ gcorr3_turn(j,i)=0.0d0
+ gcorr4_turn(j,i)=0.0d0
+ gradcorr(j,i)=0.0d0
+ gradcorr_long(j,i)=0.0d0
+ gradcorr5_long(j,i)=0.0d0
+ gradcorr6_long(j,i)=0.0d0
+ gcorr6_turn_long(j,i)=0.0d0
+ gradcorr5(j,i)=0.0d0
+ gradcorr6(j,i)=0.0d0
+ gcorr6_turn(j,i)=0.0d0
+ gsccorc(j,i)=0.0d0
+ gsccorx(j,i)=0.0d0
+ gradc(j,i,icg)=0.0d0
+ gradx(j,i,icg)=0.0d0
+ gscloc(j,i)=0.0d0
+ gsclocx(j,i)=0.0d0
+ gliptranc(j,i)=0.0d0
+ gliptranx(j,i)=0.0d0
+ gradafm(j,i)=0.0d0
+ grad_shield(j,i)=0.0d0
+ gg_tube(j,i)=0.0d0
+ gg_tube_sc(j,i)=0.0d0
+C grad_shield_side is Cbeta sidechain gradient
+ do kk=1,maxshieldlist
+ grad_shield_side(j,kk,i)=0.0d0
+ grad_shield_loc(j,kk,i)=0.0d0
+
+C grad_shield_side_ca is Calfa sidechain gradient
+
+
+C grad_shield_side_ca(j,kk,i)=0.0d0
+ enddo
+ do intertyp=1,3
+ gloc_sc(intertyp,i,icg)=0.0d0
+ enddo
+ enddo
+ enddo
+#ifndef DFA
+ do i=1,nres
+ do j=1,3
+ gdfad(j,i)=0.0d0
+ gdfat(j,i)=0.0d0
+ gdfan(j,i)=0.0d0
+ gdfab(j,i)=0.0d0
+ enddo
+ enddo
+#endif
+C
+C Initialize the gradient of local energy terms.
+C
+ do i=1,4*nres
+ gloc(i,icg)=0.0D0
+ enddo
+ do i=1,nres
+ gel_loc_loc(i)=0.0d0
+ gcorr_loc(i)=0.0d0
+ g_corr5_loc(i)=0.0d0
+ g_corr6_loc(i)=0.0d0
+ gel_loc_turn3(i)=0.0d0
+ gel_loc_turn4(i)=0.0d0
+ gel_loc_turn6(i)=0.0d0
+ gsccor_loc(i)=0.0d0
+ enddo
+c initialize gcart and gxcart
+ do i=0,nres
+ do j=1,3
+ gcart(j,i)=0.0d0
+ gxcart(j,i)=0.0d0
+ enddo
+ enddo
+ return
+ end
+c-------------------------------------------------------------------------
+ double precision function fdum()
+ fdum=0.0D0
+ return
+ end
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
C
nfl=0
icg=1
+ sideonly=.false.
C
C Initialize constants used to split the energy into long- and short-range
C components
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,
& 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
enddo
call flush(iout)
endif
+#ifdef FOURBODY
ntask_cont_from=0
ntask_cont_to=0
itask_cont_from(0)=fg_rank
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,
character*240 record
character*240 string
external fgvalue,optsave
+ common /lbfgstat/ status,niter,ncalls
c
c
c initialize some values to be used below
c
do while (.not. done)
niter = niter + 1
+c write (jout,*) "LBFGS niter",niter
muse = min(niter-1,msav)
m = m + 1
if (m .gt. msav) m = 1
c 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
--- /dev/null
+ subroutine map
+ implicit none
+ include 'DIMENSIONS'
+ include 'COMMON.MAP'
+ include 'COMMON.VAR'
+ include 'COMMON.GEO'
+ include 'COMMON.DERIV'
+ include 'COMMON.IOUNITS'
+ include 'COMMON.NAMES'
+ include 'COMMON.CONTROL'
+ include 'COMMON.TORCNSTR'
+ double precision energia(0:n_ene)
+ character*5 angid(4) /'PHI','THETA','ALPHA','OMEGA'/
+ double precision ang_list(10)
+ double precision g(maxvar),x(maxvar),gnorm,etot
+ integer i,ii,iii,j,k,nf,nfun,iretcode,nmax,ntot
+ integer uiparm(1)
+ double precision urparm(1),fdum
+ external fdum
+ double precision funcgrad,ff
+ external funcgrad
+ integer nn(10)
+ write (iout,'(a,i3,a)')'Energy map constructed in the following ',
+ & nmap,' groups of variables:'
+ do i=1,nmap
+ write (iout,'(2a,i3,a,i3)') angid(kang(i)),' of residues ',
+ & res1(i),' to ',res2(i)
+ enddo
+ nmax=nstep(1)
+ do i=2,nmap
+ if (nmax.lt.nstep(i)) nmax=nstep(i)
+ enddo
+ ntot=nmax**nmap
+ iii=0
+ write (istat,'(1h#,a14,29a15)') (" ",k=1,nmap),
+ & (ename(print_order(k)),k=1,nprint_ene),"ETOT","GNORM"
+ do i=0,ntot-1
+ ii=i
+ do j=1,nmap
+ nn(j)=mod(ii,nmax)+1
+ ii=ii/nmax
+ enddo
+ do j=1,nmap
+ if (nn(j).gt.nstep(j)) goto 10
+ enddo
+ iii=iii+1
+Cd write (iout,*) i,iii,(nn(j),j=1,nmap)
+ do j=1,nmap
+ ang_list(j)=ang_from(j)
+ & +(nn(j)-1)*(ang_to(j)-ang_from(j))/nstep(j)
+ do k=res1(j),res2(j)
+ goto (1,2,3,4), kang(j)
+ 1 phi(k)=deg2rad*ang_list(j)
+ if (minim) phi0(k-res1(j)+1)=deg2rad*ang_list(j)
+ goto 5
+ 2 theta(k)=deg2rad*ang_list(j)
+ goto 5
+ 3 alph(k)=deg2rad*ang_list(j)
+ goto 5
+ 4 omeg(k)=deg2rad*ang_list(j)
+ 5 continue
+ enddo ! k
+ enddo ! j
+ call chainbuild
+ if (minim) then
+ call geom_to_var(nvar,x)
+ call minimize(etot,x,iretcode,nfun)
+ print *,'SUMSL return code is',iretcode,' eval ',nfun
+c call intout
+ else
+ call zerograd
+ call geom_to_var(nvar,x)
+ endif
+ call etotal(energia(0))
+ etot = energia(0)
+ nf=1
+ nfl=3
+#ifdef LBFGS
+ ff=funcgrad(x,g)
+#else
+ call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
+#endif
+ gnorm=0.0d0
+ do k=1,nvar
+ gnorm=gnorm+g(k)**2
+ enddo
+ etot=energia(0)
+
+ gnorm=dsqrt(gnorm)
+c write (iout,'(6(1pe15.5))') (ang_list(k),k=1,nmap),etot,gnorm
+ write (istat,'(30e15.5)') (ang_list(k),k=1,nmap),
+ & (energia(print_order(ii)),ii=1,nprint_ene),etot,gnorm
+c write (iout,*) 'POINT',I,' ANGLES:',(ang_list(k),k=1,nmap)
+c call intout
+c call enerprint(energia)
+ 10 continue
+ enddo ! i
+ return
+ end
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'
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()
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
endif
if (check_var(var,info)) then
+#ifdef LBFGS
+ etot=1.0d21
+#else
v(10)=1.0d21
iv(1)=6
+#endif
goto 201
endif
! 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
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
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
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)
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)
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'
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
* 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
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)
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. *
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.
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)
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))
c write (*,*) 'Processor',MyID,' leaves MINIMIZE.'
c ENDDO ! NOT_DONE
-
+#endif
return
end
#ifdef MPI
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'
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
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
#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)
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"
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
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
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
include 'COMMON.GEO'
include 'COMMON.VAR'
include 'COMMON.HAIRPIN'
- include 'COMMON.DISTFIT'
+ include 'COMMON.FRAG'
character*50 linia
integer isec(maxres)
--- /dev/null
+ subroutine optsave (ncycle,f,xx)
+ implicit none
+ integer ncycle
+ double precision f
+ double precision xx(*)
+ return
+ end
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)'/
& '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
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
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
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
else
nvar=nvar+2*nside
endif
- write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1)
return
end
c----------------------------------------------------------------------------
--- /dev/null
+ subroutine sc_minimize(etot,iretcode,nfun)
+c Minimizes side-chains only, leaving backbone frozen
+crc implicit none
+
+c Includes
+ implicit real*8 (a-h,o-z)
+ include 'DIMENSIONS'
+ include 'COMMON.VAR'
+ include 'COMMON.CHAIN'
+ include 'COMMON.FFIELD'
+
+c Output arguments
+ double precision etot
+ integer iretcode,nfun
+
+c Local variables
+ integer i
+ double precision orig_w(n_ene),energy(0:n_ene)
+ double precision var(maxvar)
+
+
+c Set non side-chain weights to zero (minimization is faster)
+c NOTE: e(2) does not actually depend on the side-chain, only CA
+ orig_w(2)=wscp
+ orig_w(3)=welec
+ orig_w(4)=wcorr
+ orig_w(5)=wcorr5
+ orig_w(6)=wcorr6
+ orig_w(7)=wel_loc
+ orig_w(8)=wturn3
+ orig_w(9)=wturn4
+ orig_w(10)=wturn6
+ orig_w(11)=wang
+ orig_w(13)=wtor
+ orig_w(14)=wtor_d
+
+ wscp=0.D0
+ welec=0.D0
+ wcorr=0.D0
+ wcorr5=0.D0
+ wcorr6=0.D0
+ wel_loc=0.D0
+ wturn3=0.D0
+ wturn4=0.D0
+ wturn6=0.D0
+ wang=0.D0
+ wtor=0.D0
+ wtor_d=0.D0
+
+c Prepare to freeze backbone
+ do i=1,nres
+ mask_phi(i)=0
+ mask_theta(i)=0
+ mask_side(i)=1
+ enddo
+
+c Minimize the side-chains
+ mask_r=.true.
+ call geom_to_var(nvar,var)
+ call minimize(etot,var,iretcode,nfun)
+ call var_to_geom(nvar,var)
+ mask_r=.false.
+
+c Put the original weights back and calculate the full energy
+ wscp=orig_w(2)
+ welec=orig_w(3)
+ wcorr=orig_w(4)
+ wcorr5=orig_w(5)
+ wcorr6=orig_w(6)
+ wel_loc=orig_w(7)
+ wturn3=orig_w(8)
+ wturn4=orig_w(9)
+ wturn6=orig_w(10)
+ wang=orig_w(11)
+ wtor=orig_w(13)
+ wtor_d=orig_w(14)
+
+ call chainbuild_extconf
+ call etotal(energy)
+ etot=energy(0)
+
+ return
+ end
+
+
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
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
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
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
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
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
* 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
& 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)
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)
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)
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
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
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
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
cd enddo
return
end
+#endif
C-----------------------------------------------------------------------------
subroutine egb1(evdw)
C
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)
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))
call sc_grad
ENDIF
enddo ! j
- enddo ! iint
+c enddo ! iint
enddo ! i
end
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)
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
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'
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
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'
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
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
#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
#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
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.)
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'
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
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---------------------------------------------------------------------------
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'
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'
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
--- /dev/null
+../../lib/xdrf
\ No newline at end of file
+++ /dev/null
-#
-# 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 )
+++ /dev/null
-# 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
-
+++ /dev/null
-# 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
-
+++ /dev/null
-# 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
-
+++ /dev/null
-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)
-
+++ /dev/null
-
-
-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;
-}
+++ /dev/null
-/*____________________________________________________________________________
- |
- | 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 <limits.h>
-#include <malloc.h>
-#include <math.h>
-#include <rpc/rpc.h>
-#include <rpc/xdr.h>
-#include <stdio.h>
-#include <stdlib.h>
-#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;
-}
-
-
-
+++ /dev/null
-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)
+++ /dev/null
-/*_________________________________________________________________
- |
- | 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) ;
-
projects / unres.git / commitdiff